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=5
+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
# See libtool info pages for more information on how and when to
# change these.
-LIBGUILE_INTERFACE_CURRENT=26
+LIBGUILE_INTERFACE_CURRENT=24
LIBGUILE_INTERFACE_REVISION=0
-LIBGUILE_INTERFACE_AGE=4
+LIBGUILE_INTERFACE_AGE=2
LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
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}.
A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
to a fluid, will be set to the result of evaluating @var{exp}.
@end deftp
-@deftp {Scheme Variable} <dynwind> winder body unwinder
-@deftpx {External Representation} (dynwind @var{winder} @var{body} @var{unwinder})
+@deftp {Scheme Variable} <dynwind> winder pre body post unwinder
+@deftpx {External Representation} (dynwind @var{winder} @var{pre} @var{body} @var{post} @var{unwinder})
A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
-evaluate to thunks. Ensure that the winder and the unwinder are called
-before entering and after leaving @var{body}. Note that @var{body} is
-an expression, without a thunk wrapper.
+evaluate to thunks. Ensure that the winder and the unwinder are called
+before entering and after leaving @var{body}. Note that @var{body} is
+an expression, without a thunk wrapper. Guile actually inlines the
+bodies of @var{winder} and @var{unwinder} for the case of normal control
+flow, compiling the expressions in @var{pre} and @var{post},
+respectively.
@end deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
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
#ifndef SCM_LIBGUILE_H
#define SCM_LIBGUILE_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
+#include "libguile/finalizers.h"
#include "libguile/fluids.h"
#include "libguile/foreign.h"
#include "libguile/fports.h"
#include "libguile/srfi-4.h"
#include "libguile/version.h"
#include "libguile/vports.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
+#include "libguile/weak-table.h"
+#include "libguile/weak-vector.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stacks.h"
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
extensions.c \
feature.c \
filesys.c \
+ finalizers.c \
fluids.c \
foreign.c \
fports.c \
version.c \
vm.c \
vports.c \
- weaks.c
+ weak-set.c \
+ weak-table.c \
+ weak-vector.c
DOT_X_FILES = \
alist.x \
vectors.x \
version.x \
vports.x \
- weaks.x
+ weak-set.x \
+ weak-table.x \
+ weak-vector.x
# vm-related snarfs
DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
vectors.doc \
version.doc \
vports.doc \
- weaks.doc
+ weak-set.doc \
+ weak-table.doc \
+ weak-vector.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
expand.h \
extensions.h \
feature.h \
+ finalizers.h \
filesys.h \
fluids.h \
foreign.h \
vm-expand.h \
vm.h \
vports.h \
- weaks.h
+ weak-set.h \
+ weak-table.h \
+ weak-vector.h
nodist_modinclude_HEADERS = version.h scmconfig.h
#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_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)
-#else
-#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
- do { if (SCM_UNLIKELY (!(_cond))) \
- scm_wrong_type_arg (_subr, _pos, _arg); } while (0)
-#define SCM_ASSERT_TYPE(_cond, _arg, _pos, _subr, _msg) \
- do { if (SCM_UNLIKELY (!(_cond))) \
- scm_wrong_type_arg_msg(_subr, _pos, _arg, _msg); } while (0)
-#endif
-
-/*
- * SCM_WTA_DISPATCH
- */
-
-/* Dirk:FIXME:: In all of the SCM_WTA_DISPATCH_* macros it is assumed that
- * 'gf' is zero if uninitialized. It would be cleaner if some valid SCM value
- * like SCM_BOOL_F or SCM_UNDEFINED was chosen.
- */
-
-SCM_API SCM scm_call_generic_0 (SCM gf);
-
-#define SCM_WTA_DISPATCH_0(gf, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_0 ((gf)) \
- : (scm_error_num_args_subr ((subr)), SCM_UNSPECIFIED))
-#define SCM_GASSERT0(cond, gf, subr) \
- if (SCM_UNLIKELY(!(cond))) \
- SCM_WTA_DISPATCH_0((gf), (subr))
-
-SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
-
-#define SCM_WTA_DISPATCH_1(gf, a1, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_1 ((gf), (a1)) \
- : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-/* This form is for dispatching a subroutine. */
-#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \
- return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \
- ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \
- : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED))
-
-#define SCM_GASSERT1(cond, gf, a1, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr))
-
-SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
-
-#define SCM_WTA_DISPATCH_2(gf, a1, a2, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_call_generic_2 ((gf), (a1), (a2)) \
- : (scm_wrong_type_arg ((subr), (pos), \
- (pos) == SCM_ARG1 ? (a1) : (a2)), \
- SCM_UNSPECIFIED))
-#define SCM_GASSERT2(cond, gf, a1, a2, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_2((gf), (a1), (a2), (pos), (subr))
-
-SCM_API SCM scm_apply_generic (SCM gf, SCM args);
-
-#define SCM_WTA_DISPATCH_n(gf, args, pos, subr) \
- return (SCM_UNPACK (gf) \
- ? scm_apply_generic ((gf), (args)) \
- : (scm_wrong_type_arg ((subr), (pos), \
- scm_list_ref ((args), \
- scm_from_int ((pos) - 1))), \
- SCM_UNSPECIFIED))
-#define SCM_GASSERTn(cond, gf, args, pos, subr) \
- if (SCM_UNLIKELY (!(cond))) \
- SCM_WTA_DISPATCH_n((gf), (args), (pos), (subr))
-
#ifndef SCM_MAGIC_SNARFER
/* Let these macros pass through if
we are snarfing; thus we can tell the
\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"
#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
/* Major and minor versions must be single characters. */
-#define SCM_OBJCODE_MAJOR_VERSION 2
+#define SCM_OBJCODE_MAJOR_VERSION 3
#define SCM_OBJCODE_MINOR_VERSION 0
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
-/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
"function is @emph{not} destructive; @var{alist} is not modified.")
#define FUNC_NAME s_scm_acons
{
- return scm_cell (SCM_UNPACK (scm_cell (SCM_UNPACK (key),
- SCM_UNPACK (value))),
- SCM_UNPACK (alist));
+ return scm_cons (scm_cons (key, value), alist);
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static int
arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<arbiter ", port);
+ scm_puts
_unlocked ("#<arbiter ", port);
if (SCM_ARB_LOCKED (exp))
- scm_puts ("locked ", port);
+ scm_puts_unlocked ("locked ", port);
scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
scm_init_array_handle (void)
{
#define DEFINE_ARRAY_TYPE(tag, TAG) \
- scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_locale_symbol (#tag)
+ scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] = scm_from_utf8_symbol (#tag)
scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T;
DEFINE_ARRAY_TYPE (a, CHAR);
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
else
return 0;
- while (SCM_NIMP (ras))
+ while (scm_is_pair (ras))
{
ra1 = SCM_CAR (ras);
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
}
lvra = SCM_EOL;
plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ for (z = lra; scm_is_pair (z); z = SCM_CDR (z))
{
ra1 = SCM_CAR (z);
vra1 = scm_i_make_array (1);
{
SCM y = lra;
SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
- for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ for (z = lvra; scm_is_pair (z); z = SCM_CDR (z), y = SCM_CDR (y))
SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
return 0;
int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
if (scm_is_generalized_vector (ra))
{
else
{
ssize_t i;
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
i++, pos += h->dims[dim].inc)
{
scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
if (i < h->dims[dim].ubnd)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
}
return 1;
}
scm_array_get_handle (array, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
if (h.ndims != 1 || h.dims[0].lbnd != 0)
scm_intprint (h.ndims, 10, port);
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
{
if (print_lbnds)
{
- scm_putc ('@', port);
+ scm_putc_unlocked ('@', port);
scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
not really the same as Scheme values since they are boxed and
can be modified with array-set!, say.
*/
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate);
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
else
if (c == '-')
{
sign = -1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
while ('0' <= c && c <= '9')
{
res = 10*res + c-'0';
got_it = 1;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (got_it)
*/
if (c == '(')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_vector (scm_read (port));
}
*/
if (c == 'f')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c != '3' && c != '6')
{
if (c != EOF)
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return SCM_BOOL_F;
}
rank = 1;
&& tag_len < sizeof tag_buf / sizeof tag_buf[0])
{
tag_buf[tag_len++] = c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
}
if (tag_len == 0)
tag = SCM_BOOL_T;
if (c == '@')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
if (c == ':')
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
c = read_decimal_integer (port, c, &len);
if (len < 0)
scm_i_input_error (NULL, port,
scm_i_input_error (NULL, port,
"missing '(' in vector or array literal",
SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
elements = scm_read (port);
if (scm_is_false (shape))
-/* 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, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/throw.h"
\f
static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (async_mutex);
/* 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 */
/*
boot_print_exception (SCM port, SCM frame, SCM key, SCM args)
#define FUNC_NAME "boot-print-exception"
{
- scm_puts ("Throw to key ", port);
+ scm_puts_unlocked ("Throw to key ", port);
scm_write (key, port);
- scm_puts (" with args ", port);
+ scm_puts_unlocked (" with args ", port);
scm_write (args, port);
return SCM_UNSPECIFIED;
}
{
int i;
for (i = 0; i < n; ++i)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
static void
display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
int i = 0, n;
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (sport);
do
{
pstate->length = print_params[i].length;
{
pstate->level = print_params[i].level - 1;
scm_iprlist (hdr, exp, tlr[0], sport, pstate);
- scm_puts (&tlr[1], sport);
+ scm_puts_unlocked (&tlr[1], sport);
}
else
{
*last_file = file;
- scm_puts ("In ", port);
+ scm_puts_unlocked ("In ", port);
if (scm_is_false (file))
if (scm_is_false (line))
- scm_puts ("unknown file", port);
+ scm_puts_unlocked ("unknown file", port);
else
- scm_puts ("current input", port);
+ scm_puts_unlocked ("current input", port);
else
{
pstate->writingp = 0;
scm_iprin1 (file, port, pstate);
pstate->writingp = 1;
}
- scm_puts (":\n", port);
+ scm_puts_unlocked (":\n", port);
}
static void
if (scm_is_false (file))
{
if (scm_is_false (line))
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
else
- scm_puts ("<stdin>", port);
+ scm_puts_unlocked ("<stdin>", port);
}
else
{
pstate -> writingp = 1;
}
- scm_putc (':', port);
+ scm_putc_unlocked (':', port);
}
else if (scm_is_true (line))
{
}
if (scm_is_false (line))
- scm_puts (" ?", port);
+ scm_puts_unlocked (" ?", port);
else
scm_intprint (scm_to_int (line) + 1, 10, port);
- scm_puts (": ", port);
+ scm_puts_unlocked (": ", port);
}
static void
/* Display an application. */
display_application (frame, nfield + 1 + indentation, sport, port, pstate);
- scm_putc ('\n', port);
+ scm_putc_unlocked ('\n', port);
}
struct display_backtrace_args {
static SCM
error_during_backtrace (void *data, SCM tag, SCM throw_args)
{
- SCM port = PTR2SCM (data);
+ SCM port = SCM_PACK_POINTER (data);
- scm_puts ("Exception thrown while printing backtrace:\n", port);
+ scm_puts_unlocked ("Exception thrown while printing backtrace:\n", port);
scm_print_exception (port, SCM_BOOL_F, tag, throw_args);
return SCM_UNSPECIFIED;
scm_internal_catch (SCM_BOOL_T,
(scm_t_catch_body) display_backtrace_body, &a,
- (scm_t_catch_handler) error_during_backtrace, SCM2PTR (port));
+ (scm_t_catch_handler) error_during_backtrace, SCM_UNPACK_POINTER (port));
return SCM_UNSPECIFIED;
}
highlights = SCM_EOL;
scm_newline (port);
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F,
highlights);
scm_newline (port);
scm_t_uint32 *bits = BITVECTOR_BITS (vec);
size_t i, j;
- scm_puts ("#*", port);
+ scm_puts_unlocked ("#*", port);
for (i = 0; i < word_len; i++, bit_len -= 32)
{
scm_t_uint32 mask = 1;
for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
- scm_putc ((bits[i] & mask)? '1' : '0', port);
+ scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port);
}
return 1;
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 ();
contents = scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len,
SCM_GC_BYTEVECTOR);
- ret = PTR2SCM (contents);
+ ret = SCM_PACK_POINTER (contents);
contents += SCM_BYTEVECTOR_HEADER_BYTES;
SCM_BYTEVECTOR_SET_LENGTH (ret, c_len);
SCM_BYTEVECTOR_SET_CONTENTS (ret, contents);
SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1);
SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F);
}
return ret;
{
size_t c_len;
- ret = PTR2SCM (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
+ ret = SCM_PACK_POINTER (scm_gc_malloc (SCM_BYTEVECTOR_HEADER_BYTES,
SCM_GC_BYTEVECTOR));
c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
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_gc_bytevector (signed char *contents, size_t len)
+scm_c_take_gc_bytevector (signed char *contents, size_t len, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
SCM
scm_c_take_typed_bytevector (signed char *contents, size_t len,
- scm_t_array_element_type element_type)
+ scm_t_array_element_type element_type, SCM parent)
{
- return make_bytevector_from_buffer (len, contents, element_type);
+ SCM ret;
+
+ ret = make_bytevector_from_buffer (len, contents, element_type);
+ SCM_BYTEVECTOR_SET_PARENT (ret, parent);
+
+ return ret;
}
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
scm_array_get_handle (bv, &h);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_write (scm_array_handle_element_type (&h), port);
- scm_putc ('(', port);
+ scm_putc_unlocked ('(', port);
for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc;
i <= ubnd; i += inc)
{
if (i > 0)
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_array_handle_ref (&h, i), port);
}
- scm_putc (')', port);
+ scm_putc_unlocked (')', port);
return 1;
}
c_strlen = scm_i_string_length (str); \
if (scm_i_is_narrow_string (str)) \
{ \
+ scm_i_lock_iconv (); \
err = mem_iconveh (scm_i_string_chars (str), c_strlen, \
"ISO-8859-1", c_utf_name, \
iconveh_question_mark, NULL, \
&c_utf, &c_utf_len); \
+ scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
scm_list_1 (str), err); \
else \
{ \
const scm_t_wchar *wbuf = scm_i_string_wide_chars (str); \
+ scm_i_lock_iconv (); \
c_utf = u32_conv_to_encoding (c_utf_name, \
iconveh_question_mark, \
(scm_t_uint32 *) wbuf, \
c_strlen, NULL, NULL, &c_utf_len); \
+ scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (c_utf == NULL)) \
scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
scm_list_1 (str), errno); \
c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
utf_encoding_name (c_utf_name, (_utf_width), endianness); \
\
+ scm_i_lock_iconv (); \
err = mem_iconveh (c_utf, c_utf_len, \
c_utf_name, "UTF-8", \
iconveh_question_mark, NULL, \
&c_str, &c_strlen); \
+ scm_i_unlock_iconv (); \
if (SCM_UNLIKELY (err)) \
scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
scm_list_1 (utf), err); \
/* 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;
/* Internal API. */
#define SCM_BYTEVECTOR_P(x) \
- (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_bytevector)
+ (SCM_HAS_TYP7 (x, scm_tc7_bytevector))
#define SCM_BYTEVECTOR_FLAGS(_bv) \
(SCM_CELL_TYPE (_bv) >> 7UL)
#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f) \
SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type);
SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
- scm_t_array_element_type);
+ scm_t_array_element_type, SCM);
SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);
SCM_INTERNAL SCM scm_i_native_endianness;
-SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t);
+SCM_INTERNAL SCM scm_c_take_gc_bytevector (signed char *, size_t, SCM);
SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);
-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
sym = uc_general_category_name (cat);
if (sym != NULL)
- return scm_from_locale_symbol (sym);
+ return scm_from_utf8_symbol (sym);
return SCM_BOOL_F;
}
#undef FUNC_NAME
{
scm_t_contregs *continuation = SCM_CONTREGS (obj);
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_intprint (continuation->num_stack_items, 10, port);
- scm_puts (" @ ", port);
+ scm_puts_unlocked (" @ ", port);
scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+/* James Clark came up with this neat one instruction fix for
+ * continuations on the SPARC. It flushes the register windows so
+ * that all the state of the process is contained in the stack.
+ */
+
+#if defined (sparc) || defined (__sparc__) || defined (__sparc)
+# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
+#else
+# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
+#endif
+
/* this may return more than once: the first time with the escape
procedure, then subsequently with SCM_UNDEFINED (the vals already having been
placed on the VM stack). */
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", port);
+ scm_puts_unlocked ("Backtrace:\n", port);
scm_display_backtrace_with_highlights (stack, port,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
{
/* Print the exception unless TAG is `quit'. */
if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
- print_exception_and_backtrace (PTR2SCM (error_port), tag, args);
+ print_exception_and_backtrace (SCM_PACK_POINTER (error_port), tag, args);
return SCM_UNSPECIFIED;
}
scm_i_with_continuation_barrier (c_body, &c_data,
c_handler, &c_data,
pre_unwind_handler,
- SCM2PTR (scm_current_error_port ()));
+ SCM_UNPACK_POINTER (scm_current_error_port ()));
return c_data.result;
}
return scm_i_with_continuation_barrier (scm_body, &scm_data,
scm_handler, &scm_data,
pre_unwind_handler,
- SCM2PTR (scm_current_error_port ()));
+ SCM_UNPACK_POINTER (scm_current_error_port ()));
}
#undef FUNC_NAME
void
scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<prompt ", port);
+ scm_puts
_unlocked ("#<prompt ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
#define SCM_F_PROMPT_ESCAPE 0x1
-#define SCM_PROMPT_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
+#define SCM_PROMPT_P(x) (SCM_HAS_TYP7 (x, scm_tc7_prompt))
#define SCM_PROMPT_FLAGS(x) (SCM_CELL_WORD ((x), 0) >> 8)
#define SCM_PROMPT_ESCAPE_P(x) (SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
#define SCM_PROMPT_TAG(x) (SCM_CELL_OBJECT ((x), 1))
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;
if (scm_is_true (src))
return src;
- switch (SCM_TYP7 (proc)) {
- case scm_tcs_struct:
- if (!SCM_STRUCT_APPLICABLE_P (proc)
- || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
- break;
- proc = SCM_STRUCT_PROCEDURE (proc);
+ if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)
+ && SCM_HEAP_OBJECT_P ((proc = SCM_STRUCT_PROCEDURE (proc))))
continue;
- default:
- break;
- }
}
while (0);
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2012
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012
* 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 (scm_is_false (module_prefix))
- {
- module_prefix = scm_list_2 (scm_sym_app, scm_sym_modules);
- make_modules_in_var = scm_c_lookup ("make-modules-in");
- beautify_user_module_x_var =
- scm_c_lookup ("beautify-user-module!");
- try_module_autoload_var = scm_c_lookup ("try-module-autoload");
- }
-}
-
-static SCM
-scm_module_full_name (SCM name)
-{
- init_module_stuff ();
- if (scm_is_eq (SCM_CAR (name), scm_sym_app))
- return name;
- else
- return scm_append (scm_list_2 (module_prefix, name));
-}
-
-SCM
-scm_make_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
- scm_the_root_module (),
- scm_module_full_name (name));
-}
-
-SCM
-scm_ensure_user_module (SCM module)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
- "Use `scm_c_define_module instead.");
-
- scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
- return SCM_UNSPECIFIED;
-}
-
-SCM
-scm_load_scheme_module (SCM name)
-{
- init_module_stuff ();
- scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
- "Use `scm_c_resolve_module instead.");
-
- return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
-}
-
-/* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
-
-static void
-maybe_close_port (void *data, SCM port)
-{
- SCM except_set = PTR2SCM (data);
-
- while (!scm_is_null (except_set))
- {
- SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except_set));
- if (scm_is_eq (p, port))
- return;
- except_set = SCM_CDR (except_set);
- }
-
- scm_close_port (port);
-}
-
-SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
- (SCM ports),
- "[DEPRECATED] Close all open file ports used by the interpreter\n"
- "except for those supplied as arguments. This procedure\n"
- "was intended to be used before an exec call to close file descriptors\n"
- "which are not needed in the new process. However it has the\n"
- "undesirable side effect of flushing buffers, so it's deprecated.\n"
- "Use port-for-each instead.")
-#define FUNC_NAME s_scm_close_all_ports_except
-{
- SCM p;
- SCM_VALIDATE_REST_ARGUMENT (ports);
-
- for (p = ports; !scm_is_null (p); p = SCM_CDR (p))
- SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
-
- scm_c_port_for_each (maybe_close_port, SCM2PTR (ports));
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0,
- (SCM var, SCM hint),
- "Do not use this function.")
-#define FUNC_NAME s_scm_variable_set_name_hint
-{
- SCM_VALIDATE_VARIABLE (1, var);
- SCM_VALIDATE_SYMBOL (2, hint);
- scm_c_issue_deprecation_warning
- ("'variable-set-name-hint!' is deprecated. Do not use it.");
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
- (SCM name),
- "Do not use this function.")
-#define FUNC_NAME s_scm_builtin_variable
-{
- SCM_VALIDATE_SYMBOL (1,name);
- scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
- "Use module system operations instead.");
- return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T);
-}
-#undef FUNC_NAME
-
-SCM
-scm_makstr (size_t len, int dummy)
-{
- scm_c_issue_deprecation_warning
- ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
- return scm_c_make_string (len, SCM_UNDEFINED);
-}
-
-SCM
-scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED)
-{
- scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
- "Use `scm_from_locale_stringn' instead.");
-
- return scm_from_locale_stringn (src, len);
-}
-
-SCM
-scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
-{
- scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
- "Use `scm_c_with_fluids' instead.");
-
- return scm_c_with_fluids (fluids, values, cproc, cdata);
-}
-
-SCM
-scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
-
- return scm_c_define_gsubr (name, req, opt, rst, fcn);
-}
-
-SCM
-scm_make_gsubr_with_generic (const char *name,
- int req, int opt, int rst,
- SCM (*fcn)(), SCM *gf)
-{
- scm_c_issue_deprecation_warning
- ("`scm_make_gsubr_with_generic' is deprecated. "
- "Use `scm_c_define_gsubr_with_generic' instead.");
-
- return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf);
-}
-
-SCM
-scm_create_hook (const char *name, int n_args)
-{
- scm_c_issue_deprecation_warning
- ("'scm_create_hook' is deprecated. "
- "Use 'scm_make_hook' and 'scm_c_define' instead.");
- {
- SCM hook = scm_make_hook (scm_from_int (n_args));
- scm_c_define (name, hook);
- return hook;
- }
-}
-
-SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memq}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memq
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memq' is deprecated. Use 'memq' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (scm_is_eq (SCM_CAR (lst), x))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{memv}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_memv
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-memv' is deprecated. Use 'memv' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
- (SCM x, SCM lst),
- "This procedure behaves like @code{member}, but does no type or error checking.\n"
- "Its use is recommended only in writing Guile internals,\n"
- "not for high-level Scheme programs.")
-#define FUNC_NAME s_scm_sloppy_member
-{
- scm_c_issue_deprecation_warning
- ("'sloppy-member' is deprecated. Use 'member' instead.");
-
- for(; scm_is_pair (lst); lst = SCM_CDR(lst))
- {
- if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
- return lst;
- }
- return lst;
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
-
-SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
- (SCM port),
- "Read a form from @var{port} (standard input by default), and evaluate it\n"
- "(memoizing it in the process) in the top-level environment. If no data\n"
- "is left to be read from @var{port}, an @code{end-of-file} error is\n"
- "signalled.")
-#define FUNC_NAME s_scm_read_and_eval_x
-{
- SCM form;
-
- scm_c_issue_deprecation_warning
- ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
-
- form = scm_read (port);
- if (SCM_EOF_OBJECT_P (form))
- scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
- return scm_eval_x (form, scm_current_module ());
-}
-#undef FUNC_NAME
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-struct cce_handler_data {
- SCM (*err_filter) ();
- void *closure;
-};
-
-static SCM
-invoke_err_filter (void *d, SCM tag, SCM args)
-{
- struct cce_handler_data *data = (struct cce_handler_data *)d;
- return data->err_filter (SCM_BOOL_F, data->closure);
-}
-
-SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
-{
- scm_c_issue_deprecation_warning
- ("'scm_call_catching_errors' is deprecated. "
- "Use 'scm_internal_catch' instead.");
-
- {
- struct cce_handler_data data;
- data.err_filter = err_filter;
- data.closure = closure;
- return scm_internal_catch (SCM_BOOL_T,
- (scm_t_catch_body)thunk, closure,
- (scm_t_catch_handler)invoke_err_filter, &data);
- }
-}
-
-long
-scm_make_smob_type_mfpe (char *name, size_t size,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state *),
- SCM (*equalp) (SCM, SCM))
-{
- scm_c_issue_deprecation_warning
- ("'scm_make_smob_type_mfpe' is deprecated. "
- "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
-
- {
- long answer = scm_make_smob_type (name, size);
- scm_set_smob_mfpe (answer, mark, free, print, equalp);
- return answer;
- }
-}
-
-void
-scm_set_smob_mfpe (long tc,
- SCM (*mark) (SCM),
- size_t (*free) (SCM),
- int (*print) (SCM, SCM, scm_print_state *),
- SCM (*equalp) (SCM, SCM))
-{
- scm_c_issue_deprecation_warning
- ("'scm_set_smob_mfpe' is deprecated. "
- "Use 'scm_set_smob_mark' instead, for example.");
-
- if (mark) scm_set_smob_mark (tc, mark);
- if (free) scm_set_smob_free (tc, free);
- if (print) scm_set_smob_print (tc, print);
- if (equalp) scm_set_smob_equalp (tc, equalp);
-}
-
-size_t
-scm_smob_free (SCM obj)
-{
- long n = SCM_SMOBNUM (obj);
-
- scm_c_issue_deprecation_warning
- ("`scm_smob_free' is deprecated. "
- "It is no longer needed.");
-
- if (scm_smobs[n].size > 0)
- scm_gc_free ((void *) SCM_SMOB_DATA_1 (obj),
- scm_smobs[n].size, SCM_SMOBNAME (n));
- return 0;
-}
-
-SCM
-scm_read_0str (char *expr)
-{
- scm_c_issue_deprecation_warning
- ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
-
- return scm_c_read_string (expr);
-}
-
-SCM
-scm_eval_0str (const char *expr)
-{
- scm_c_issue_deprecation_warning
- ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
-
- return scm_c_eval_string (expr);
-}
-
-SCM
-scm_strprint_obj (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
- return scm_object_to_string (obj, SCM_UNDEFINED);
-}
-
-char *
-scm_i_object_chars (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_CHARS is deprecated. See the manual for alternatives.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_CHARS (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_CHARS (obj);
- abort ();
-}
-
-long
-scm_i_object_length (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_LENGTH is deprecated. "
- "Use scm_c_string_length instead, for example, or see the manual.");
- if (SCM_STRINGP (obj))
- return SCM_STRING_LENGTH (obj);
- if (SCM_SYMBOLP (obj))
- return SCM_SYMBOL_LENGTH (obj);
- if (SCM_VECTORP (obj))
- return SCM_VECTOR_LENGTH (obj);
- abort ();
-}
-
-SCM
-scm_sym2ovcell_soft (SCM sym, SCM obarray)
-{
- SCM lsym, z;
- size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray);
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
- "Use hashtables instead.");
-
- SCM_CRITICAL_SECTION_START;
- for (lsym = SCM_VECTOR_REF (obarray, hash);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (z), sym))
- {
- SCM_CRITICAL_SECTION_END;
- return z;
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-
-
-SCM
-scm_sym2ovcell (SCM sym, SCM obarray)
-#define FUNC_NAME "scm_sym2ovcell"
-{
- SCM answer;
-
- scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
- "Use hashtables instead.");
-
- answer = scm_sym2ovcell_soft (sym, obarray);
- if (scm_is_true (answer))
- return answer;
- SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym));
- return SCM_UNSPECIFIED; /* not reached */
-}
-#undef FUNC_NAME
-
-
-/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
-
- OBARRAY should be a vector of lists, indexed by the name's hash
- value, modulo OBARRAY's length. Each list has the form
- ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
- value associated with that symbol (in the current module? in the
- system module?)
-
- To "intern" a symbol means: if OBARRAY already contains a symbol by
- that name, return its (SYMBOL . VALUE) pair; otherwise, create a
- new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
- appropriate list of the OBARRAY, and return the pair.
-
- If softness is non-zero, don't create a symbol if it isn't already
- in OBARRAY; instead, just return #f.
-
- If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
- return (SYMBOL . SCM_UNDEFINED). */
-
-
-static SCM
-intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness)
-{
- size_t raw_hash = scm_i_symbol_hash (symbol);
- size_t hash;
- SCM lsym;
-
- if (scm_is_false (obarray))
- {
- if (softness)
- return SCM_BOOL_F;
- else
- return scm_cons (symbol, SCM_UNDEFINED);
- }
-
- hash = raw_hash % SCM_VECTOR_LENGTH (obarray);
-
- for (lsym = SCM_VECTOR_REF(obarray, hash);
- SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
- {
- SCM a = SCM_CAR (lsym);
- SCM z = SCM_CAR (a);
- if (scm_is_eq (z, symbol))
- return a;
- }
-
- if (softness)
- {
- return SCM_BOOL_F;
- }
- else
- {
- SCM cell = scm_cons (symbol, SCM_UNDEFINED);
- SCM slot = SCM_VECTOR_REF (obarray, hash);
-
- SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot));
-
- return cell;
- }
-}
-
-
-SCM
-scm_intern_obarray_soft (const char *name, size_t len, SCM obarray,
- unsigned int softness)
-{
- SCM symbol = scm_from_locale_symboln (name, len);
-
- scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
- "Use hashtables instead.");
-
- return intern_obarray_soft (symbol, obarray, softness);
-}
-
-SCM
-scm_intern_obarray (const char *name,size_t len,SCM obarray)
-{
- scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
- "Use hashtables instead.");
-
- return scm_intern_obarray_soft (name, len, obarray, 0);
-}
-
-/* Lookup the value of the symbol named by the nul-terminated string
- NAME in the current module. */
-SCM
-scm_symbol_value0 (const char *name)
-{
- scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
- "Use `scm_lookup' instead.");
-
- return scm_variable_ref (scm_c_lookup (name));
-}
-
-SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
- (SCM o, SCM s, SCM softp),
- "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
- "@var{string}.\n\n"
- "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
- "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
- "symbol table; merely return the pair (@var{symbol}\n"
- ". @var{#<undefined>}).\n\n"
- "The @var{soft?} argument determines whether new symbol table entries\n"
- "should be created when the specified symbol is not already present in\n"
- "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
- "new entries should not be added for symbols not already present in the\n"
- "table; instead, simply return @code{#f}.")
-#define FUNC_NAME s_scm_string_to_obarray_symbol
-{
- SCM vcell;
- SCM answer;
- int softness;
-
- SCM_VALIDATE_STRING (2, s);
- SCM_ASSERT (scm_is_bool (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME);
-
- scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
- "Use hashtables instead.");
-
- softness = (!SCM_UNBNDP (softp) && scm_is_true(softp));
- /* iron out some screwy calling conventions */
- if (scm_is_false (o))
- {
- /* nothing interesting to do here. */
- return scm_string_to_symbol (s);
- }
- else if (scm_is_eq (o, SCM_BOOL_T))
- o = SCM_BOOL_F;
-
- vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness);
- if (scm_is_false (vcell))
- return vcell;
- answer = SCM_CAR (vcell);
- return answer;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
- "unspecified initial value. The symbol table is not modified if a symbol\n"
- "with this name is already present.")
-#define FUNC_NAME s_scm_intern_symbol
-{
- size_t hval;
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_UNSPECIFIED;
-
- scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- /* If the symbol is already interned, simply return. */
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval);
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
- }
- }
- SCM_VECTOR_SET (o, hval,
- scm_acons (s, SCM_UNDEFINED,
- SCM_VECTOR_REF (o, hval)));
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
- (SCM o, SCM s),
- "Remove the symbol with name @var{string} from @var{obarray}. This\n"
- "function returns @code{#t} if the symbol was present and @code{#f}\n"
- "otherwise.")
-#define FUNC_NAME s_scm_unintern_symbol
-{
- size_t hval;
-
- scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return SCM_BOOL_F;
- SCM_VALIDATE_VECTOR (1,o);
- hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
- SCM_CRITICAL_SECTION_START;
- {
- SCM lsym_follow;
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F;
- SCM_NIMP (lsym);
- lsym_follow = lsym, lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (scm_is_eq (SCM_CAR (sym), s))
- {
- /* Found the symbol to unintern. */
- if (scm_is_false (lsym_follow))
- SCM_VECTOR_SET (o, hval, lsym);
- else
- SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_T;
- }
- }
- }
- SCM_CRITICAL_SECTION_END;
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0,
- (SCM o, SCM s),
- "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
- "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
- "use the global symbol table. If @var{string} is not interned in\n"
- "@var{obarray}, an error is signalled.")
-#define FUNC_NAME s_scm_symbol_binding
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- return scm_variable_ref (scm_lookup (s));
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- return SCM_CDR(vcell);
-}
-#undef FUNC_NAME
-
-#if 0
-SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string}, and @code{#f} otherwise.")
-#define FUNC_NAME s_scm_symbol_interned_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (var != SCM_BOOL_F)
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return (SCM_NIMP(vcell)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-#undef FUNC_NAME
-#endif
-
-SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
- (SCM o, SCM s),
- "Return @code{#t} if @var{obarray} contains a symbol with name\n"
- "@var{string} bound to a defined value. This differs from\n"
- "@var{symbol-interned?} in that the mere mention of a symbol\n"
- "usually causes it to be interned; @code{symbol-bound?}\n"
- "determines whether a symbol has been given any meaningful\n"
- "value.")
-#define FUNC_NAME s_scm_symbol_bound_p
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
- "Use hashtables instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var)))
- return SCM_BOOL_T;
- return SCM_BOOL_F;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell_soft (s, o);
- return scm_from_bool (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0,
- (SCM o, SCM s, SCM v),
- "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
- "it to @var{value}. An error is signalled if @var{string} is not present\n"
- "in @var{obarray}.")
-#define FUNC_NAME s_scm_symbol_set_x
-{
- SCM vcell;
-
- scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
- "Use the module system instead.");
-
- SCM_VALIDATE_SYMBOL (2,s);
- if (scm_is_false (o))
- {
- scm_define (s, v);
- return SCM_UNSPECIFIED;
- }
- SCM_VALIDATE_VECTOR (1,o);
- vcell = scm_sym2ovcell (s, o);
- SCM_SETCDR (vcell, v);
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-#define MAX_PREFIX_LENGTH 30
-
-static int gentemp_counter;
-
-SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
- (SCM prefix, SCM obarray),
- "Create a new symbol with a name unique in an obarray.\n"
- "The name is constructed from an optional string @var{prefix}\n"
- "and a counter value. The default prefix is @code{t}. The\n"
- "@var{obarray} is specified as a second optional argument.\n"
- "Default is the system obarray where all normal symbols are\n"
- "interned. The counter is increased by 1 at each\n"
- "call. There is no provision for resetting the counter.")
-#define FUNC_NAME s_scm_gentemp
-{
- char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
- char *name = buf;
- int n_digits;
- size_t len;
-
- scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
- "Use `gensym' instead.");
-
- if (SCM_UNBNDP (prefix))
- {
- name[0] = 't';
- len = 1;
- }
- else
- {
- SCM_VALIDATE_STRING (1, prefix);
- len = scm_i_string_length (prefix);
- name = scm_to_locale_stringn (prefix, &len);
- name = scm_realloc (name, len + SCM_INTBUFLEN);
- }
-
- if (SCM_UNBNDP (obarray))
- return scm_gensym (prefix);
- else
- SCM_ASSERT ((scm_is_vector (obarray) || SCM_I_WVECTP (obarray)),
- obarray,
- SCM_ARG2,
- FUNC_NAME);
- do
- n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]);
- while (scm_is_true (scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 1)));
- {
- SCM vcell = scm_intern_obarray_soft (name,
- len + n_digits,
- obarray,
- 0);
- if (name != buf)
- free (name);
- return SCM_CAR (vcell);
- }
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_makinum (scm_t_signed_bits val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
- return SCM_I_MAKINUM (val);
-}
-
-int
-scm_i_inump (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
- return SCM_I_INUMP (obj);
-}
-
-scm_t_signed_bits
-scm_i_inum (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
- return scm_to_intmax (obj);
-}
-
-char *
-scm_c_string2str (SCM obj, char *str, size_t *lenp)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
-
- if (str == NULL)
- {
- char *result = scm_to_locale_string (obj);
- if (lenp)
- *lenp = scm_i_string_length (obj);
- return result;
- }
- else
- {
- /* Pray that STR is large enough.
- */
- size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX);
- str[len] = '\0';
- if (lenp)
- *lenp = len;
- return str;
- }
-}
-
-char *
-scm_c_substring2str (SCM obj, char *str, size_t start, size_t len)
-{
- scm_c_issue_deprecation_warning
- ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
-
- if (start)
- obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED);
-
- scm_to_locale_stringbuf (obj, str, len);
- return str;
-}
-
-/* Converts the given Scheme symbol OBJ into a C string, containing a copy
- of OBJ's content with a trailing null byte. If LENP is non-NULL, set
- *LENP to the string's length.
-
- When STR is non-NULL it receives the copy and is returned by the function,
- otherwise new memory is allocated and the caller is responsible for
- freeing it via free(). If out of memory, NULL is returned.
-
- Note that Scheme symbols may contain arbitrary data, including null
- characters. This means that null termination is not a reliable way to
- determine the length of the returned value. However, the function always
- copies the complete contents of OBJ, and sets *LENP to the length of the
- scheme symbol (if LENP is non-null). */
-char *
-scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
-{
- return scm_c_string2str (scm_symbol_to_string (obj), str, lenp);
-}
-
-double
-scm_truncate (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_truncate is deprecated. Use scm_c_truncate instead.");
- return scm_c_truncate (x);
-}
-
-double
-scm_round (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_round is deprecated. Use scm_c_round instead.");
- return scm_c_round (x);
-}
-
-SCM
-scm_sys_expt (SCM x, SCM y)
-{
- scm_c_issue_deprecation_warning
- ("scm_sys_expt is deprecated. Use scm_expt instead.");
- return scm_expt (x, y);
-}
-
-double
-scm_asinh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_asinh is deprecated. Use asinh instead.");
-#if HAVE_ASINH
- return asinh (x);
-#else
- return log (x + sqrt (x * x + 1));
-#endif
-}
-
-double
-scm_acosh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_acosh is deprecated. Use acosh instead.");
-#if HAVE_ACOSH
- return acosh (x);
-#else
- return log (x + sqrt (x * x - 1));
-#endif
-}
-
-double
-scm_atanh (double x)
-{
- scm_c_issue_deprecation_warning
- ("scm_atanh is deprecated. Use atanh instead.");
-#if HAVE_ATANH
- return atanh (x);
-#else
- return 0.5 * log ((1 + x) / (1 - x));
-#endif
-}
-
-SCM
-scm_sys_atan2 (SCM z1, SCM z2)
-{
- scm_c_issue_deprecation_warning
- ("scm_sys_atan2 is deprecated. Use scm_atan instead.");
- return scm_atan (z1, z2);
-}
-
-char *
-scm_i_deprecated_symbol_chars (SCM sym)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
-
- return (char *)scm_i_symbol_chars (sym);
-}
-
-size_t
-scm_i_deprecated_symbol_length (SCM sym)
-{
- scm_c_issue_deprecation_warning
- ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
- return scm_i_symbol_length (sym);
-}
-
-int
-scm_i_keywordp (SCM obj)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
- return scm_is_keyword (obj);
-}
-
-SCM
-scm_i_keywordsym (SCM keyword)
-{
- scm_c_issue_deprecation_warning
- ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
- return scm_keyword_dash_symbol (keyword);
-}
-
-int
-scm_i_vectorp (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
- return SCM_I_IS_VECTOR (x);
-}
-
-unsigned long
-scm_i_vector_length (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
- return SCM_I_VECTOR_LENGTH (x);
-}
-
-const SCM *
-scm_i_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
- return SCM_I_VECTOR_ELTS (x);
-}
-
-SCM *
-scm_i_writable_velts (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_WRITABLE_VELTS is deprecated. "
- "Use scm_vector_writable_elements instead.");
- return SCM_I_VECTOR_WELTS (x);
-}
-
-SCM
-scm_i_vector_ref (SCM x, size_t idx)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_REF is deprecated. "
- "Use scm_c_vector_ref or scm_vector_elements instead.");
- return scm_c_vector_ref (x, idx);
-}
-
-void
-scm_i_vector_set (SCM x, size_t idx, SCM val)
-{
- scm_c_issue_deprecation_warning
- ("SCM_VECTOR_SET is deprecated. "
- "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
- scm_c_vector_set_x (x, idx, val);
-}
-
-SCM
-scm_vector_equal_p (SCM x, SCM y)
-{
- scm_c_issue_deprecation_warning
- ("scm_vector_euqal_p is deprecated. "
- "Use scm_equal_p instead.");
- return scm_equal_p (x, y);
-}
-
-SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Fill the elements of @var{uvec} by reading\n"
- "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
- "The optional arguments @var{start} (inclusive) and @var{end}\n"
- "(exclusive) allow a specified region to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be read, potentially blocking\n"
- "while waiting for more input or end-of-file.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "read(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially filled before reaching end-of-file or in\n"
- "the single call to read(2).\n\n"
- "@code{uniform-vector-read!} returns the number of elements\n"
- "read.\n\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults\n"
- "to the value returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_read_x
-{
- SCM result;
- size_t c_width, c_start, c_end;
-
- SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-
- scm_c_issue_deprecation_warning
- ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
- "`(rnrs io ports)' instead.");
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-
- c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
- c_start *= c_width;
-
- c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t (end);
- c_end *= c_width;
-
- result = scm_get_bytevector_n_x (port_or_fd, uvec,
- scm_from_size_t (c_start),
- scm_from_size_t (c_end - c_start));
-
- if (SCM_EOF_OBJECT_P (result))
- result = SCM_INUM0;
-
- return result;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Write the elements of @var{uvec} as raw bytes to\n"
- "@var{port-or-fdes}, in the host byte order.\n\n"
- "The optional arguments @var{start} (inclusive)\n"
- "and @var{end} (exclusive) allow\n"
- "a specified region to be written.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be written, potentially blocking\n"
- "while waiting for more room.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "write(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially written in the single call to write(2).\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_write
-{
- size_t c_width, c_start, c_end;
-
- SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-
- scm_c_issue_deprecation_warning
- ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
- "`(rnrs io ports)' instead.");
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- c_width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-
- c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start);
- c_start *= c_width;
-
- c_end = SCM_UNBNDP (end) ? SCM_BYTEVECTOR_LENGTH (uvec) : scm_to_size_t (end);
- c_end *= c_width;
-
- return scm_put_bytevector (port_or_fd, uvec,
- scm_from_size_t (c_start),
- scm_from_size_t (c_end - c_start));
-}
-#undef FUNC_NAME
-
-static SCM
-scm_ra2contig (SCM ra, int copy)
-{
- SCM ret;
- long inc = 1;
- size_t k, len = 1;
- for (k = SCM_I_ARRAY_NDIM (ra); k--;)
- len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_I_ARRAY_NDIM (ra);
- if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
- {
- if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
- return ra;
- if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
- 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_i_make_array (k);
- SCM_I_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
- SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
- SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_I_ARRAY_V (ret) =
- scm_make_generalized_vector (scm_array_type (ra), scm_from_size_t (inc),
- SCM_UNDEFINED);
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
- "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
- "binary objects from @var{port-or-fdes}.\n"
- "If an end of file is encountered,\n"
- "the objects up to that point are put into @var{ura}\n"
- "(starting at the beginning) and the remainder of the array is\n"
- "unchanged.\n\n"
- "The optional arguments @var{start} and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "@code{uniform-array-read!} returns the number of objects read.\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
- "returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_array_read_x
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 0);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- if (!scm_is_eq (cra, ura))
- scm_array_copy_x (cra, ura);
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
- (SCM ura, SCM port_or_fd, SCM start, SCM end),
- "Writes all elements of @var{ura} as binary objects to\n"
- "@var{port-or-fdes}.\n\n"
- "The optional arguments @var{start}\n"
- "and @var{end} allow\n"
- "a specified region of a vector (or linearized array) to be written.\n\n"
- "The number of objects actually written is returned.\n"
- "@var{port-or-fdes} may be\n"
- "omitted, in which case it defaults to the value returned by\n"
- "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_array_write
-{
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
-
- if (scm_is_uniform_vector (ura))
- {
- return scm_uniform_vector_write (ura, port_or_fd, start, end);
- }
- else if (SCM_I_ARRAYP (ura))
- {
- size_t base, vlen, cstart, cend;
- SCM cra, ans;
-
- cra = scm_ra2contig (ura, 1);
- base = SCM_I_ARRAY_BASE (cra);
- vlen = SCM_I_ARRAY_DIMS (cra)->inc *
- (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
- cstart = 0;
- cend = vlen;
- if (!SCM_UNBNDP (start))
- {
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
- }
-
- ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
- scm_from_size_t (base + cstart),
- scm_from_size_t (base + cend));
-
- return ans;
- }
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM
-scm_i_cur_inp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
- return scm_current_input_port ();
-}
-
-SCM
-scm_i_cur_outp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
- return scm_current_output_port ();
-}
-
-SCM
-scm_i_cur_errp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
- return scm_current_error_port ();
-}
-
-SCM
-scm_i_cur_loadp (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
- return scm_current_load_port ();
-}
-
-SCM
-scm_i_progargs (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_progargs is deprecated. Use scm_program_arguments instead.");
- return scm_program_arguments ();
-}
-
-SCM
-scm_i_deprecated_dynwinds (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_dynwinds is deprecated. Do not use it.");
- return scm_i_dynwinds ();
-}
-
-SCM_STACKITEM *
-scm_i_stack_base (void)
-{
- scm_c_issue_deprecation_warning
- ("scm_stack_base is deprecated. Do not use it.");
- return SCM_I_CURRENT_THREAD->base;
-}
-
-int
-scm_i_fluidp (SCM x)
-{
- scm_c_issue_deprecation_warning
- ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
- return scm_is_fluid (x);
-}
-
-\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))
- {
-#if HAVE_MODULES
- func = scm_dynamic_func (func, dobj);
-#else
- scm_misc_error ("dynamic-args-call",
- "dynamic-func not available to resolve ~S",
- scm_list_1 (func));
-#endif
- }
- SCM_VALIDATE_POINTER (SCM_ARG1, func);
-
- fptr = SCM_POINTER_VALUE (func);
-
- argv = scm_i_allocate_string_pointers (args);
- for (argc = 0; argv[argc]; argc++)
- ;
- result = (*fptr) (argc, argv);
-
- return scm_from_int (result);
-}
-#undef FUNC_NAME
-
-
-\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 (!scm_is_false (not_found_proc))
- SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
- return scm_cons (not_found_proc, SCM_EOL);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
- (SCM prop, SCM obj),
- "Return the property @var{prop} of @var{obj}.\n"
- "\n"
- "When no value has yet been associated with @var{prop} and\n"
- "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
- "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
- "and the result set as the property value. If\n"
- "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
- "property value.")
-#define FUNC_NAME s_scm_primitive_property_ref
-{
- SCM alist;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-ref' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
-
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- if (scm_is_pair (alist))
- {
- SCM assoc = scm_assq (prop, alist);
- if (scm_is_true (assoc))
- return SCM_CDR (assoc);
- }
-
- if (scm_is_false (SCM_CAR (prop)))
- return SCM_BOOL_F;
- else
- {
- SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
- scm_hashq_set_x (properties_whash, obj,
- scm_acons (prop, val, alist));
- return val;
- }
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
- (SCM prop, SCM obj, SCM val),
- "Set the property @var{prop} of @var{obj} to @var{val}.")
-#define FUNC_NAME s_scm_primitive_property_set_x
-{
- SCM alist, assoc;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-set!' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- assoc = scm_assq (prop, alist);
- if (scm_is_pair (assoc))
- SCM_SETCDR (assoc, val);
- else
- scm_hashq_set_x (properties_whash, obj,
- scm_acons (prop, val, alist));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
- (SCM prop, SCM obj),
- "Remove any value associated with @var{prop} and @var{obj}.")
-#define FUNC_NAME s_scm_primitive_property_del_x
-{
- SCM alist;
-
- scm_c_issue_deprecation_warning
- ("`primitive-property-del!' is deprecated. Use object properties.");
-
- SCM_VALIDATE_CONS (SCM_ARG1, prop);
- alist = scm_hashq_ref (properties_whash, obj, SCM_EOL);
- if (scm_is_pair (alist))
- scm_hashq_set_x (properties_whash, obj, scm_assq_remove_x (alist, prop));
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
-
-\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
-
-
-scm_t_bits
-scm_i_deprecated_asrtgo (scm_t_bits condition)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ASRTGO is deprecated. Use `if (!condition) goto label;' directly.");
-
- return condition;
-}
-
-
-\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, 2012 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#include "libguile/__scm.h"
-#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_DEPRECATED SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
-SCM_DEPRECATED SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
- scm_t_bits ccr, scm_t_bits cdr);
-
-\f
-
-SCM_DEPRECATED scm_t_bits scm_i_deprecated_asrtgo (scm_t_bits condition);
-
-/* Deprecated 08-01-2012, as it's undocumented and unused. */
-#define SCM_ASRTGO(_cond, _label) \
- do { if (!scm_i_deprecated_asrtgo(_cond)) goto _label; } while (0)
-
-\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 */
-/* Copyright (C) 2001, 2006, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
};
static scm_i_pthread_mutex_t warn_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (warn_lock);
static struct issued_warning *issued_warnings;
static int print_summary = 0;
fprintf (stderr, "%s\n", msg);
else
{
- scm_puts (msg, scm_current_warning_port ());
+ scm_puts_unlocked (msg, scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
}
}
static int
dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<dynamic-object ", port);
+ scm_puts_unlocked ("#<dynamic-object ", port);
scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
if (DYNL_HANDLE (exp) == NULL)
- scm_puts (" (unlinked)", port);
- scm_putc ('>', port);
+ scm_puts_unlocked (" (unlinked)", port);
+ scm_putc_unlocked ('>', port);
return 1;
}
scm_swap_bindings (SCM vars, SCM vals)
{
SCM tmp;
- while (SCM_NIMP (vals))
+ while (scm_is_pair (vals))
{
tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
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:
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<boot-closure ", port);
+ scm_uintprint (SCM_UNPACK (closure), 16, port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
case scm_tc7_wvect:
case scm_tc7_pointer:
case scm_tc7_hashtable:
+ case scm_tc7_weak_set:
+ case scm_tc7_weak_table:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:
#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
(scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
scm_from_locale_string ("pw"))));
printer = SCM_BOOL_F;
- name = scm_from_locale_symbol (exp_names[n]);
+ name = scm_from_utf8_symbol (exp_names[n]);
code = scm_from_size_t (n);
fields = SCM_EOL;
{
size_t m = exp_nfields[n];
while (m--)
- fields = scm_cons (scm_from_locale_symbol (exp_field_names[n][m]), fields);
+ fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields);
}
return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
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 \
scm_add_feature (const char *str)
{
SCM old = SCM_VARIABLE_REF (features_var);
- SCM new = scm_cons (scm_from_locale_symbol (str), old);
+ SCM new = scm_cons (scm_from_utf8_symbol (str), old);
SCM_VARIABLE_SET (features_var, new);
}
#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"
}
if (SCM_OPFPORTP (object))
{
- scm_flush (object);
+ scm_flush_unlocked (object);
fdes = SCM_FPORT_FDES (object);
}
else
static int
scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (!SCM_DIR_OPEN_P (exp))
- scm_puts ("closed: ", port);
- scm_puts ("directory stream ", port);
+ scm_puts_unlocked ("closed: ", port);
+ scm_puts_unlocked ("directory stream ", port);
scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_DIR_FLAG_OPEN (1L << 0)
-#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
+#define SCM_DIRP(x) (SCM_HAS_TYP16 (x, scm_tc16_dir))
#define SCM_DIR_OPEN_P(x) (SCM_SMOB_FLAGS (x) & SCM_DIR_FLAG_OPEN)
\f
--- /dev/null
+/* Copyright (C) 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/bdw-gc.h"
+#include "libguile/_scm.h"
+#include "libguile/finalizers.h"
+#include "libguile/gc.h"
+#include "libguile/threads.h"
+
+\f
+
+void
+scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ GC_finalization_proc prev;
+ GC_PTR prev_data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, proc, data, &prev, &prev_data);
+}
+
+struct scm_t_chained_finalizer
+{
+ int resuscitating_p;
+ scm_t_finalizer_proc proc;
+ void *data;
+ scm_t_finalizer_proc prev;
+ void *prev_data;
+};
+
+static void
+chained_finalizer (void *obj, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data = data;
+ if (chained_data->resuscitating_p)
+ {
+ if (chained_data->prev)
+ scm_i_set_finalizer (obj, chained_data->prev, chained_data->prev_data);
+ chained_data->proc (obj, chained_data->data);
+ }
+ else
+ {
+ chained_data->proc (obj, chained_data->data);
+ if (chained_data->prev)
+ chained_data->prev (obj, chained_data->prev_data);
+ }
+}
+
+void
+scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data;
+ chained_data = scm_gc_malloc (sizeof (*chained_data), "chained finalizer");
+ chained_data->resuscitating_p = 1;
+ chained_data->proc = proc;
+ chained_data->data = data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, chained_finalizer, chained_data,
+ &chained_data->prev,
+ &chained_data->prev_data);
+}
+
+static void
+shuffle_resuscitators_to_front (struct scm_t_chained_finalizer *cd)
+{
+ while (cd->prev == chained_finalizer)
+ {
+ struct scm_t_chained_finalizer *prev = cd->prev_data;
+ scm_t_finalizer_proc proc = cd->proc;
+ void *data = cd->data;
+
+ if (!prev->resuscitating_p)
+ break;
+
+ cd->resuscitating_p = 1;
+ cd->proc = prev->proc;
+ cd->data = prev->data;
+
+ prev->resuscitating_p = 0;
+ prev->proc = proc;
+ prev->data = data;
+
+ cd = prev;
+ }
+}
+
+void
+scm_i_add_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
+{
+ struct scm_t_chained_finalizer *chained_data;
+ chained_data = scm_gc_malloc (sizeof (*chained_data), "chained finalizer");
+ chained_data->resuscitating_p = 0;
+ chained_data->proc = proc;
+ chained_data->data = data;
+ GC_REGISTER_FINALIZER_NO_ORDER (obj, chained_finalizer, chained_data,
+ &chained_data->prev,
+ &chained_data->prev_data);
+ shuffle_resuscitators_to_front (chained_data);
+}
+
+\f
+
+
+void
+scm_init_finalizers (void)
+{
+}
--- /dev/null
+#ifndef SCM_FINALIZERS_H
+#define SCM_FINALIZERS_H
+
+/* Copyright (C) 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+typedef void (*scm_t_finalizer_proc) (void *obj, void *data);
+
+SCM_INTERNAL void scm_i_set_finalizer (void *obj, scm_t_finalizer_proc,
+ void *data);
+SCM_INTERNAL void scm_i_add_finalizer (void *obj, scm_t_finalizer_proc,
+ void *data);
+SCM_INTERNAL void scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc,
+ void *data);
+
+SCM_INTERNAL void scm_init_finalizers (void);
+
+#endif /* SCM_FINALIZERS_H */
static size_t allocated_fluids_len = 0;
static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (fluid_admin_mutex);
#define IS_FLUID(x) SCM_FLUID_P (x)
#define FLUID_NUM(x) SCM_I_FLUID_NUM (x)
void
scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<fluid ", port);
+ scm_puts_unlocked ("#<fluid ", port);
scm_intprint ((int) FLUID_NUM (exp), 10, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<dynamic-state ", port);
+ scm_puts_unlocked ("#<dynamic-state ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
void
scm_i_with_fluids_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<with-fluids ", port);
+ scm_puts_unlocked ("#<with-fluids ", port);
scm_intprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
\f
allocated_fluids_len += FLUID_GROW;
}
- allocated_fluids[n] = SCM2PTR (fluid);
+ allocated_fluids[n] = SCM_UNPACK_POINTER (fluid);
SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8)));
GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n],
always in the same place for a given thread, in the dynamic-state vector.
*/
-#define SCM_WITH_FLUIDS_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_fluids)
+#define SCM_WITH_FLUIDS_P(x) (SCM_HAS_TYP7 (x, scm_tc7_with_fluids))
#define SCM_WITH_FLUIDS_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8)
#define SCM_WITH_FLUIDS_NTH_FLUID(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2))
#define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2))
grow.
*/
-#define SCM_FLUID_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_fluid)
+#define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid))
#ifdef BUILDING_LIBGUILE
#define SCM_I_FLUID_NUM(x) ((size_t)(SCM_CELL_WORD_0 (x) >> 8))
#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x))
SCM_API void scm_dynwind_fluid (SCM fluid, SCM value);
#ifdef BUILDING_LIBGUILE
-#define SCM_I_DYNAMIC_STATE_P(x) (!SCM_IMP (x) && SCM_TYP7 (x) == scm_tc7_dynamic_state)
+#define SCM_I_DYNAMIC_STATE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_dynamic_state))
#define SCM_I_DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x))
#endif
static SCM pointer_weak_refs = SCM_BOOL_F;
-static scm_i_pthread_mutex_t weak_refs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static void
register_weak_reference (SCM from, SCM to)
{
- scm_i_pthread_mutex_lock (&weak_refs_lock);
- scm_hashq_set_x (pointer_weak_refs, from, to);
- scm_i_pthread_mutex_unlock (&weak_refs_lock);
+ scm_weak_table_putq_x (pointer_weak_refs, from, to);
}
static void
pointer_finalizer_trampoline (GC_PTR ptr, GC_PTR data)
{
scm_t_pointer_finalizer finalizer = data;
- finalizer (SCM_POINTER_VALUE (PTR2SCM (ptr)));
+ finalizer (SCM_POINTER_VALUE (SCM_PACK_POINTER (ptr)));
}
SCM_DEFINE (scm_pointer_p, "pointer?", 1, 0, 0,
ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
if (finalizer)
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- pointer_finalizer_trampoline,
- finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ scm_i_set_finalizer (SCM2PTR (ret), pointer_finalizer_trampoline,
+ finalizer);
}
return ret;
SCM ret;
ret = scm_from_pointer ((void*) SCM_UNPACK (scm), NULL);
- if (SCM_NIMP (ret))
+ if (SCM_HEAP_OBJECT_P (ret))
register_weak_reference (ret, scm);
return ret;
blen = scm_to_size_t (len);
ret = scm_c_take_typed_bytevector ((signed char *) ptr + boffset,
- blen, btype);
- register_weak_reference (ret, pointer);
+ blen, btype, pointer);
+
return ret;
}
#undef FUNC_NAME
"Scheme. If you need a Scheme finalizer, use guardians.")
#define FUNC_NAME s_scm_set_pointer_finalizer_x
{
- void *c_finalizer;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
-
SCM_VALIDATE_POINTER (1, pointer);
SCM_VALIDATE_POINTER (2, finalizer);
- c_finalizer = SCM_POINTER_VALUE (finalizer);
-
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (pointer),
- pointer_finalizer_trampoline,
- c_finalizer,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_add_finalizer (SCM2PTR (pointer), pointer_finalizer_trampoline,
+ SCM_POINTER_VALUE (finalizer));
return SCM_UNSPECIFIED;
}
void
scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<pointer 0x", port);
+ scm_puts
_unlocked ("#<pointer 0x", port);
scm_uintprint (scm_to_uintptr (scm_pointer_address (pointer)), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
\f
size_t i;
SCM proc, *argv, result;
- proc = PTR2SCM (data);
+ proc = SCM_PACK_POINTER (data);
argv = alloca (cif->nargs * sizeof (*argv));
closure = ffi_closure_alloc (sizeof (ffi_closure), &executable);
err = ffi_prep_closure_loc ((ffi_closure *) closure, cif,
- invoke_closure, SCM2PTR (proc),
+ invoke_closure, SCM_UNPACK_POINTER (proc),
executable);
if (err != FFI_OK)
{
"scm_init_foreign",
(scm_t_extension_init_func)scm_init_foreign,
NULL);
- pointer_weak_refs = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ pointer_weak_refs = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*
typedef void (*scm_t_pointer_finalizer) (void *);
-#define SCM_POINTER_P(x) \
- (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
+#define SCM_POINTER_P(x) (SCM_HAS_TYP7 (x, scm_tc7_pointer))
#define SCM_VALIDATE_POINTER(pos, x) \
SCM_MAKE_VALIDATE (pos, x, POINTER_P)
#define SCM_POINTER_VALUE(x) \
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
drained = scm_nullstr;
if (SCM_OUTPUT_PORT_P (port))
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->read_buf == pt->putback_buf)
{
#define FUNC_NAME "scm_fdes_to_port"
{
SCM port;
- scm_t_port *pt;
+ scm_t_fport *fp;
int flags;
/* test that fdes is valid. */
SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
}
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
+ "file port");
+ fp->fdes = fdes;
+
+ port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp);
+
+ SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes);
+
+ if (mode_bits & SCM_BUF0)
+ scm_fport_buffer_add (port, 0, 0);
+ else
+ scm_fport_buffer_add (port, -1, -1);
- port = scm_new_port_table_entry (scm_tc16_fport);
- SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
- pt = SCM_PTAB_ENTRY(port);
- {
- scm_t_fport *fp
- = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport),
- "file port");
-
- fp->fdes = fdes;
- pt->rw_random = SCM_FDES_RANDOM_P (fdes);
- SCM_SETSTREAM (port, fp);
- if (mode_bits & SCM_BUF0)
- scm_fport_buffer_add (port, 0, 0);
- else
- scm_fport_buffer_add (port, -1, -1);
- }
SCM_SET_FILENAME (port, name);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
return port;
}
#undef FUNC_NAME
#endif
}
+
+\f
+
+/* Revealed counts --- an oddity inherited from SCSH. */
+
+#define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
+
+static SCM revealed_ports = SCM_EOL;
+static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (revealed_lock);
+
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+int
+scm_revealed_count (SCM port)
+{
+ int ret;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+ ret = SCM_REVEALED (port);
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return ret;
+}
+
+SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
+ (SCM port),
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
+ (SCM port, SCM rcount),
+ "Sets the revealed count for a port to a given value.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ int r, prev;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ r = scm_to_int (rcount);
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ prev = SCM_REVEALED (port);
+ SCM_REVEALED (port) = r;
+
+ if (r && !prev)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (prev && !r)
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
+ (SCM port, SCM addend),
+ "Add @var{addend} to the revealed count of @var{port}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_adjust_port_revealed_x
+{
+ int a;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+
+ a = scm_to_int (addend);
+ if (!a)
+ return SCM_UNSPECIFIED;
+
+ scm_i_pthread_mutex_lock (&revealed_lock);
+
+ SCM_REVEALED (port) += a;
+ if (SCM_REVEALED (port) == a)
+ revealed_ports = scm_cons (port, revealed_ports);
+ else if (!SCM_REVEALED (port))
+ revealed_ports = scm_delq_x (port, revealed_ports);
+
+ scm_i_pthread_mutex_unlock (&revealed_lock);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
\f
static int
fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
if (SCM_OPFPORTP (exp))
{
if (scm_is_string (name) || scm_is_symbol (name))
scm_display (name, port);
else
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
fdes = (SCM_FSTREAM (exp))->fdes;
#if (defined HAVE_TTYNAME) && (defined HAVE_POSIX)
}
else
{
- scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
- scm_putc (' ', port);
+ scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc_unlocked (' ', port);
scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
if (offset != 0 || whence != SEEK_CUR)
{
/* could expand to avoid a second seek. */
- scm_end_input (port);
+ scm_end_input_unlocked (port);
result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
}
else
pt->rw_active = SCM_PORT_NEITHER;
}
+static void
+close_the_fd (void *data)
+{
+ scm_t_fport *fp = data;
+
+ close (fp->fdes);
+ /* There's already one exception. That's probably enough! */
+ errno = 0;
+}
+
static int
fport_close (SCM port)
{
scm_t_fport *fp = SCM_FSTREAM (port);
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
int rv;
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (close_the_fd, fp, 0);
fport_flush (port);
- SCM_SYSCALL (rv = close (fp->fdes));
- if (rv == -1 && errno != EBADF)
- {
- if (scm_gc_running_p)
- /* silently ignore the error. scm_error would abort if we
- called it now. */
- ;
- else
- scm_syserror ("fport_close");
- }
- if (pt->read_buf == pt->putback_buf)
- pt->read_buf = pt->saved_read_buf;
- if (pt->read_buf != &pt->shortbuf)
- scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
- if (pt->write_buf != &pt->shortbuf)
- scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
- scm_gc_free (fp, sizeof (*fp), "file port");
- return rv;
+ scm_dynwind_end ();
+
+ scm_port_non_buffer (SCM_PTAB_ENTRY (port));
+
+ rv = close (fp->fdes);
+ if (rv)
+ /* It's not useful to retry after EINTR, as the file descriptor is
+ in an undefined state. See http://lwn.net/Articles/365294/.
+ Instead just throw an error if close fails, trusting that the fd
+ was cleaned up. */
+ scm_syserror ("fport_close");
+
+ return 0;
}
static size_t
#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* struct allocated for each buffered FPORT. */
typedef struct scm_t_fport {
int fdes; /* file descriptor. */
+ int revealed; /* 0 not revealed, > 1 revealed.
+ * Revealed ports do not get GC'd.
+ */
} scm_t_fport;
SCM_API scm_t_bits scm_tc16_fport;
#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x))
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)
-#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport))
+#define SCM_FPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_fport))
#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
SCM_API SCM scm_open_file (SCM filename, SCM modes);
SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
SCM_API SCM scm_file_port_p (SCM obj);
+
+\f
+/* Revealed counts. */
+SCM_API int scm_revealed_count (SCM port);
+SCM_API SCM scm_port_revealed (SCM port);
+SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_API SCM scm_adjust_port_revealed_x (SCM port, SCM addend);
+
+\f
SCM_INTERNAL void scm_init_fports (void);
/* internal functions */
void
scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<frame ", port);
+ scm_puts_unlocked ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
\f
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
+#define SCM_VM_FRAME_P(x) (SCM_HAS_TYP7 (x, scm_tc7_frame))
#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
{
return scm_gc_strndup (str, strlen (str), what);
}
-
-#if SCM_ENABLE_DEPRECATED == 1
-
-/* {Deprecated front end to malloc}
- *
- * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
- * scm_done_free
- *
- * These functions provide services comparable to malloc, realloc, and
- * free.
- *
- * There has been a fair amount of confusion around the use of these functions;
- * see "Memory Blocks" in the manual. They are totally unnecessary in 2.0 given
- * the Boehm GC.
- */
-
-void *
-scm_must_malloc (size_t size, const char *what)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_malloc is deprecated. "
- "Use scm_gc_malloc and scm_gc_free instead.");
-
- return scm_gc_malloc (size, what);
-}
-
-void *
-scm_must_realloc (void *where,
- size_t old_size,
- size_t size,
- const char *what)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_realloc is deprecated. "
- "Use scm_gc_realloc and scm_gc_free instead.");
-
- return scm_gc_realloc (where, old_size, size, what);
-}
-
-char *
-scm_must_strndup (const char *str, size_t length)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_strndup is deprecated. "
- "Use scm_gc_strndup and scm_gc_free instead.");
-
- return scm_gc_strndup (str, length, "string");
-}
-
-char *
-scm_must_strdup (const char *str)
-{
- scm_c_issue_deprecation_warning
- ("scm_must_strdup is deprecated. "
- "Use scm_gc_strdup and scm_gc_free instead.");
-
- return scm_gc_strdup (str, "string");
-}
-
-void
-scm_must_free (void *obj)
-#define FUNC_NAME "scm_must_free"
-{
- scm_c_issue_deprecation_warning
- ("scm_must_free is deprecated. "
- "Use scm_gc_malloc and scm_gc_free instead.");
-
- do_gc_free (obj);
-}
-#undef FUNC_NAME
-
-
-void
-scm_done_malloc (long size)
-{
- scm_c_issue_deprecation_warning
- ("scm_done_malloc is deprecated. "
- "Use scm_gc_register_collectable_memory instead.");
-
- if (size >= 0)
- scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
- else
- scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
-}
-
-void
-scm_done_free (long size)
-{
- scm_c_issue_deprecation_warning
- ("scm_done_free is deprecated. "
- "Use scm_gc_unregister_collectable_memory instead.");
-
- if (size >= 0)
- scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
- else
- scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
-}
-
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/gen-scmconfig.h"
#include <stdio.h>
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/tags.h"
*/
int scm_debug_cells_gc_interval = 0;
-#if SCM_ENABLE_DEPRECATED == 1
/* Hash table that keeps a reference to objects the user wants to protect from
- garbage collection. It could arguably be private but applications have come
- to rely on it (e.g., Lilypond 2.13.9). */
-SCM scm_protects;
-#else
+ garbage collection. */
static SCM scm_protects;
-#endif
+
#if (SCM_DEBUG_CELL_ACCESSES == 1)
}
scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_gc_admin_mutex);
void
scm_init_gc_protect_object ()
return "foreign";
case scm_tc7_hashtable:
return "hashtable";
+ case scm_tc7_weak_set:
+ return "weak-set";
+ case scm_tc7_weak_table:
+ return "weak-table";
case scm_tc7_fluid:
return "fluid";
case scm_tc7_dynamic_state:
SCM word_1;
} scm_t_cell;
-/* Cray machines have pointers that are incremented once for each
- * word, rather than each byte, the 3 most significant bits encode the
- * byte within the word. The following macros deal with this by
- * storing the native Cray pointers like the ones that looks like scm
- * expects. This is done for any pointers that point to a cell,
- * pointers to scm_vector elts, functions, &c are not munged.
- */
-#ifdef _UNICOS
-# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
-# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
-#else
-# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
-# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
-#endif /* def _UNICOS */
-
-
+/* FIXME: deprecate. */
+#define PTR2SCM(x) (SCM_PACK_POINTER (x))
+#define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK_POINTER (x)))
/* Low level cell data accessing macros. These macros should only be used
* from within code related to garbage collection issues, since they will
\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 = SCM_PACK_POINTER (SCM_GC_MALLOC (sizeof (scm_t_cell)));
+
+ /* Initialize the type slot last so that the cell is ignored by the GC
+ until it is completely initialized. This is only relevant when the GC
+ can actually run during this code, which it can't since the GC only runs
+ when all other threads are stopped. */
+ SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+ SCM_GC_SET_CELL_WORD (cell, 0, car);
+
+ return cell;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM z;
+
+ z = SCM_PACK_POINTER (SCM_GC_MALLOC (2 * sizeof (scm_t_cell)));
+ /* Initialize the type slot last so that the cell is ignored by the
+ GC until it is completely initialized. This is only relevant
+ when the GC can actually run during this code, which it can't
+ since the GC only runs when all other threads are stopped.
+ */
+ SCM_GC_SET_CELL_WORD (z, 1, cbr);
+ SCM_GC_SET_CELL_WORD (z, 2, ccr);
+ SCM_GC_SET_CELL_WORD (z, 3, cdr);
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+SCM_INLINE_IMPLEMENTATION SCM
+scm_words (scm_t_bits car, scm_t_uint16 n_words)
+{
+ SCM z;
+
+ z = SCM_PACK_POINTER (SCM_GC_MALLOC (sizeof (scm_t_bits) * n_words));
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+ /* FIXME: is the following concern even relevant with BDW-GC? */
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
+
SCM_API void scm_remember_upto_here_1 (SCM obj);
SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);
SCM_API void scm_remember_upto_here (SCM obj1, ...);
SCM_API void scm_gc_unregister_root (SCM *p);
SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
-#if SCM_ENABLE_DEPRECATED == 1
-SCM_DEPRECATED SCM scm_protects;
-#endif
SCM_INTERNAL void scm_storage_prehistory (void);
SCM_INTERNAL void scm_init_gc_protect_object (void);
SCM_INTERNAL void scm_init_gc (void);
-#if SCM_ENABLE_DEPRECATED == 1
-
-SCM_DEPRECATED SCM scm_deprecated_newcell (void);
-SCM_DEPRECATED SCM scm_deprecated_newcell2 (void);
-
-#define SCM_NEWCELL(_into) \
- do { _into = scm_deprecated_newcell (); } while (0)
-#define SCM_NEWCELL2(_into) \
- do { _into = scm_deprecated_newcell2 (); } while (0)
-
-SCM_DEPRECATED void * scm_must_malloc (size_t len, const char *what);
-SCM_DEPRECATED void * scm_must_realloc (void *where,
- size_t olen, size_t len,
- const char *what);
-SCM_DEPRECATED char *scm_must_strdup (const char *str);
-SCM_DEPRECATED char *scm_must_strndup (const char *str, size_t n);
-SCM_DEPRECATED void scm_done_malloc (long size);
-SCM_DEPRECATED void scm_done_free (long size);
-SCM_DEPRECATED void scm_must_free (void *obj);
-
-#endif
-
#endif /* SCM_GC_H */
/*
SCM_BEGIN_FOREIGN_BLOCK;
unmark_port (gdb_input_port);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
- scm_puts (str, gdb_input_port);
+ scm_puts_unlocked (str, gdb_input_port);
scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
ans = scm_read (gdb_input_port);
if (SCM_GC_P)
{
- if (SCM_NIMP (ans))
+ if (SCM_HEAP_OBJECT_P (ans))
{
SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
status = -1;
}
gdb_result = ans;
/* Protect answer from future GC (FIXME: still needed with BDW-GC?) */
- if (SCM_NIMP (ans))
+ if (SCM_HEAP_OBJECT_P (ans))
scm_permanent_object (ans);
exit:
remark_port (gdb_input_port);
{
scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
- scm_flush (gdb_output_port);
+ scm_flush_unlocked (gdb_output_port);
*(pt->write_buf + pt->read_buf_size) = 0;
SEND_STRING (pt->read_buf);
}
- 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");
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
#include "libguile/vm.h"
#include "libguile/validate.h"
SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
-/* FIXME, exports should come from the scm file only */
-#define DEFVAR(v, val) \
- { scm_module_define (scm_module_goops, (v), (val)); \
- scm_module_export (scm_module_goops, scm_list_1 ((v))); \
- }
-
-
/* Class redefinition protocol:
A class is represented by a heap header h1 which points to a
static SCM class_bitvector;
static SCM vtable_class_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t vtable_class_map_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
{
SCM class;
- scm_i_pthread_mutex_lock (&vtable_class_map_lock);
-
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
if (scm_is_false (vtable_class_map))
- vtable_class_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
if (scm_is_false (scm_struct_vtable_p (vtable)))
abort ();
- class = scm_hashq_ref (vtable_class_map, vtable, SCM_BOOL_F);
-
- scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+ class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F);
if (scm_is_false (class))
{
/* Don't worry about races. This only happens when creating a
vtable, which happens by definition in one thread. */
- scm_i_pthread_mutex_lock (&vtable_class_map_lock);
- scm_hashq_set_x (vtable_class_map, vtable, class);
- scm_i_pthread_mutex_unlock (&vtable_class_map_lock);
+ scm_weak_table_putq_x (vtable_class_map, vtable, class);
}
return class;
SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
SCM_SYMBOL (sym_slots, "slots");
SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
-SCM_SYMBOL (sym_keyword_access, "keyword-access");
SCM_SYMBOL (sym_nfields, "nfields");
scm_list_1 (sym_default_slot_definition_class),
scm_list_1 (sym_slots),
scm_list_1 (sym_getters_n_setters),
- scm_list_1 (sym_keyword_access),
scm_list_1 (sym_nfields),
SCM_UNDEFINED);
}
/**** <class> ****/
SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT);
SCM name = scm_from_latin1_symbol ("<class>");
- scm_class_class = scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL);
+ scm_class_class = scm_i_make_vtable_vtable (cs);
SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
| SCM_CLASSF_METACLASS));
prep_hashsets (scm_class_class);
- DEFVAR(name, scm_class_class);
+ scm_module_define (scm_module_goops, name, scm_class_class);
/**** <top> ****/
name = scm_from_latin1_symbol ("<top>");
scm_class_top = scm_basic_make_class (scm_class_class, name,
SCM_EOL, SCM_EOL);
- DEFVAR(name, scm_class_top);
+ scm_module_define (scm_module_goops, name, scm_class_top);
/**** <object> ****/
name = scm_from_latin1_symbol ("<object>");
scm_class_object = scm_basic_make_class (scm_class_class, name,
scm_list_1 (scm_class_top), SCM_EOL);
- DEFVAR (name, scm_class_object);
+ scm_module_define (scm_module_goops, name, scm_class_object);
/* <top> <object> and <class> were partially initialized. Correct them here */
SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
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
static void
make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
{
- SCM tmp = scm_from_locale_symbol (name);
+ SCM tmp = scm_from_utf8_symbol (name);
*var = scm_basic_make_class (meta, tmp,
scm_is_pair (super) ? super : scm_list_1 (super),
slots);
- DEFVAR(tmp, *var);
+ scm_module_define (scm_module_goops, tmp, *var);
}
static SCM
make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
{
- SCM class, name;
+ SCM name;
if (type_name)
{
char buffer[100];
sprintf (buffer, template, type_name);
- name = scm_from_locale_symbol (buffer);
+ name = scm_from_utf8_symbol (buffer);
}
else
name = SCM_GOOPS_UNBOUND;
- class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
- name, supers, SCM_EOL);
-
- /* Only define name if doesn't already exist. */
- if (!SCM_GOOPS_UNBOUNDP (name)
- && scm_is_false (scm_module_variable (scm_module_goops, name)))
- DEFVAR (name, class);
- return class;
+ return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
}
static SCM
make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep)
{
- SCM class, name;
+ SCM name;
+
if (scm_is_true (type_name_sym))
{
name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"),
else
name = SCM_GOOPS_UNBOUND;
- class = scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
- name, supers, SCM_EOL);
-
- /* Only define name if doesn't already exist. */
- if (!SCM_GOOPS_UNBOUNDP (name)
- && scm_is_false (scm_module_variable (scm_module_goops, name)))
- DEFVAR (name, class);
- return class;
+ return scm_basic_make_class (applicablep ? scm_class_procedure_class : scm_class_class,
+ name, supers, SCM_EOL);
}
SCM
{
long i;
- for (i = 0; i < scm_numptob; ++i)
+ for (i = scm_c_num_port_types () - 1; i >= 0; i--)
scm_make_port_classes (i, SCM_PTOBNAME (i));
}
SCM name = scm_from_latin1_symbol ("no-applicable-method");
scm_no_applicable_method =
scm_make (scm_list_3 (scm_class_generic, k_name, name));
- DEFVAR (name, scm_no_applicable_method);
+ scm_module_define (scm_module_goops, name, scm_no_applicable_method);
}
return SCM_UNSPECIFIED;
"pw" /* default-slot-definition-class */ \
"pw" /* slots */ \
"pw" /* getters-n-setters */ \
- "pw" /* keyword access */ \
"pw" /* nfields */
#define scm_si_redefined (scm_vtable_offset_user + 0)
#define scm_si_cpl (scm_vtable_offset_user + 13) /* (class ...) */
#define scm_si_slotdef_class (scm_vtable_offset_user + 14)
#define scm_si_slots (scm_vtable_offset_user + 15) /* ((name . options) ...) */
-#define scm_si_name_access (scm_vtable_offset_user + 16)
-#define scm_si_getters_n_setters scm_si_name_access
-#define scm_si_keyword_access (scm_vtable_offset_user + 17)
-#define scm_si_nfields (scm_vtable_offset_user + 18) /* an integer */
-#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 19)
+#define scm_si_getters_n_setters (scm_vtable_offset_user + 16)
+#define scm_si_nfields (scm_vtable_offset_user + 17) /* an integer */
+#define SCM_N_CLASS_SLOTS (scm_vtable_offset_user + 18)
typedef struct scm_t_method {
SCM generic_function;
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_t_bits flags;
/* make objtable */
- sname = scm_from_locale_symbol (name);
+ sname = scm_from_utf8_symbol (name);
table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
SCM_SIMPLE_VECTOR_SET (table, 1, sname);
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
- scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
+ scm_puts_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
scm_display(req1, scm_cur_outp);
- scm_puts ("\n req2: ", scm_cur_outp);
+ scm_puts_unlocked ("\n req2: ", scm_cur_outp);
scm_display(req2, scm_cur_outp);
- scm_puts ("\n opt: ", scm_cur_outp);
+ scm_puts_unlocked ("\n opt: ", scm_cur_outp);
scm_display(opt, scm_cur_outp);
- scm_puts ("\n rest: ", scm_cur_outp);
+ scm_puts_unlocked ("\n rest: ", scm_cur_outp);
scm_display(rst, scm_cur_outp);
scm_newline(scm_cur_outp);
return SCM_UNSPECIFIED;
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/hashtab.h"
-#include "libguile/weaks.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"
{
t_guardian *g = GUARDIAN_DATA (guardian);
- scm_puts ("#<guardian ", port);
+ scm_puts_unlocked ("#<guardian ", port);
scm_uintprint ((scm_t_bits) g, 16, port);
- scm_puts (" (reachable: ", port);
+ scm_puts_unlocked (" (reachable: ", port);
scm_display (scm_from_uint (g->live), port);
- scm_puts (" unreachable: ", port);
+ scm_puts_unlocked (" unreachable: ", port);
scm_display (scm_length (g->zombies), port);
- scm_puts (")", port);
+ scm_puts_unlocked (")", port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
SCM cell_pool;
SCM obj, guardian_list, proxied_finalizer;
- obj = PTR2SCM (ptr);
- guardian_list = SCM_CDR (PTR2SCM (finalizer_data));
- proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data));
+ obj = SCM_PACK_POINTER (ptr);
+ guardian_list = SCM_CDR (SCM_PACK_POINTER (finalizer_data));
+ proxied_finalizer = SCM_CAR (SCM_PACK_POINTER (finalizer_data));
#ifdef DEBUG_GUARDIANS
printf ("finalizing guarded %p (%u guardians)\n",
guardian_list = SCM_CDR (guardian_list))
{
SCM zombies;
+ SCM guardian;
t_guardian *g;
- if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
+ guardian = scm_c_weak_vector_ref (scm_car (guardian_list), 0);
+
+ if (scm_is_false (guardian))
{
/* The guardian itself vanished in the meantime. */
#ifdef DEBUG_GUARDIANS
continue;
}
- g = GUARDIAN_DATA (SCM_CAR (guardian_list));
+ g = GUARDIAN_DATA (guardian);
if (g->live == 0)
abort ();
GC_finalization_proc finalizer, prev_finalizer;
GC_PTR finalizer_data, prev_finalizer_data;
- finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
- finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));
+ finalizer = (GC_finalization_proc) SCM_UNPACK_POINTER (SCM_CAR (proxied_finalizer));
+ finalizer_data = SCM_UNPACK_POINTER (SCM_CDR (proxied_finalizer));
if (finalizer == NULL)
abort ();
{
t_guardian *g = GUARDIAN_DATA (guardian);
- if (SCM_NIMP (obj))
+ if (SCM_HEAP_OBJECT_P (obj))
{
/* Register a finalizer and pass a pair as the ``client data''
argument. The pair contains in its car `#f' or a pair describing a
g->live++;
- /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
- collected before the objects it guards (see `guardians.test'). */
- guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL);
+ /* Note: GUARDIANS_FOR_OBJ holds weak references to guardians so
+ that a guardian can be collected before the objects it guards
+ (see `guardians.test'). */
+ guardians_for_obj = scm_cons (scm_make_weak_vector (SCM_INUM1, guardian),
+ SCM_EOL);
finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded,
- SCM2PTR (finalizer_data),
+ GC_REGISTER_FINALIZER_NO_ORDER (SCM_UNPACK_POINTER (obj), finalize_guarded,
+ SCM_UNPACK_POINTER (finalizer_data),
&prev_finalizer, &prev_data);
if (prev_finalizer == finalize_guarded)
if (prev_data == NULL)
abort ();
- prev_finalizer_data = PTR2SCM (prev_data);
+ prev_finalizer_data = SCM_PACK_POINTER (prev_data);
if (!scm_is_pair (prev_finalizer_data))
abort ();
`finalize_guarded ()' has finished. */
SCM proxied_finalizer;
- proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer),
- PTR2SCM (prev_data));
+ proxied_finalizer = scm_cons (SCM_PACK_POINTER (prev_finalizer),
+ SCM_PACK_POINTER (prev_data));
SCM_SETCAR (finalizer_data, proxied_finalizer);
}
}
-/* Copyright (C) 1996,1997,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1996, 1997, 2000, 2001, 2006, 2008,
+ * 2011 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
#include <libguile/scmconfig.h>
#endif
#include <ltdl.h>
+#include <locale.h>
#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
int
main (int argc, char **argv)
{
+ /* Install the locale right at the beginning so that string conversion
+ for command-line arguments, along with possible error messages, use
+ the right locale. See
+ <https://lists.gnu.org/archive/html/guile-devel/2011-11/msg00041.html>
+ for the rationale. */
+ if (setlocale (LC_ALL, "") == NULL)
+ fprintf (stderr, "guile: warning: failed to install locale\n");
+
scm_install_gmp_memory_functions = 1;
scm_boot_guile (argc, argv, inner_main, 0);
return 0; /* never reached */
#endif
+/* This hash function is originally from
+ http://burtleburtle.net/bob/c/lookup3.c by Bob Jenkins, May 2006,
+ Public Domain. No warranty. */
+
+#define rot(x,k) (((x)<<(k)) | ((x)>>(32-(k))))
+#define mix(a,b,c) \
+{ \
+ a -= c; a ^= rot(c, 4); c += b; \
+ b -= a; b ^= rot(a, 6); a += c; \
+ c -= b; c ^= rot(b, 8); b += a; \
+ a -= c; a ^= rot(c,16); c += b; \
+ b -= a; b ^= rot(a,19); a += c; \
+ c -= b; c ^= rot(b, 4); b += a; \
+}
+
+#define final(a,b,c) \
+{ \
+ c ^= b; c -= rot(b,14); \
+ a ^= c; a -= rot(c,11); \
+ b ^= a; b -= rot(a,25); \
+ c ^= b; c -= rot(b,16); \
+ a ^= c; a -= rot(c,4); \
+ b ^= a; b -= rot(a,14); \
+ c ^= b; c -= rot(b,24); \
+}
+
+#define JENKINS_LOOKUP3_HASHWORD2(k, length, ret) \
+ do { \
+ scm_t_uint32 a, b, c; \
+ \
+ /* Set up the internal state. */ \
+ a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47; \
+ \
+ /* Handle most of the key. */ \
+ while (length > 3) \
+ { \
+ a += k[0]; \
+ b += k[1]; \
+ c += k[2]; \
+ mix (a, b, c); \
+ length -= 3; \
+ k += 3; \
+ } \
+ \
+ /* Handle the last 3 elements. */ \
+ switch(length) /* All the case statements fall through. */ \
+ { \
+ case 3 : c += k[2]; \
+ case 2 : b += k[1]; \
+ case 1 : a += k[0]; \
+ final (a, b, c); \
+ case 0: /* case 0: nothing left to add */ \
+ break; \
+ } \
+ \
+ if (sizeof (ret) == 8) \
+ ret = (((unsigned long) c) << 32) | b; \
+ else \
+ ret = c; \
+ } while (0)
+
+
+static unsigned long
+narrow_string_hash (const scm_t_uint8 *str, size_t len)
+{
+ unsigned long ret;
+ JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
+}
+
+static unsigned long
+wide_string_hash (const scm_t_wchar *str, size_t len)
+{
+ unsigned long ret;
+ JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
+}
+
unsigned long
scm_string_hash (const unsigned char *str, size_t len)
{
- /* from suggestion at: */
- /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
-
- unsigned long h = 0;
- while (len-- > 0)
- h = *str++ + h*37;
- return h;
+ return narrow_string_hash (str, len);
}
unsigned long
scm_i_string_hash (SCM str)
{
size_t len = scm_i_string_length (str);
- size_t i = 0;
- unsigned long h = 0;
- while (len-- > 0)
- h = (unsigned long) scm_i_string_ref (str, i++) + h * 37;
-
- scm_remember_upto_here_1 (str);
- return h;
+ if (scm_i_is_narrow_string (str))
+ return narrow_string_hash ((const scm_t_uint8 *) scm_i_string_chars (str),
+ len);
+ else
+ return wide_string_hash (scm_i_string_wide_chars (str), len);
}
unsigned long
scm_i_locale_string_hash (const char *str, size_t len)
{
-#ifdef HAVE_WCHAR_H
- mbstate_t state;
- wchar_t c;
- size_t byte_idx = 0, nbytes;
- unsigned long h = 0;
-
- if (len == (size_t) -1)
- len = strlen (str);
-
- while ((nbytes = mbrtowc (&c, str + byte_idx, len - byte_idx, &state)) > 0)
- {
- if (nbytes >= (size_t) -2)
- /* Invalid input string; punt. */
- return scm_i_string_hash (scm_from_locale_stringn (str, len));
-
- h = (unsigned long) c + h * 37;
- byte_idx += nbytes;
- }
-
- return h;
-#else
return scm_i_string_hash (scm_from_locale_stringn (str, len));
-#endif
}
unsigned long
scm_i_latin1_string_hash (const char *str, size_t len)
{
- const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
- size_t i = 0;
- unsigned long h = 0;
-
if (len == (size_t) -1)
len = strlen (str);
- for (; i < len; i++)
- h = (unsigned long) ustr[i] + h * 37;
-
- return h;
+ return narrow_string_hash ((const scm_t_uint8 *) str, len);
}
+/* A tricky optimization, but probably worth it. */
unsigned long
scm_i_utf8_string_hash (const char *str, size_t len)
{
- const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
- size_t byte_idx = 0;
- unsigned long h = 0;
-
+ const scm_t_uint8 *end, *ustr = (const scm_t_uint8 *) str;
+ unsigned long ret;
+
+ /* The length of the string in characters. This name corresponds to
+ Jenkins' original name. */
+ size_t length;
+
+ scm_t_uint32 a, b, c, u32;
+
if (len == (size_t) -1)
len = strlen (str);
- while (byte_idx < len)
+ end = ustr + len;
+
+ if (u8_check (ustr, len) != NULL)
+ /* Invalid UTF-8; punt. */
+ return scm_i_string_hash (scm_from_utf8_stringn (str, len));
+
+ length = u8_strnlen (ustr, len);
+
+ /* Set up the internal state. */
+ a = b = c = 0xdeadbeef + ((scm_t_uint32)(length<<2)) + 47;
+
+ /* Handle most of the key. */
+ while (length > 3)
{
- ucs4_t c;
- int nbytes;
-
- nbytes = u8_mbtouc (&c, ustr + byte_idx, len - byte_idx);
- if (nbytes == 0)
- break;
- else if (nbytes < 0)
- /* Bad UTF-8; punt. */
- return scm_i_string_hash (scm_from_utf8_stringn (str, len));
-
- h = (unsigned long) c + h * 37;
- byte_idx += nbytes;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ mix (a, b, c);
+ length -= 3;
}
- return h;
-}
+ /* Handle the last 3 elements's. */
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ a += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ b += u32;
+ if (--length)
+ {
+ ustr += u8_mbtouc_unsafe (&u32, ustr, end - ustr);
+ c += u32;
+ }
+ }
+ final (a, b, c);
-/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
-/* Dirk:FIXME:: scm_hasher could be made static. */
+ if (sizeof (unsigned long) == 8)
+ ret = (((unsigned long) c) << 32) | b;
+ else
+ ret = c;
+
+ ret >>= 2; /* Ensure that it fits in a fixnum. */
+ return ret;
+}
-unsigned long
-scm_hasher(SCM obj, unsigned long n, size_t d)
+/* Thomas Wang's integer hasher, from
+ http://www.cris.com/~Ttwang/tech/inthash.htm. */
+static unsigned long
+scm_raw_ihashq (scm_t_bits key)
{
- switch (SCM_ITAG3 (obj)) {
- case scm_tc3_int_1:
- case scm_tc3_int_2:
- return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */
- case scm_tc3_imm24:
- if (SCM_CHARP(obj))
- return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
- switch (SCM_UNPACK (obj)) {
- case SCM_EOL_BITS:
- d = 256;
- break;
- case SCM_BOOL_T_BITS:
- d = 257;
- break;
- case SCM_BOOL_F_BITS:
- d = 258;
- break;
- case SCM_EOF_VAL_BITS:
- d = 259;
- break;
- default:
- d = 263; /* perhaps should be error */
+ if (sizeof (key) < 8)
+ {
+ key = (key ^ 61) ^ (key >> 16);
+ key = key + (key << 3);
+ key = key ^ (key >> 4);
+ key = key * 0x27d4eb2d;
+ key = key ^ (key >> 15);
}
- return d % n;
- default:
- return 263 % n; /* perhaps should be error */
- case scm_tc3_cons:
- switch SCM_TYP7(obj) {
- default:
- return 263 % n;
+ else
+ {
+ key = (~key) + (key << 21); // key = (key << 21) - key - 1;
+ key = key ^ (key >> 24);
+ key = (key + (key << 3)) + (key << 8); // key * 265
+ key = key ^ (key >> 14);
+ key = (key + (key << 2)) + (key << 4); // key * 21
+ key = key ^ (key >> 28);
+ key = key + (key << 31);
+ }
+ key >>= 2; /* Ensure that it fits in a fixnum. */
+ return key;
+}
+
+/* `depth' is used to limit recursion. */
+static unsigned long
+scm_raw_ihash (SCM obj, size_t depth)
+{
+ if (SCM_IMP (obj))
+ return scm_raw_ihashq (SCM_UNPACK (obj));
+
+ switch (SCM_TYP7(obj))
+ {
+ /* FIXME: do better for structs, variables, ... Also the hashes
+ are currently associative, which ain't the right thing. */
case scm_tc7_smob:
- return 263 % n;
+ return scm_raw_ihashq (SCM_TYP16 (obj));
case scm_tc7_number:
- switch SCM_TYP16 (obj) {
- case scm_tc16_big:
- return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
- case scm_tc16_real:
- {
- double r = SCM_REAL_VALUE (obj);
- if (floor (r) == r && !isinf (r) && !isnan (r))
- {
- obj = scm_inexact_to_exact (obj);
- return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
- }
- }
- /* Fall through */
- case scm_tc16_complex:
- case scm_tc16_fraction:
- obj = scm_number_to_string (obj, scm_from_int (10));
- /* Fall through */
- }
- /* Fall through */
+ if (scm_is_integer (obj))
+ {
+ SCM n = SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM);
+ if (scm_is_inexact (obj))
+ obj = scm_inexact_to_exact (obj);
+ return scm_raw_ihashq (scm_to_ulong (scm_modulo (obj, n)));
+ }
+ else
+ return scm_i_string_hash (scm_number_to_string (obj, scm_from_int (10)));
case scm_tc7_string:
- {
- unsigned long hash =
- scm_i_string_hash (obj) % n;
- return hash;
- }
+ return scm_i_string_hash (obj);
case scm_tc7_symbol:
- return scm_i_symbol_hash (obj) % n;
+ return scm_i_symbol_hash (obj);
case scm_tc7_pointer:
- {
- /* Pointer objects are typically used to store addresses of heap
- objects. On most platforms, these are at least 3-byte
- aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
- addresses), so get rid of the least significant bits. */
- scm_t_uintptr significant_bits;
-
- significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
- return (size_t) significant_bits % n;
- }
+ return scm_raw_ihashq ((scm_t_uintptr) SCM_POINTER_VALUE (obj));
case scm_tc7_wvect:
case scm_tc7_vector:
{
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
- if (len > 5)
- {
- size_t i = d/2;
- unsigned long h = 1;
- while (i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
- h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
- }
- return h;
- }
- else
- {
- size_t i = len;
- unsigned long h = (n)-1;
- while (i--)
- {
- SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
- h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
- }
- return h;
- }
+ size_t i = depth / 2;
+ unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
+ if (len)
+ while (i--)
+ h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
+ return h;
}
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
- if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
- + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
- else return 1;
- case scm_tc7_port:
- return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- case scm_tc7_program:
- return 262 % n;
+ if (depth)
+ return (scm_raw_ihash (SCM_CAR (obj), depth / 2)
+ ^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
+ else
+ return scm_raw_ihashq (scm_tc3_cons);
+ default:
+ return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}
- }
}
\f
-
unsigned long
scm_ihashq (SCM obj, unsigned long n)
{
- return (SCM_UNPACK (obj) >> 1) % n;
+ return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
}
unsigned long
scm_ihashv (SCM obj, unsigned long n)
{
- if (SCM_CHARP(obj))
- return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
-
if (SCM_NUMP(obj))
- return (unsigned long) scm_hasher(obj, n, 10);
+ return scm_raw_ihash (obj, 10) % n;
else
- return SCM_UNPACK (obj) % n;
+ return scm_raw_ihashq (SCM_UNPACK (obj)) % n;
}
unsigned long
scm_ihash (SCM obj, unsigned long n)
{
- return (unsigned long) scm_hasher (obj, n, 10);
+ return (unsigned long) scm_raw_ihash (obj, 10) % n;
}
SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
size_t len);
SCM_INTERNAL unsigned long scm_i_string_hash (SCM str);
-SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);
* The implementation stores the upper and lower number of items which
* trigger a resize in the hashtable object.
*
- * Weak hash tables use weak pairs in the bucket lists rather than
- * normal pairs.
- *
* Possible hash table sizes (primes) are stored in the array
* hashtable_size.
*/
static char *s_hashtable = "hashtable";
-
-\f
-/* Helper functions and macros to deal with weak pairs.
-
- Weak pairs need to be accessed very carefully since their components can
- be nullified by the GC when the object they refer to becomes unreachable.
- Hence the macros and functions below that detect such weak pairs within
- buckets and remove them. */
-
-
-/* Remove nullified weak pairs from ALIST such that the result contains only
- valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
- deleted. */
static SCM
-scm_fixup_weak_alist (SCM alist, size_t *removed_items)
-{
- SCM result;
- SCM prev = SCM_EOL;
-
- *removed_items = 0;
- for (result = alist;
- scm_is_pair (alist);
- alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (SCM_WEAK_PAIR_DELETED_P (pair))
- {
- /* Remove from ALIST weak pair PAIR whose car/cdr has been
- nullified by the GC. */
- if (scm_is_null (prev))
- result = SCM_CDR (alist);
- else
- SCM_SETCDR (prev, SCM_CDR (alist));
-
- (*removed_items)++;
-
- /* Leave PREV unchanged. */
- }
- else
- prev = alist;
- }
-
- return result;
-}
-
-static void
-vacuum_weak_hash_table (SCM table)
-{
- SCM buckets = SCM_HASHTABLE_VECTOR (table);
- unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- size_t len = SCM_HASHTABLE_N_ITEMS (table);
-
- while (k--)
- {
- size_t removed;
- SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- alist = scm_fixup_weak_alist (alist, &removed);
- assert (removed <= len);
- len -= removed;
- SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
- }
-
- SCM_SET_HASHTABLE_N_ITEMS (table, len);
-}
-
-
-/* Packed arguments for `do_weak_bucket_fixup'. */
-struct t_fixup_args
-{
- SCM bucket;
- SCM *bucket_copy;
- size_t removed_items;
-};
-
-static void *
-do_weak_bucket_fixup (void *data)
-{
- struct t_fixup_args *args;
- SCM pair, *copy;
-
- args = (struct t_fixup_args *) data;
-
- args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
-
- for (pair = args->bucket, copy = args->bucket_copy;
- scm_is_pair (pair);
- pair = SCM_CDR (pair), copy += 2)
- {
- /* At this point, all weak pairs have been removed. */
- assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair)));
-
- /* Copy the key and value. */
- copy[0] = SCM_CAAR (pair);
- copy[1] = SCM_CDAR (pair);
- }
-
- return args;
-}
-
-/* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
- for in the alist that is the BUCKET_INDEXth element of BUCKETS.
- Optionally update TABLE and rehash it. */
-static SCM
-weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
- scm_t_hash_fn hash_fn,
- scm_t_assoc_fn assoc, SCM object, void *closure)
-{
- SCM result;
- SCM bucket, *strong_refs;
- struct t_fixup_args args;
-
- bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index);
-
- /* Prepare STRONG_REFS as an array large enough to hold all the keys
- and values in BUCKET. */
- strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
-
- args.bucket = bucket;
- args.bucket_copy = strong_refs;
-
- /* Fixup BUCKET. Do that with the allocation lock held to avoid
- seeing disappearing links pointing to objects that have already
- been reclaimed (this happens when the disappearing links that point
- to it haven't yet been cleared.)
-
- The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
- of BUCKET's entries after it's been fixed up. Thus, all the
- entries kept in BUCKET are still reachable when ASSOC sees
- them. */
- GC_call_with_alloc_lock (do_weak_bucket_fixup, &args);
-
- bucket = args.bucket;
- SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
-
- result = assoc (object, bucket, closure);
-
- /* If we got a result, it should not have NULL fields. */
- if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result))
- abort ();
-
- scm_remember_upto_here_1 (strong_refs);
-
- if (args.removed_items > 0)
- {
- /* Update TABLE's item count and optionally trigger a rehash. */
- size_t remaining;
-
- assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items);
-
- remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
- SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
-
- if (remaining < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
- }
-
- return result;
-}
-
-
-/* Packed arguments for `weak_bucket_assoc_by_hash'. */
-struct assoc_by_hash_data
-{
- SCM alist;
- SCM ret;
- scm_t_hash_predicate_fn predicate;
- void *closure;
-};
-
-/* See scm_hash_fn_get_handle_by_hash below. */
-static void*
-weak_bucket_assoc_by_hash (void *args)
-{
- struct assoc_by_hash_data *data = args;
- SCM alist = data->alist;
-
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (!SCM_WEAK_PAIR_DELETED_P (pair)
- && data->predicate (SCM_CAR (pair), data->closure))
- {
- data->ret = pair;
- break;
- }
- }
- return args;
-}
-
-
-\f
-static SCM
-make_hash_table (int flags, unsigned long k, const char *func_name)
+make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
++i;
n = hashtable_size[i];
- /* In both cases, i.e., regardless of whether we are creating a weak hash
- table, we return a non-weak vector. This is because the vector itself
- is not weak in the case of a weak hash table: the alist pairs are. */
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
- t->flags = flags;
- t->hash_fn = NULL;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
-
- /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
- is not needed since CLOSURE can not be guaranteed to be valid
- after this function returns.
- */
- if (closure == NULL)
- SCM_HASHTABLE (table)->hash_fn = hash_fn;
}
SCM_HASHTABLE (table)->size_index = i;
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
- /* When this is a weak hashtable, running the GC might change it.
- We need to cope with this while rehashing its elements. We do
- this by first installing the new, empty bucket vector. Then we
- remove the elements from the old bucket vector and insert them
- into the new one.
- */
-
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
- if (SCM_WEAK_PAIR_DELETED_P (handle))
- /* HANDLE is a nullified weak pair: skip it. */
- continue;
-
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<", port);
- if (SCM_HASHTABLE_WEAK_KEY_P (exp))
- scm_puts ("weak-key-", port);
- else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
- scm_puts ("weak-value-", port);
- else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
- scm_puts ("doubly-weak-", port);
- scm_puts ("hash-table ", port);
+ scm_puts_unlocked ("#<hash-table ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
SCM
scm_c_make_hash_table (unsigned long k)
{
- return make_hash_table (0, k, "scm_c_make_hash_table");
+ return make_hash_table (k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
"Make a new abstract hash table object with minimum number of buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
- if (SCM_UNBNDP (n))
- return make_hash_table (0, 0, FUNC_NAME);
- else
- return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
-}
-#undef FUNC_NAME
-
-/* The before-gc C hook only runs if GC_set_start_callback is available,
- so if not, fall back on a finalizer-based implementation. */
-static int
-weak_gc_callback (void **weak)
-{
- void *val = weak[0];
- void (*callback) (SCM) = weak[1];
-
- if (!val)
- return 0;
-
- callback (PTR2SCM (val));
-
- return 1;
-}
-
-#ifdef HAVE_GC_SET_START_CALLBACK
-static void*
-weak_gc_hook (void *hook_data, void *fn_data, void *data)
-{
- if (!weak_gc_callback (fn_data))
- scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
-
- return NULL;
-}
-#else
-static void
-weak_gc_finalizer (void *ptr, void *data)
-{
- if (weak_gc_callback (ptr))
- GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL);
-}
-#endif
-
-static void
-scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
-{
- void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
-
- weak[0] = SCM2PTR (obj);
- weak[1] = (void*)callback;
- GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
-
-#ifdef HAVE_GC_SET_START_CALLBACK
- scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0);
-#else
- GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL);
-#endif
-}
-
-SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
- (SCM n),
- "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
- "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
- "Return a weak hash table with @var{size} buckets.\n"
- "\n"
- "You can modify weak hash tables in exactly the same way you\n"
- "would modify regular hash tables. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_key_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
- (SCM n),
- "Return a hash table with weak values with @var{size} buckets.\n"
- "(@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_value_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
- (SCM n),
- "Return a hash table with weak keys and values with @var{size}\n"
- "buckets. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_doubly_weak_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
+ return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME
+#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an abstract hash table object.")
#define FUNC_NAME s_scm_hash_table_p
{
- return scm_from_bool (SCM_HASHTABLE_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
- (SCM obj),
- "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
- "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
- "Return @code{#t} if @var{obj} is the specified weak hash\n"
- "table. Note that a doubly weak hash table is neither a weak key\n"
- "nor a weak value hash table.")
-#define FUNC_NAME s_scm_weak_key_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak value hash table.")
-#define FUNC_NAME s_scm_weak_value_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a doubly weak hash table.")
-#define FUNC_NAME s_scm_doubly_weak_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
+ return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
}
#undef FUNC_NAME
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- h = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
-
- return h;
-}
-#undef FUNC_NAME
-
-
-/* This procedure implements three optimizations, with respect to the
- raw get_handle():
-
- 1. For weak tables, it's assumed that calling the predicate in the
- allocation lock is safe. In practice this means that the predicate
- cannot call arbitrary scheme functions.
-
- 2. We don't check for overflow / underflow and rehash.
-
- 3. We don't actually have to allocate a key -- instead we get the
- hash value directly. This is useful for, for example, looking up
- strings in the symbol table.
- */
-SCM
-scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
- scm_t_hash_predicate_fn predicate_fn,
- void *closure)
-#define FUNC_NAME "scm_hash_fn_ref_by_hash"
-{
- unsigned long k;
- SCM buckets, alist, h = SCM_BOOL_F;
-
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
-
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- return SCM_BOOL_F;
-
- k = raw_hash % SCM_SIMPLE_VECTOR_LENGTH (buckets);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
-
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- struct assoc_by_hash_data args;
-
- args.alist = alist;
- args.ret = SCM_BOOL_F;
- args.predicate = predicate_fn;
- args.closure = closure;
- GC_call_with_alloc_lock (weak_bucket_assoc_by_hash, &args);
- h = args.ret;
- }
- else
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
- if (predicate_fn (SCM_CAR (pair), closure))
- {
- h = pair;
- break;
- }
- }
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
return h;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- it = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_pair (it))
return it;
scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
- /* When this is a weak hashtable, running the GC can change it.
- Thus, we must allocate the new cells first and can only then
- access BUCKETS. Also, we need to fetch the bucket vector
- again since the hashtable might have been rehashed. This
- necessitates a new hash value as well.
- */
SCM handle, new_bucket;
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- /* FIXME: We don't support weak alist vectors. */
- /* Use a weak cell. */
- if (SCM_HASHTABLE_DOUBLY_WEAK_P (table))
- handle = scm_doubly_weak_pair (obj, init);
- else if (SCM_HASHTABLE_WEAK_KEY_P (table))
- handle = scm_weak_car_pair (obj, init);
- else
- handle = scm_weak_cdr_pair (obj, init);
- }
- else
- /* Use a regular, non-weak cell. */
- handle = scm_cons (obj, init);
-
+ handle = scm_cons (obj, init);
new_bucket = scm_cons (handle, SCM_EOL);
if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
return dflt;
}
-struct weak_cdr_data
-{
- SCM pair;
- SCM cdr;
-};
-
-static void*
-get_weak_cdr (void *data)
-{
- struct weak_cdr_data *d = data;
-
- if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair))
- d->cdr = SCM_BOOL_F;
- else
- d->cdr = SCM_CDR (d->pair);
-
- return NULL;
-}
-
-static SCM
-weak_pair_cdr (SCM x)
-{
- struct weak_cdr_data data;
-
- data.pair = x;
- GC_call_with_alloc_lock (get_weak_cdr, &data);
-
- return data.cdr;
-}
-
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
hash_fn, assoc_fn, closure);
if (!scm_is_eq (SCM_CDR (pair), val))
- {
- if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table)))
- {
- /* If the former value was on the heap, we need to unregister
- the weak link. */
- SCM prev = weak_pair_cdr (pair);
-
- SCM_SETCDR (pair, val);
-
- if (SCM_NIMP (prev) && !SCM_NIMP (val))
- GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (pair));
- else
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (pair),
- (GC_PTR) SCM2PTR (val));
- }
- else
- SCM_SETCDR (pair, val);
- }
+ SCM_SETCDR (pair, val);
return val;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- h = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_true (h))
{
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_clear_x (table);
+
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_refq (table, key, dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_putq_x (table, key, val);
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_remq_x (table, key);
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
#undef FUNC_NAME
+static int
+assv_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key),
+ key, val);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key));
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_get_handle (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
return scm_hash_fn_create_handle_x (table, key, init,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
#undef FUNC_NAME
+static int
+assoc_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key),
+ key, val);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key));
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
{
SCM hash;
SCM assoc;
+ SCM key;
} scm_t_ihashx_closure;
-
-
static unsigned long
scm_ihashx (SCM obj, unsigned long n, void *arg)
{
return scm_to_ulong (answer);
}
-
-
static SCM
scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
return scm_call_2 (closure->assoc, obj, alist);
}
+static int
+assx_predicate (SCM k, SCM v, void *closure)
+{
+ scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
+
+ /* FIXME: The hashx interface is crazy. Hash tables have nothing to
+ do with alists in principle. Instead of getting an assoc proc,
+ hashx functions should use an equality predicate. Perhaps we can
+ change this before 2.2, but until then, add a terrible, terrible
+ hack. */
+
+ return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
+}
+
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
-
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+ closure.key = key;
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
-
- if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
+ closure.key = key;
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
dflt = SCM_BOOL_F;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
+ }
+
return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = obj;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
+ return SCM_UNSPECIFIED;
+ }
+
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_fold (proc, init, table);
+
SCM_VALIDATE_HASHTABLE (3, table);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
(void *) SCM_UNPACK (proc), init, table);
#define FUNC_NAME s_scm_hash_for_each
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_for_each (proc, table);
+
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
- if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table)))
- SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL);
-
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(void *) SCM_UNPACK (proc),
table);
#define FUNC_NAME s_scm_hash_map_to_list
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_map_to_list (proc, table);
+
SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
long i, n;
SCM buckets, result = init;
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_fold (fn, closure, init, table);
+
SCM_VALIDATE_HASHTABLE (0, table);
buckets = SCM_HASHTABLE_VECTOR (table);
ls = SCM_CDR (ls))
{
handle = SCM_CAR (ls);
-
- if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle))
- /* Don't try to unlink this weak pair, as we're not within
- the allocation lock. Instead rely on
- vacuum_weak_hash_table to do its job. */
- continue;
- else
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
-/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
-#include "weaks.h"
-
\f
-#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
-#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE
-
-#define SCM_HASHTABLE_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_hashtable)
+#define SCM_HASHTABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_hashtable))
#define SCM_VALIDATE_HASHTABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
#define SCM_HASHTABLE_VECTOR(h) SCM_CELL_OBJECT_1 (h)
#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 ((x), (v))
#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x))
-#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags)
-#define SCM_HASHTABLE_WEAK_KEY_P(x) \
- (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR)
-#define SCM_HASHTABLE_WEAK_VALUE_P(x) \
- (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CDR)
-#define SCM_HASHTABLE_DOUBLY_WEAK_P(x) \
- ((SCM_HASHTABLE_FLAGS (x) \
- & (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR)) \
- == (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR))
-#define SCM_HASHTABLE_WEAK_P(x) SCM_HASHTABLE_FLAGS (x)
#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
#define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n)
#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
some equality predicate. */
typedef SCM (*scm_t_assoc_fn) (SCM obj, SCM alist, void *closure);
-/* Function that returns true if the given object is the one we are
- looking for, for scm_hash_fn_ref_by_hash. */
-typedef int (*scm_t_hash_predicate_fn) (SCM obj, void *closure);
-
/* Function to fold over the entries of a hash table. */
typedef SCM (*scm_t_hash_fold_fn) (void *closure, SCM key, SCM value,
SCM result);
typedef SCM (*scm_t_hash_handle_fn) (void *closure, SCM handle);
typedef struct scm_t_hashtable {
- int flags; /* properties of table */
unsigned long n_items; /* number of items in table */
unsigned long lower; /* when to shrink */
unsigned long upper; /* when to grow */
SCM_API SCM scm_vector_to_hash_table (SCM vector);
SCM_API SCM scm_c_make_hash_table (unsigned long k);
SCM_API SCM scm_make_hash_table (SCM n);
-SCM_API SCM scm_make_weak_key_hash_table (SCM k);
-SCM_API SCM scm_make_weak_value_hash_table (SCM k);
-SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
SCM_API SCM scm_hash_table_p (SCM h);
-SCM_API SCM scm_weak_key_hash_table_p (SCM h);
-SCM_API SCM scm_weak_value_hash_table_p (SCM h);
-SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
SCM_INTERNAL void scm_i_rehash (SCM table, scm_t_hash_fn hash_fn,
void *closure, const char *func_name);
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
void *closure);
-SCM_INTERNAL
-SCM scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
- scm_t_hash_predicate_fn predicate_fn,
- void *closure);
SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
hook_print (SCM hook, SCM port, scm_print_state *pstate)
{
SCM ls, name;
- scm_puts ("#<hook ", port);
+ scm_puts_unlocked ("#<hook ", port);
scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (hook), 16, port);
ls = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (ls))
+ while (scm_is_pair (ls))
{
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
name = scm_procedure_name (SCM_CAR (ls));
if (scm_is_true (name))
scm_iprin1 (name, port, pstate);
else
- scm_putc ('?', port);
+ scm_putc_unlocked ('?', port);
ls = SCM_CDR (ls);
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
scm_c_run_hook (SCM hook, SCM args)
{
SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (procs))
+ while (scm_is_pair (procs))
{
scm_apply_0 (SCM_CAR (procs), args);
procs = SCM_CDR (procs);
scm_c_run_hookn (SCM hook, SCM *argv, size_t nargs)
{
SCM procs = SCM_HOOK_PROCEDURES (hook);
- while (SCM_NIMP (procs))
+ while (scm_is_pair (procs))
{
scm_call_n (SCM_CAR (procs), argv, nargs);
procs = SCM_CDR (procs);
#include "libguile/version.h"
#include "libguile/vm.h"
#include "libguile/vports.h"
-#include "libguile/weaks.h"
#include "libguile/guardians.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
{
stream_body_data *body_data = (stream_body_data *) data;
SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, SCM_BOOL_F);
-
- SCM_REVEALED (port) = 1;
+ scm_set_port_revealed_x (port, SCM_INUM1);
return port;
}
scm_storage_prehistory ();
scm_threads_prehistory (base); /* requires storage_prehistory */
- scm_weaks_prehistory (); /* requires storage_prehistory */
+ scm_weak_set_prehistory (); /* requires storage_prehistory */
+ scm_weak_table_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
scm_debug_malloc_prehistory ();
#endif
- scm_symbols_prehistory (); /* requires weaks_prehistory */
+ scm_symbols_prehistory (); /* requires weak_table_prehistory */
scm_modules_prehistory ();
scm_init_array_handle ();
scm_bootstrap_bytevectors (); /* Requires array-handle */
scm_init_throw (); /* Requires smob_prehistory */
scm_init_trees ();
scm_init_version ();
- scm_init_weaks ();
+ scm_init_weak_set ();
+ scm_init_weak_table ();
+ scm_init_weak_vectors ();
scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
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"
+#include "libguile/ports.h"
-/* classes: h_files */
-
-#ifndef SCM_INLINE_H
-#define SCM_INLINE_H
-
-/* Copyright (C) 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
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-/* This file is for inline functions. On platforms that don't support
- inlining functions, they are turned into ordinary functions. See
- "inline.c".
-*/
-
-#include <stdio.h>
-#include <string.h>
-
-#include "libguile/__scm.h"
-
-#include "libguile/pairs.h"
-#include "libguile/gc.h"
-#include "libguile/threads.h"
-#include "libguile/array-handle.h"
-#include "libguile/ports.h"
-#include "libguile/numbers.h"
-#include "libguile/error.h"
-
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-
-/* GCC has `__inline__' in all modes, including strict ansi. GCC 4.3 and
- above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
- unless `-fgnu89-inline' is used. Here we want GNU "extern inline"
- semantics, hence the `__gnu_inline__' attribute, in accordance with:
- http://gcc.gnu.org/gcc-4.3/porting_to.html .
-
- With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
- semantics are not supported), but a warning is issued in C99 mode if
- `__gnu_inline__' is not used.
-
- Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
- C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
- inline" in that case. */
-
-# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
-# define SCM_C_USE_EXTERN_INLINE 1
-# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
-# define SCM_C_EXTERN_INLINE \
- extern __inline__ __attribute__ ((__gnu_inline__))
-# else
-# define SCM_C_EXTERN_INLINE extern __inline__
-# endif
-# elif (defined SCM_C_INLINE)
-# define SCM_C_EXTERN_INLINE static SCM_C_INLINE
-# endif
-
-#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */
-
-
-#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
- || (defined SCM_C_USE_EXTERN_INLINE)
-
-/* The `extern' declarations. They should only appear when used from
- "inline.c", when `inline' is not supported at all or when "extern inline"
- is used. */
-
-#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_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
-
- return z;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-SCM
-scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
-{
- if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- return h->impl->vref (h, h->base + p);
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-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))
- /* catch overflow */
- scm_out_of_range (NULL, scm_from_ssize_t (p));
- /* perhaps should catch overflow here too */
- h->impl->vset (h, h->base + p, v);
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_is_pair (SCM x)
-{
- /* The following "workaround_for_gcc_295" avoids bad code generated by
- i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
-
- Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
- the fetch of the tag word from x is done before confirming it's a
- non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
- immediate. This was seen to afflict scm_srfi1_split_at and something
- deep in the bowels of ceval(). In both cases segvs resulted from
- deferencing a random immediate value. srfi-1.test exposes the problem
- through a short list, the immediate being SCM_EOL in that case.
- Something in syntax.test exposed the ceval() problem.
-
- Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
- problem, without even using that variable. The "w=w" is just to
- prevent a warning about it being unused.
- */
-#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
- volatile SCM workaround_for_gcc_295 = x;
- workaround_for_gcc_295 = workaround_for_gcc_295;
-#endif
-
- return SCM_I_CONSP (x);
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_is_string (SCM x)
-{
- return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
-}
-
-/* Port I/O. */
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_get_byte_or_eof (SCM port)
-{
- int c;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
- return EOF;
- }
-
- c = *(pt->read_pos++);
-
- return c;
-}
-
-/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-int
-scm_peek_byte_or_eof (SCM port)
-{
- int c;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_WRITE)
- /* may be marginally faster than calling scm_flush. */
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- if (pt->read_pos >= pt->read_end)
- {
- if (SCM_UNLIKELY (scm_fill_input (port) == EOF))
- return EOF;
- }
-
- c = *pt->read_pos;
-
- return c;
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
-scm_putc (char c, SCM port)
-{
- SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (&c, 1, port);
-}
-
-#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
-SCM_C_EXTERN_INLINE
-#endif
-void
-scm_puts (const char *s, SCM port)
-{
- SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
- scm_lfwrite (s, strlen (s), port);
-}
-
-
-#endif
-#endif
+/* classes: h_files */
+
+#ifndef SCM_INLINE_H
+#define SCM_INLINE_H
+
+/* Copyright (C) 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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+/* This file is for inline functions. On platforms that don't support
+ inlining functions, they are turned into ordinary functions. On
+ platforms that do support inline functions, the definitions are still
+ compiled into the library, once, in inline.c. */
+
+#include "libguile/__scm.h"
+
+#include "libguile/pairs.h"
+#include "libguile/gc.h"
+#include "libguile/threads.h"
+#include "libguile/array-handle.h"
+#include "libguile/ports.h"
+#include "libguile/numbers.h"
+#include "libguile/error.h"
+
+
+SCM_INLINE 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);
+
+SCM_INLINE int scm_is_pair (SCM x);
+SCM_INLINE int scm_is_string (SCM x);
+
+SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_INLINE SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
+
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+/* Either inlining, or being included from inline.c. */
+
+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))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ return h->impl->vref (h, h->base + p);
+}
+
+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))
+ /* catch overflow */
+ scm_out_of_range (NULL, scm_from_ssize_t (p));
+ /* perhaps should catch overflow here too */
+ h->impl->vset (h, h->base + p, v);
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_is_pair (SCM x)
+{
+ /* The following "workaround_for_gcc_295" avoids bad code generated by
+ i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
+
+ Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
+ the fetch of the tag word from x is done before confirming it's a
+ non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
+ immediate. This was seen to afflict scm_srfi1_split_at and something
+ deep in the bowels of ceval(). In both cases segvs resulted from
+ deferencing a random immediate value. srfi-1.test exposes the problem
+ through a short list, the immediate being SCM_EOL in that case.
+ Something in syntax.test exposed the ceval() problem.
+
+ Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
+ problem, without even using that variable. The "w=w" is just to
+ prevent a warning about it being unused.
+ */
+#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
+ volatile SCM workaround_for_gcc_295 = x;
+ workaround_for_gcc_295 = workaround_for_gcc_295;
+#endif
+
+ return SCM_I_CONSP (x);
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_is_string (SCM x)
+{
+ return SCM_HAS_TYP7 (x, scm_tc7_string);
+}
+
+#endif
+#endif
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static scm_i_pthread_mutex_t itable_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (itable_lock);
static struct scm_instruction*
{
table[i].opcode = i;
if (table[i].name)
- table[i].symname = scm_from_locale_symbol (table[i].name);
+ table[i].symname = scm_from_utf8_symbol (table[i].name);
else
table[i].symname = SCM_BOOL_F;
}
-/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
{
scm_t_port *pt = SCM_PTAB_ENTRY (new);
scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (new);
/* must flush to old fdes. */
if (pt->rw_active == SCM_PORT_WRITE)
ptob->flush (new);
else if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (new);
+ scm_end_input_unlocked (new);
ans = dup2 (oldfd, newfd);
if (ans == -1)
SCM_SYSERROR;
#undef FUNC_NAME
static SCM
-get_matching_port (void *closure, SCM port, SCM val, SCM result)
+get_matching_port (void *closure, SCM port, SCM result)
{
int fd = * (int *) closure;
scm_t_port *entry = SCM_PTAB_ENTRY (port);
SCM result = SCM_EOL;
int int_fd = scm_to_int (fd);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- result = scm_internal_hash_fold (get_matching_port,
- (void*) &int_fd, result,
- scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ result = scm_c_weak_set_fold (get_matching_port,
+ (void*) &int_fd, result,
+ scm_i_port_weak_set);
return result;
}
#undef FUNC_NAME
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static int
keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts ("#:", port);
+ scm_puts_unlocked ("#:", port);
scm_display (KEYWORDSYM (exp), port);
return 1;
}
while (! SCM_UNBNDP (elt))
{
#if (SCM_DEBUG_CELL_ACCESSES == 1)
- if (SCM_NIMP (elt))
+ if (SCM_HEAP_OBJECT_P (elt))
SCM_VALIDATE_CELL(elt, 0);
#endif
*pos = scm_cons (elt, SCM_EOL);
else
{
compiled_is_newer = 0;
- scm_puts (";;; note: source file ", scm_current_error_port ());
+ scm_puts_unlocked (";;; note: source file ", scm_current_error_port ());
scm_display (full_filename, scm_current_error_port ());
- scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
+ scm_puts_unlocked ("\n;;; newer than compiled ", scm_current_error_port ());
scm_display (compiled_filename, scm_current_error_port ());
- scm_puts ("\n", scm_current_error_port ());
+ scm_puts_unlocked ("\n", scm_current_error_port ());
}
return compiled_is_newer;
static SCM
do_try_auto_compile (void *data)
{
- SCM source = PTR2SCM (data);
+ SCM source = SCM_PACK_POINTER (data);
SCM comp_mod, compile_file;
- scm_puts (";;; compiling ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiling ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
scm_newline (scm_current_error_port ());
/* Assume `*current-warning-prefix*' has an appropriate value. */
res = scm_call_n (scm_variable_ref (compile_file), args, 5);
- scm_puts (";;; compiled ", scm_current_error_port ());
+ scm_puts_unlocked (";;; compiled ", scm_current_error_port ());
scm_display (res, scm_current_error_port ());
scm_newline (scm_current_error_port ());
return res;
}
else
{
- scm_puts (";;; it seems ", scm_current_error_port ());
+ scm_puts_unlocked (";;; it seems ", scm_current_error_port ());
scm_display (source, scm_current_error_port ());
- scm_puts ("\n;;; is part of the compiler; skipping auto-compilation\n",
+ scm_puts_unlocked ("\n;;; is part of the compiler; skipping auto-compilation\n",
scm_current_error_port ());
return SCM_BOOL_F;
}
static SCM
auto_compile_catch_handler (void *data, SCM tag, SCM throw_args)
{
- SCM source = PTR2SCM (data);
+ SCM source = SCM_PACK_POINTER (data);
SCM oport, lines;
oport = scm_open_output_string ();
scm_print_exception (oport, SCM_BOOL_F, tag, throw_args);
- scm_puts (";;; WARNING: compilation of ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; WARNING: compilation of ", scm_current_warning_port ());
scm_display (source, scm_current_warning_port ());
- scm_puts (" failed:\n", scm_current_warning_port ());
+ scm_puts_unlocked (" failed:\n", scm_current_warning_port ());
lines = scm_string_split (scm_get_output_string (oport),
SCM_MAKE_CHAR ('\n'));
for (; scm_is_pair (lines); lines = scm_cdr (lines))
if (scm_c_string_length (scm_car (lines)))
{
- scm_puts (";;; ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; ", scm_current_warning_port ());
scm_display (scm_car (lines), scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
}
if (!message_shown)
{
- scm_puts (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
+ scm_puts_unlocked (";;; note: auto-compilation is enabled, set GUILE_AUTO_COMPILE=0\n"
";;; or pass the --no-auto-compile argument to disable.\n",
scm_current_warning_port ());
message_shown = 1;
scm_sys_warn_auto_compilation_enabled ();
return scm_c_catch (SCM_BOOL_T,
do_try_auto_compile,
- SCM2PTR (source),
+ SCM_UNPACK_POINTER (source),
auto_compile_catch_handler,
- SCM2PTR (source),
+ SCM_UNPACK_POINTER (source),
NULL, NULL);
}
if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback,
&stat_source, &stat_compiled))
{
- scm_puts (";;; found fresh local cache at ", scm_current_warning_port ());
+ scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ());
scm_display (fallback, scm_current_warning_port ());
scm_newline (scm_current_warning_port ());
return scm_load_compiled_with_vm (fallback);
for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
{
- SCM key = scm_from_locale_symbol (info[i].name);
+ SCM key = scm_from_utf8_symbol (info[i].name);
SCM val = scm_from_locale_string (info[i].value);
*loc = scm_acons (key, val, *loc);
}
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
if (scm_is_false (SCM_MACRO_TYPE (macro)))
- scm_puts ("#<primitive-syntax-transformer ", port);
+ scm_puts
_unlocked ("#<primitive-syntax-transformer ", port);
else
- scm_puts ("#<syntax-transformer ", port);
+ scm_puts_unlocked ("#<syntax-transformer ", port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
{
SCM z = scm_words (scm_tc16_macro, 5);
SCM_SET_SMOB_DATA_N (z, 1, (scm_t_bits)fn);
- SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_locale_symbol (name));
+ SCM_SET_SMOB_OBJECT_N (z, 2, scm_from_utf8_symbol (name));
SCM_SET_SMOB_OBJECT_N (z, 3, SCM_BOOL_F);
SCM_SET_SMOB_OBJECT_N (z, 4, SCM_BOOL_F);
return z;
/* classes: src_files
- * Copyright (C) 1995,1997,1998,2000,2001, 2006 Free Software Foundation, Inc.
+ * Copyright (C) 1995,1997,1998,2000,2001, 2006, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
static int
malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_puts("#<malloc ", port);
+ scm_puts_unlocked("#<malloc ", port);
scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
return 1;
}
#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",
static int
scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<memoized ", port);
+ scm_puts_unlocked ("#<memoized ", port);
scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
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)));
}
}
char buf[16];
buf[15] = 0;
snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
- return scm_from_locale_symbol (buf);
+ return scm_from_utf8_symbol (buf);
}
static SCM
{
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,
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009,2010,2011,2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
ptr++;
if (ptr > name)
{
- SCM sym = scm_from_locale_symboln (name, ptr-name);
+ SCM sym = scm_from_utf8_symboln (name, ptr-name);
*tail = scm_cons (sym, SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
if (name)
{
va_list ap;
- SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
+ SCM names = scm_cons (scm_from_utf8_symbol (name), SCM_EOL);
SCM *tail = SCM_CDRLOC (names);
va_start (ap, name);
while (1)
const char *n = va_arg (ap, const char *);
if (n == NULL)
break;
- *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
+ *tail = scm_cons (scm_from_utf8_symbol (n), SCM_EOL);
tail = SCM_CDRLOC (*tail);
}
va_end (ap);
{
SCM var;
- if (SCM_NIMP (proc))
+ if (SCM_HEAP_OBJECT_P (proc))
{
if (SCM_EVAL_CLOSURE_P (proc))
{
SCM
scm_c_module_lookup (SCM module, const char *name)
{
- return scm_module_lookup (module, scm_from_locale_symbol (name));
+ return scm_module_lookup (module, scm_from_utf8_symbol (name));
}
SCM
SCM
scm_c_lookup (const char *name)
{
- return scm_lookup (scm_from_locale_symbol (name));
+ return scm_lookup (scm_from_utf8_symbol (name));
}
SCM
scm_c_public_variable (const char *module_name, const char *name)
{
return scm_public_variable (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_variable (const char *module_name, const char *name)
{
return scm_private_variable (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_public_lookup (const char *module_name, const char *name)
{
return scm_public_lookup (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_lookup (const char *module_name, const char *name)
{
return scm_private_lookup (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_public_ref (const char *module_name, const char *name)
{
return scm_public_ref (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_private_ref (const char *module_name, const char *name)
{
return scm_private_ref (convert_module_name (module_name),
- scm_from_locale_symbol (name));
+ scm_from_utf8_symbol (name));
}
SCM
scm_c_module_define (SCM module, const char *name, SCM value)
{
- return scm_module_define (module, scm_from_locale_symbol (name), value);
+ return scm_module_define (module, scm_from_utf8_symbol (name), value);
}
SCM
SCM
scm_c_define (const char *name, SCM value)
{
- return scm_define (scm_from_locale_symbol (name), value);
+ return scm_define (scm_from_utf8_symbol (name), value);
}
SCM_DEFINE (scm_define, "define!", 2, 0, 0,
{
handle = SCM_CAR (ls);
- if (SCM_UNPACK (SCM_CAR (handle)) == 0)
- {
- /* FIXME: We hit a weak pair whose car has become unreachable.
- We should remove the pair in question or something. */
- }
- else
- {
- if (scm_is_eq (SCM_CDR (handle), variable))
- return SCM_CAR (handle);
- }
+ if (scm_is_eq (SCM_CDR (handle), variable))
+ return SCM_CAR (handle);
ls = SCM_CDR (ls);
}
void
scm_modules_prehistory ()
{
- scm_pre_modules_obarray = scm_c_make_hash_table (1533);
+ scm_pre_modules_obarray = scm_c_make_hash_table (1790);
}
void
#ifndef SCM_NULL_THREADS_H
#define SCM_NULL_THREADS_H
-/* Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2005, 2006, 2010, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define scm_i_scm_pthread_cond_wait scm_i_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait scm_i_pthread_cond_timedwait
+#define SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(m,lock,unlock) /* noop */
+#define scm_i_pthread_atfork(pre,parent,child) do {} while (0)
+
#endif /* SCM_NULL_THREADS_H */
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
{
SCM bignum;
- bignum = PTR2SCM (ptr);
+ bignum = SCM_PACK_POINTER (ptr);
mpz_clear (SCM_I_BIG_MPZ (bignum));
}
make_bignum (void)
{
scm_t_bits *p;
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
/* Allocate one word for the type tag and enough room for an `mpz_t'. */
p = scm_gc_malloc_pointerless (sizeof (scm_t_bits) + sizeof (mpz_t),
"bignum");
p[0] = scm_tc16_big;
- GC_REGISTER_FINALIZER_NO_ORDER (p, finalize_bignum, NULL,
- &prev_finalizer,
- &prev_finalizer_data);
+ scm_i_set_finalizer (p, finalize_bignum, NULL);
return SCM_PACK (p);
}
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';
scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_double (double val, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port);
}
int
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port);
return !0;
}
scm_i_print_complex (double real, double imag, SCM port)
{
char num_buf[FLOBUFLEN];
- scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+ scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port);
}
int
void (*freefunc) (void *, size_t);
mp_get_memory_functions (NULL, NULL, &freefunc);
scm_remember_upto_here_1 (exp);
- scm_lfwrite (str, len, port);
+ scm_lfwrite_unlocked (str, len, port);
freefunc (str, len + 1);
return !0;
}
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
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
"complex"));
SCM_SET_CELL_TYPE (z, scm_tc16_complex);
SCM_COMPLEX_REAL (z) = re;
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);
{
SCM z;
- z = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
+ z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
SCM_SET_CELL_TYPE (z, scm_tc16_real);
SCM_REAL_VALUE (z) = val;
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 SCM_INEXACTP(x) \
(!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
-#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real)
-#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex)
+#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
+#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
#define SCM_COMPLEX_REAL(x) (((scm_t_complex *) SCM2PTR (x))->real)
/* Each bignum is just an mpz_t stored in a double cell starting at word 1. */
#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
-#define SCM_BIGP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_big)
+#define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
-#define SCM_NUMP(x) (!SCM_IMP(x) \
- && ((0x00ff & SCM_CELL_TYPE (x)) == scm_tc7_number))
+#define SCM_NUMP(x) (SCM_HAS_TYP7 (x, scm_tc7_number))
-#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
+#define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction))
#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_int8 *s8vector;
scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- s8vector = scm_gc_malloc_pointerless (len, FUNC_NAME);
- memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
-
- return scm_c_take_gc_bytevector (s8vector, len);
+ return scm_c_take_gc_bytevector ((scm_t_int8*)SCM_OBJCODE_DATA (objcode),
+ len, objcode);
}
#undef FUNC_NAME
to_native_order (SCM_OBJCODE_LEN (objcode), target_endianness ())
+ to_native_order (SCM_OBJCODE_META_LEN (objcode), target_endianness ());
- scm_c_write (port, cookie, strlen (SCM_OBJCODE_COOKIE));
- scm_c_write (port, SCM_OBJCODE_DATA (objcode),
- sizeof (struct scm_objcode) + total_size);
+ scm_c_write_unlocked (port, cookie, strlen (SCM_OBJCODE_COOKIE));
+ scm_c_write_unlocked (port, SCM_OBJCODE_DATA (objcode),
+ sizeof (struct scm_objcode)
+ + total_size);
return SCM_UNSPECIFIED;
}
void
scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<objcode ", port);
+ scm_puts_unlocked ("#<objcode ", port);
scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
\f
#define SCM_OBJCODE_TYPE_SLICE (2)
#define SCM_OBJCODE_TYPE_STATIC (3)
-#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_objcode)
+#define SCM_OBJCODE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_objcode))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#include "libguile/hashtab.h"
#include "libguile/alist.h"
#include "libguile/root.h"
-#include "libguile/weaks.h"
#include "libguile/objprop.h"
\f
*/
static SCM object_whash;
-static scm_i_pthread_mutex_t whash_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0,
(SCM obj),
"Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_object_properties
{
- SCM ret;
-
- scm_i_pthread_mutex_lock (&whash_mutex);
- ret = scm_hashq_ref (object_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&whash_mutex);
-
- return ret;
+ return scm_weak_table_refq (object_whash, obj, SCM_EOL);
}
#undef FUNC_NAME
"Set @var{obj}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_object_properties_x
{
- scm_i_pthread_mutex_lock (&whash_mutex);
- scm_hashq_set_x (object_whash, obj, alist);
- scm_i_pthread_mutex_unlock (&whash_mutex);
+ scm_weak_table_putq_x (object_whash, obj, alist);
return alist;
}
{
SCM assoc;
assoc = scm_assq (key, scm_object_properties (obj));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
+ return (scm_is_pair (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
}
#undef FUNC_NAME
SCM alist;
SCM assoc;
- scm_i_pthread_mutex_lock (&whash_mutex);
- alist = scm_hashq_ref (object_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ alist = scm_weak_table_refq (object_whash, obj, SCM_EOL);
assoc = scm_assq (key, alist);
- if (SCM_NIMP (assoc))
+ if (scm_is_pair (assoc))
SCM_SETCDR (assoc, value);
else
- scm_hashq_set_x (object_whash, obj, scm_acons (key, value, alist));
- scm_i_pthread_mutex_unlock (&whash_mutex);
+ scm_weak_table_putq_x (object_whash, obj, scm_acons (key, value, alist));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return value;
}
void
scm_init_objprop ()
{
- object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ object_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/objprop.x"
}
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 Free Software Foundation
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
SCM_SYMBOL (scm_yes_sym, "yes");
SCM_SYMBOL (scm_no_sym, "no");
-static SCM protected_objects = SCM_EOL;
-
/* Return a list of the current option setting. The format of an
* option setting is described in the above documentation. */
static SCM
for (i = 0; options[i].name; ++i)
{
- SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
+ SCM ls = scm_cons (scm_from_utf8_string (options[i].doc), SCM_EOL);
switch (options[i].type)
{
case SCM_OPTION_BOOLEAN:
int dry_run)
{
unsigned int i;
- SCM locally_protected_args = args;
- SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits));
- scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
+ scm_t_bits *new_vals;
+
+ new_vals = scm_gc_malloc (options_length (options) * sizeof (scm_t_bits),
+ "new-options");
for (i = 0; options[i].name; ++i)
{
if (options[i].type == SCM_OPTION_BOOLEAN)
- flags[i] = 0;
+ new_vals[i] = 0;
else
- flags[i] = options[i].val;
+ new_vals[i] = options[i].val;
}
while (!SCM_NULL_OR_NIL_P (args))
switch (options[i].type)
{
case SCM_OPTION_BOOLEAN:
- flags[i] = 1;
+ new_vals[i] = 1;
break;
case SCM_OPTION_INTEGER:
args = SCM_CDR (args);
- flags[i] = scm_to_size_t (scm_car (args));
+ new_vals[i] = scm_to_size_t (scm_car (args));
break;
case SCM_OPTION_SCM:
args = SCM_CDR (args);
- flags[i] = SCM_UNPACK (scm_car (args));
+ new_vals[i] = SCM_UNPACK (scm_car (args));
break;
}
found = 1;
return;
for (i = 0; options[i].name; ++i)
- {
- if (options[i].type == SCM_OPTION_SCM)
- {
- SCM old = SCM_PACK (options[i].val);
- SCM new = SCM_PACK (flags[i]);
- if (!SCM_IMP (old))
- protected_objects = scm_delq1_x (old, protected_objects);
- if (!SCM_IMP (new))
- protected_objects = scm_cons (new, protected_objects);
- }
- options[i].val = flags[i];
- }
-
- scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
+ options[i].val = new_vals[i];
}
for (i = 0; options[i].name; ++i)
{
- SCM name = scm_from_locale_symbol (options[i].name);
+ SCM name = scm_from_utf8_symbol (options[i].name);
options[i].name = (char *) SCM_UNPACK (name);
}
func (SCM_UNDEFINED);
void
scm_init_options ()
{
- scm_gc_register_root (&protected_objects);
-
#include "libguile/options.x"
}
#include "libguile/validate.h"
#include "libguile/ports.h"
#include "libguile/vectors.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
* Indexes into this table are used when generating type
* tags for smobjects (if you know a tag you can get an index and conversely).
*/
-scm_t_ptob_descriptor *scm_ptobs = NULL;
-long scm_numptob = 0;
+static scm_t_ptob_descriptor **scm_ptobs = NULL;
+static long scm_numptob = 0; /* Number of port types. */
+static long scm_ptobs_size = 0; /* Number of slots in the port type
+ table. */
+static scm_i_pthread_mutex_t scm_ptobs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_ptobs_lock);
-/* GC marker for a port with stream of SCM type. */
-SCM
-scm_markstream (SCM ptr)
+long
+scm_c_num_port_types (void)
{
- int openp;
- openp = SCM_CELL_WORD_0 (ptr) & SCM_OPN;
- if (openp)
- return SCM_PACK (SCM_STREAM (ptr));
- else
- return SCM_BOOL_F;
+ long ret;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+ ret = scm_numptob;
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ return ret;
+}
+
+scm_t_ptob_descriptor*
+scm_c_port_type_ref (long ptobnum)
+{
+ scm_t_ptob_descriptor *ret = NULL;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+
+ if (0 <= ptobnum && ptobnum < scm_numptob)
+ ret = scm_ptobs[ptobnum];
+
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ if (!ret)
+ scm_out_of_range ("scm_c_port_type_ref", scm_from_long (ptobnum));
+
+ return ret;
+}
+
+long
+scm_c_port_type_add_x (scm_t_ptob_descriptor *desc)
+{
+ long ret = -1;
+
+ scm_i_pthread_mutex_lock (&scm_ptobs_lock);
+
+ if (scm_numptob + 1 < SCM_I_MAX_PORT_TYPE_COUNT)
+ {
+ if (scm_numptob == scm_ptobs_size)
+ {
+ unsigned long old_size = scm_ptobs_size;
+ scm_t_ptob_descriptor **old_ptobs = scm_ptobs;
+
+ /* Currently there are only 9 predefined port types, so one
+ resize will cover it. */
+ scm_ptobs_size = old_size + 10;
+
+ if (scm_ptobs_size >= SCM_I_MAX_PORT_TYPE_COUNT)
+ scm_ptobs_size = SCM_I_MAX_PORT_TYPE_COUNT;
+
+ scm_ptobs = scm_gc_malloc (sizeof (*scm_ptobs) * scm_ptobs_size,
+ "scm_ptobs");
+
+ memcpy (scm_ptobs, old_ptobs, sizeof (*scm_ptobs) * scm_numptob);
+ }
+
+ ret = scm_numptob++;
+ scm_ptobs[ret] = desc;
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_ptobs_lock);
+
+ if (ret < 0)
+ scm_out_of_range ("scm_c_port_type_add_x", scm_from_long (scm_numptob));
+
+ return ret;
}
/*
int (*fill_input) (SCM port),
void (*write) (SCM port, const void *data, size_t size))
{
- char *tmp;
- if (SCM_I_MAX_PORT_TYPE_COUNT - 1 <= scm_numptob)
- goto ptoberr;
- SCM_CRITICAL_SECTION_START;
- tmp = (char *) scm_gc_realloc ((char *) scm_ptobs,
- scm_numptob * sizeof (scm_t_ptob_descriptor),
- (1 + scm_numptob)
- * sizeof (scm_t_ptob_descriptor),
- "port-type");
- if (tmp)
- {
- scm_ptobs = (scm_t_ptob_descriptor *) tmp;
+ scm_t_ptob_descriptor *desc;
+ long ptobnum;
- scm_ptobs[scm_numptob].name = name;
- scm_ptobs[scm_numptob].mark = 0;
- scm_ptobs[scm_numptob].free = NULL;
- scm_ptobs[scm_numptob].print = scm_port_print;
- scm_ptobs[scm_numptob].equalp = 0;
- scm_ptobs[scm_numptob].close = 0;
+ desc = scm_gc_malloc_pointerless (sizeof (*desc), "port-type");
+ memset (desc, 0, sizeof (*desc));
- scm_ptobs[scm_numptob].write = write;
- scm_ptobs[scm_numptob].flush = flush_port_default;
+ desc->name = name;
+ desc->print = scm_port_print;
+ desc->write = write;
+ desc->flush = flush_port_default;
+ desc->end_input = end_input_default;
+ desc->fill_input = fill_input;
- scm_ptobs[scm_numptob].end_input = end_input_default;
- scm_ptobs[scm_numptob].fill_input = fill_input;
- scm_ptobs[scm_numptob].input_waiting = 0;
+ ptobnum = scm_c_port_type_add_x (desc);
- scm_ptobs[scm_numptob].seek = 0;
- scm_ptobs[scm_numptob].truncate = 0;
-
- scm_numptob++;
- }
- SCM_CRITICAL_SECTION_END;
- if (!tmp)
- {
- ptoberr:
- scm_memory_error ("scm_make_port_type");
- }
- /* Make a class object if Goops is present */
+ /* Make a class object if GOOPS is present. */
if (SCM_UNPACK (scm_port_class[0]) != 0)
- scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
- return scm_tc7_port + (scm_numptob - 1) * 256;
+ scm_make_port_classes (ptobnum, name);
+
+ return scm_tc7_port + ptobnum * 256;
}
void
scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->mark = mark;
}
void
scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->free = free;
}
void
scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port,
- scm_print_state *pstate))
+ scm_print_state *pstate))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print;
}
void
scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->equalp = equalp;
}
void
-scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
+scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close;
}
void
-scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
+scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input;
+ scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc));
+ ptob->flush = flush;
+ ptob->flags |= SCM_PORT_TYPE_HAS_FLUSH;
}
void
-scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
+scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input;
}
void
-scm_set_port_seek (scm_t_bits tc,
- scm_t_off (*seek) (SCM, scm_t_off, int))
+scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM, scm_t_off, int))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->seek = seek;
}
void
scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM, scm_t_off))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->truncate = truncate;
}
void
scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM))
{
- scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
+ scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting;
}
\f
-SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
- (SCM port),
- "Return @code{#t} if a character is ready on input @var{port}\n"
- "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
- "@code{#t} then the next @code{read-char} operation on\n"
- "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
- "port at end of file then @code{char-ready?} returns @code{#t}.\n"
- "\n"
- "@code{char-ready?} exists to make it possible for a\n"
- "program to accept characters from interactive ports without\n"
- "getting stuck waiting for input. Any input editors associated\n"
- "with such ports must make sure that characters whose existence\n"
- "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
- "If @code{char-ready?} were to return @code{#f} at end of file,\n"
- "a port at end of file would be indistinguishable from an\n"
- "interactive port that has no ready characters.")
-#define FUNC_NAME s_scm_char_ready_p
-{
- scm_t_port *pt;
-
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
- /* It's possible to close the current input port, so validate even in
- this case. */
- SCM_VALIDATE_OPINPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
-
- /* if the current read buffer is filled, or the
- last pushed-back char has been read and the saved buffer is
- filled, result is true. */
- if (pt->read_pos < pt->read_end
- || (pt->read_buf == pt->putback_buf
- && pt->saved_read_pos < pt->saved_read_end))
- return SCM_BOOL_T;
- else
- {
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
-
- if (ptob->input_waiting)
- return scm_from_bool(ptob->input_waiting (port));
- else
- return SCM_BOOL_T;
- }
-}
-#undef FUNC_NAME
-
-/* move up to read_len chars from port's putback and/or read buffers
- into memory starting at dest. returns the number of chars moved. */
-size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- size_t chars_read = 0;
- size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
-
- if (from_buf > 0)
- {
- memcpy (dest, pt->read_pos, from_buf);
- pt->read_pos += from_buf;
- chars_read += from_buf;
- read_len -= from_buf;
- dest += from_buf;
- }
-
- /* if putback was active, try the real input buffer too. */
- if (pt->read_buf == pt->putback_buf)
- {
- from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
- if (from_buf > 0)
- {
- memcpy (dest, pt->saved_read_pos, from_buf);
- pt->saved_read_pos += from_buf;
- chars_read += from_buf;
- }
- }
- return chars_read;
-}
-
-/* Clear a port's read buffers, returning the contents. */
-SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
- (SCM port),
- "This procedure clears a port's input buffers, similar\n"
- "to the way that force-output clears the output buffer. The\n"
- "contents of the buffers are returned as a single string, e.g.,\n"
- "\n"
- "@lisp\n"
- "(define p (open-input-file ...))\n"
- "(drain-input p) => empty string, nothing buffered yet.\n"
- "(unread-char (read-char p) p)\n"
- "(drain-input p) => initial chars from p, up to the buffer size.\n"
- "@end lisp\n\n"
- "Draining the buffers may be useful for cleanly finishing\n"
- "buffered I/O so that the file descriptor can be used directly\n"
- "for further input.")
-#define FUNC_NAME s_scm_drain_input
-{
- SCM result;
- char *data;
- scm_t_port *pt;
- long count;
-
- SCM_VALIDATE_OPINPORT (1, port);
- pt = SCM_PTAB_ENTRY (port);
-
- count = pt->read_end - pt->read_pos;
- if (pt->read_buf == pt->putback_buf)
- count += pt->saved_read_end - pt->saved_read_pos;
-
- if (count)
- {
- result = scm_i_make_string (count, &data, 0);
- scm_take_from_input_buffers (port, data, count);
- }
- else
- result = scm_nullstr;
-
- return result;
-}
-#undef FUNC_NAME
-
-\f
/* Standard ports --- current input, output, error, and more(!). */
static SCM cur_inport_fluid = SCM_BOOL_F;
scm_dynwind_fluid (cur_loadport_fluid, port);
}
+
\f
-/* The port table --- an array of pointers to ports. */
-/*
- We need a global registry of ports to flush them all at exit, and to
- get all the ports matching a file descriptor.
+/* Retrieving a port's mode. */
+
+/* Return the flags that characterize a port based on the mode
+ * string used to open a file for that port.
+ *
+ * See PORT FLAGS in scm.h
*/
-SCM scm_i_port_weak_hash;
-scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static long
+scm_i_mode_bits_n (SCM modes)
+{
+ return (SCM_OPN
+ | (scm_i_string_contains_char (modes, 'r')
+ || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
+ | (scm_i_string_contains_char (modes, 'w')
+ || scm_i_string_contains_char (modes, 'a')
+ || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
+ | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
+ | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
+}
+
+long
+scm_mode_bits (char *modes)
+{
+ return scm_i_mode_bits (scm_from_locale_string (modes));
+}
+
+long
+scm_i_mode_bits (SCM modes)
+{
+ long bits;
+
+ if (!scm_is_string (modes))
+ scm_wrong_type_arg_msg (NULL, 0, modes, "string");
+
+ bits = scm_i_mode_bits_n (modes);
+ scm_remember_upto_here_1 (modes);
+ return bits;
+}
+
+/* Return the mode flags from an open port.
+ * Some modes such as "append" are only used when opening
+ * a file and are not returned here. */
+
+SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
+ (SCM port),
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
+#define FUNC_NAME s_scm_port_mode
+{
+ char modes[4];
+ modes[0] = '\0';
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "r+");
+ else
+ strcpy (modes, "r");
+ }
+ else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "w");
+ if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
+ strcat (modes, "0");
+
+ return scm_from_latin1_string (modes);
+}
+#undef FUNC_NAME
+
\f
-/* Port finalization. */
+/* The port table --- a weak set of all ports.
-static void finalize_port (GC_PTR, GC_PTR);
+ We need a global registry of ports to flush them all at exit, and to
+ get all the ports matching a file descriptor. */
+SCM scm_i_port_weak_set;
+
+
+\f
+
+/* Port finalization. */
+
+struct do_free_data
+{
+ scm_t_ptob_descriptor *ptob;
+ SCM port;
+};
-/* Register a finalizer for PORT. */
-static SCM_C_INLINE_KEYWORD void
-register_finalizer_for_port (SCM port)
+static SCM
+do_free (void *body_data)
{
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalization_data;
+ struct do_free_data *data = body_data;
- /* Register a finalizer for PORT so that its iconv CDs get freed and
- optionally its type's `free' function gets called. */
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (port), finalize_port, 0,
- &prev_finalizer,
- &prev_finalization_data);
+ /* `close' is for explicit `close-port' by user. `free' is for this
+ purpose: ports collected by the GC. */
+ data->ptob->free (data->port);
+
+ return SCM_BOOL_T;
}
/* Finalize the object (a port) pointed to by PTR. */
static void
finalize_port (GC_PTR ptr, GC_PTR data)
{
- long port_type;
- SCM port = PTR2SCM (ptr);
+ SCM port = SCM_PACK_POINTER (ptr);
if (!SCM_PORTP (port))
abort ();
if (SCM_OPENP (port))
{
- if (SCM_REVEALED (port) > 0)
- /* Keep "revealed" ports alive and re-register a finalizer. */
- register_finalizer_for_port (port);
- else
- {
- scm_t_port *entry;
-
- port_type = SCM_TC2PTOBNUM (SCM_CELL_TYPE (port));
- if (port_type >= scm_numptob)
- abort ();
+ struct do_free_data data;
- if (scm_ptobs[port_type].free)
- /* Yes, I really do mean `.free' rather than `.close'. `.close'
- is for explicit `close-port' by user. */
- scm_ptobs[port_type].free (port);
+ SCM_CLR_PORT_OPEN_FLAG (port);
- entry = SCM_PTAB_ENTRY (port);
+ data.ptob = SCM_PORT_DESCRIPTOR (port);
+ data.port = port;
- if (entry->input_cd != (iconv_t) -1)
- iconv_close (entry->input_cd);
- if (entry->output_cd != (iconv_t) -1)
- iconv_close (entry->output_cd);
+ scm_internal_catch (SCM_BOOL_T, do_free, &data,
+ scm_handle_by_message_noexit, NULL);
- SCM_SETSTREAM (port, 0);
- SCM_CLR_PORT_OPEN_FLAG (port);
-
- scm_gc_ports_collected++;
- }
+ scm_gc_ports_collected++;
}
}
-
\f
-/* This function is not and should not be thread safe. */
SCM
-scm_new_port_table_entry (scm_t_bits tag)
-#define FUNC_NAME "scm_new_port_table_entry"
+scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler handler,
+ scm_t_bits stream)
{
- /*
- We initialize the cell to empty, this is in case scm_gc_calloc
- triggers GC ; we don't want the GC to scan a half-finished Z.
- */
-
- SCM z = scm_cons (SCM_EOL, SCM_EOL);
- scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
- const char *enc;
+ SCM ret;
+ scm_t_port *entry;
+ scm_t_ptob_descriptor *ptob;
- entry->file_name = SCM_BOOL_F;
- entry->rw_active = SCM_PORT_NEITHER;
- entry->port = z;
+ entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag));
- /* Initialize this port with the thread's current default
- encoding. */
- enc = scm_i_default_port_encoding ();
- entry->encoding = enc ? scm_gc_strdup (enc, "port") : NULL;
+ ret = scm_words (tag | mode_bits, 3);
+ SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry);
+ SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob);
- /* The conversion descriptors will be opened lazily. */
- entry->input_cd = (iconv_t) -1;
- entry->output_cd = (iconv_t) -1;
+ entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
+ scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
- entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F);
-
- SCM_SET_CELL_TYPE (z, tag);
- SCM_SETPTAB_ENTRY (z, entry);
-
- scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F);
-
- /* For each new port, register a finalizer so that it port type's free
- function can be invoked eventually. */
- register_finalizer_for_port (z);
-
- return z;
-}
-#undef FUNC_NAME
-
-#if SCM_ENABLE_DEPRECATED==1
-scm_t_port *
-scm_add_to_port_table (SCM port)
-{
- 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_i_remove_port (SCM port)
-#define FUNC_NAME "scm_remove_port"
-{
- scm_t_port *p;
-
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- p = SCM_PTAB_ENTRY (port);
- scm_port_non_buffer (p);
- p->putback_buf = NULL;
- p->putback_buf_size = 0;
-
- if (p->input_cd != (iconv_t) -1)
- {
- iconv_close (p->input_cd);
- p->input_cd = (iconv_t) -1;
- }
-
- if (p->output_cd != (iconv_t) -1)
- {
- iconv_close (p->output_cd);
- p->output_cd = (iconv_t) -1;
- }
+ entry->file_name = SCM_BOOL_F;
+ entry->rw_active = SCM_PORT_NEITHER;
+ entry->port = ret;
+ entry->stream = stream;
+ entry->encoding = encoding ? scm_gc_strdup (encoding, "port") : NULL;
+ if (encoding && strcmp (encoding, "UTF-8") == 0)
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ else
+ entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ entry->ilseq_handler = handler;
+ entry->iconv_descriptors = NULL;
- SCM_SETPTAB_ENTRY (port, 0);
+ if (SCM_PORT_DESCRIPTOR (ret)->free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
- scm_hashq_remove_x (scm_i_port_weak_hash, port);
+ if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_add_x (scm_i_port_weak_set, ret);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return ret;
}
-#undef FUNC_NAME
-
-/* Functions for debugging. */
-#ifdef GUILE_DEBUG
-SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
- (),
- "Return the number of ports in the port table. @code{pt-size}\n"
- "is only included in @code{--enable-guile-debug} builds.")
-#define FUNC_NAME s_scm_pt_size
+SCM
+scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream)
{
- return scm_from_int (SCM_HASHTABLE_N_ITEMS (scm_i_port_weak_hash));
+ return scm_c_make_port_with_encoding (tag, mode_bits,
+ scm_i_default_port_encoding (),
+ scm_i_get_conversion_strategy (SCM_BOOL_F),
+ stream);
}
-#undef FUNC_NAME
-#endif
-void
-scm_port_non_buffer (scm_t_port *pt)
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
{
- pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
- pt->write_buf = pt->write_pos = &pt->shortbuf;
- pt->read_buf_size = pt->write_buf_size = 1;
- pt->write_end = pt->write_buf + pt->write_buf_size;
+ return scm_c_make_port (tag, 0, 0);
}
\f
-/* Revealed counts --- an oddity inherited from SCSH. */
-
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
-
-int
-scm_revealed_count (SCM port)
-{
- return SCM_REVEALED(port);
-}
-
+/* Predicates. */
-/* Return the revealed count for a port. */
-
-SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
- (SCM port),
- "Return the revealed count for @var{port}.")
-#define FUNC_NAME s_scm_port_revealed
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (scm_revealed_count (port));
+ return scm_from_bool (SCM_PORTP (x));
}
#undef FUNC_NAME
-/* Set the revealed count for a port. */
-SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
- (SCM port, SCM rcount),
- "Sets the revealed count for a port to a given value.\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_set_port_revealed_x
+SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_input_port_p
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_REVEALED (port) = scm_to_int (rcount);
- return SCM_UNSPECIFIED;
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
}
#undef FUNC_NAME
-
-\f
-/* Retrieving a port's mode. */
-
-/* Return the flags that characterize a port based on the mode
- * string used to open a file for that port.
- *
- * See PORT FLAGS in scm.h
- */
-
-static long
-scm_i_mode_bits_n (SCM modes)
-{
- return (SCM_OPN
- | (scm_i_string_contains_char (modes, 'r')
- || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0)
- | (scm_i_string_contains_char (modes, 'w')
- || scm_i_string_contains_char (modes, 'a')
- || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0)
- | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0)
- | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0));
-}
-
-long
-scm_mode_bits (char *modes)
+SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_output_port_p
{
- return scm_i_mode_bits (scm_from_locale_string (modes));
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
}
+#undef FUNC_NAME
-long
-scm_i_mode_bits (SCM modes)
+SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
{
- long bits;
-
- if (!scm_is_string (modes))
- scm_wrong_type_arg_msg (NULL, 0, modes, "string");
-
- bits = scm_i_mode_bits_n (modes);
- scm_remember_upto_here_1 (modes);
- return bits;
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
}
+#undef FUNC_NAME
-/* Return the mode flags from an open port.
- * Some modes such as "append" are only used when opening
- * a file and are not returned here. */
-
-SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
- (SCM port),
- "Return the port modes associated with the open port @var{port}.\n"
- "These will not necessarily be identical to the modes used when\n"
- "the port was opened, since modes such as \"append\" which are\n"
- "used only during port creation are not retained.")
-#define FUNC_NAME s_scm_port_mode
+SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_eof_object_p
{
- char modes[4];
- modes[0] = '\0';
-
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPPORT (1, port);
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "r+");
- else
- strcpy (modes, "r");
- }
- else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- strcpy (modes, "w");
- if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
- strcat (modes, "0");
- return scm_from_locale_string (modes);
+ return scm_from_bool (SCM_EOF_OBJECT_P (x));
}
#undef FUNC_NAME
\f
+
/* Closing ports. */
+static void close_iconv_descriptors (scm_t_iconv_descriptors *id);
+
/* scm_close_port
* Call the close operation on a port object.
* see also scm_close.
"descriptors.")
#define FUNC_NAME s_scm_close_port
{
- size_t i;
+ scm_t_port *p;
int rv;
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port);
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
- i = SCM_PTOBNUM (port);
- if (scm_ptobs[i].close)
- rv = (scm_ptobs[i].close) (port);
+
+ p = SCM_PTAB_ENTRY (port);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH)
+ scm_weak_set_remove_x (scm_i_port_weak_set, port);
+
+ if (SCM_PORT_DESCRIPTOR (port)->close)
+ /* Note! This may throw an exception. Anything after this point
+ should be resilient to non-local exits. */
+ rv = SCM_PORT_DESCRIPTOR (port)->close (port);
else
rv = 0;
- scm_i_remove_port (port);
- SCM_CLR_PORT_OPEN_FLAG (port);
+
+ if (p->iconv_descriptors)
+ {
+ /* If we don't get here, the iconv_descriptors finalizer will
+ clean up. */
+ close_iconv_descriptors (p->iconv_descriptors);
+ p->iconv_descriptors = NULL;
+ }
+
return scm_from_bool (rv >= 0);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-static SCM
-collect_keys (void *unused, SCM key, SCM value, SCM result)
-{
- return scm_cons (key, result);
-}
+\f
+
+/* Encoding characters to byte streams, and decoding byte streams to
+ characters. */
+
+/* A fluid specifying the default encoding for newly created ports. If it is
+ a string, that is the encoding. If it is #f, it is in the "native"
+ (Latin-1) encoding. */
+SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
+
+static int scm_port_encoding_init = 0;
+
+/* Use ENCODING as the default encoding for future ports. */
void
-scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+scm_i_set_default_port_encoding (const char *encoding)
{
- SCM ports;
+ if (!scm_port_encoding_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized",
+ SCM_EOL);
- /* Copy out the port table as a list so that we get strong references
- to all the values. */
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
- ports = scm_internal_hash_fold (collect_keys, NULL,
- SCM_EOL, scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ if (encoding == NULL
+ || !strcmp (encoding, "ASCII")
+ || !strcmp (encoding, "ANSI_X3.4-1968")
+ || !strcmp (encoding, "ISO-8859-1"))
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
+ else
+ scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
+ scm_from_locale_string (encoding));
+}
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
+/* Return the name of the default encoding for newly created ports; a
+ return value of NULL means "ISO-8859-1". */
+const char *
+scm_i_default_port_encoding (void)
+{
+ if (!scm_port_encoding_init)
+ return NULL;
+ else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
+ return NULL;
+ else
{
- SCM p = scm_car (ports);
- if (SCM_PORTP (p))
- proc (data, p);
+ SCM encoding;
+
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
+ if (!scm_is_string (encoding))
+ return NULL;
+ else
+ return scm_i_string_chars (encoding);
}
}
-SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
- (SCM proc),
- "Apply @var{proc} to each port in the Guile port table\n"
- "in turn. The return value is unspecified. More specifically,\n"
- "@var{proc} is applied exactly once to every port that exists\n"
- "in the system at the time @code{port-for-each} is invoked.\n"
- "Changes to the port table while @code{port-for-each} is running\n"
- "have no effect as far as @code{port-for-each} is concerned.")
-#define FUNC_NAME s_scm_port_for_each
+static void
+finalize_iconv_descriptors (GC_PTR ptr, GC_PTR data)
{
- SCM ports;
+ close_iconv_descriptors (ptr);
+}
- SCM_VALIDATE_PROC (1, proc);
+static scm_t_iconv_descriptors *
+open_iconv_descriptors (const char *encoding, int reading, int writing)
+{
+ scm_t_iconv_descriptors *id;
+ iconv_t input_cd, output_cd;
- /* Copy out the port table as a list so that we get strong references
- to all the values. */
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
- ports = scm_internal_hash_fold (collect_keys, NULL,
- SCM_EOL, scm_i_port_weak_hash);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ input_cd = (iconv_t) -1;
+ output_cd = (iconv_t) -1;
- for (; scm_is_pair (ports); ports = scm_cdr (ports))
- if (SCM_PORTP (SCM_CAR (ports)))
- scm_call_1 (proc, SCM_CAR (ports));
+ if (reading)
+ {
+ /* Open an input iconv conversion descriptor, from ENCODING
+ to UTF-8. We choose UTF-8, not UTF-32, because iconv
+ implementations can typically convert from anything to
+ UTF-8, but not to UTF-32 (see
+ <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
+
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
+
+ scm_i_lock_iconv ();
+ input_cd = iconv_open ("UTF-8", encoding);
+ scm_i_unlock_iconv ();
+ if (input_cd == (iconv_t) -1)
+ goto invalid_encoding;
+ }
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+ if (writing)
+ {
+ /* Assume opening an iconv descriptor causes about 16 KB of
+ allocation. */
+ scm_gc_register_allocation (16 * 1024);
+
+ scm_i_lock_iconv ();
+ output_cd = iconv_open (encoding, "UTF-8");
+ scm_i_unlock_iconv ();
+ if (output_cd == (iconv_t) -1)
+ {
+ scm_i_lock_iconv ();
+ if (input_cd != (iconv_t) -1)
+ iconv_close (input_cd);
+ scm_i_unlock_iconv ();
+ goto invalid_encoding;
+ }
+ }
+ id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors");
+ id->input_cd = input_cd;
+ id->output_cd = output_cd;
-\f
-/* Utter miscellany. Gosh, we should clean this up some time. */
+ /* Register a finalizer to close the descriptors. */
+ scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL);
-SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an input port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_input_port_p
-{
- return scm_from_bool (SCM_INPUT_PORT_P (x));
+ return id;
+
+ invalid_encoding:
+ {
+ SCM err;
+ err = scm_from_locale_string (encoding);
+ scm_misc_error ("open_iconv_descriptors",
+ "invalid or unknown character encoding ~s",
+ scm_list_1 (err));
+ }
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an output port, otherwise return\n"
- "@code{#f}. Any object satisfying this predicate also satisfies\n"
- "@code{port?}.")
-#define FUNC_NAME s_scm_output_port_p
+static void
+close_iconv_descriptors (scm_t_iconv_descriptors *id)
{
- x = SCM_COERCE_OUTPORT (x);
- return scm_from_bool (SCM_OUTPUT_PORT_P (x));
+ scm_i_lock_iconv ();
+ if (id->input_cd != (iconv_t) -1)
+ iconv_close (id->input_cd);
+ if (id->output_cd != (iconv_t) -1)
+ iconv_close (id->output_cd);
+ scm_i_unlock_iconv ();
+ id->input_cd = (void *) -1;
+ id->output_cd = (void *) -1;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
- (SCM x),
- "Return a boolean indicating whether @var{x} is a port.\n"
- "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
- "@var{x}))}.")
-#define FUNC_NAME s_scm_port_p
+scm_t_iconv_descriptors *
+scm_i_port_iconv_descriptors (SCM port)
{
- return scm_from_bool (SCM_PORTP (x));
+ scm_t_port *pt;
+
+ pt = SCM_PTAB_ENTRY (port);
+
+ assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
+
+ if (!pt->iconv_descriptors)
+ {
+ if (!pt->encoding)
+ pt->encoding = "ISO-8859-1";
+ pt->iconv_descriptors =
+ open_iconv_descriptors (pt->encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
+ }
+
+ return pt->iconv_descriptors;
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
- (SCM port),
- "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
- "open.")
-#define FUNC_NAME s_scm_port_closed_p
+void
+scm_i_set_port_encoding_x (SCM port, const char *encoding)
{
+ scm_t_port *pt;
+ scm_t_iconv_descriptors *prev;
+
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ prev = pt->iconv_descriptors;
+
+ if (encoding == NULL)
+ encoding = "ISO-8859-1";
+
+ if (strcmp (encoding, "UTF-8") == 0)
+ {
+ pt->encoding = "UTF-8";
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+ pt->iconv_descriptors = NULL;
+ }
+ else
+ {
+ /* Open descriptors before mutating the port. */
+ pt->iconv_descriptors =
+ open_iconv_descriptors (encoding,
+ SCM_INPUT_PORT_P (port),
+ SCM_OUTPUT_PORT_P (port));
+ pt->encoding = scm_gc_strdup (encoding, "port");
+ pt->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+ }
+
+ if (prev)
+ close_iconv_descriptors (prev);
+}
+
+SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+ (SCM port),
+ "Returns, as a string, the character encoding that @var{port}\n"
+ "uses to interpret its input and output.\n")
+#define FUNC_NAME s_scm_port_encoding
+{
+ scm_t_port *pt;
+ const char *enc;
+
SCM_VALIDATE_PORT (1, port);
- return scm_from_bool (!SCM_OPPORTP (port));
+
+ pt = SCM_PTAB_ENTRY (port);
+ enc = pt->encoding;
+ if (enc)
+ return scm_from_locale_string (pt->encoding);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
- (SCM x),
- "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
- "return @code{#f}.")
-#define FUNC_NAME s_scm_eof_object_p
+SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
+ (SCM port, SCM enc),
+ "Sets the character encoding that will be used to interpret all\n"
+ "port I/O. New ports are created with the encoding\n"
+ "appropriate for the current locale if @code{setlocale} has \n"
+ "been called or ISO-8859-1 otherwise\n"
+ "and this procedure can be used to modify that encoding.\n")
+#define FUNC_NAME s_scm_set_port_encoding_x
{
- return scm_from_bool(SCM_EOF_OBJECT_P (x));
+ char *enc_str;
+
+ SCM_VALIDATE_PORT (1, port);
+ SCM_VALIDATE_STRING (2, enc);
+
+ enc_str = scm_to_locale_string (enc);
+ scm_i_set_port_encoding_x (port, enc_str);
+ free (enc_str);
+
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
- (SCM port),
- "Flush the specified output port, or the current output port if @var{port}\n"
- "is omitted. The current output buffer contents are passed to the\n"
- "underlying port implementation (e.g., in the case of fports, the\n"
- "data will be written to the file and the output buffer will be cleared.)\n"
- "It has no effect on an unbuffered port.\n\n"
- "The return value is unspecified.")
-#define FUNC_NAME s_scm_force_output
+
+/* This determines how conversions handle unconvertible characters. */
+SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
+static int scm_conversion_strategy_init = 0;
+
+scm_t_string_failed_conversion_handler
+scm_i_get_conversion_strategy (SCM port)
{
- if (SCM_UNBNDP (port))
- port = scm_current_output_port ();
+ SCM encoding;
+
+ if (scm_is_false (port))
+ {
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ {
+ encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
+ if (scm_is_false (encoding))
+ return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ else
+ return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
+ }
+ }
else
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_t_port *pt;
+ pt = SCM_PTAB_ENTRY (port);
+ return pt->ilseq_handler;
+ }
+
+}
+
+void
+scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler handler)
+{
+ SCM strategy;
+ scm_t_port *pt;
+
+ strategy = scm_from_int ((int) handler);
+
+ if (scm_is_false (port))
+ {
+ /* Set the default encoding for future ports. */
+ if (!scm_conversion_strategy_init
+ || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
+ scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
+ SCM_EOL);
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
+ }
+ else
+ {
+ /* Set the character encoding for this port. */
+ pt = SCM_PTAB_ENTRY (port);
+ pt->ilseq_handler = handler;
+ }
+}
+
+SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
+ 1, 0, 0, (SCM port),
+ "Returns the behavior of the port when handling a character that\n"
+ "is not representable in the port's current encoding.\n"
+ "It returns the symbol @code{error} if unrepresentable characters\n"
+ "should cause exceptions, @code{substitute} if the port should\n"
+ "try to replace unrepresentable characters with question marks or\n"
+ "approximate characters, or @code{escape} if unrepresentable\n"
+ "characters should be converted to string escapes.\n"
+ "\n"
+ "If @var{port} is @code{#f}, then the current default behavior\n"
+ "will be returned. New ports will have this default behavior\n"
+ "when they are created.\n")
+#define FUNC_NAME s_scm_port_conversion_strategy
+{
+ scm_t_string_failed_conversion_handler h;
+
+ SCM_VALIDATE_OPPORT (1, port);
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
}
- scm_flush (port);
+
+ h = scm_i_get_conversion_strategy (port);
+ if (h == SCM_FAILED_CONVERSION_ERROR)
+ return scm_from_latin1_symbol ("error");
+ else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
+ return scm_from_latin1_symbol ("substitute");
+ else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ return scm_from_latin1_symbol ("escape");
+ else
+ abort ();
+
+ /* Never gets here. */
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
+ 2, 0, 0,
+ (SCM port, SCM sym),
+ "Sets the behavior of the interpreter when outputting a character\n"
+ "that is not representable in the port's current encoding.\n"
+ "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
+ "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
+ "when an unconvertible character is encountered. If it is\n"
+ "@code{'substitute}, then unconvertible characters will \n"
+ "be replaced with approximate characters, or with question marks\n"
+ "if no approximately correct character is available.\n"
+ "If it is @code{'escape},\n"
+ "it will appear as a hex escape when output.\n"
+ "\n"
+ "If @var{port} is an open port, the conversion error behavior\n"
+ "is set for that port. If it is @code{#f}, it is set as the\n"
+ "default behavior for any future ports that get created in\n"
+ "this thread.\n")
+#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+{
+ SCM err;
+ SCM qm;
+ SCM esc;
+
+ if (!scm_is_false (port))
+ {
+ SCM_VALIDATE_OPPORT (1, port);
+ }
+
+ err = scm_from_latin1_symbol ("error");
+ if (scm_is_true (scm_eqv_p (sym, err)))
+ {
+ scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
+ return SCM_UNSPECIFIED;
+ }
+
+ qm = scm_from_latin1_symbol ("substitute");
+ if (scm_is_true (scm_eqv_p (sym, qm)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ return SCM_UNSPECIFIED;
+ }
+
+ esc = scm_from_latin1_symbol ("escape");
+ if (scm_is_true (scm_eqv_p (sym, esc)))
+ {
+ scm_i_set_conversion_strategy_x (port,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ return SCM_UNSPECIFIED;
+ }
+
+ SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+\f
+
+/* The port lock. */
+
static void
-flush_output_port (void *closure, SCM port)
+lock_port (void *mutex)
{
- if (SCM_OPOUTPORTP (port))
- scm_flush (port);
+ scm_i_pthread_mutex_lock (mutex);
}
-SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
- (),
- "Equivalent to calling @code{force-output} on\n"
- "all open output ports. The return value is unspecified.")
-#define FUNC_NAME s_scm_flush_all_ports
+static void
+unlock_port (void *mutex)
{
- scm_c_port_for_each (&flush_output_port, NULL);
- return SCM_UNSPECIFIED;
+ scm_i_pthread_mutex_unlock (mutex);
+}
+
+void
+scm_dynwind_lock_port (SCM port)
+#define FUNC_NAME "dynwind-lock-port"
+{
+ scm_i_pthread_mutex_t *lock;
+ SCM_VALIDATE_OPPORT (SCM_ARG1, port);
+ scm_c_lock_port (port, &lock);
+ if (lock)
+ {
+ scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler (lock_port, lock, 0);
+ }
}
#undef FUNC_NAME
-SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
- (SCM port),
- "Return the next character available from @var{port}, updating\n"
- "@var{port} to point to the following character. If no more\n"
- "characters are available, the end-of-file object is returned.\n"
- "\n"
- "When @var{port}'s data cannot be decoded according to its\n"
- "character encoding, a @code{decoding-error} is raised and\n"
- "@var{port} points past the erroneous byte sequence.\n")
-#define FUNC_NAME s_scm_read_char
+
+\f
+
+/* Input. */
+
+int
+scm_get_byte_or_eof (SCM port)
{
- scm_t_wchar c;
- if (SCM_UNBNDP (port))
- port = scm_current_input_port ();
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_get_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
+}
+
+int
+scm_peek_byte_or_eof (SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_peek_byte_or_eof_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+ return ret;
+}
+
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+/* This structure, and the following swap_buffer function, are used
+ for temporarily swapping a port's own read buffer, and the buffer
+ that the caller of scm_c_read provides. */
+struct port_and_swap_buffer
+{
+ scm_t_port *pt;
+ unsigned char *buffer;
+ size_t size;
+};
+
+static void
+swap_buffer (void *data)
+{
+ struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
+ unsigned char *old_buf = psb->pt->read_buf;
+ size_t old_size = psb->pt->read_buf_size;
+
+ /* Make the port use (buffer, size) from the struct. */
+ psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
+ psb->pt->read_buf_size = psb->size;
+
+ /* Save the port's old (buffer, size) in the struct. */
+ psb->buffer = old_buf;
+ psb->size = old_size;
+}
+
+size_t
+scm_c_read_unlocked (SCM port, void *buffer, size_t size)
+#define FUNC_NAME "scm_c_read"
+{
+ scm_t_port *pt;
+ size_t n_read = 0, n_available;
+ struct port_and_swap_buffer psb;
+
SCM_VALIDATE_OPINPORT (1, port);
- c = scm_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- return SCM_MAKE_CHAR (c);
+
+ pt = SCM_PTAB_ENTRY (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ /* Take bytes first from the port's read buffer. */
+ if (pt->read_pos < pt->read_end)
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+
+ /* Avoid the scm_dynwind_* costs if we now have enough data. */
+ if (size == 0)
+ return n_read;
+
+ /* Now we will call scm_fill_input repeatedly until we have read the
+ requested number of bytes. (Note that a single scm_fill_input
+ call does not guarantee to fill the whole of the port's read
+ buffer.) */
+ if (pt->read_buf_size <= 1 && pt->encoding == NULL)
+ {
+ /* The port that we are reading from is unbuffered - i.e. does
+ not have its own persistent buffer - but we have a buffer,
+ provided by our caller, that is the right size for the data
+ that is wanted. For the following scm_fill_input calls,
+ therefore, we use the buffer in hand as the port's read
+ buffer.
+
+ We need to make sure that the port's normal (1 byte) buffer
+ is reinstated in case one of the scm_fill_input () calls
+ throws an exception; we use the scm_dynwind_* API to achieve
+ that.
+
+ A consequence of this optimization is that the fill_input
+ functions can't unget characters. That'll push data to the
+ pushback buffer instead of this psb buffer. */
+#if SCM_DEBUG == 1
+ unsigned char *pback = pt->putback_buf;
+#endif
+ psb.pt = pt;
+ psb.buffer = buffer;
+ psb.size = size;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+
+ /* Call scm_fill_input until we have all the bytes that we need,
+ or we hit EOF. */
+ while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
+ {
+ pt->read_buf_size -= (pt->read_end - pt->read_pos);
+ pt->read_pos = pt->read_buf = pt->read_end;
+ }
+#if SCM_DEBUG == 1
+ if (pback != pt->putback_buf
+ || pt->read_buf - (unsigned char *) buffer < 0)
+ scm_misc_error (FUNC_NAME,
+ "scm_c_read must not call a fill function that pushes "
+ "back characters onto an unbuffered port", SCM_EOL);
+#endif
+ n_read += pt->read_buf - (unsigned char *) buffer;
+
+ /* Reinstate the port's normal buffer. */
+ scm_dynwind_end ();
+ }
+ else
+ {
+ /* The port has its own buffer. It is important that we use it,
+ even if it happens to be smaller than our caller's buffer, so
+ that a custom port implementation's entry points (in
+ particular, fill_input) can rely on the buffer always being
+ the same as they first set up. */
+ while (size && (scm_fill_input_unlocked (port) != EOF))
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+ }
+
+ return n_read;
}
#undef FUNC_NAME
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
+{
+ scm_i_pthread_mutex_t *lock;
+ size_t ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_c_read_unlocked (port, buffer, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+
+ return ret;
+}
+
/* Update the line and column number of PORT after consumption of C. */
static inline void
update_port_lf (scm_t_wchar c, SCM port)
*len = 0;
pt = SCM_PTAB_ENTRY (port);
- byte = scm_get_byte_or_eof (port);
+ byte = scm_get_byte_or_eof_unlocked (port);
if (byte == EOF)
{
*codepoint = EOF;
else if (buf[0] >= 0xc2 && buf[0] <= 0xdf)
{
/* 2-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
else if ((buf[0] & 0xf0) == 0xe0)
{
/* 3-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80
buf[1] = (scm_t_uint8) byte;
*len = 2;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
else if (buf[0] >= 0xf0 && buf[0] <= 0xf4)
{
/* 4-byte form. */
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY (((byte & 0xc0) != 0x80)
buf[1] = (scm_t_uint8) byte;
*len = 2;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
buf[2] = (scm_t_uint8) byte;
*len = 3;
- byte = scm_peek_byte_or_eof (port);
+ byte = scm_peek_byte_or_eof_unlocked (port);
ASSERT_NOT_EOF (byte);
if (SCM_UNLIKELY ((byte & 0xc0) != 0x80))
get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
- scm_t_port *pt;
+ scm_t_iconv_descriptors *id;
int err, byte_read;
size_t bytes_consumed, output_size;
char *output;
scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
- pt = SCM_PTAB_ENTRY (port);
+ id = scm_i_port_iconv_descriptors (port);
for (output_size = 0, output = (char *) utf8_buf,
bytes_consumed = 0, err = 0;
char *input;
size_t input_left, output_left, done;
- byte_read = scm_get_byte_or_eof (port);
+ byte_read = scm_get_byte_or_eof_unlocked (port);
if (byte_read == EOF)
{
if (bytes_consumed == 0)
input_left = bytes_consumed + 1;
output_left = sizeof (utf8_buf);
- done = iconv (pt->input_cd, &input, &input_left,
- &output, &output_left);
+ done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
if (done == (size_t) -1)
{
err = errno;
*len = bytes_consumed;
}
- return err;
-}
-
-/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
- with the byte representation of the codepoint in PORT's encoding, and
- set *LEN to the length in bytes of that representation. Return 0 on
- success and an errno value on error. */
-static int
-get_codepoint (SCM port, scm_t_wchar *codepoint,
- char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
-{
- int err;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->input_cd == (iconv_t) -1)
- /* Initialize the conversion descriptors, if needed. */
- scm_i_set_port_encoding_x (port, pt->encoding);
-
- /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */
- if (pt->input_cd == (iconv_t) -1)
- err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
- else
- err = get_iconv_codepoint (port, codepoint, buf, len);
-
- if (SCM_LIKELY (err == 0))
- update_port_lf (*codepoint, port);
- else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
- {
- *codepoint = '?';
- err = 0;
- update_port_lf (*codepoint, port);
- }
-
- return err;
-}
-
-/* Read a codepoint from PORT and return it. */
-scm_t_wchar
-scm_getc (SCM port)
-#define FUNC_NAME "scm_getc"
-{
- int err;
- size_t len;
- scm_t_wchar codepoint;
- char buf[SCM_MBCHAR_BUF_SIZE];
-
- err = get_codepoint (port, &codepoint, buf, &len);
- if (SCM_UNLIKELY (err != 0))
- /* At this point PORT should point past the invalid encoding, as per
- R6RS-lib Section 8.2.4. */
- scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
-
- return codepoint;
-}
-#undef FUNC_NAME
-
-/* this should only be called when the read buffer is empty. it
- tries to refill the read buffer. it returns the first char from
- the port, which is either EOF or *(pt->read_pos). */
-int
-scm_fill_input (SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- assert (pt->read_pos == pt->read_end);
-
- if (pt->read_buf == pt->putback_buf)
- {
- /* finished reading put-back chars. */
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- if (pt->read_pos < pt->read_end)
- return *(pt->read_pos);
- }
- return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port);
-}
-
-
-/* scm_lfwrite
- *
- * This function differs from scm_c_write; it updates port line and
- * column. */
-
-void
-scm_lfwrite (const char *ptr, size_t size, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- ptob->write (port, ptr, size);
-
- for (; size; ptr++, size--)
- update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* Write STR to PORT from START inclusive to END exclusive. */
-void
-scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
-
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
-
- if (end == (size_t) -1)
- end = scm_i_string_length (str);
-
- scm_display (scm_c_substring (str, start, end), port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
-}
-
-/* scm_c_read
- *
- * Used by an application to read arbitrary number of bytes from an
- * SCM port. Same semantics as libc read, except that scm_c_read only
- * returns less than SIZE bytes if at end-of-file.
- *
- * Warning: Doesn't update port line and column counts! */
-
-/* This structure, and the following swap_buffer function, are used
- for temporarily swapping a port's own read buffer, and the buffer
- that the caller of scm_c_read provides. */
-struct port_and_swap_buffer
-{
- scm_t_port *pt;
- unsigned char *buffer;
- size_t size;
-};
-
-static void
-swap_buffer (void *data)
-{
- struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
- unsigned char *old_buf = psb->pt->read_buf;
- size_t old_size = psb->pt->read_buf_size;
-
- /* Make the port use (buffer, size) from the struct. */
- psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
- psb->pt->read_buf_size = psb->size;
-
- /* Save the port's old (buffer, size) in the struct. */
- psb->buffer = old_buf;
- psb->size = old_size;
-}
-
-size_t
-scm_c_read (SCM port, void *buffer, size_t size)
-#define FUNC_NAME "scm_c_read"
-{
- scm_t_port *pt;
- size_t n_read = 0, n_available;
- struct port_and_swap_buffer psb;
-
- SCM_VALIDATE_OPINPORT (1, port);
-
- pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- scm_ptobs[SCM_PTOBNUM (port)].flush (port);
-
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_READ;
-
- /* Take bytes first from the port's read buffer. */
- if (pt->read_pos < pt->read_end)
- {
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
- }
-
- /* Avoid the scm_dynwind_* costs if we now have enough data. */
- if (size == 0)
- return n_read;
-
- /* Now we will call scm_fill_input repeatedly until we have read the
- requested number of bytes. (Note that a single scm_fill_input
- call does not guarantee to fill the whole of the port's read
- buffer.) */
- if (pt->read_buf_size <= 1 && pt->encoding == NULL)
- {
- /* The port that we are reading from is unbuffered - i.e. does
- not have its own persistent buffer - but we have a buffer,
- provided by our caller, that is the right size for the data
- that is wanted. For the following scm_fill_input calls,
- therefore, we use the buffer in hand as the port's read
- buffer.
-
- We need to make sure that the port's normal (1 byte) buffer
- is reinstated in case one of the scm_fill_input () calls
- throws an exception; we use the scm_dynwind_* API to achieve
- that.
-
- A consequence of this optimization is that the fill_input
- functions can't unget characters. That'll push data to the
- pushback buffer instead of this psb buffer. */
-#if SCM_DEBUG == 1
- unsigned char *pback = pt->putback_buf;
-#endif
- psb.pt = pt;
- psb.buffer = buffer;
- psb.size = size;
- scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
- scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
- scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
-
- /* Call scm_fill_input until we have all the bytes that we need,
- or we hit EOF. */
- while (pt->read_buf_size && (scm_fill_input (port) != EOF))
- {
- pt->read_buf_size -= (pt->read_end - pt->read_pos);
- pt->read_pos = pt->read_buf = pt->read_end;
- }
-#if SCM_DEBUG == 1
- if (pback != pt->putback_buf
- || pt->read_buf - (unsigned char *) buffer < 0)
- scm_misc_error (FUNC_NAME,
- "scm_c_read must not call a fill function that pushes "
- "back characters onto an unbuffered port", SCM_EOL);
-#endif
- n_read += pt->read_buf - (unsigned char *) buffer;
-
- /* Reinstate the port's normal buffer. */
- scm_dynwind_end ();
- }
- else
- {
- /* The port has its own buffer. It is important that we use it,
- even if it happens to be smaller than our caller's buffer, so
- that a custom port implementation's entry points (in
- particular, fill_input) can rely on the buffer always being
- the same as they first set up. */
- while (size && (scm_fill_input (port) != EOF))
- {
- n_available = min (size, pt->read_end - pt->read_pos);
- memcpy (buffer, pt->read_pos, n_available);
- buffer = (char *) buffer + n_available;
- pt->read_pos += n_available;
- n_read += n_available;
- size -= n_available;
- }
- }
-
- return n_read;
-}
-#undef FUNC_NAME
-
-/* scm_c_write
- *
- * Used by an application to write arbitrary number of bytes to an SCM
- * port. Similar semantics as libc write. However, unlike libc
- * write, scm_c_write writes the requested number of bytes and has no
- * return value.
- *
- * Warning: Doesn't update port line and column counts!
- */
+ return err;
+}
-void
-scm_c_write (SCM port, const void *ptr, size_t size)
-#define FUNC_NAME "scm_c_write"
+/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF
+ with the byte representation of the codepoint in PORT's encoding, and
+ set *LEN to the length in bytes of that representation. Return 0 on
+ success and an errno value on error. */
+static int
+get_codepoint (SCM port, scm_t_wchar *codepoint,
+ char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
{
- scm_t_port *pt;
- scm_t_ptob_descriptor *ptob;
+ int err;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
- SCM_VALIDATE_OPOUTPORT (1, port);
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+ err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
+ else
+ err = get_iconv_codepoint (port, codepoint, buf, len);
- pt = SCM_PTAB_ENTRY (port);
- ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ if (SCM_LIKELY (err == 0))
+ update_port_lf (*codepoint, port);
+ else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
+ {
+ *codepoint = '?';
+ err = 0;
+ update_port_lf (*codepoint, port);
+ }
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ return err;
+}
- ptob->write (port, ptr, size);
+/* Read a codepoint from PORT and return it. */
+scm_t_wchar
+scm_getc_unlocked (SCM port)
+#define FUNC_NAME "scm_getc"
+{
+ int err;
+ size_t len;
+ scm_t_wchar codepoint;
+ char buf[SCM_MBCHAR_BUF_SIZE];
- if (pt->rw_random)
- pt->rw_active = SCM_PORT_WRITE;
+ err = get_codepoint (port, &codepoint, buf, &len);
+ if (SCM_UNLIKELY (err != 0))
+ /* At this point PORT should point past the invalid encoding, as per
+ R6RS-lib Section 8.2.4. */
+ scm_decoding_error (FUNC_NAME, err, "input decoding error", port);
+
+ return codepoint;
}
#undef FUNC_NAME
-void
-scm_flush (SCM port)
+scm_t_wchar
+scm_getc (SCM port)
{
- long i = SCM_PTOBNUM (port);
- assert (i >= 0);
- (scm_ptobs[i].flush) (port);
-}
+ scm_i_pthread_mutex_t *lock;
+ scm_t_wchar ret;
-void
-scm_end_input (SCM port)
-{
- long offset;
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_c_lock_port (port, &lock);
+ ret = scm_getc_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
- if (pt->read_buf == pt->putback_buf)
- {
- offset = pt->read_end - pt->read_pos;
- pt->read_buf = pt->saved_read_buf;
- pt->read_pos = pt->saved_read_pos;
- pt->read_end = pt->saved_read_end;
- pt->read_buf_size = pt->saved_read_buf_size;
- }
- else
- offset = 0;
+ return ret;
+}
- scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
+SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
+ (SCM port),
+ "Return the next character available from @var{port}, updating\n"
+ "@var{port} to point to the following character. If no more\n"
+ "characters are available, the end-of-file object is returned.\n"
+ "\n"
+ "When @var{port}'s data cannot be decoded according to its\n"
+ "character encoding, a @code{decoding-error} is raised and\n"
+ "@var{port} points past the erroneous byte sequence.\n")
+#define FUNC_NAME s_scm_read_char
+{
+ scm_t_wchar c;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+ c = scm_getc_unlocked (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ return SCM_MAKE_CHAR (c);
}
+#undef FUNC_NAME
+
\f
+/* Pushback. */
void
-scm_unget_byte (int c, SCM port)
+scm_unget_byte_unlocked (int c, SCM port)
#define FUNC_NAME "scm_unget_byte"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
}
#undef FUNC_NAME
+void
+scm_unget_byte (int c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_unget_byte_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
+
void
-scm_ungetc (scm_t_wchar c, SCM port)
+scm_ungetc_unlocked (scm_t_wchar c, SCM port)
#define FUNC_NAME "scm_ungetc"
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
encoding = "ISO-8859-1";
len = sizeof (result_buf);
+ scm_i_lock_iconv ();
result = u32_conv_to_encoding (encoding,
(enum iconv_ilseq_handler) pt->ilseq_handler,
(uint32_t *) &c, 1, NULL,
result_buf, &len);
+ scm_i_unlock_iconv ();
if (SCM_UNLIKELY (result == NULL || len == 0))
scm_encoding_error (FUNC_NAME, errno,
SCM_BOOL_F, SCM_MAKE_CHAR (c));
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (result[i], port);
+ scm_unget_byte_unlocked (result[i], port);
if (SCM_UNLIKELY (result != result_buf))
free (result);
}
#undef FUNC_NAME
+void
+scm_ungetc (scm_t_wchar c, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungetc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
void
-scm_ungets (const char *s, int n, SCM port)
+scm_ungets_unlocked (const char *s, int n, SCM port)
{
/* This is simple minded and inefficient, but unreading strings is
* probably not a common operation, and remember that line and
* Please feel free to write an optimized version!
*/
while (n--)
- scm_ungetc (s[n], port);
+ scm_ungetc_unlocked (s[n], port);
}
+void
+scm_ungets (const char *s, int n, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_ungets_unlocked (s, n, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
(SCM port),
err = get_codepoint (port, &c, bytes, &len);
for (i = len - 1; i >= 0; i--)
- scm_unget_byte (bytes[i], port);
+ scm_unget_byte_unlocked (bytes[i], port);
SCM_COL (port) = column;
SCM_LINUM (port) = line;
c = SCM_CHAR (cobj);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return cobj;
}
#undef FUNC_NAME
n = scm_i_string_length (str);
while (n--)
- scm_ungetc (scm_i_string_ref (str, n), port);
+ scm_ungetc_unlocked (scm_i_string_ref (str, n), port);
return str;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
- (SCM fd_port, SCM offset, SCM whence),
- "Sets the current position of @var{fd_port} to the integer\n"
- "@var{offset}, which is interpreted according to the value of\n"
- "@var{whence}.\n"
- "\n"
- "One of the following variables should be supplied for\n"
- "@var{whence}:\n"
- "@defvar SEEK_SET\n"
- "Seek from the beginning of the file.\n"
- "@end defvar\n"
- "@defvar SEEK_CUR\n"
- "Seek from the current position.\n"
- "@end defvar\n"
- "@defvar SEEK_END\n"
- "Seek from the end of the file.\n"
- "@end defvar\n"
- "If @var{fd_port} is a file descriptor, the underlying system\n"
- "call is @code{lseek}. @var{port} may be a string port.\n"
- "\n"
- "The value returned is the new position in the file. This means\n"
- "that the current position of a port can be obtained using:\n"
- "@lisp\n"
- "(seek port 0 SEEK_CUR)\n"
- "@end lisp")
-#define FUNC_NAME s_scm_seek
-{
- int how;
- fd_port = SCM_COERCE_OUTPORT (fd_port);
+\f
- how = scm_to_int (whence);
- if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
- SCM_OUT_OF_RANGE (3, whence);
+/* Manipulating the buffers. */
- if (SCM_OPPORTP (fd_port))
- {
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
+/* This routine does not take any locks, as it is usually called as part
+ of a port implementation. */
+void
+scm_port_non_buffer (scm_t_port *pt)
+{
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->read_buf_size = pt->write_buf_size = 1;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+}
- if (!ptob->seek)
- SCM_MISC_ERROR ("port is not seekable",
- scm_cons (fd_port, SCM_EOL));
- else
- rv = ptob->seek (fd_port, off, how);
- return scm_from_off_t_or_off64_t (rv);
- }
- else /* file descriptor?. */
+/* this should only be called when the read buffer is empty. it
+ tries to refill the read buffer. it returns the first char from
+ the port, which is either EOF or *(pt->read_pos). */
+int
+scm_fill_input_unlocked (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ assert (pt->read_pos == pt->read_end);
+
+ if (pt->read_buf == pt->putback_buf)
{
- off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
- off_t_or_off64_t rv;
- rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
- if (rv == -1)
- SCM_SYSERROR;
- return scm_from_off_t_or_off64_t (rv);
+ /* finished reading put-back chars. */
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ if (pt->read_pos < pt->read_end)
+ return *(pt->read_pos);
}
+ return SCM_PORT_DESCRIPTOR (port)->fill_input (port);
}
-#undef FUNC_NAME
-
-#ifndef O_BINARY
-#define O_BINARY 0
-#endif
-/* Mingw has ftruncate(), perhaps implemented above using chsize, but
- doesn't have the filename version truncate(), hence this code. */
-#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
-static int
-truncate (const char *file, off_t length)
+int
+scm_fill_input (SCM port)
{
- int ret, fdes;
+ scm_i_pthread_mutex_t *lock;
+ int ret;
+
+ scm_c_lock_port (port, &lock);
+ ret = scm_fill_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
- fdes = open (file, O_BINARY | O_WRONLY);
- if (fdes == -1)
- return -1;
+ return ret;
+}
- ret = ftruncate (fdes, length);
- if (ret == -1)
+/* move up to read_len chars from port's putback and/or read buffers
+ into memory starting at dest. returns the number of chars moved. */
+size_t
+scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t chars_read = 0;
+ size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
+
+ if (from_buf > 0)
{
- int save_errno = errno;
- close (fdes);
- errno = save_errno;
- return -1;
+ memcpy (dest, pt->read_pos, from_buf);
+ pt->read_pos += from_buf;
+ chars_read += from_buf;
+ read_len -= from_buf;
+ dest += from_buf;
}
- return close (fdes);
+ /* if putback was active, try the real input buffer too. */
+ if (pt->read_buf == pt->putback_buf)
+ {
+ from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->saved_read_pos, from_buf);
+ pt->saved_read_pos += from_buf;
+ chars_read += from_buf;
+ }
+ }
+ return chars_read;
}
-#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
- (SCM object, SCM length),
- "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
- "can be a filename string, a port object, or an integer file\n"
- "descriptor.\n"
- "The return value is unspecified.\n"
- "\n"
- "For a port or file descriptor @var{length} can be omitted, in\n"
- "which case the file is truncated at the current position (per\n"
- "@code{ftell} above).\n"
+/* Clear a port's read buffers, returning the contents. */
+SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
+ (SCM port),
+ "This procedure clears a port's input buffers, similar\n"
+ "to the way that force-output clears the output buffer. The\n"
+ "contents of the buffers are returned as a single string, e.g.,\n"
"\n"
- "On most systems a file can be extended by giving a length\n"
- "greater than the current size, but this is not mandatory in the\n"
- "POSIX standard.")
-#define FUNC_NAME s_scm_truncate_file
+ "@lisp\n"
+ "(define p (open-input-file ...))\n"
+ "(drain-input p) => empty string, nothing buffered yet.\n"
+ "(unread-char (read-char p) p)\n"
+ "(drain-input p) => initial chars from p, up to the buffer size.\n"
+ "@end lisp\n\n"
+ "Draining the buffers may be useful for cleanly finishing\n"
+ "buffered I/O so that the file descriptor can be used directly\n"
+ "for further input.")
+#define FUNC_NAME s_scm_drain_input
{
- int rv;
+ SCM result;
+ char *data;
+ scm_t_port *pt;
+ long count;
- /* "object" can be a port, fdes or filename.
+ SCM_VALIDATE_OPINPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
- Negative "length" makes no sense, but it's left to truncate() or
- ftruncate() to give back an error for that (normally EINVAL).
- */
+ count = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ count += pt->saved_read_end - pt->saved_read_pos;
- if (SCM_UNBNDP (length))
+ if (count)
{
- /* must supply length if object is a filename. */
- if (scm_is_string (object))
- SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
-
- length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
+ result = scm_i_make_string (count, &data, 0);
+ scm_take_from_input_buffers (port, data, count);
}
+ else
+ result = scm_nullstr;
+
+ return result;
+}
+#undef FUNC_NAME
- object = SCM_COERCE_OUTPORT (object);
- if (scm_is_integer (object))
- {
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
- c_length));
- }
- else if (SCM_OPOUTPORTP (object))
+void
+scm_end_input_unlocked (SCM port)
+{
+ long offset;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_buf == pt->putback_buf)
{
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- scm_t_port *pt = SCM_PTAB_ENTRY (object);
- scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
-
- if (!ptob->truncate)
- SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
- if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (object);
- else if (pt->rw_active == SCM_PORT_WRITE)
- ptob->flush (object);
-
- ptob->truncate (object, c_length);
- rv = 0;
+ offset = pt->read_end - pt->read_pos;
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
}
else
- {
- off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
- char *str = scm_to_locale_string (object);
- int eno;
- SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
- eno = errno;
- free (str);
- errno = eno;
- }
- if (rv == -1)
- SCM_SYSERROR;
- return SCM_UNSPECIFIED;
+ offset = 0;
+
+ SCM_PORT_DESCRIPTOR (port)->end_input (port, offset);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
- (SCM port),
- "Return the current line number for @var{port}.\n"
- "\n"
- "The first line of a file is 0. But you might want to add 1\n"
- "when printing line numbers, since starting from 1 is\n"
- "traditional in error messages, and likely to be more natural to\n"
- "non-programmers.")
-#define FUNC_NAME s_scm_port_line
+void
+scm_end_input (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_long (SCM_LINUM (port));
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_end_input_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
- (SCM port, SCM line),
- "Set the current line number for @var{port} to @var{line}. The\n"
- "first line of a file is 0.")
-#define FUNC_NAME s_scm_set_port_line_x
+SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
+ (SCM port),
+ "Flush the specified output port, or the current output port if @var{port}\n"
+ "is omitted. The current output buffer contents are passed to the\n"
+ "underlying port implementation (e.g., in the case of fports, the\n"
+ "data will be written to the file and the output buffer will be cleared.)\n"
+ "It has no effect on an unbuffered port.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_force_output
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+ else
+ {
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ }
+ scm_flush_unlocked (port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
- (SCM port),
- "Return the current column number of @var{port}.\n"
- "If the number is\n"
- "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
- "- i.e. the first character of the first line is line 0, column 0.\n"
- "(However, when you display a file position, for example in an error\n"
- "message, we recommend you add 1 to get 1-origin integers. This is\n"
- "because lines and column numbers traditionally start with 1, and that is\n"
- "what non-programmers will find most natural.)")
-#define FUNC_NAME s_scm_port_column
+void
+scm_flush_unlocked (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return scm_from_int (SCM_COL (port));
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
- (SCM port, SCM column),
- "Set the current column of @var{port}. Before reading the first\n"
- "character on a line the column should be 0.")
-#define FUNC_NAME s_scm_set_port_column_x
+void
+scm_flush (SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
- return SCM_UNSPECIFIED;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_flush_unlocked (port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
- (SCM port),
- "Return the filename associated with @var{port}, or @code{#f}\n"
- "if no filename is associated with the port.")
-#define FUNC_NAME s_scm_port_filename
+
+\f
+
+/* Output. */
+
+void
+scm_putc (char c, SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- return SCM_FILENAME (port);
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_putc_unlocked (c, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
- (SCM port, SCM filename),
- "Change the filename associated with @var{port}, using the current input\n"
- "port if none is specified. Note that this does not change the port's\n"
- "source of data, but only the value that is returned by\n"
- "@code{port-filename} and reported in diagnostic output.")
-#define FUNC_NAME s_scm_set_port_filename_x
+void
+scm_puts (const char *s, SCM port)
{
- port = SCM_COERCE_OUTPORT (port);
- SCM_VALIDATE_OPENPORT (1, port);
- /* We allow the user to set the filename to whatever he likes. */
- SCM_SET_FILENAME (port, filename);
- return SCM_UNSPECIFIED;
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_puts_unlocked (s, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
-#undef FUNC_NAME
+
+/* scm_c_write
+ *
+ * Used by an application to write arbitrary number of bytes to an SCM
+ * port. Similar semantics as libc write. However, unlike libc
+ * write, scm_c_write writes the requested number of bytes and has no
+ * return value.
+ *
+ * Warning: Doesn't update port line and column counts!
+ */
+void
+scm_c_write_unlocked (SCM port, const void *ptr, size_t size)
+#define FUNC_NAME "scm_c_write"
+{
+ scm_t_port *pt;
+ scm_t_ptob_descriptor *ptob;
-/* A fluid specifying the default encoding for newly created ports. If it is
- a string, that is the encoding. If it is #f, it is in the "native"
- (Latin-1) encoding. */
-SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
+ SCM_VALIDATE_OPOUTPORT (1, port);
-static int scm_port_encoding_init = 0;
+ pt = SCM_PTAB_ENTRY (port);
+ ptob = SCM_PORT_DESCRIPTOR (port);
-/* Use ENCODING as the default encoding for future ports. */
-void
-scm_i_set_default_port_encoding (const char *encoding)
-{
- if (!scm_port_encoding_init
- || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized",
- SCM_EOL);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- if (encoding == NULL
- || !strcmp (encoding, "ASCII")
- || !strcmp (encoding, "ANSI_X3.4-1968")
- || !strcmp (encoding, "ISO-8859-1"))
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
- else
- scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var),
- scm_from_locale_string (encoding));
+ ptob->write (port, ptr, size);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
+#undef FUNC_NAME
-/* Return the name of the default encoding for newly created ports; a
- return value of NULL means "ISO-8859-1". */
-const char *
-scm_i_default_port_encoding (void)
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
{
- if (!scm_port_encoding_init)
- return NULL;
- else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
- return NULL;
- else
- {
- SCM encoding;
-
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
- if (!scm_is_string (encoding))
- return NULL;
- else
- return scm_i_string_chars (encoding);
- }
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_c_write_unlocked (port, ptr, size);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
}
+/* scm_lfwrite
+ *
+ * This function differs from scm_c_write; it updates port line and
+ * column. */
void
-scm_i_set_port_encoding_x (SCM port, const char *encoding)
+scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port)
{
- scm_t_port *pt;
- iconv_t new_input_cd, new_output_cd;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
- new_input_cd = (iconv_t) -1;
- new_output_cd = (iconv_t) -1;
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
+ ptob->write (port, ptr, size);
- if (encoding == NULL)
- encoding = "ISO-8859-1";
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
- if (pt->encoding != encoding)
- pt->encoding = scm_gc_strdup (encoding, "port");
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
- /* If ENCODING is UTF-8, then no conversion descriptor is opened
- because we do I/O ourselves. This saves 100+ KiB for each
- descriptor. */
- if (strcmp (encoding, "UTF-8"))
- {
- if (SCM_CELL_WORD_0 (port) & SCM_RDNG)
- {
- /* Open an input iconv conversion descriptor, from ENCODING
- to UTF-8. We choose UTF-8, not UTF-32, because iconv
- implementations can typically convert from anything to
- UTF-8, but not to UTF-32 (see
- <http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html>). */
- new_input_cd = iconv_open ("UTF-8", encoding);
- if (new_input_cd == (iconv_t) -1)
- goto invalid_encoding;
- }
+void
+scm_lfwrite (const char *ptr, size_t size, SCM port)
+{
+ scm_i_pthread_mutex_t *lock;
+ scm_c_lock_port (port, &lock);
+ scm_lfwrite_unlocked (ptr, size, port);
+ if (lock)
+ scm_i_pthread_mutex_unlock (lock);
+
+}
- if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
- {
- new_output_cd = iconv_open (encoding, "UTF-8");
- if (new_output_cd == (iconv_t) -1)
- {
- if (new_input_cd != (iconv_t) -1)
- iconv_close (new_input_cd);
- goto invalid_encoding;
- }
- }
- }
+/* Write STR to PORT from START inclusive to END exclusive. */
+void
+scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->input_cd != (iconv_t) -1)
- iconv_close (pt->input_cd);
- if (pt->output_cd != (iconv_t) -1)
- iconv_close (pt->output_cd);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (port);
- pt->input_cd = new_input_cd;
- pt->output_cd = new_output_cd;
+ if (end == (size_t) -1)
+ end = scm_i_string_length (str);
- return;
+ scm_display (scm_c_substring (str, start, end), port);
- invalid_encoding:
- {
- SCM err;
- err = scm_from_locale_string (encoding);
- scm_misc_error ("scm_i_set_port_encoding_x",
- "invalid or unknown character encoding ~s",
- scm_list_1 (err));
- }
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
-SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0,
+
+\f
+
+/* Querying and setting positions, and character availability. */
+
+SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
(SCM port),
- "Returns, as a string, the character encoding that @var{port}\n"
- "uses to interpret its input and output.\n")
-#define FUNC_NAME s_scm_port_encoding
+ "Return @code{#t} if a character is ready on input @var{port}\n"
+ "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
+ "@code{#t} then the next @code{read-char} operation on\n"
+ "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
+ "port at end of file then @code{char-ready?} returns @code{#t}.\n"
+ "\n"
+ "@code{char-ready?} exists to make it possible for a\n"
+ "program to accept characters from interactive ports without\n"
+ "getting stuck waiting for input. Any input editors associated\n"
+ "with such ports must make sure that characters whose existence\n"
+ "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
+ "If @code{char-ready?} were to return @code{#f} at end of file,\n"
+ "a port at end of file would be indistinguishable from an\n"
+ "interactive port that has no ready characters.")
+#define FUNC_NAME s_scm_char_ready_p
{
scm_t_port *pt;
- const char *enc;
- SCM_VALIDATE_PORT (1, port);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ /* It's possible to close the current input port, so validate even in
+ this case. */
+ SCM_VALIDATE_OPINPORT (1, port);
pt = SCM_PTAB_ENTRY (port);
- enc = pt->encoding;
- if (enc)
- return scm_from_locale_string (pt->encoding);
+
+ /* if the current read buffer is filled, or the
+ last pushed-back char has been read and the saved buffer is
+ filled, result is true. */
+ if (pt->read_pos < pt->read_end
+ || (pt->read_buf == pt->putback_buf
+ && pt->saved_read_pos < pt->saved_read_end))
+ return SCM_BOOL_T;
else
- return SCM_BOOL_F;
+ {
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port);
+
+ if (ptob->input_waiting)
+ return scm_from_bool(ptob->input_waiting (port));
+ else
+ return SCM_BOOL_T;
+ }
}
#undef FUNC_NAME
-SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0,
- (SCM port, SCM enc),
- "Sets the character encoding that will be used to interpret all\n"
- "port I/O. New ports are created with the encoding\n"
- "appropriate for the current locale if @code{setlocale} has \n"
- "been called or ISO-8859-1 otherwise\n"
- "and this procedure can be used to modify that encoding.\n")
-#define FUNC_NAME s_scm_set_port_encoding_x
+SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
+ (SCM fd_port, SCM offset, SCM whence),
+ "Sets the current position of @var{fd_port} to the integer\n"
+ "@var{offset}, which is interpreted according to the value of\n"
+ "@var{whence}.\n"
+ "\n"
+ "One of the following variables should be supplied for\n"
+ "@var{whence}:\n"
+ "@defvar SEEK_SET\n"
+ "Seek from the beginning of the file.\n"
+ "@end defvar\n"
+ "@defvar SEEK_CUR\n"
+ "Seek from the current position.\n"
+ "@end defvar\n"
+ "@defvar SEEK_END\n"
+ "Seek from the end of the file.\n"
+ "@end defvar\n"
+ "If @var{fd_port} is a file descriptor, the underlying system\n"
+ "call is @code{lseek}. @var{port} may be a string port.\n"
+ "\n"
+ "The value returned is the new position in the file. This means\n"
+ "that the current position of a port can be obtained using:\n"
+ "@lisp\n"
+ "(seek port 0 SEEK_CUR)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_seek
{
- char *enc_str;
-
- SCM_VALIDATE_PORT (1, port);
- SCM_VALIDATE_STRING (2, enc);
-
- enc_str = scm_to_locale_string (enc);
- scm_i_set_port_encoding_x (port, enc_str);
- free (enc_str);
-
- return SCM_UNSPECIFIED;
-}
-#undef FUNC_NAME
+ int how;
+ fd_port = SCM_COERCE_OUTPORT (fd_port);
-/* This determines how conversions handle unconvertible characters. */
-SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy");
-static int scm_conversion_strategy_init = 0;
+ how = scm_to_int (whence);
+ if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
+ SCM_OUT_OF_RANGE (3, whence);
-scm_t_string_failed_conversion_handler
-scm_i_get_conversion_strategy (SCM port)
-{
- SCM encoding;
-
- if (scm_is_false (port))
+ if (SCM_OPPORTP (fd_port))
{
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+
+ if (!ptob->seek)
+ SCM_MISC_ERROR ("port is not seekable",
+ scm_cons (fd_port, SCM_EOL));
else
- {
- encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy));
- if (scm_is_false (encoding))
- return SCM_FAILED_CONVERSION_QUESTION_MARK;
- else
- return (scm_t_string_failed_conversion_handler) scm_to_int (encoding);
- }
+ rv = ptob->seek (fd_port, off, how);
+ return scm_from_off_t_or_off64_t (rv);
}
- else
+ else /* file descriptor?. */
{
- scm_t_port *pt;
- pt = SCM_PTAB_ENTRY (port);
- return pt->ilseq_handler;
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_from_off_t_or_off64_t (rv);
}
-
}
+#undef FUNC_NAME
-void
-scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler handler)
-{
- SCM strategy;
- scm_t_port *pt;
-
- strategy = scm_from_int ((int) handler);
-
- if (scm_is_false (port))
- {
- /* Set the default encoding for future ports. */
- if (!scm_conversion_strategy_init
- || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy)))
- scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
- SCM_EOL);
- scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy);
- }
- else
- {
- /* Set the character encoding for this port. */
- pt = SCM_PTAB_ENTRY (port);
- pt->ilseq_handler = handler;
- }
-}
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
-SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy",
- 1, 0, 0, (SCM port),
- "Returns the behavior of the port when handling a character that\n"
- "is not representable in the port's current encoding.\n"
- "It returns the symbol @code{error} if unrepresentable characters\n"
- "should cause exceptions, @code{substitute} if the port should\n"
- "try to replace unrepresentable characters with question marks or\n"
- "approximate characters, or @code{escape} if unrepresentable\n"
- "characters should be converted to string escapes.\n"
- "\n"
- "If @var{port} is @code{#f}, then the current default behavior\n"
- "will be returned. New ports will have this default behavior\n"
- "when they are created.\n")
-#define FUNC_NAME s_scm_port_conversion_strategy
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
{
- scm_t_string_failed_conversion_handler h;
+ int ret, fdes;
- SCM_VALIDATE_OPPORT (1, port);
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
- if (!scm_is_false (port))
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
{
- SCM_VALIDATE_OPPORT (1, port);
- }
-
- h = scm_i_get_conversion_strategy (port);
- if (h == SCM_FAILED_CONVERSION_ERROR)
- return scm_from_latin1_symbol ("error");
- else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK)
- return scm_from_latin1_symbol ("substitute");
- else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
- return scm_from_latin1_symbol ("escape");
- else
- abort ();
+ int save_errno = errno;
+ close (fdes);
+ errno = save_errno;
+ return -1;
+ }
- /* Never gets here. */
- return SCM_UNDEFINED;
+ return close (fdes);
}
-#undef FUNC_NAME
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
-SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!",
- 2, 0, 0,
- (SCM port, SCM sym),
- "Sets the behavior of the interpreter when outputting a character\n"
- "that is not representable in the port's current encoding.\n"
- "@var{sym} can be either @code{'error}, @code{'substitute}, or\n"
- "@code{'escape}. If it is @code{'error}, an error will be thrown\n"
- "when an unconvertible character is encountered. If it is\n"
- "@code{'substitute}, then unconvertible characters will \n"
- "be replaced with approximate characters, or with question marks\n"
- "if no approximately correct character is available.\n"
- "If it is @code{'escape},\n"
- "it will appear as a hex escape when output.\n"
+SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
+ (SCM object, SCM length),
+ "Truncate file @var{object} to @var{length} bytes. @var{object}\n"
+ "can be a filename string, a port object, or an integer file\n"
+ "descriptor.\n"
+ "The return value is unspecified.\n"
"\n"
- "If @var{port} is an open port, the conversion error behavior\n"
- "is set for that port. If it is @code{#f}, it is set as the\n"
- "default behavior for any future ports that get created in\n"
- "this thread.\n")
-#define FUNC_NAME s_scm_set_port_conversion_strategy_x
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
+#define FUNC_NAME s_scm_truncate_file
{
- SCM err;
- SCM qm;
- SCM esc;
+ int rv;
- if (!scm_is_false (port))
+ /* "object" can be a port, fdes or filename.
+
+ Negative "length" makes no sense, but it's left to truncate() or
+ ftruncate() to give back an error for that (normally EINVAL).
+ */
+
+ if (SCM_UNBNDP (length))
{
- SCM_VALIDATE_OPPORT (1, port);
+ /* must supply length if object is a filename. */
+ if (scm_is_string (object))
+ SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
+
+ length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
}
- err = scm_from_latin1_symbol ("error");
- if (scm_is_true (scm_eqv_p (sym, err)))
+ object = SCM_COERCE_OUTPORT (object);
+ if (scm_is_integer (object))
{
- scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR);
- return SCM_UNSPECIFIED;
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
+ c_length));
}
-
- qm = scm_from_latin1_symbol ("substitute");
- if (scm_is_true (scm_eqv_p (sym, qm)))
+ else if (SCM_OPOUTPORTP (object))
{
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_QUESTION_MARK);
- return SCM_UNSPECIFIED;
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ scm_t_port *pt = SCM_PTAB_ENTRY (object);
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
+
+ if (!ptob->truncate)
+ SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input_unlocked (object);
+ else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (object);
+
+ ptob->truncate (object, c_length);
+ rv = 0;
}
-
- esc = scm_from_latin1_symbol ("escape");
- if (scm_is_true (scm_eqv_p (sym, esc)))
+ else
{
- scm_i_set_conversion_strategy_x (port,
- SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
- return SCM_UNSPECIFIED;
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ char *str = scm_to_locale_string (object);
+ int eno;
+ SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
+ eno = errno;
+ free (str);
+ errno = eno;
}
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
- SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym));
+SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
+ (SCM port),
+ "Return the current line number for @var{port}.\n"
+ "\n"
+ "The first line of a file is 0. But you might want to add 1\n"
+ "when printing line numbers, since starting from 1 is\n"
+ "traditional in error messages, and likely to be more natural to\n"
+ "non-programmers.")
+#define FUNC_NAME s_scm_port_line
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_long (SCM_LINUM (port));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
+ (SCM port, SCM line),
+ "Set the current line number for @var{port} to @var{line}. The\n"
+ "first line of a file is 0.")
+#define FUNC_NAME s_scm_set_port_line_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
+ (SCM port),
+ "Return the current column number of @var{port}.\n"
+ "If the number is\n"
+ "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
+ "- i.e. the first character of the first line is line 0, column 0.\n"
+ "(However, when you display a file position, for example in an error\n"
+ "message, we recommend you add 1 to get 1-origin integers. This is\n"
+ "because lines and column numbers traditionally start with 1, and that is\n"
+ "what non-programmers will find most natural.)")
+#define FUNC_NAME s_scm_port_column
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (SCM_COL (port));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
+ (SCM port, SCM column),
+ "Set the current column of @var{port}. Before reading the first\n"
+ "character on a line the column should be 0.")
+#define FUNC_NAME s_scm_set_port_column_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
+ (SCM port),
+ "Return the filename associated with @var{port}, or @code{#f}\n"
+ "if no filename is associated with the port.")
+#define FUNC_NAME s_scm_port_filename
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return SCM_FILENAME (port);
+}
+#undef FUNC_NAME
+SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
+ (SCM port, SCM filename),
+ "Change the filename associated with @var{port}, using the current input\n"
+ "port if none is specified. Note that this does not change the port's\n"
+ "source of data, but only the value that is returned by\n"
+ "@code{port-filename} and reported in diagnostic output.")
+#define FUNC_NAME s_scm_set_port_filename_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ /* We allow the user to set the filename to whatever he likes. */
+ SCM_SET_FILENAME (port, filename);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
+\f
+
+/* Implementation helpers for port printing functions. */
void
scm_print_port_mode (SCM exp, SCM port)
{
- scm_puts (SCM_CLOSEDP (exp)
+ scm_puts_unlocked (SCM_CLOSEDP (exp)
? "closed: "
: (SCM_RDNG & SCM_CELL_WORD_0 (exp)
? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
if (!type)
type = "port";
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
scm_print_port_mode (exp, port);
- scm_puts (type, port);
- scm_putc (' ', port);
+ scm_puts_unlocked (type, port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
+
+\f
+
+/* Iterating over all ports. */
+
+struct for_each_data
+{
+ void (*proc) (void *data, SCM p);
+ void *data;
+};
+
+static SCM
+for_each_trampoline (void *data, SCM port, SCM result)
+{
+ struct for_each_data *d = data;
+
+ d->proc (d->data, port);
+
+ return result;
+}
+
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+{
+ struct for_each_data d;
+
+ d.proc = proc;
+ d.data = data;
+
+ scm_c_weak_set_fold (for_each_trampoline, &d, SCM_EOL,
+ scm_i_port_weak_set);
+}
+
+static void
+scm_for_each_trampoline (void *data, SCM port)
+{
+ scm_call_1 (SCM_PACK_POINTER (data), port);
+}
+
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @code{port-for-each} is invoked.\n"
+ "Changes to the port table while @code{port-for-each} is running\n"
+ "have no effect as far as @code{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_port_for_each (scm_for_each_trampoline, SCM_UNPACK_POINTER (proc));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+flush_output_port (void *closure, SCM port)
+{
+ if (SCM_OPOUTPORTP (port))
+ scm_flush_unlocked (port);
+}
+
+SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
+ (),
+ "Equivalent to calling @code{force-output} on\n"
+ "all open output ports. The return value is unspecified.")
+#define FUNC_NAME s_scm_flush_all_ports
+{
+ scm_c_port_for_each (&flush_output_port, NULL);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
\f
/* Void ports. */
static SCM
scm_i_void_port (long mode_bits)
{
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- {
- SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
- scm_t_port * pt = SCM_PTAB_ENTRY(answer);
+ SCM ret;
- scm_port_non_buffer (pt);
+ ret = scm_c_make_port (scm_tc16_void_port, mode_bits, 0);
+
+ scm_port_non_buffer (SCM_PTAB_ENTRY (ret));
- SCM_SETSTREAM (answer, 0);
- SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
- return answer;
- }
+ return ret;
}
SCM
}
#undef FUNC_NAME
+
\f
+
/* Initialization. */
void
cur_errport_fluid = scm_make_fluid ();
cur_loadport_fluid = scm_make_fluid ();
- scm_i_port_weak_hash = scm_make_weak_key_hash_table (SCM_I_MAKINUM(31));
+ scm_i_port_weak_set = scm_c_make_weak_set (31);
#include "libguile/ports.x"
#define SCM_PORTS_H
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- * 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ * 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
+#include <stdio.h>
+#include <string.h>
#include <unistd.h>
+#include "libguile/gc.h"
+#include "libguile/tags.h"
+#include "libguile/error.h"
#include "libguile/print.h"
#include "libguile/struct.h"
#include "libguile/threads.h"
SCM_PORT_WRITE = 2
} scm_t_port_rw_active;
+typedef enum scm_t_port_encoding_mode {
+ SCM_PORT_ENCODING_MODE_UTF8,
+ SCM_PORT_ENCODING_MODE_ICONV
+} scm_t_port_encoding_mode;
+
+/* This is a separate object so that only those ports that use iconv
+ cause finalizers to be registered. */
+typedef struct scm_t_iconv_descriptors
+{
+ /* input/output iconv conversion descriptors */
+ void *input_cd;
+ void *output_cd;
+} scm_t_iconv_descriptors;
+
/* C representation of a Scheme port. */
typedef struct
{
SCM port; /* Link back to the port object. */
- int revealed; /* 0 not revealed, > 1 revealed.
- * Revealed ports do not get GC'd.
- */
+ scm_i_pthread_mutex_t *lock; /* A recursive lock for this port. */
+
/* data for the underlying port implementation as a raw C value. */
scm_t_bits stream;
long line_number; /* debugging support. */
int column_number; /* debugging support. */
- /* Character encoding support */
- char *encoding;
- scm_t_string_failed_conversion_handler ilseq_handler;
-
/* port buffers. the buffer(s) are set up for all ports.
in the case of string ports, the buffer is the string itself.
in the case of unbuffered file ports, the buffer is a
unsigned char *putback_buf;
size_t putback_buf_size; /* allocated size of putback_buf. */
- /* input/output iconv conversion descriptors */
- void *input_cd;
- void *output_cd;
+ /* Character encoding support */
+ char *encoding;
+ scm_t_port_encoding_mode encoding_mode;
+ scm_t_string_failed_conversion_handler ilseq_handler;
+ scm_t_iconv_descriptors *iconv_descriptors;
} scm_t_port;
-SCM_INTERNAL scm_i_pthread_mutex_t scm_i_port_table_mutex;
-SCM_INTERNAL SCM scm_i_port_weak_hash;
+SCM_INTERNAL SCM scm_i_port_weak_set;
#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */
#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
-#define SCM_PORTP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_port))
-#define SCM_OPPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN)))
-#define SCM_OPINPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
-#define SCM_OPOUTPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
-#define SCM_INPUT_PORT_P(x) \
- (!SCM_IMP(x) \
- && (((0x7f | SCM_RDNG) & SCM_CELL_WORD_0(x)) == (scm_tc7_port | SCM_RDNG)))
-#define SCM_OUTPUT_PORT_P(x) \
- (!SCM_IMP(x) \
- && (((0x7f | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_WRTNG)))
-#define SCM_OPENP(x) (!SCM_IMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x)))
-#define SCM_CLOSEDP(x) (!SCM_OPENP(x))
+#define SCM_PORTP(x) (SCM_HAS_TYP7 (x, scm_tc7_port))
+#define SCM_OPPORTP(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
+#define SCM_INPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
+#define SCM_OUTPUT_PORT_P(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
+#define SCM_OPINPORTP(x) (SCM_OPPORTP (x) && SCM_INPUT_PORT_P (x))
+#define SCM_OPOUTPORTP(x) (SCM_OPPORTP (x) && SCM_OUTPUT_PORT_P (x))
+#define SCM_OPENP(x) (SCM_OPPORTP (x))
+#define SCM_CLOSEDP(x) (!SCM_OPENP (x))
#define SCM_CLR_PORT_OPEN_FLAG(p) \
SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN)
#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_1 (x))
+#define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_2 (port))
#define SCM_SETPTAB_ENTRY(x, ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent)))
#define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream)
#define SCM_SETSTREAM(x, s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s))
#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n))
#define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number)
#define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number)
-#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
-#define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s))
#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0)
#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0)
\f
+typedef enum scm_t_port_type_flags {
+ SCM_PORT_TYPE_HAS_FLUSH = 1 << 0
+} scm_t_port_type_flags;
+
/* port-type description. */
typedef struct scm_t_ptob_descriptor
{
scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE);
void (*truncate) (SCM port, scm_t_off length);
+ unsigned flags;
} scm_t_ptob_descriptor;
#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8))
#define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x)))
/* SCM_PTOBNAME can be 0 if name is missing */
-#define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name
-
-\f
+#define SCM_PTOBNAME(ptobnum) (scm_c_port_type_ref (ptobnum)->name)
-/* Hey you! Yes you, reading the header file! We're going to deprecate
- scm_ptobs in 2.2, so please don't write any new code that uses it.
- Thanks. */
-SCM_API scm_t_ptob_descriptor *scm_ptobs;
-SCM_API long scm_numptob;
-
-\f
-
-SCM_API SCM scm_markstream (SCM ptr);
+/* Port types, and their vtables. */
+SCM_INTERNAL long scm_c_num_port_types (void);
+SCM_API scm_t_ptob_descriptor* scm_c_port_type_ref (long ptobnum);
+SCM_API long scm_c_port_type_add_x (scm_t_ptob_descriptor *desc);
SCM_API scm_t_bits scm_make_port_type (char *name,
int (*fill_input) (SCM port),
void (*write) (SCM port,
SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM));
SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM));
-SCM_API void scm_set_port_flush (scm_t_bits tc,
- void (*flush) (SCM port));
+SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port));
SCM_API void scm_set_port_end_input (scm_t_bits tc,
- void (*end_input) (SCM port,
- int offset));
+ void (*end_input) (SCM port,
+ int offset));
SCM_API void scm_set_port_seek (scm_t_bits tc,
scm_t_off (*seek) (SCM port,
scm_t_off OFFSET,
void (*truncate) (SCM port,
scm_t_off length));
SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM));
-SCM_API SCM scm_char_ready_p (SCM port);
-size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
-SCM_API SCM scm_drain_input (SCM port);
+
+/* The input, output, error, and load ports. */
SCM_API SCM scm_current_input_port (void);
SCM_API SCM scm_current_output_port (void);
SCM_API SCM scm_current_error_port (void);
SCM_API void scm_dynwind_current_input_port (SCM port);
SCM_API void scm_dynwind_current_output_port (SCM port);
SCM_API void scm_dynwind_current_error_port (SCM port);
-SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
-SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
-SCM_API SCM scm_pt_size (void);
-SCM_API SCM scm_pt_member (SCM member);
-SCM_API void scm_port_non_buffer (scm_t_port *pt);
-SCM_API int scm_revealed_count (SCM port);
-SCM_API SCM scm_port_revealed (SCM port);
-SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port);
+
+/* Mode bits. */
+SCM_INTERNAL long scm_i_mode_bits (SCM modes);
SCM_API long scm_mode_bits (char *modes);
SCM_API SCM scm_port_mode (SCM port);
-SCM_API SCM scm_close_input_port (SCM port);
-SCM_API SCM scm_close_output_port (SCM port);
-SCM_API SCM scm_close_port (SCM port);
-SCM_API SCM scm_port_for_each (SCM proc);
-SCM_API void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data);
+
+/* Low-level constructors. */
+SCM_API SCM
+scm_c_make_port_with_encoding (scm_t_bits tag,
+ unsigned long mode_bits,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler handler,
+ scm_t_bits stream);
+SCM_API SCM scm_c_make_port (scm_t_bits tag, unsigned long mode_bits,
+ scm_t_bits stream);
+SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
+
+/* Predicates. */
+SCM_API SCM scm_port_p (SCM x);
SCM_API SCM scm_input_port_p (SCM x);
SCM_API SCM scm_output_port_p (SCM x);
-SCM_API SCM scm_port_p (SCM x);
SCM_API SCM scm_port_closed_p (SCM port);
SCM_API SCM scm_eof_object_p (SCM x);
-SCM_API SCM scm_force_output (SCM port);
-SCM_API SCM scm_flush_all_ports (void);
-SCM_API SCM scm_read_char (SCM port);
-SCM_API scm_t_wchar scm_getc (SCM port);
+
+/* Closing ports. */
+SCM_API SCM scm_close_port (SCM port);
+SCM_API SCM scm_close_input_port (SCM port);
+SCM_API SCM scm_close_output_port (SCM port);
+
+/* Encoding characters to byte streams, and decoding byte streams to
+ characters. */
+SCM_INTERNAL const char *scm_i_default_port_encoding (void);
+SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
+SCM_INTERNAL scm_t_iconv_descriptors *scm_i_port_iconv_descriptors (SCM port);
+SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
+SCM_API SCM scm_port_encoding (SCM port);
+SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
+SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port);
+SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
+ scm_t_string_failed_conversion_handler h);
+SCM_API SCM scm_port_conversion_strategy (SCM port);
+SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
+
+/* Acquiring and releasing the port lock. */
+SCM_API void scm_dynwind_lock_port (SCM port);
+SCM_INLINE int scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock);
+SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock);
+
+/* Input. */
+SCM_API int scm_get_byte_or_eof (SCM port);
+SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_peek_byte_or_eof (SCM port);
+SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
-SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
-SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
-SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
- SCM port);
-SCM_API void scm_flush (SCM port);
-SCM_API void scm_end_input (SCM port);
-SCM_API int scm_fill_input (SCM port);
+SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size);
+SCM_API scm_t_wchar scm_getc (SCM port);
+SCM_API scm_t_wchar scm_getc_unlocked (SCM port);
+SCM_API SCM scm_read_char (SCM port);
+
+/* Pushback. */
SCM_INTERNAL void scm_unget_byte (int c, SCM port);
+SCM_INTERNAL void scm_unget_byte_unlocked (int c, SCM port);
SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
+SCM_API void scm_ungetc_unlocked (scm_t_wchar c, SCM port);
SCM_API void scm_ungets (const char *s, int n, SCM port);
+SCM_API void scm_ungets_unlocked (const char *s, int n, SCM port);
SCM_API SCM scm_peek_char (SCM port);
SCM_API SCM scm_unread_char (SCM cobj, SCM port);
SCM_API SCM scm_unread_string (SCM str, SCM port);
+
+/* Manipulating the buffers. */
+SCM_API void scm_port_non_buffer (scm_t_port *pt);
+SCM_API int scm_fill_input (SCM port);
+SCM_API int scm_fill_input_unlocked (SCM port);
+SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
+SCM_API SCM scm_drain_input (SCM port);
+SCM_API void scm_end_input (SCM port);
+SCM_API void scm_end_input_unlocked (SCM port);
+SCM_API SCM scm_force_output (SCM port);
+SCM_API void scm_flush (SCM port);
+SCM_API void scm_flush_unlocked (SCM port);
+
+/* Output. */
+SCM_API void scm_putc (char c, SCM port);
+SCM_INLINE void scm_putc_unlocked (char c, SCM port);
+SCM_API void scm_puts (const char *str_data, SCM port);
+SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port);
+SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
+SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size);
+SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port);
+SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
+ SCM port);
+
+/* Querying and setting positions, and character availability. */
+SCM_API SCM scm_char_ready_p (SCM port);
SCM_API SCM scm_seek (SCM object, SCM offset, SCM whence);
SCM_API SCM scm_truncate_file (SCM object, SCM length);
SCM_API SCM scm_port_line (SCM port);
SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
SCM_API SCM scm_port_filename (SCM port);
SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
-SCM_INTERNAL const char *scm_i_default_port_encoding (void);
-SCM_INTERNAL void scm_i_set_default_port_encoding (const char *);
-SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
-SCM_API SCM scm_port_encoding (SCM port);
-SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
-SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port);
-SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port,
- scm_t_string_failed_conversion_handler h);
-SCM_API SCM scm_port_conversion_strategy (SCM port);
-SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior);
+
+/* Implementation helpers for port printing functions. */
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_print_port_mode (SCM exp, SCM port);
+
+/* Iterating over all ports. */
+SCM_API SCM scm_port_for_each (SCM proc);
+SCM_API void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data);
+SCM_API SCM scm_flush_all_ports (void);
+
+/* Void ports. */
SCM_API SCM scm_void_port (char * mode_str);
SCM_API SCM scm_sys_make_void_port (SCM mode);
+
+/* Initialization. */
SCM_INTERNAL void scm_init_ports (void);
-#if SCM_ENABLE_DEPRECATED==1
-SCM_DEPRECATED scm_t_port * scm_add_to_port_table (SCM port);
-#endif
-#ifdef GUILE_DEBUG
-SCM_API SCM scm_pt_size (void);
-SCM_API SCM scm_pt_member (SCM member);
-#endif /* GUILE_DEBUG */
+/* Inline function implementations. */
-/* internal */
+#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
+SCM_INLINE_IMPLEMENTATION int
+scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock)
+{
+ *lock = SCM_PTAB_ENTRY (port)->lock;
-SCM_INTERNAL long scm_i_mode_bits (SCM modes);
-SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port);
+ if (*lock)
+ return scm_i_pthread_mutex_lock (*lock);
+ else
+ return 0;
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock)
+{
+ *lock = SCM_PTAB_ENTRY (port)->lock;
+ if (*lock)
+ {
+ int ret = scm_i_pthread_mutex_trylock (*lock);
+ if (ret != 0)
+ *lock = NULL;
+ return ret;
+ }
+ else
+ return 0;
+}
+
+SCM_INLINE_IMPLEMENTATION int
+scm_get_byte_or_eof_unlocked (SCM port)
+{
+ int c;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ /* may be marginally faster than calling scm_flush. */
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ c = *(pt->read_pos++);
+
+ return c;
+}
+
+/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */
+SCM_INLINE_IMPLEMENTATION int
+scm_peek_byte_or_eof_unlocked (SCM port)
+{
+ int c;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ /* may be marginally faster than calling scm_flush. */
+ SCM_PORT_DESCRIPTOR (port)->flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
+ return EOF;
+ }
+
+ c = *pt->read_pos;
+
+ return c;
+}
+
+SCM_INLINE_IMPLEMENTATION void
+scm_putc_unlocked (char c, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite_unlocked (&c, 1, port);
+}
+
+SCM_INLINE_IMPLEMENTATION void
+scm_puts_unlocked (const char *s, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite_unlocked (s, strlen (s), port);
+}
+#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */
#endif /* SCM_PORTS_H */
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for
details. */
scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_locale_mutex);
#ifdef HAVE_SETLOCALE
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/read.h"
-#include "libguile/weaks.h"
#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
{ \
if (pstate->top - pstate->list_offset >= pstate->level) \
{ \
- scm_putc ('#', port); \
+ scm_putc_unlocked ('#', port); \
return; \
} \
} \
for (i = pstate->top - 1; 1; --i)
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
break;
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
scm_intprint (i - self, 10, port);
- scm_putc ('#', port);
+ scm_putc_unlocked ('#', port);
}
/* Print the name of a symbol. */
len = scm_i_symbol_length (sym);
strategy = scm_i_get_conversion_strategy (port);
- scm_lfwrite ("#{", 2, port);
+ scm_lfwrite_unlocked ("#{", 2, port);
for (pos = 0; pos < len; pos++)
{
}
}
- scm_lfwrite ("}#", 2, port);
+ scm_lfwrite_unlocked ("}#", 2, port);
}
/* FIXME: allow R6RS hex escapes instead of #{...}#. */
void
scm_print_symbol_name (const char *str, size_t len, SCM port)
{
- SCM symbol = scm_from_locale_symboln (str, len);
+ SCM symbol = scm_from_utf8_symboln (str, len);
scm_i_print_symbol_name (symbol, port);
}
scm_intprint (i, 8, port); \
else \
{ \
- scm_puts ("x", port); \
+ scm_puts_unlocked ("x", port); \
scm_intprint (i, 16, port); \
} \
} \
else if (SCM_IFLAGP (exp)
&& ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
{
- scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+ scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port);
}
else
{
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
{
}
else
{
- scm_puts ("#<uninterned-symbol ", port);
+ scm_puts_unlocked ("#<uninterned-symbol ", port);
scm_i_print_symbol_name (exp, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
break;
case scm_tc7_variable:
case scm_tc7_hashtable:
scm_i_hashtable_print (exp, port, pstate);
break;
+ case scm_tc7_weak_set:
+ scm_i_weak_set_print (exp, port, pstate);
+ break;
+ case scm_tc7_weak_table:
+ scm_i_weak_table_print (exp, port, pstate);
+ break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;
break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
- if (SCM_IS_WHVEC (exp))
- scm_puts ("#wh(", port);
- else
- scm_puts ("#w(", port);
+ scm_puts_unlocked ("#w(", port);
goto common_vector_printer;
case scm_tc7_vector:
ENTER_NESTED_DATA (pstate, exp, circref);
- scm_puts ("#(", port);
+ scm_puts_unlocked ("#(", port);
common_vector_printer:
{
register long i;
last = pstate->length - 1;
cutp = 1;
}
- if (SCM_I_WVECTP (exp))
- {
- /* Elements of weak vectors may not be accessed via the
- `SIMPLE_VECTOR_REF ()' macro. */
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (scm_c_vector_ref (exp, i),
- port, pstate);
- scm_putc (' ', port);
- }
- }
- else
- {
- for (i = 0; i < last; ++i)
- {
- scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
- scm_putc (' ', port);
- }
- }
-
+ for (i = 0; i < last; ++i)
+ {
+ scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
+ scm_putc_unlocked (' ', port);
+ }
if (i == last)
{
/* CHECK_INTS; */
scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
}
if (cutp)
- scm_puts (" ...", port);
- scm_putc (')', port);
+ scm_puts_unlocked (" ...", port);
+ scm_putc_unlocked (')', port);
}
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_port:
{
- register long i = SCM_PTOBNUM (exp);
- if (i < scm_numptob
- && scm_ptobs[i].print
- && (scm_ptobs[i].print) (exp, port, pstate))
+ scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp);
+ if (ptob->print && ptob->print (exp, port, pstate))
break;
goto punk;
}
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (utf8_buf, utf8_len, port);
+ scm_lfwrite_unlocked (utf8_buf, utf8_len, port);
printed += i - printed;
}
scm_t_string_failed_conversion_handler strategy)
{
size_t printed;
- scm_t_port *pt;
+ scm_t_iconv_descriptors *id;
- pt = SCM_PTAB_ENTRY (port);
+ id = scm_i_port_iconv_descriptors (port);
printed = 0;
output = encoded_output;
output_left = sizeof (encoded_output);
- done = iconv (pt->output_cd, &input, &input_left,
+ done = iconv (id->output_cd, &input, &input_left,
&output, &output_left);
output_len = sizeof (encoded_output) - output_left;
int errno_save = errno;
/* Reset the `iconv' state. */
- iconv (pt->output_cd, NULL, NULL, NULL, NULL);
+ iconv (id->output_cd, NULL, NULL, NULL, NULL);
/* Print the OUTPUT_LEN bytes successfully converted. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
/* See how many input codepoints these OUTPUT_LEN bytes
corresponds to. */
{
/* INPUT was successfully converted, entirely; print the
result. */
- scm_lfwrite (encoded_output, output_len, port);
+ scm_lfwrite_unlocked (encoded_output, output_len, port);
codepoints_read = i - printed;
printed += codepoints_read;
}
pt = SCM_PTAB_ENTRY (port);
- if (pt->output_cd == (iconv_t) -1)
- /* Initialize the conversion descriptors, if needed. */
- scm_i_set_port_encoding_x (port, pt->encoding);
-
- /* FIXME: In 2.1, add a flag to determine whether a port is UTF-8. */
- if (pt->output_cd == (iconv_t) -1)
+ if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
return display_string_as_utf8 (str, narrow_p, len, port);
else
return display_string_using_iconv (str, narrow_p, len,
/* Use special escapes for some C0 controls. */
buf[0] = '\\';
buf[1] = escapes[ch - 0x07];
- scm_lfwrite (buf, 2, port);
+ scm_lfwrite_unlocked (buf, 2, port);
}
else if (!SCM_R6RS_ESCAPES_P)
{
buf[1] = 'x';
buf[2] = hex[ch / 16];
buf[3] = hex[ch % 16];
- scm_lfwrite (buf, 4, port);
+ scm_lfwrite_unlocked (buf, 4, port);
}
else if (ch <= 0xFFFF)
{
buf[3] = hex[(ch & 0xF00) >> 8];
buf[4] = hex[(ch & 0xF0) >> 4];
buf[5] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 6, port);
+ scm_lfwrite_unlocked (buf, 6, port);
}
else if (ch > 0xFFFF)
{
buf[5] = hex[(ch & 0xF00) >> 8];
buf[6] = hex[(ch & 0xF0) >> 4];
buf[7] = hex[(ch & 0xF)];
- scm_lfwrite (buf, 8, port);
+ scm_lfwrite_unlocked (buf, 8, port);
}
}
else
buf[i] = 'x';
i --;
buf[i] = '\\';
- scm_lfwrite (buf + i, 9 - i, port);
+ scm_lfwrite_unlocked (buf + i, 9 - i, port);
}
}
else
name = scm_i_charname (SCM_MAKE_CHAR (ch));
if (name != NULL)
- scm_puts (name, port);
+ scm_puts_unlocked (name, port);
else
PRINT_CHAR_ESCAPE (ch, port);
}
scm_intprint (scm_t_intmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port);
}
void
scm_uintprint (scm_t_uintmax n, int radix, SCM port)
{
char num_buf[SCM_INTBUFLEN];
- scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+ scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port);
}
/* Print an object of unrecognized type.
void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
- scm_puts ("#<unknown-", port);
- scm_puts (hdr, port);
+ scm_puts_unlocked ("#<unknown-", port);
+ scm_puts_unlocked (hdr, port);
if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
{
- scm_puts (" (0x", port);
+ scm_puts_unlocked (" (0x", port);
scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
- scm_puts (" . 0x", port);
+ scm_puts_unlocked (" . 0x", port);
scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
- scm_puts (") @", port);
+ scm_puts_unlocked (") @", port);
}
- scm_puts (" 0x", port);
+ scm_puts_unlocked (" 0x", port);
scm_uintprint (SCM_UNPACK (ptr), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
{
register SCM hare, tortoise;
long floor = pstate->top - 2;
- scm_puts (hdr, port);
+ scm_puts_unlocked (hdr, port);
/* CHECK_INTS; */
if (pstate->fancyp)
goto fancy_printing;
if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
goto circref;
PUSH_REF (pstate, exp);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
end:
- scm_putc (tlr, port);
+ scm_putc_unlocked (tlr, port);
pstate->top = floor + 2;
return;
{
if (n == 0)
{
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
goto skip_tail;
}
else
}
PUSH_REF(pstate, exp);
++pstate->list_offset;
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
/* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate);
}
}
if (!SCM_NULL_OR_NIL_P (exp))
{
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
scm_iprin1 (exp, port, pstate);
}
skip_tail:
pstate->list_offset -= pstate->top - floor - 2;
circref:
- scm_puts (" . ", port);
+ scm_puts_unlocked (" . ", port);
print_circref (port, pstate, exp);
goto end;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 1);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
+ scm_dynwind_begin (0);
+ scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port));
scm_prin1 (obj, port, 0);
+ scm_dynwind_end ();
+
return SCM_UNSPECIFIED;
}
SCM_VALIDATE_OPORT_VALUE (1, port);
- scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+ scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
obj = SCM_PORT_WITH_PS_PORT (obj);
- return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
+ return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate);
}
SCM
void
scm_init_print ()
{
- SCM vtable, layout, type;
-
- scm_gc_register_root (&print_state_pool);
- scm_gc_register_root (&scm_print_state_vtable);
- vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
- layout =
- scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
- type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+ SCM type;
+
+ type = scm_make_vtable (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT),
+ SCM_BOOL_F);
scm_set_struct_vtable_name_x (type, scm_from_latin1_symbol ("print-state"));
scm_print_state_vtable = type;
/*
* private-gc.h - private declarations for garbage collection.
*
- * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 Free Software Foundation, Inc.
+ * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09, 11 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
-/* CELL_P checks a random word whether it has the right form for a
- pointer to a cell. Use scm_i_find_heap_segment_containing_object
- to find out whether it actually points to a real cell.
-
- The right form for a cell pointer is this: the low three bits must
- be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
- resulting pointer must be correctly aligned.
- scm_i_initialize_heap_segment_data guarantees that the test below
- works.
-*/
-#define CELL_P(x) ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)
-
SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
#endif
-/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006,
- * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
# include <config.h>
#endif
-#define SCM_BUILDING_DEPRECATED_CODE
-
#include "libguile/_scm.h"
#include "libguile/alist.h"
-#include "libguile/deprecation.h"
-#include "libguile/deprecated.h"
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
+#include "libguile/weak-table.h"
#include "libguile/programs.h"
#include "libguile/validate.h"
\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;
-static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
static SCM arity_overrides;
{
SCM o;
- scm_i_pthread_mutex_lock (&overrides_lock);
- o = scm_hashq_ref (arity_overrides, proc, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
if (scm_is_true (o))
{
while (!SCM_PROGRAM_P (proc))
{
- if (SCM_IMP (proc))
- return 0;
- switch (SCM_TYP7 (proc))
+ if (SCM_STRUCTP (proc))
{
- case scm_tc7_smob:
- if (!SCM_SMOB_APPLICABLE_P (proc))
- return 0;
- proc = scm_i_smob_apply_trampoline (proc);
- break;
- case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
return 0;
proc = SCM_STRUCT_PROCEDURE (proc);
- break;
- default:
- return 0;
}
+ else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
+ {
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ return 0;
+ proc = scm_i_smob_apply_trampoline (proc);
+ }
+ else
+ return 0;
}
return scm_i_program_arity (proc, req, opt, rest);
SCM_VALIDATE_INT_COPY (3, opt, t);
SCM_VALIDATE_BOOL (4, rest);
- scm_i_pthread_mutex_lock (&overrides_lock);
- scm_hashq_set_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
return SCM_UNDEFINED;
}
#undef FUNC_NAME
SCM_VALIDATE_PROC (1, proc);
- scm_i_pthread_mutex_lock (&overrides_lock);
- ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_false (ret))
{
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_is_true (scm_assq (scm_sym_arity, alist)))
- SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
-#endif
-
- scm_i_pthread_mutex_lock (&overrides_lock);
- scm_hashq_set_x (overrides, proc, alist);
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ scm_weak_table_putq_x (overrides, proc, alist);
return SCM_UNSPECIFIED;
}
{
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);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
if (scm_is_false (props))
{
if (SCM_PROGRAM_P (proc))
else
props = SCM_EOL;
}
- scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
- scm_i_pthread_mutex_unlock (&overrides_lock);
+ scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
void
scm_init_procprop ()
{
- overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
- arity_overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
#include "libguile/procprop.x"
}
#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
"Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_struct:
- if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
- || SCM_STRUCT_APPLICABLE_P (obj)))
- break;
- case scm_tc7_program:
- return SCM_BOOL_T;
- case scm_tc7_smob:
- return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
- default:
- return SCM_BOOL_F;
- }
- return SCM_BOOL_F;
+ return scm_from_bool (SCM_PROGRAM_P (obj)
+ || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
+ || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
+ && SCM_SMOB_APPLICABLE_P (obj)));
}
#undef FUNC_NAME
"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
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<continuation ", port);
+ scm_puts_unlocked ("#<continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
{
/* twingliness */
- scm_puts ("#<partial-continuation ", port);
+ scm_puts
_unlocked ("#<partial-continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else if (scm_is_false (write_program) || print_error)
{
- scm_puts ("#<program ", port);
+ scm_puts
_unlocked ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
else
{
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
-#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
+#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program))
#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x))
#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x))
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3))
promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<promise ", port);
+ scm_puts
_unlocked ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return !0;
}
#ifndef SCM_PTHREADS_THREADS_H
#define SCM_PTHREADS_THREADS_H
-/* Copyright (C) 2002, 2005, 2006, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2002, 2005, 2006, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#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
*/
#define scm_i_scm_pthread_cond_wait scm_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait scm_pthread_cond_timedwait
+#define SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(m,lock,unlock) \
+ static void lock (void) { pthread_mutex_lock (m); } \
+ static void unlock (void) { pthread_mutex_unlock (m); }
+
+/* noop */
+#define scm_i_pthread_atfork(pre,parent,child) \
+ pthread_atfork (pre, parent, child)
+
#endif /* SCM_PTHREADS_THREADS_H */
/*
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (bytevector_input_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (bv));
- port = scm_new_port_table_entry (bytevector_input_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Prevent BV from being GC'd. */
- SCM_SETSTREAM (port, SCM_UNPACK (bv));
-
/* Have the port directly access the bytevector. */
c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_port->read_end = (unsigned char *) c_bv + c_len;
c_port->read_buf_size = c_len;
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (custom_binary_input_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (method_vector));
- port = scm_new_port_table_entry (custom_binary_input_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
/* Have the port directly access the buffer (bytevector). */
c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
c_port->read_end = (unsigned char *) c_bv;
c_port->read_buf_size = c_len;
- /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
- SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
if (SCM_LIKELY (c_count > 0))
/* XXX: `scm_c_read ()' does not update the port position. */
- c_read = scm_c_read (port, c_bv, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
scm_out_of_range (FUNC_NAME, count);
if (SCM_LIKELY (c_count > 0))
- c_read = scm_c_read (port, c_bv + c_start, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_start, c_count);
else
/* Don't invoke `scm_c_read ()' since it may block. */
c_read = 0;
}
/* We can't use `scm_c_read ()' since it blocks. */
- c_chr = scm_getc (port);
+ c_chr = scm_getc_unlocked (port);
if (c_chr != EOF)
{
c_bv[c_total] = (char) c_chr;
c_len = (unsigned) c_total;
}
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+ result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
+ SCM_BOOL_F);
}
return result;
/* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
reached. */
- c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count);
c_total += c_read, c_count -= c_read;
}
while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
c_len = (unsigned) c_total;
}
- result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len);
+ result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
+ SCM_BOOL_F);
}
return result;
SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
c_octet = scm_to_uint8 (octet);
- scm_putc ((char) c_octet, port);
+ scm_putc_unlocked ((char) c_octet, port);
return SCM_UNSPECIFIED;
}
else
c_start = 0, c_count = c_len;
- scm_c_write (port, c_bv + c_start, c_count);
+ scm_c_write_unlocked (port, c_bv + c_start, c_count);
return SCM_UNSPECIFIED;
}
scm_t_bop_buffer *buf;
const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (bytevector_output_port_type);
- c_port = SCM_PTAB_ENTRY (port);
-
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
bop_buffer_init (buf);
- c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
- c_port->write_buf_size = 0;
-
- SCM_SET_BOP_BUFFER (port, buf);
+ port = scm_c_make_port_with_encoding (bytevector_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
- /* Mark PORT as open and writable. */
- SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+ c_port = SCM_PTAB_ENTRY (port);
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
/* Make the bop procedure. */
SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf);
bop_buffer_init (buf);
if (result_buf.len == 0)
- bv = scm_c_take_gc_bytevector (NULL, 0);
+ bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F);
else
{
if (result_buf.total_len > result_buf.len)
SCM_GC_BOP);
bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer,
- result_buf.len);
+ result_buf.len, SCM_BOOL_F);
}
return bv;
SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
+ port = scm_c_make_port_with_encoding (custom_binary_output_port_type,
+ mode_bits,
+ NULL, /* encoding */
+ SCM_FAILED_CONVERSION_ERROR,
+ SCM_UNPACK (method_vector));
- port = scm_new_port_table_entry (custom_binary_output_port_type);
c_port = SCM_PTAB_ENTRY (port);
- /* Match the expectation of `binary-port?'. */
- c_port->encoding = NULL;
-
- /* Attach it the method vector. */
- SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
-
/* Have the port directly access the buffer (bytevector). */
c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
c_port->write_buf_size = c_port->read_buf_size = 0;
- /* Mark PORT as open, writable and unbuffered. */
- SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
-
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
scm_t_port *c_port;
const unsigned long mode_bits = SCM_OPN | mode;
- scm_i_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- port = scm_new_port_table_entry (transcoded_port_type);
-
- SCM_SETSTREAM (port, SCM_UNPACK (binary_port));
-
- SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits);
+ port = scm_c_make_port (transcoded_port_type, mode_bits,
+ SCM_UNPACK (binary_port));
if (SCM_INPUT_PORT_P (port))
{
SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
}
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
-
return port;
}
static void
tp_write (SCM port, const void *data, size_t size)
{
- scm_c_write (SCM_TP_BINARY_PORT (port), data, size);
+ scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size);
}
static int
scm_force_output (bport);
if (c_bport->read_pos >= c_bport->read_end)
- scm_fill_input (bport);
+ scm_fill_input_unlocked (bport);
count = c_bport->read_end - c_bport->read_pos;
if (count > c_port->read_buf_size)
We just throw away the data when the underlying port is closed. */
if (SCM_OPOUTPORTP (binary_port))
- scm_c_write (binary_port, c_port->write_buf, count);
+ scm_c_write_unlocked (binary_port, c_port->write_buf, count);
c_port->write_pos = c_port->write_buf;
c_port->rw_active = SCM_PORT_NEITHER;
for (j = c_start; j < c_end; j++)
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
{
size_t chars_read = j - c_start;
{
size_t k;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
for (k = 0; k < num_delims; k++)
{
if (scm_i_string_ref (delims, k) == c)
{
if (scm_is_false (gobble))
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_cons (SCM_MAKE_CHAR (c),
scm_from_size_t (j - cstart));
}
else
{
- buf[index] = scm_getc (port);
+ buf[index] = scm_getc_unlocked (port);
switch (buf[index])
{
case EOF:
{
int chr;
- chr = scm_get_byte_or_eof (port);
+ chr = scm_get_byte_or_eof_unlocked (port);
if (chr == EOF)
return 0;
else if (CHAR_IS_DELIMITER (chr))
{
- scm_unget_byte (chr, port);
+ scm_unget_byte_unlocked (chr, port);
return 0;
}
else
{
scm_t_wchar c;
while (1)
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goteof:
case ';':
lp:
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto goteof;
break;
case '#':
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
eoferr = "read_sharp";
}
/* fall through */
default:
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return '#';
}
break;
if (terminating_char == c)
return SCM_EOL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port);
/* Note that it is possible for scm_read_expression to return
"in pair: mismatched close paren: ~A",
scm_list_1 (SCM_MAKE_CHAR (c)));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
tmp = scm_read_expression (port);
/* See above note about scm_sym_dot. */
c = 0; \
while (i < ndigits) \
{ \
- a = scm_getc (port); \
+ a = scm_getc_unlocked (port); \
if (a == EOF) \
goto str_eof; \
if (terminator \
do
{
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if (c == EOF)
return;
}
while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR));
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
}
static SCM
int column = SCM_COL (port) - 1;
str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
- while ('"' != (c = scm_getc (port)))
+ while ('"' != (c = scm_getc_unlocked (port)))
{
if (c == EOF)
{
if (c == '\\')
{
- switch (c = scm_getc (port))
+ switch (c = scm_getc_unlocked (port))
{
case EOF:
goto str_eof;
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, sizeof (buffer),
&overflow_buffer, &bytes_read);
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
&overflow_buffer, &bytes_read);
if (bytes_read > 0)
break;
default:
- scm_ungetc (chr, port);
- scm_ungetc ('#', port);
+ scm_ungetc_unlocked (chr, port);
+ scm_ungetc_unlocked ('#', port);
radix = 10;
}
{
scm_t_wchar c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = scm_sym_uq_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = scm_sym_unquote;
}
break;
{
int c;
- c = scm_getc (port);
+ c = scm_getc_unlocked (port);
if ('@' == c)
p = sym_unsyntax_splicing;
else
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
p = sym_unsyntax;
}
break;
/* We use the get_byte here because there is no need to get the
locale correct with comment input. This presumes that newline
always represents itself no matter what the encoding is. */
- for (c = scm_get_byte_or_eof (port);
+ for (c = scm_get_byte_or_eof_unlocked (port);
(c != EOF) && (c != '\n');
- c = scm_get_byte_or_eof (port));
+ c = scm_get_byte_or_eof_unlocked (port));
return SCM_UNSPECIFIED;
}
if (bytes_read == 0)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr == EOF)
scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
"while reading character", SCM_EOL);
static SCM
scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column)
{
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != 'u')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '8')
goto syntax;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
if (chr != '(')
goto syntax;
terribly inefficient but who cares? */
SCM s_bits = SCM_EOL;
- for (chr = scm_getc (port);
+ for (chr = scm_getc_unlocked (port);
(chr != EOF) && ((chr == '0') || (chr == '1'));
- chr = scm_getc (port))
+ chr = scm_getc_unlocked (port))
{
s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
}
if (chr != EOF)
- scm_ungetc (chr, port);
+ scm_ungetc_unlocked (chr, port);
return maybe_annotate_source
(scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
for (;;)
{
- int c = scm_getc (port);
+ int c = scm_getc_unlocked (port);
if (c == EOF)
scm_i_input_error ("skip_block_comment", port,
scm_read_shebang (scm_t_wchar chr, SCM port)
{
int c = 0;
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != '6')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != '6')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 'r')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
{
- scm_ungetc (c, port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
- if ((c = scm_get_byte_or_eof (port)) != 's')
+ if ((c = scm_get_byte_or_eof_unlocked (port)) != 's')
{
- scm_ungetc (c, port);
- scm_ungetc ('r', port);
- scm_ungetc ('6', port);
- scm_ungetc ('r', port);
+ scm_ungetc_unlocked (c, port);
+ scm_ungetc_unlocked ('r', port);
+ scm_ungetc_unlocked ('6', port);
+ scm_ungetc_unlocked ('r', port);
return scm_read_scsh_block_comment (chr, port);
}
nested. So care must be taken. */
int nesting_level = 1;
- int a = scm_getc (port);
+ int a = scm_getc_unlocked (port);
if (a == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
while (nesting_level > 0)
{
- int b = scm_getc (port);
+ int b = scm_getc_unlocked (port);
if (b == EOF)
scm_i_input_error ("scm_read_r6rs_block_comment", port,
if (EOF == c)
scm_i_input_error ("read_commented_expression", port,
"no expression after #; comment", SCM_EOL);
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
scm_read_expression (port);
return SCM_UNSPECIFIED;
}
buf = scm_i_string_start_writing (buf);
- while ((chr = scm_getc (port)) != EOF)
+ while ((chr = scm_getc_unlocked (port)) != EOF)
{
if (saw_brace)
{
that the extended read syntax would never put a `\' before
an `x'. For now, we just ignore other instances of
backslash in the string. */
- switch ((chr = scm_getc (port)))
+ switch ((chr = scm_getc_unlocked (port)))
{
case EOF:
goto done;
{
SCM result;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
result = scm_read_sharp_extension (chr, port);
if (!scm_is_eq (result, SCM_UNSPECIFIED))
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
case '@':
-#if SCM_ENABLE_DEPRECATED
- /* See below for 'i' and 'e'. */
- case 'a':
- case 'y':
- case 'h':
- case 'l':
-#endif
- return (scm_read_array (chr, port, line, column));
+ return (scm_read_array (chr, port, line, column));
case 'i':
case 'e':
-#if SCM_ENABLE_DEPRECATED
- {
- /* When next char is '(', it really is an old-style
- uniform array. */
- scm_t_wchar next_c = scm_getc (port);
- if (next_c != EOF)
- scm_ungetc (next_c, port);
- if (next_c == '(')
- return scm_read_array (chr, port, line, column);
- /* Fall through. */
- }
-#endif
case 'b':
case 'B':
case 'o':
{
scm_t_wchar chr;
- chr = scm_getc (port);
+ chr = scm_getc_unlocked (port);
switch (chr)
{
c = flush_ws (port, (char *) NULL);
if (EOF == c)
return SCM_EOF_VAL;
- scm_ungetc (c, port);
+ scm_ungetc_unlocked (c, port);
return (scm_read_expression (port));
}
pt = SCM_PTAB_ENTRY (port);
if (pt->rw_active == SCM_PORT_WRITE)
- scm_flush (port);
+ scm_flush_unlocked (port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_READ;
if (pt->read_pos == pt->read_end)
{
/* We can use the read buffer, and thus avoid a seek. */
- if (scm_fill_input (port) == EOF)
+ if (scm_fill_input_unlocked (port) == EOF)
return NULL;
bytes_read = pt->read_end - pt->read_pos;
if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
return NULL;
- bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
+ bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE);
header[bytes_read] = '\0';
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
}
-/* Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
return scm_from_long (write_len);
}
if (pt->write_pos > pt->write_buf)
- scm_flush (port);
+ scm_flush_unlocked (port);
fdes = SCM_FPORT_FDES (port);
}
{
int err;
};
+#ifndef HAVE_GC_GET_SUSPEND_SIGNAL
+static int
+GC_get_suspend_signal (void)
+{
+#if defined SIG_SUSPEND
+ return SIG_SUSPEND;
+#elif defined SIGPWR
+ return SIGPWR;
+#elif defined SIGLOST
+ return SIGLOST;
+#elif defined _SIGRTMIN
+ return _SIGRTMIN + 6;
+#elif defined SIGRTMIN
+ return SIGRTMIN + 6;
+#elif defined __GLIBC__
+ return 32+6;
+#else
+ return SIGUSR1;
+#endif
+}
+#endif /* HAVE_GC_GET_SUSPEND_SIGNAL */
+
static void*
read_signal_pipe_data (void * data)
{
#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
sigset_t all_sigs;
sigfillset (&all_sigs);
+ /* On libgc 7.1 and earlier, GC_do_blocking doesn't actually do
+ anything. So in that case, libgc will want to suspend the signal
+ delivery thread, so we need to allow it to do so by unmasking the
+ suspend signal. */
+ sigdelset (&all_sigs, GC_get_suspend_signal ());
scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
#endif
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
long n = SCM_SMOBNUM (exp);
- scm_puts ("#<", port);
- scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
+ scm_putc_unlocked (' ', port);
if (scm_smobs[n].size)
scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
else
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
}
static SCM tramp_weak_map = SCM_BOOL_F;
-static scm_i_pthread_mutex_t tramp_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM
scm_i_smob_apply_trampoline (SCM smob)
{
SCM tramp;
- scm_i_pthread_mutex_lock (&tramp_lock);
- tramp = scm_hashq_ref (tramp_weak_map, smob, SCM_BOOL_F);
- scm_i_pthread_mutex_unlock (&tramp_lock);
+ tramp = scm_weak_table_refq (tramp_weak_map, smob, SCM_BOOL_F);
if (scm_is_true (tramp))
return tramp;
name = "smob-apply";
objtable = scm_c_make_vector (2, SCM_UNDEFINED);
SCM_SIMPLE_VECTOR_SET (objtable, 0, smob);
- SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_locale_symbol (name));
+ SCM_SIMPLE_VECTOR_SET (objtable, 1, scm_from_utf8_symbol (name));
tramp = scm_make_program (SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode,
objtable, SCM_BOOL_F);
/* Race conditions (between the ref and this set!) cannot cause
any harm here. */
- scm_i_pthread_mutex_lock (&tramp_lock);
- scm_hashq_set_x (tramp_weak_map, smob, tramp);
- scm_i_pthread_mutex_unlock (&tramp_lock);
+ scm_weak_table_putq_x (tramp_weak_map, smob, tramp);
return tramp;
}
}
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)
register SCM cell;
register scm_t_bits tc, smobnum;
- cell = PTR2SCM (addr);
+ cell = SCM_PACK_POINTER (addr);
if (SCM_TYP7 (cell) != scm_tc7_smob)
/* It is likely that the GC passed us a pointer to a free-list element
mark_stack_ptr = SCM_I_CURRENT_THREAD->current_mark_stack_ptr;
- if (SCM_NIMP (obj))
+ if (SCM_HEAP_OBJECT_P (obj))
/* Mark the returned object. */
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (obj),
mark_stack_ptr,
#define CURRENT_MARK_LIMIT \
((struct GC_ms_entry *)(SCM_I_CURRENT_THREAD->current_mark_stack_limit))
- if (SCM_NIMP (o))
+ if (SCM_HEAP_OBJECT_P (o))
{
/* At this point, the `current_mark_*' fields of the current thread
must be defined (they are set in `smob_mark ()'). */
#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);
- smob = PTR2SCM (ptr);
+ smob = SCM_PACK_POINTER (ptr);
#if 0
printf ("finalizing SMOB %p (smobnum: %u)\n",
ptr, SCM_SMOBNUM (smob));
free_smob (smob);
}
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_smob (scm_t_bits tc, scm_t_bits data)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. Since the marker only deals with double cells, that case
+ allocates a double cell. We leave words 2 and 3 to there initial
+ values, which is 0. */
+ if (scm_smobs [smobnum].mark)
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ ret = SCM_PACK_POINTER (GC_MALLOC (sizeof (scm_t_cell)));
+
+ SCM_SET_CELL_WORD_1 (ret, data);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
+
+ return ret;
+}
+
+/* Return a SMOB with typecode TC. The SMOB type corresponding to TC may
+ provide a custom mark procedure and it will be honored. */
+SCM
+scm_i_new_double_smob (scm_t_bits tc, scm_t_bits data1,
+ scm_t_bits data2, scm_t_bits data3)
+{
+ scm_t_bits smobnum = SCM_TC2SMOBNUM (tc);
+ SCM ret;
+
+ /* Use the smob_gc_kind if needed to allow the mark procedure to
+ run. */
+ if (scm_smobs [smobnum].mark)
+ ret = SCM_PACK_POINTER (GC_generic_malloc (2 * sizeof (scm_t_cell), smob_gc_kind));
+ else
+ ret = SCM_PACK_POINTER (GC_MALLOC (2 * sizeof (scm_t_cell)));
+
+ SCM_SET_CELL_WORD_3 (ret, data3);
+ SCM_SET_CELL_WORD_2 (ret, data2);
+ SCM_SET_CELL_WORD_1 (ret, data1);
+ SCM_SET_CELL_WORD_0 (ret, tc);
+
+ if (scm_smobs[smobnum].free)
+ scm_i_set_finalizer (SCM2PTR (ret), finalize_smob, NULL);
+
+ return ret;
+}
+
\f
void
scm_smob_prehistory ()
scm_smobs[i].apply_trampoline_objcode = SCM_BOOL_F;
}
- tramp_weak_map = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+ tramp_weak_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
}
/*
#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_HAS_TYP16 (obj, tag)
+#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
+#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
+
+/* Maximum number of SMOB types. */
+#define SCM_I_MAX_SMOB_TYPE_COUNT 256
+
+SCM_API long scm_numsmob;
+SCM_API scm_smob_descriptor scm_smobs[];
+
+
\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);
) \
SCM_SNARF_INIT( \
/* Initialize the foreign. */ \
- scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
+ scm_i_paste (FNAME, __raw_objtable)[1] = scm_i_paste (FNAME, __subr_foreign); \
/* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
+ scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __name); \
/* Initialize the objcode trampoline. */ \
SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
# define SCM_SYMBOL(c_name, scheme_name) \
SCM_SNARF_HERE(static SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
+SCM_SNARF_INIT(c_name = scm_from_utf8_symbol (scheme_name))
# define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
SCM_SNARF_HERE(SCM c_name) \
-SCM_SNARF_INIT(c_name = scm_from_locale_symbol (scheme_name))
+SCM_SNARF_INIT(c_name = scm_from_utf8_symbol (scheme_name))
#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */
/* for primitive-generics, add a foreign to the end */
#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
- static SCM_ALIGNED (8) SCM c_name[4] = \
+ static SCM_ALIGNED (8) SCM c_name[3] = \
{ \
SCM_PACK (scm_tc7_vector | (2 << 8)), \
- SCM_PACK (0), \
foreign, \
- SCM_BOOL_F, /* the name */ \
+ SCM_BOOL_F /* the name */ \
}
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
#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)
{
#include "libguile/hash.h"
#include "libguile/ports.h"
#include "libguile/root.h"
-#include "libguile/weaks.h"
#include "libguile/gc.h"
#include "libguile/validate.h"
SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
static SCM scm_source_whash;
-static scm_i_pthread_mutex_t source_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/*
srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
{
int writingp = SCM_WRITINGP (pstate);
- scm_puts ("#<srcprops ", port);
+ scm_puts_unlocked ("#<srcprops ", port);
SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate);
SCM_SET_WRITINGP (pstate, writingp);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}
return SCM_EOL;
else
{
- SCM p;
-
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&source_lock);
+ SCM p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (SRCPROPSP (p))
return scm_srcprops_to_alist (p);
{
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- scm_hashq_set_x (scm_source_whash, obj, alist);
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, obj, alist);
return alist;
}
if (SCM_IMP (obj))
return 0;
else
- {
- int ret;
-
- scm_i_pthread_mutex_lock (&source_lock);
- ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
- scm_i_pthread_mutex_unlock (&source_lock);
-
- return ret;
- }
+ return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
}
#undef FUNC_NAME
{
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (line, col, fname,
- SCM_COPY_SOURCE_P
- ? scm_copy_tree (obj)
- : SCM_UNDEFINED,
- SCM_EOL));
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (line, col, fname,
+ SCM_COPY_SOURCE_P
+ ? scm_copy_tree (obj)
+ : SCM_UNDEFINED,
+ SCM_EOL));
}
#undef FUNC_NAME
"@var{obj}'s source property list.")
#define FUNC_NAME s_scm_source_property
{
+ SCM p;
+
if (SCM_IMP (obj))
return SCM_BOOL_F;
+
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
+
+ if (!SRCPROPSP (p))
+ goto alist;
+ if (scm_is_eq (scm_sym_line, key))
+ return scm_from_int (SRCPROPLINE (p));
+ else if (scm_is_eq (scm_sym_column, key))
+ return scm_from_int (SRCPROPCOL (p));
+ else if (scm_is_eq (scm_sym_copy, key))
+ return SRCPROPCOPY (p);
else
{
- SCM p;
-
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
- scm_i_pthread_mutex_unlock (&source_lock);
-
- if (!SRCPROPSP (p))
- goto alist;
- if (scm_is_eq (scm_sym_line, key))
- p = scm_from_int (SRCPROPLINE (p));
- else if (scm_is_eq (scm_sym_column, key))
- p = scm_from_int (SRCPROPCOL (p));
- else if (scm_is_eq (scm_sym_copy, key))
- p = SRCPROPCOPY (p);
- else
- {
- p = SRCPROPALIST (p);
- alist:
- p = scm_assoc (key, p);
- return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
- }
- return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+ p = SRCPROPALIST (p);
+ alist:
+ p = scm_assoc (key, p);
+ return (scm_is_pair (p) ? SCM_CDR (p) : SCM_BOOL_F);
}
}
#undef FUNC_NAME
SCM p;
SCM_VALIDATE_NIM (1, obj);
- scm_i_pthread_mutex_lock (&source_lock);
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
+ p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key))
{
if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (scm_to_int (datum), 0,
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (scm_to_int (datum), 0,
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_column, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (0, scm_to_int (datum),
- SCM_UNDEFINED, SCM_UNDEFINED, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (0, scm_to_int (datum),
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
}
else if (scm_is_eq (scm_sym_copy, key))
{
if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum);
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
}
else
{
if (SRCPROPSP (p))
SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p)));
else
- scm_hashq_set_x (scm_source_whash, obj,
- scm_acons (key, datum, p));
+ scm_weak_table_putq_x (scm_source_whash, obj,
+ scm_acons (key, datum, p));
}
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return SCM_UNSPECIFIED;
}
{
SCM p, z;
z = scm_cons (x, y);
- scm_i_pthread_mutex_lock (&source_lock);
/* Copy source properties possibly associated with xorig. */
- p = scm_hashq_ref (scm_source_whash, xorig, SCM_BOOL_F);
+ p = scm_weak_table_refq (scm_source_whash, xorig, SCM_BOOL_F);
if (scm_is_true (p))
- scm_hashq_set_x (scm_source_whash, z, p);
- scm_i_pthread_mutex_unlock (&source_lock);
+ scm_weak_table_putq_x (scm_source_whash, z, p);
return z;
}
#undef FUNC_NAME
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
- scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
+ scm_source_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
scm_c_define ("source-whash", scm_source_whash);
scm_last_alist_filename = scm_cons (SCM_EOL,
p = SCM_CHARSET_DATA (charset);
- scm_puts ("#<charset {", port);
+ scm_puts_unlocked ("#<charset {", port);
for (i = 0; i < p->len; i++)
{
if (first)
first = 0;
else
- scm_puts (" ", port);
+ scm_puts_unlocked (" ", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
if (p->ranges[i].lo != p->ranges[i].hi)
{
- scm_puts ("..", port);
+ scm_puts_unlocked ("..", port);
scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
}
if (i >= max_ranges_to_print)
{
/* Too many to print here. Quit early. */
- scm_puts (" ...", port);
+ scm_puts_unlocked (" ...", port);
break;
}
}
- scm_puts ("}>", port);
+ scm_puts_unlocked ("}>", port);
return 1;
}
cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
- scm_puts ("#<charset-cursor ", port);
+ scm_puts_unlocked ("#<charset-cursor ", port);
if (cur->range == (size_t) (-1))
- scm_puts ("(empty)", port);
+ scm_puts_unlocked ("(empty)", port);
else
{
scm_write (scm_from_size_t (cur->range), port);
- scm_puts (":", port);
+ scm_puts_unlocked (":", port);
scm_write (scm_from_int32 (cur->n), port);
}
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_CHARSET_GET(cs,idx) \
scm_i_charset_get((scm_t_char_set *)SCM_SMOB_DATA(cs),idx)
-#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
+#define SCM_CHARSETP(x) (SCM_HAS_TYP16 (x, scm_tc16_charset))
/* Smob type code for character sets. */
SCM_API int scm_tc16_charset;
/* 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)
{
scm_uintprint ((scm_stack_size (thread->continuation_base)
* sizeof (SCM_STACKITEM)),
16, port);
- scm_puts (" of stack: 0x", port);
+ scm_puts_unlocked (" of stack: 0x", port);
scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
- scm_puts (" - 0x", port);
+ scm_puts_unlocked (" - 0x", port);
scm_uintprint ((scm_t_bits) &stack, 16, port);
- scm_puts ("\n", port);
+ scm_puts_unlocked ("\n", port);
}
#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)\
lenhist[1000]++;
#endif
- buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
+ buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1,
"string"));
SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG);
#endif
raw_len = (len + 1) * sizeof (scm_t_wchar);
- buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
+ buf = SCM_PACK_POINTER (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len,
"string"));
SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE);
return new_buf;
}
+\f
+
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (stringbuf_write_mutex);
+
+static scm_i_pthread_mutex_t iconv_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+void
+scm_i_lock_iconv (void)
+{
+ scm_i_pthread_mutex_lock (&iconv_mutex);
+}
+
+void
+scm_i_unlock_iconv (void)
+{
+ scm_i_pthread_mutex_unlock (&iconv_mutex);
+}
\f
/* Copy-on-write strings.
#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
-#define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
+#define IS_STRING(str) (SCM_HAS_TYP7 (str, STRING_TAG))
/* Read-only strings.
*/
\f
/* String conversion to/from C. */
+static void
+decoding_error (const char *func_name, int errno_save,
+ const char *str, size_t len)
+{
+ /* Raise an error and pass the raw C string as a bytevector to the `throw'
+ handler. */
+ SCM bv;
+ signed char *buf;
+
+ buf = scm_gc_malloc_pointerless (len, "bytevector");
+ memcpy (buf, str, len);
+ bv = scm_c_take_gc_bytevector (buf, len, SCM_BOOL_F);
+
+ scm_decoding_error (func_name, errno_save,
+ "input locale conversion error", bv);
+}
+
SCM
scm_from_stringn (const char *str, size_t len, const char *encoding,
scm_t_string_failed_conversion_handler handler)
len = strlen (str);
if (encoding == NULL || len == 0)
- {
- /* If encoding is null (or the string is empty), use Latin-1. */
- char *buf;
- res = scm_i_make_string (len, &buf, 0);
- memcpy (buf, str, len);
- return res;
- }
+ return scm_from_latin1_stringn (str, len);
+ else if (strcmp (encoding, "UTF-8") == 0)
+ return scm_from_utf8_stringn (str, len);
u32len = 0;
+ scm_i_lock_iconv ();
u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding,
(enum iconv_ilseq_handler)
handler,
str, len,
NULL,
NULL, &u32len);
+ scm_i_unlock_iconv ();
if (SCM_UNLIKELY (u32 == NULL))
- {
- /* Raise an error and pass the raw C string as a bytevector to the `throw'
- handler. */
- SCM bv;
- signed char *buf;
-
- buf = scm_gc_malloc_pointerless (len, "bytevector");
- memcpy (buf, str, len);
- bv = scm_c_take_gc_bytevector (buf, len);
-
- scm_decoding_error (__func__, errno,
- "input locale conversion error", bv);
- }
+ decoding_error (__func__, errno, str, len);
i = 0;
while (i < u32len)
SCM
scm_from_utf8_stringn (const char *str, size_t len)
{
- return scm_from_stringn (str, len, "UTF-8", SCM_FAILED_CONVERSION_ERROR);
+ size_t i, char_len;
+ const scm_t_uint8 *ustr = (const scm_t_uint8 *) str;
+ int ascii = 1, narrow = 1;
+ SCM res;
+
+ if (len == (size_t) -1)
+ len = strlen (str);
+
+ i = 0;
+ char_len = 0;
+
+ while (i < len)
+ {
+ if (ustr[i] <= 127)
+ {
+ char_len++;
+ i++;
+ }
+ else
+ {
+ ucs4_t c;
+ int nbytes;
+
+ ascii = 0;
+
+ nbytes = u8_mbtouc (&c, ustr + i, len - i);
+
+ if (nbytes < 0)
+ /* Bad UTF-8. */
+ decoding_error (__func__, errno, str, len);
+
+ if (c > 255)
+ narrow = 0;
+
+ char_len++;
+ i += nbytes;
+ }
+ }
+
+ if (ascii)
+ {
+ char *dst;
+ res = scm_i_make_string (char_len, &dst, 0);
+ memcpy (dst, str, len);
+ }
+ else if (narrow)
+ {
+ char *dst;
+ size_t j;
+ ucs4_t c;
+
+ res = scm_i_make_string (char_len, &dst, 0);
+
+ for (i = 0, j = 0; i < len; j++)
+ {
+ i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
+ dst[j] = (signed char) c;
+ }
+ }
+ else
+ {
+ scm_t_wchar *dst;
+ size_t j;
+ ucs4_t c;
+
+ res = scm_i_make_wide_string (char_len, &dst, 0);
+
+ for (i = 0, j = 0; i < len; j++)
+ {
+ i += u8_mbtouc_unsafe (&c, ustr + i, len - i);
+ dst[j] = c;
+ }
+ }
+
+ return res;
}
SCM
enc = "ISO-8859-1";
if (scm_i_is_narrow_string (str))
{
+ scm_i_lock_iconv ();
ret = mem_iconveh (scm_i_string_chars (str), ilen,
"ISO-8859-1", enc,
(enum iconv_ilseq_handler) handler, NULL,
&buf, &len);
+ scm_i_unlock_iconv ();
if (ret != 0)
scm_encoding_error (__func__, errno,
}
else
{
+ scm_i_lock_iconv ();
buf = u32_conv_to_encoding (enc,
(enum iconv_ilseq_handler) handler,
(scm_t_uint32 *) scm_i_string_wide_chars (str),
ilen,
NULL,
NULL, &len);
+ scm_i_unlock_iconv ();
if (buf == NULL)
scm_encoding_error (__func__, errno,
"cannot convert wide string to output locale",
*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)
{
{
scm_nullstr = scm_i_make_string (0, NULL, 0);
+ scm_i_pthread_atfork (scm_i_lock_iconv, scm_i_unlock_iconv,
+ scm_i_unlock_iconv);
+
#include "libguile/strings.x"
}
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* internal utility functions. */
+SCM_INTERNAL void scm_i_lock_iconv (void);
+SCM_INTERNAL void scm_i_unlock_iconv (void);
+
SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list);
SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM start, size_t *cstart,
-/* 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 */
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* NOTES:
write_buf/write_end point to the ends of the allocated bytevector.
- read_buf/read_end in principle point to the part of the bytevector which
- has been written to, but this is only updated after a flush.
- read_pos and write_pos in principle should be equal, but this is only true
- when rw_active is SCM_PORT_NEITHER.
+ read_buf/read_end point to the part of the bytevector which has been
+ written to. read_pos and write_pos are always equal.
ENHANCE-ME - output blocks:
static int
-stfill_buffer (SCM port)
+st_fill_input (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->read_pos >= pt->read_end)
return EOF;
else
- return scm_return_first_int (*pt->read_pos, port);
+ return *pt->read_pos;
}
/* Change the size of a port's bytevector to NEW_SIZE. This doesn't
unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
unsigned long int min_size = min (old_size, new_size);
- scm_t_off index = pt->write_pos - pt->write_buf;
+ scm_t_off offset = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
{
pt->stream = SCM_UNPACK (new_stream);
pt->read_buf = pt->write_buf = (unsigned char *)dst;
- pt->read_pos = pt->write_pos = pt->write_buf + index;
+ pt->read_pos = pt->write_pos = pt->write_buf + offset;
pt->write_end = pt->write_buf + pt->write_buf_size;
pt->read_end = pt->read_buf + pt->read_buf_size;
}
}
-/* Ensure that `write_pos' < `write_end' by enlarging the buffer when
- necessary. Update `read_buf' to account for written chars. The
- buffer is enlarged geometrically. */
static void
-st_flush (SCM port)
+st_write (SCM port, const void *data, size_t size)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->write_pos == pt->write_end)
- st_resize_port (pt, pt->write_buf_size * 2);
+ if (size > pt->write_end - pt->write_pos)
+ st_resize_port (pt, max (pt->write_buf_size * 2,
+ pt->write_end - pt->write_pos + size));
+
+ memcpy ((char *) pt->write_pos, data, size);
+ pt->read_pos = (pt->write_pos += size);
- pt->read_pos = pt->write_pos;
if (pt->read_pos > pt->read_end)
{
pt->read_end = (unsigned char *) pt->read_pos;
pt->read_buf_size = pt->read_end - pt->read_buf;
}
- pt->rw_active = SCM_PORT_NEITHER;
-}
-
-static void
-st_write (SCM port, const void *data, size_t size)
-{
- scm_t_port *pt = SCM_PTAB_ENTRY (port);
- const char *input = (char *) data;
-
- while (size > 0)
- {
- int space = pt->write_end - pt->write_pos;
- int write_len = (size > space) ? space : size;
-
- memcpy ((char *) pt->write_pos, input, write_len);
- pt->write_pos += write_len;
- size -= write_len;
- input += write_len;
- if (write_len == space)
- st_flush (port);
- }
}
static void
else
/* all other cases. */
{
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
-
if (pt->rw_active == SCM_PORT_READ)
- scm_end_input (port);
+ scm_end_input_unlocked (port);
+
+ pt->rw_active = SCM_PORT_NEITHER;
switch (whence)
{
pt->read_buf_size = length;
pt->read_end = pt->read_buf + length;
if (pt->read_pos > pt->read_end)
- pt->read_pos = pt->read_end;
-
- if (pt->write_pos > pt->read_end)
- pt->write_pos = pt->read_end;
+ pt->read_pos = pt->write_pos = pt->read_end;
}
/* The initial size in bytes of a string port's buffer. */
{
SCM z, buf;
scm_t_port *pt;
- size_t str_len, c_pos;
+ const char *encoding;
+ size_t read_buf_size, str_len, c_pos;
char *c_buf;
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
- scm_dynwind_begin (0);
- scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex);
-
- z = scm_new_port_table_entry (scm_tc16_strport);
- pt = SCM_PTAB_ENTRY(z);
+ encoding = scm_i_default_port_encoding ();
if (scm_is_false (str))
{
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
/* Reset `read_buf_size'. It will contain the actual number of
- bytes written to PT. */
- pt->read_buf_size = 0;
+ bytes written to the port. */
+ read_buf_size = 0;
c_pos = 0;
}
else
SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
- /* Create a copy of STR in the encoding of PT. */
- copy = scm_to_stringn (str, &str_len, pt->encoding,
+ /* Create a copy of STR in ENCODING. */
+ copy = scm_to_stringn (str, &str_len, encoding,
SCM_FAILED_CONVERSION_ERROR);
buf = scm_c_make_bytevector (str_len);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
free (copy);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
- pt->read_buf_size = str_len;
+ read_buf_size = str_len;
}
- SCM_SETSTREAM (z, SCM_UNPACK (buf));
- SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
+ z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
+ encoding,
+ SCM_FAILED_CONVERSION_ERROR,
+ (scm_t_bits)buf);
+ pt = SCM_PTAB_ENTRY (z);
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
+ pt->read_buf_size = read_buf_size;
pt->write_buf_size = str_len;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
-
pt->rw_random = 1;
- scm_dynwind_end ();
-
- /* Ensure WRITE_POS is writable. */
- if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
- st_flush (z);
-
- scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
return z;
}
SCM
scm_strport_to_string (SCM port)
{
- SCM str;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- if (pt->rw_active == SCM_PORT_WRITE)
- st_flush (port);
-
if (pt->read_buf_size == 0)
return scm_nullstr;
- if (pt->encoding == NULL)
- {
- char *buf;
- str = scm_i_make_string (pt->read_buf_size, &buf, 0);
- memcpy (buf, pt->read_buf, pt->read_buf_size);
- }
- else
- str = scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
- pt->encoding, pt->ilseq_handler);
- scm_remember_upto_here_1 (port);
- return str;
+ return scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
+ pt->encoding, pt->ilseq_handler);
}
SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
static scm_t_bits
scm_make_stptob ()
{
- scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
+ scm_t_bits tc = scm_make_port_type ("string", st_fill_input, st_write);
scm_set_port_end_input (tc, st_end_input);
- scm_set_port_flush (tc, st_flush);
scm_set_port_seek (tc, st_seek);
scm_set_port_truncate (tc, st_truncate);
#ifndef SCM_STRPORTS_H
#define SCM_STRPORTS_H
-/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
-#define SCM_STRPORTP(x) (!SCM_IMP (x) && \
- (SCM_TYP16 (x) == scm_tc16_strport))
+#define SCM_STRPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_strport))
#define SCM_OPSTRPORTP(x) (SCM_STRPORTP (x) && \
(SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINSTRPORTP(x) (SCM_OPSTRPORTP (x) && \
-/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include <alloca.h>
#include <assert.h>
+#define SCM_BUILDING_DEPRECATED_CODE
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
-#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
/* vtable_data can be null when making a vtable vtable */
if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
- {
- /* Register a finalizer for the newly created instance. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalizer_data;
- GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
- struct_finalizer_trampoline,
- NULL,
- &prev_finalizer,
- &prev_finalizer_data);
- }
+ /* Register a finalizer for the newly created instance. */
+ scm_i_set_finalizer (SCM2PTR (ret), struct_finalizer_trampoline, NULL);
return ret;
}
+#if SCM_ENABLE_DEPRECATED == 1
SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
(SCM user_fields, SCM tail_array_size, SCM init),
"Return a new, self-describing vtable structure.\n\n"
return obj;
}
#undef FUNC_NAME
+#endif
+SCM
+scm_i_make_vtable_vtable (SCM user_fields)
+#define FUNC_NAME s_scm_make_vtable_vtable
+{
+ SCM fields, layout, obj;
+ size_t basic_size;
+ scm_t_bits v;
+
+ SCM_VALIDATE_STRING (1, user_fields);
+
+ fields = scm_string_append (scm_list_2 (required_vtable_fields,
+ user_fields));
+ layout = scm_make_struct_layout (fields);
+ if (!scm_is_valid_vtable_layout (layout))
+ SCM_MISC_ERROR ("invalid user fields", scm_list_1 (user_fields));
+
+ basic_size = scm_i_symbol_length (layout) / 2;
+
+ obj = scm_i_alloc_struct (NULL, basic_size);
+ /* Make it so that the vtable of OBJ is itself. */
+ SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
+
+ v = SCM_UNPACK (layout);
+ scm_struct_init (obj, layout, 0, 1, &v);
+ SCM_SET_VTABLE_FLAGS (obj,
+ SCM_VTABLE_FLAG_VTABLE | SCM_VTABLE_FLAG_VALIDATED);
+
+ return obj;
+}
+#undef FUNC_NAME
SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
(SCM fields, SCM printer),
{
SCM vtable = SCM_STRUCT_VTABLE (exp);
SCM name = scm_struct_vtable_name (vtable);
- scm_puts ("#<", port);
+ scm_puts_unlocked ("#<", port);
if (scm_is_true (name))
{
scm_display (name, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
else
{
if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
- scm_puts ("vtable:", port);
+ scm_puts_unlocked ("vtable:", port);
else
- scm_puts ("struct:", port);
+ scm_puts_unlocked ("struct:", port);
scm_uintprint (SCM_UNPACK (vtable), 16, port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
scm_write (SCM_VTABLE_LAYOUT (vtable), port);
- scm_putc (' ', port);
+ scm_putc_unlocked (' ', port);
}
scm_uintprint (SCM_UNPACK (exp), 16, port);
/* hackety hack */
{
if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
{
- scm_puts (" proc: ", port);
+ scm_puts_unlocked (" proc: ", port);
if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
scm_write (SCM_STRUCT_PROCEDURE (exp), port);
else
- scm_puts ("(not a procedure?)", port);
+ scm_puts_unlocked ("(not a procedure?)", port);
}
if (SCM_STRUCT_SETTER_P (exp))
{
- scm_puts (" setter: ", port);
+ scm_puts_unlocked (" setter: ", port);
scm_write (SCM_STRUCT_SETTER (exp), port);
}
}
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
}
}
GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));
required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
+ scm_c_define ("standard-vtable-fields", required_vtable_fields);
required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);
- scm_standard_vtable_vtable =
- scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ scm_standard_vtable_vtable = scm_i_make_vtable_vtable (scm_nullstr);
+ scm_c_define ("<standard-vtable>", scm_standard_vtable_vtable);
scm_applicable_struct_vtable_vtable =
scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
scm_t_bits init[]);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
-SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_INTERNAL SCM scm_i_make_vtable_vtable (SCM extra_fields);
+#if SCM_ENABLE_DEPRECATED == 1
+SCM_DEPRECATED SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+#endif
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
# include <config.h>
#endif
+#include <unistr.h>
+
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/fluids.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-#include "libguile/weaks.h"
+#include "libguile/weak-set.h"
#include "libguile/modules.h"
#include "libguile/read.h"
#include "libguile/srfi-13.h"
\f
static SCM symbols;
-static scm_i_pthread_mutex_t symbols_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
lookup_interned_symbol (SCM name, unsigned long raw_hash)
{
struct string_lookup_data data;
- SCM handle;
data.string = name;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- string_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ string_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
struct latin1_lookup_data
unsigned long raw_hash)
{
struct latin1_lookup_data data;
- SCM handle;
data.str = str;
data.len = len;
data.string_hash = raw_hash;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_get_handle_by_hash (symbols, raw_hash,
- latin1_lookup_predicate_fn,
- &data);
- scm_i_pthread_mutex_unlock (&symbols_lock);
-
- if (scm_is_true (handle))
- return SCM_CAR (handle);
- else
- return SCM_BOOL_F;
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ latin1_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
-static unsigned long
-symbol_lookup_hash_fn (SCM obj, unsigned long max, void *closure)
+struct utf8_lookup_data
{
- return scm_i_symbol_hash (obj) % max;
-}
+ const char *str;
+ size_t len;
+ unsigned long string_hash;
+};
-static SCM
-symbol_lookup_assoc_fn (SCM obj, SCM alist, void *closure)
+static int
+utf8_string_equals_wide_string (const scm_t_uint8 *narrow, size_t nlen,
+ const scm_t_wchar *wide, size_t wlen)
{
- for (; !scm_is_null (alist); alist = SCM_CDR (alist))
+ size_t byte_idx = 0, char_idx = 0;
+
+ while (byte_idx < nlen && char_idx < wlen)
{
- SCM sym = SCM_CAAR (alist);
-
- if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (obj)
- && scm_is_true (scm_string_equal_p (scm_symbol_to_string (sym),
- scm_symbol_to_string (obj))))
- return SCM_CAR (alist);
+ ucs4_t c;
+ int nbytes;
+
+ nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx);
+ if (nbytes == 0)
+ break;
+ else if (nbytes < 0)
+ /* Bad UTF-8. */
+ return 0;
+ else if (c != wide[char_idx])
+ return 0;
+
+ byte_idx += nbytes;
+ char_idx++;
}
- return SCM_BOOL_F;
+ return byte_idx == nlen && char_idx == wlen;
}
-/* Intern SYMBOL, an uninterned symbol. Might return a different
- symbol, if another one was interned at the same time. */
-static SCM
-intern_symbol (SCM symbol)
+static int
+utf8_lookup_predicate_fn (SCM sym, void *closure)
{
- SCM handle;
+ struct utf8_lookup_data *data = closure;
- scm_i_pthread_mutex_lock (&symbols_lock);
- handle = scm_hash_fn_create_handle_x (symbols, symbol, SCM_UNDEFINED,
- symbol_lookup_hash_fn,
- symbol_lookup_assoc_fn,
- NULL);
- scm_i_pthread_mutex_unlock (&symbols_lock);
+ if (scm_i_symbol_hash (sym) != data->string_hash)
+ return 0;
+
+ if (scm_i_is_narrow_symbol (sym))
+ return (scm_i_symbol_length (sym) == data->len
+ && strncmp (scm_i_symbol_chars (sym), data->str, data->len) == 0);
+ else
+ return utf8_string_equals_wide_string ((const scm_t_uint8 *) data->str,
+ data->len,
+ scm_i_symbol_wide_chars (sym),
+ scm_i_symbol_length (sym));
+}
- return SCM_CAR (handle);
+static SCM
+lookup_interned_utf8_symbol (const char *str, size_t len,
+ unsigned long raw_hash)
+{
+ struct utf8_lookup_data data;
+
+ data.str = str;
+ data.len = len;
+ data.string_hash = raw_hash;
+
+ return scm_c_weak_set_lookup (symbols, raw_hash,
+ utf8_lookup_predicate_fn,
+ &data, SCM_BOOL_F);
}
+static int
+symbol_lookup_predicate_fn (SCM sym, void *closure)
+{
+ SCM other = SCM_PACK_POINTER (closure);
+
+ if (scm_i_symbol_hash (sym) == scm_i_symbol_hash (other)
+ && scm_i_symbol_length (sym) == scm_i_symbol_length (other))
+ {
+ if (scm_i_is_narrow_symbol (sym))
+ return scm_i_is_narrow_symbol (other)
+ && (strncmp (scm_i_symbol_chars (sym),
+ scm_i_symbol_chars (other),
+ scm_i_symbol_length (other)) == 0);
+ else
+ return scm_is_true
+ (scm_string_equal_p (scm_symbol_to_string (sym),
+ scm_symbol_to_string (other)));
+ }
+ return 0;
+}
+
static SCM
scm_i_str2symbol (SCM str)
{
/* The symbol was not found, create it. */
symbol = scm_i_make_symbol (str, 0, raw_hash,
scm_cons (SCM_BOOL_F, SCM_EOL));
- return intern_symbol (symbol);
+
+ /* Might return a different symbol, if another one was interned at
+ the same time. */
+ return scm_c_weak_set_add_x (symbols, raw_hash,
+ symbol_lookup_predicate_fn,
+ SCM_UNPACK_POINTER (symbol), symbol);
}
}
SCM
scm_from_utf8_symboln (const char *sym, size_t len)
{
- SCM str = scm_from_utf8_stringn (sym, len);
- return scm_i_str2symbol (str);
+ unsigned long hash;
+ SCM ret;
+
+ if (len == (size_t) -1)
+ len = strlen (sym);
+ hash = scm_i_utf8_string_hash (sym, len);
+
+ ret = lookup_interned_utf8_symbol (sym, len, hash);
+ if (scm_is_false (ret))
+ {
+ SCM str = scm_from_utf8_stringn (sym, len);
+ ret = scm_i_str2symbol (str);
+ }
+
+ return ret;
}
void
scm_symbols_prehistory ()
{
- symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
+ symbols = scm_c_make_weak_set (5000);
}
#ifndef SCM_SYMBOLS_H
#define SCM_SYMBOLS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#include "libguile/__scm.h"
\f
-#define scm_is_symbol(x) (!SCM_IMP (x) \
- && (SCM_TYP7 (x) == scm_tc7_symbol))
+#define scm_is_symbol(x) (SCM_HAS_TYP7 (x, scm_tc7_symbol))
#define scm_i_symbol_hash(x) ((unsigned long) SCM_CELL_WORD_2 (x))
#define scm_i_symbol_is_interned(x) \
(!(SCM_CELL_WORD_0 (x) & SCM_I_F_SYMBOL_UNINTERNED))
/* internal functions. */
SCM_INTERNAL unsigned long scm_i_hash_symbol (SCM obj, unsigned long n,
- void *closure);
+ void *closure);
SCM_INTERNAL void scm_symbols_prehistory (void);
SCM_INTERNAL void scm_init_symbols (void);
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2012
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
# define SCM_PACK(x) ((SCM) (x))
#endif
+/* Packing SCM objects into and out of pointers.
+ */
+#define SCM_UNPACK_POINTER(x) ((scm_t_bits *) (SCM_UNPACK (x)))
+#define SCM_PACK_POINTER(x) (SCM_PACK ((scm_t_bits) (x)))
+
/* SCM values can not be compared by using the operator ==. Use the following
* macro instead, which is the equivalent of the scheme predicate 'eq?'.
/* Representation of scheme objects:
*
- * Guile's type system is designed to work on systems where scm_t_bits and SCM
- * variables consist of at least 32 bits. The objects that a SCM variable can
- * represent belong to one of the following two major categories:
- *
- * - Immediates -- meaning that the SCM variable contains an entire Scheme
- * object. That means, all the object's data (including the type tagging
- * information that is required to identify the object's type) must fit into
- * 32 bits.
- *
- * - Non-immediates -- meaning that the SCM variable holds a pointer into the
- * heap of cells (see below). On systems where a pointer needs more than 32
- * bits this means that scm_t_bits and SCM variables need to be large enough
- * to hold such pointers. In contrast to immediates, the object's data of
- * a non-immediate can consume arbitrary amounts of memory: The heap cell
- * being pointed to consists of at least two scm_t_bits variables and thus
- * can be used to hold pointers to malloc'ed memory of any size.
- *
- * The 'heap' is the memory area that is under control of Guile's garbage
- * collector. It holds 'single-cells' or 'double-cells', which consist of
- * either two or four scm_t_bits variables, respectively. It is guaranteed
- * that the address of a cell on the heap is 8-byte aligned. That is, since
- * non-immediates hold a cell address, the three least significant bits of a
- * non-immediate can be used to store additional information. The bits are
- * used to store information about the object's type and thus are called
- * tc3-bits, where tc stands for type-code.
- *
- * For a given SCM value, the distinction whether it holds an immediate or
- * non-immediate object is based on the tc3-bits (see above) of its scm_t_bits
+ * Guile's type system is designed to work on systems where scm_t_bits
+ * and SCM variables consist of at least 32 bits. The objects that a
+ * SCM variable can represent belong to one of the following two major
+ * categories:
+ *
+ * - Immediates -- meaning that the SCM variable contains an entire
+ * Scheme object. That means, all the object's data (including the
+ * type tagging information that is required to identify the object's
+ * type) must fit into 32 bits.
+ *
+ * - Heap objects -- meaning that the SCM variable holds a pointer into
+ * the heap. On systems where a pointer needs more than 32 bits this
+ * means that scm_t_bits and SCM variables need to be large enough to
+ * hold such pointers. In contrast to immediates, the data associated
+ * with a heap object can consume arbitrary amounts of memory.
+ *
+ * The 'heap' is the memory area that is under control of Guile's
+ * garbage collector. It holds allocated memory of various sizes. The
+ * impact on the runtime type system is that Guile needs to be able to
+ * determine the type of an object given the pointer. Usually the way
+ * that Guile does this is by storing a "type tag" in the first word of
+ * the object.
+ *
+ * Some objects are common enough that they get special treatment.
+ * Since Guile guarantees that the address of a GC-allocated object on
+ * the heap is 8-byte aligned, Guile can play tricks with the lower 3
+ * bits. That is, since heap objects encode a pointer to an
+ * 8-byte-aligned pointer, the three least significant bits of a SCM can
+ * be used to store additional information. The bits are used to store
+ * information about the object's type and thus are called tc3-bits,
+ * where tc stands for type-code.
+ *
+ * For a given SCM value, the distinction whether it holds an immediate
+ * or heap object is based on the tc3-bits (see above) of its scm_t_bits
* equivalent: If the tc3-bits equal #b000, then the SCM value holds a
- * non-immediate, and the scm_t_bits variable's value is just the pointer to
- * the heap cell.
+ * heap object, and the scm_t_bits variable's value is just the pointer
+ * to the heap cell.
*
* Summarized, the data of a scheme object that is represented by a SCM
- * variable consists of a) the SCM variable itself, b) in case of
- * non-immediates the data of the single-cell or double-cell the SCM object
- * points to, c) in case of non-immediates potentially additional data outside
- * of the heap (like for example malloc'ed data), and d) in case of
- * non-immediates potentially additional data inside of the heap, since data
- * stored in b) and c) may hold references to other cells.
+ * variable consists of a) the SCM variable itself, b) in case of heap
+ * objects memory that the SCM object points to, c) in case of heap
+ * objects potentially additional data outside of the heap (like for
+ * example malloc'ed data), and d) in case of heap objects potentially
+ * additional data inside of the heap, since data stored in b) and c)
+ * may hold references to other cells.
*
*
* Immediates
*
* Operations on immediate objects can typically be processed faster than on
- * non-immediates. The reason is that the object's data can be extracted
+ * heap objects. The reason is that the object's data can be extracted
* directly from the SCM variable (or rather a corresponding scm_t_bits
* variable), instead of having to perform additional memory accesses to
* obtain the object's data from the heap. In order to get the best possible
* special objects listed above.
*
*
- * Non-Immediates
- *
- * All object types not mentioned above in the list of immedate objects are
- * represented as non-immediates. Whether a non-immediate scheme object is
- * represented by a single-cell or a double-cell depends on the object's type,
- * namely on the set of attributes that have to be stored with objects of that
- * type. Every non-immediate type is allowed to define its own layout and
- * interpretation of the data stored in its cell (with some restrictions, see
- * below).
- *
- * One of the design goals of guile's type system is to make it possible to
- * store a scheme pair with as little memory usage as possible. The minimum
- * amount of memory that is required to store two scheme objects (car and cdr
- * of a pair) is the amount of memory required by two scm_t_bits or SCM
- * variables. Therefore pairs in guile are stored in single-cells.
- *
- * Another design goal for the type system is to store procedure objects
- * created by lambda expresssions (closures) and class instances (goops
- * objects) with as little memory usage as possible. Closures are represented
- * by a reference to the function code and a reference to the closure's
- * environment. Class instances are represented by a reference to the
- * instance's class definition and a reference to the instance's data. Thus,
- * closures as well as class instances also can be stored in single-cells.
- *
- * Certain other non-immediate types also store their data in single-cells.
- * By design decision, the heap is split into areas for single-cells and
- * double-cells, but not into areas for single-cells-holding-pairs and areas
- * for single-cells-holding-non-pairs. Any single-cell on the heap therefore
- * can hold pairs (consisting of two scm_t_bits variables representing two
- * scheme objects - the car and cdr of the pair) and non-pairs (consisting of
- * two scm_t_bits variables that hold bit patterns as defined by the layout of
- * the corresponding object's type).
+ * Heap Objects
+ *
+ * All object types not mentioned above in the list of immedate objects
+ * are represented as heap objects. The amount of memory referenced by
+ * a heap object depends on the object's type, namely on the set of
+ * attributes that have to be stored with objects of that type. Every
+ * heap object type is allowed to define its own layout and
+ * interpretation of the data stored in its cell (with some
+ * restrictions, see below).
+ *
+ * One of the design goals of guile's type system is to make it possible
+ * to store a scheme pair with as little memory usage as possible. The
+ * minimum amount of memory that is required to store two scheme objects
+ * (car and cdr of a pair) is the amount of memory required by two
+ * scm_t_bits or SCM variables. Therefore pairs in guile are stored in
+ * two words, and are tagged with a bit pattern in the SCM value, not
+ * with a type tag on the heap.
*
*
* Garbage collection
*
- * During garbage collection, unreachable cells on the heap will be freed.
- * That is, the garbage collector will detect cells which have no SCM variable
- * pointing towards them. In order to properly release all memory belonging
- * to the object to which a cell belongs, the gc needs to be able to interpret
- * the cell contents in the correct way. That means that the gc needs to be
- * able to determine the object type associated with a cell only from the cell
- * itself.
- *
- * Consequently, if the gc detects an unreachable single-cell, those two
- * scm_t_bits variables must provide enough information to determine whether
- * they belong to a pair (i. e. both scm_t_bits variables represent valid
- * scheme objects), to a closure, a class instance or if they belong to any
- * other non-immediate. Guile's type system is designed to make it possible
- * to determine a the type to which a cell belongs in the majority of cases
- * from the cell's first scm_t_bits variable. (Given a SCM variable X holding
- * a non-immediate object, the macro SCM_CELL_TYPE(X) will deliver the
- * corresponding cell's first scm_t_bits variable.)
- *
- * If the cell holds a scheme pair, then we already know that the first
- * scm_t_bits variable of the cell will hold a scheme object with one of the
- * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b110
- * (small integer), #b100 (non-integer immediate). All these tc3-codes have
- * in common, that their least significant bit is #b0. This fact is used by
- * the garbage collector to identify cells that hold pairs. The remaining
- * tc3-codes are assigned as follows: #b001 (class instance or, more
- * precisely, a struct, of which a class instance is a special case), #b011
- * (closure), #b101/#b111 (all remaining non-immediate types).
+ * During garbage collection, unreachable objects on the heap will be
+ * freed. To determine the set of reachable objects, by default, the GC
+ * just traces all words in all heap objects. It is possible to
+ * register custom tracing ("marking") procedures.
+ *
+ * If an object is unreachable, by default, the GC just notes this fact
+ * and moves on. Later allocations will clear out the memory associated
+ * with the object, and re-use it. It is possible to register custom
+ * finalizers, however.
+ *
+ *
+ * Run-time type introspection
+ *
+ * Guile's type system is designed to make it possible to determine a
+ * the type of a heap object from the object's first scm_t_bits
+ * variable. (Given a SCM variable X holding a heap object, the macro
+ * SCM_CELL_TYPE(X) will deliver the corresponding object's first
+ * scm_t_bits variable.)
+ *
+ * If the object holds a scheme pair, then we already know that the
+ * first scm_t_bits variable of the cell will hold a scheme object with
+ * one of the following tc3-codes: #b000 (heap object), #b010 (small
+ * integer), #b110 (small integer), #b100 (non-integer immediate). All
+ * these tc3-codes have in common, that their least significant bit is
+ * #b0. This fact is used by the garbage collector to identify cells
+ * that hold pairs. The remaining tc3-codes are assigned as follows:
+ * #b001 (class instance or, more precisely, a struct, of which a class
+ * instance is a special case), #b011 (closure), #b101/#b111 (all
+ * remaining heap object types).
*
*
* Summary of type codes of scheme objects (SCM variables)
* of the SCM variables corresponding scm_t_bits value.
*
* Note that (as has been explained above) tc1==1 can only occur in the first
- * scm_t_bits variable of a cell belonging to a non-immediate object that is
+ * scm_t_bits variable of a cell belonging to a heap object that is
* not a pair. For an explanation of the tc tags with tc1==1, see the next
* section with the summary of the type codes on the heap.
*
* (1: This can never be the case for a scheme object.)
*
* tc2:
- * 00: Either a non-immediate or some non-integer immediate
+ * 00: Either a heap object or some non-integer immediate
* (01: This can never be the case for a scheme object.)
* 10: Small integer
* (11: This can never be the case for a scheme object.)
*
* tc3:
- * 000: a non-immediate object (pair, closure, class instance etc.)
+ * 000: a heap object (pair, closure, class instance etc.)
* (001: This can never be the case for a scheme object.)
* 010: an even small integer (least significant bit is 0).
* (011: This can never be the case for a scheme object.)
* 110: an odd small integer (least significant bit is 1).
* (111: This can never be the case for a scheme object.)
*
- * The remaining bits of the non-immediate objects form the pointer to the
- * heap cell. The remaining bits of the small integers form the integer's
+ * The remaining bits of the heap objects form the pointer to the heap
+ * cell. The remaining bits of the small integers form the integer's
* value and sign. Thus, the only scheme objects for which a further
* subdivision is of interest are the ones with tc3==100.
*
*
* tc2:
* 00: the cell belongs to a pair with no short integer in its car.
- * 01: the cell belongs to a non-pair (struct or some other non-immediate).
+ * 01: the cell belongs to a non-pair (struct or some other heap object).
* 10: the cell belongs to a pair with a short integer in its car.
- * 11: the cell belongs to a non-pair (closure or some other non-immediate).
+ * 11: the cell belongs to a non-pair (closure or some other heap object).
*
* tc3:
- * 000: the cell belongs to a pair with a non-immediate in its car.
+ * 000: the cell belongs to a pair with a heap object in its car.
* 001: the cell belongs to a struct
* 010: the cell belongs to a pair with an even short integer in its car.
* 011: the cell belongs to a closure
* 100: the cell belongs to a pair with a non-integer immediate in its car.
- * 101: the cell belongs to some other non-immediate.
+ * 101: the cell belongs to some other heap object.
* 110: the cell belongs to a pair with an odd short integer in its car.
- * 111: the cell belongs to some other non-immediate.
+ * 111: the cell belongs to some other heap object.
*
* tc7 (for tc3==1x1):
* See below for the list of types. Note the special case of scm_tc7_vector
\f
-/* Checking if a SCM variable holds an immediate or a non-immediate object:
+/* Checking if a SCM variable holds an immediate or a heap object:
* This check can either be performed by checking for tc3==000 or tc3==00x,
* since for a SCM variable it is known that tc1==0. */
#define SCM_IMP(x) (6 & SCM_UNPACK (x))
#define SCM_NIMP(x) (!SCM_IMP (x))
+#define SCM_HEAP_OBJECT_P(x) (SCM_NIMP (x))
/* Checking if a SCM variable holds an immediate integer: See numbers.h for
* the definition of the following macros: SCM_I_FIXNUM_BIT,
/* Checking if a SCM variable holds a pair (for historical reasons, in Guile
* also known as a cons-cell): This is done by first checking that the SCM
- * variable holds a non-immediate, and second, by checking that tc1==0 holds
+ * variable holds a heap object, and second, by checking that tc1==0 holds
* for the SCM_CELL_TYPE of the SCM variable.
*/
#define SCM_ITAG7(x) (127 & SCM_UNPACK (x))
#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CELL_TYPE (x))
+#define SCM_HAS_HEAP_TYPE(x, type, tag) \
+ (SCM_NIMP (x) && type (x) == (tag))
+#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
+#define SCM_HAS_TYP7S(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7S, tag))
#define scm_tc7_symbol 5
#define scm_tc7_variable 7
#define scm_tc7_with_fluids 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
-#define scm_tc7_array 85
-#define scm_tc7_bitvector 87
-#define scm_tc7_unused_20 93
-#define scm_tc7_unused_11 95
+#define scm_tc7_weak_set 85
+#define scm_tc7_weak_table 87
+#define scm_tc7_array 93
+#define scm_tc7_bitvector 95
#define scm_tc7_unused_12 101
#define scm_tc7_unused_18 103
#define scm_tc7_unused_13 109
/* Definitions for tc16: */
#define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x))
-#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag))
+#define SCM_HAS_TYP16(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP16, tag))
+#define SCM_TYP16_PREDICATE(tag, x) (SCM_HAS_TYP16 (x, tag))
\f
case scm_tc2_int + 112: case scm_tc2_int + 116: case scm_tc3_imm24 + 112:\
case scm_tc2_int + 120: case scm_tc2_int + 124: case scm_tc3_imm24 + 120
-/* For cons pairs with non-immediate values in the SCM_CAR
+/* For cons pairs with heap objects in the SCM_CAR
*/
#define scm_tcs_cons_nimcar \
scm_tc3_cons + 0:\
\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 */
/*
#include "libguile/init.h"
#include "libguile/scmsigs.h"
#include "libguile/strings.h"
-#include "libguile/weaks.h"
#include <full-read.h>
else
id = u.um;
- scm_puts ("#<thread ", port);
+ scm_puts_unlocked ("#<thread ", port);
scm_uintprint (id, 10, port);
- scm_puts (" (", port);
+ scm_puts_unlocked (" (", port);
scm_uintprint ((scm_t_bits)t, 16, port);
- scm_puts (")>", port);
+ scm_puts_unlocked (")>", port);
return 1;
}
static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (thread_admin_mutex);
static scm_i_thread *all_threads = NULL;
static int thread_count;
{
scm_i_thread *t = (scm_i_thread *) v;
- /* Ensure the signal handling thread has been launched, because we might be
- shutting it down. This needs to be done in Guile mode. */
- scm_i_ensure_signal_delivery_thread ();
-
if (!scm_is_false (t->cleanup_handler))
{
SCM ptr = t->cleanup_handler;
while (!scm_is_null (t->mutexes))
{
- SCM mutex = SCM_WEAK_PAIR_CAR (t->mutexes);
+ SCM mutex = scm_c_weak_vector_ref (scm_car (t->mutexes), 0);
- if (!SCM_UNBNDP (mutex))
+ if (scm_is_true (mutex))
{
fat_mutex *m = SCM_MUTEX_DATA (mutex);
scm_i_pthread_mutex_unlock (&m->lock);
}
- t->mutexes = SCM_WEAK_PAIR_CDR (t->mutexes);
+ t->mutexes = scm_cdr (t->mutexes);
}
scm_i_pthread_mutex_unlock (&t->admin_mutex);
fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_mutex *m = SCM_MUTEX_DATA (mx);
- scm_puts ("#<mutex ", port);
+ scm_puts_unlocked ("#<mutex ", port);
scm_uintprint ((scm_t_bits)m, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
The weak pair itself is eventually removed when MUTEX
is unlocked. Note that `t->mutexes' lists mutexes
currently held by T, so it should be small. */
- t->mutexes = scm_weak_car_pair (mutex, t->mutexes);
+ t->mutexes = scm_cons (scm_make_weak_vector (SCM_INUM1, mutex),
+ t->mutexes);
scm_i_pthread_mutex_unlock (&t->admin_mutex);
}
#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
+static void
+remove_mutex_from_thread (SCM mutex, scm_i_thread *t)
+{
+ SCM walk, prev;
+
+ for (prev = SCM_BOOL_F, walk = t->mutexes; scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (mutex, scm_c_weak_vector_ref (SCM_CAR (walk), 0)))
+ {
+ if (scm_is_pair (prev))
+ SCM_SETCDR (prev, SCM_CDR (walk));
+ else
+ t->mutexes = SCM_CDR (walk);
+ break;
+ }
+ }
+}
+
static int
fat_mutex_unlock (SCM mutex, SCM cond,
const scm_t_timespec *waittime, int relock)
if (m->level == 0)
{
/* Change the owner of MUTEX. */
- t->mutexes = scm_delq_x (mutex, t->mutexes);
+ remove_mutex_from_thread (mutex, t);
m->owner = unblock_from_queue (m->waiting);
}
}
t->block_asyncs--;
- scm_async_click ();
+ scm_async_tick ();
scm_remember_upto_here_2 (cond, mutex);
if (m->level == 0)
{
/* Change the owner of MUTEX. */
- t->mutexes = scm_delq_x (mutex, t->mutexes);
+ remove_mutex_from_thread (mutex, t);
m->owner = unblock_from_queue (m->waiting);
}
fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
fat_cond *c = SCM_CONDVAR_DATA (cv);
- scm_puts ("#<condition-variable ", port);
+ scm_puts_unlocked ("#<condition-variable ", port);
scm_uintprint ((scm_t_bits)c, 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return 1;
}
/* This mutex is used by SCM_CRITICAL_SECTION_START/END.
*/
scm_i_pthread_mutex_t scm_i_critical_section_mutex;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_critical_section_mutex);
static SCM dynwind_critical_section_mutex;
/*** Initialization */
scm_i_pthread_mutex_t scm_i_misc_mutex;
+SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX (scm_i_misc_mutex);
#if SCM_USE_PTHREAD_THREADS
pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
#ifndef SCM_THREADS_H
#define SCM_THREADS_H
-/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_VALIDATE_CONDVAR(pos, a) \
scm_assert_smob_type (scm_tc16_condvar, (a))
+#define SCM_PTHREAD_ATFORK_LOCK_STATIC_MUTEX(m) \
+ SCM_SNARF_HERE(SCM_DEFINE_ATFORK_HANDLERS_FOR_MUTEX(&m,lock_##m,unlock_##m))\
+ SCM_SNARF_INIT(scm_i_pthread_atfork (lock_##m, unlock_##m, unlock_##m);)
+
SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
scm_t_catch_handler handler, void *handler_data);
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);
int
scm_exit_status (SCM args)
{
- if (!SCM_NULL_OR_NIL_P (args))
+ if (scm_is_pair (args))
{
SCM cqa = SCM_CAR (args);
if (scm_is_integer (cqa))
return (scm_to_int (cqa));
else if (scm_is_false (cqa))
- return 1;
+ return EXIT_FAILURE;
+ else
+ return EXIT_SUCCESS;
}
- return 0;
+ else if (scm_is_null (args))
+ return EXIT_SUCCESS;
+ else
+ /* A type error. Strictly speaking we shouldn't get here. */
+ return EXIT_FAILURE;
}
if (should_print_backtrace (tag, stack))
{
- scm_puts ("Backtrace:\n", p);
+ scm_puts_unlocked ("Backtrace:\n", p);
scm_display_backtrace_with_highlights (stack, p,
SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL);
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define SCM_VALIDATE_ARRAY(pos, v) \
do { \
- SCM_ASSERT (!SCM_IMP (v) \
+ SCM_ASSERT (SCM_HEAP_OBJECT_P (v) \
&& scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
v, pos, FUNC_NAME); \
} while (0)
SCM port = SCM_PORT_WITH_PS_PORT (pwps);
scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
- scm_puts ("#<values ", port);
+ scm_puts_unlocked ("#<values ", port);
scm_iprin1 (values, port, ps);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
return SCM_UNSPECIFIED;
}
void
scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<variable ", port);
+ scm_puts_unlocked ("#<variable ", port);
scm_uintprint (SCM_UNPACK (exp), 16, port);
- scm_puts (" value: ", port);
+ scm_puts_unlocked (" value: ", port);
scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
- scm_putc('>', port);
+ scm_putc_unlocked('>', port);
}
\f
#ifndef SCM_VARIABLE_H
#define SCM_VARIABLE_H
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
/* Variables
*/
-#define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_TYP7(X) == scm_tc7_variable)
+#define SCM_VARIABLEP(X) (SCM_HAS_TYP7 (X, scm_tc7_variable))
#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1 (V)
#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
#define SCM_VARIABLE_LOC(V) (SCM_CELL_OBJECT_LOC ((V), 1))
size_t *lenp, ssize_t *incp)
{
if (SCM_I_WVECTP (vec))
- /* FIXME: We should check each (weak) element of the vector for NULL and
- convert it to SCM_BOOL_F. */
- abort ();
+ scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_generalized_vector_get_handle (vec, h);
if (lenp)
size_t *lenp, ssize_t *incp)
{
if (SCM_I_WVECTP (vec))
- /* FIXME: We should check each (weak) element of the vector for NULL and
- convert it to SCM_BOOL_F. */
- abort ();
+ scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_generalized_vector_get_handle (vec, h);
if (lenp)
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
scm_c_vector_ref (SCM v, size_t k)
{
- if (SCM_I_IS_VECTOR (v))
+ if (SCM_I_IS_NONWEAK_VECTOR (v))
{
- register SCM elt;
-
if (k >= SCM_I_VECTOR_LENGTH (v))
scm_out_of_range (NULL, scm_from_size_t (k));
- elt = (SCM_I_VECTOR_ELTS(v))[k];
-
- if (SCM_UNPACK (elt) == 0 && SCM_I_WVECTP (v))
- /* ELT was a weak pointer and got nullified by the GC. */
- return SCM_BOOL_F;
-
- return elt;
+ return SCM_SIMPLE_VECTOR_REF (v, k);
}
+ else if (SCM_I_WVECTP (v))
+ return scm_c_weak_vector_ref (v, k);
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
{
scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- register SCM elt;
-
- if (k >= dim->ubnd - dim->lbnd + 1)
- scm_out_of_range (NULL, scm_from_size_t (k));
- k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
- elt = (SCM_I_VECTOR_ELTS (vv))[k];
-
- if (SCM_UNPACK (elt) == 0 && (SCM_I_WVECTP (vv)))
- /* ELT was a weak pointer and got nullified by the GC. */
- return SCM_BOOL_F;
-
- return elt;
- }
- scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
+
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ if (SCM_I_IS_NONWEAK_VECTOR (vv))
+ return SCM_SIMPLE_VECTOR_REF (vv, k);
+ else if (SCM_I_WVECTP (vv))
+ return scm_c_weak_vector_ref (vv, k);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
- SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
+ return scm_wta_dispatch_2 (g_vector_ref, v, scm_from_size_t (k), 2,
+ "vector-ref");
}
SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
void
scm_c_vector_set_x (SCM v, size_t k, SCM obj)
{
- if (SCM_I_IS_VECTOR (v))
+ if (SCM_I_IS_NONWEAK_VECTOR (v))
{
if (k >= SCM_I_VECTOR_LENGTH (v))
- scm_out_of_range (NULL, scm_from_size_t (k));
- (SCM_I_VECTOR_WELTS(v))[k] = obj;
- if (SCM_I_WVECTP (v))
- {
- /* Make it a weak pointer. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (v))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) SCM2PTR (obj));
- }
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ SCM_SIMPLE_VECTOR_SET (v, k, obj);
}
+ else if (SCM_I_WVECTP (v))
+ scm_c_weak_vector_set_x (v, k, obj);
else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
{
scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
SCM vv = SCM_I_ARRAY_V (v);
- if (SCM_I_IS_VECTOR (vv))
- {
- if (k >= dim->ubnd - dim->lbnd + 1)
- scm_out_of_range (NULL, scm_from_size_t (k));
- k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
- (SCM_I_VECTOR_WELTS (vv))[k] = obj;
-
- if (SCM_I_WVECTP (vv))
- {
- /* Make it a weak pointer. */
- GC_PTR link = (GC_PTR) & ((SCM_I_VECTOR_WELTS (vv))[k]);
- SCM_I_REGISTER_DISAPPEARING_LINK (link,
- (GC_PTR) SCM2PTR (obj));
- }
- }
+
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ if (SCM_I_IS_NONWEAK_VECTOR (vv))
+ SCM_SIMPLE_VECTOR_SET (vv, k, obj);
+ else if (SCM_I_WVECTP (vv))
+ scm_c_weak_vector_set_x (vv, k, obj);
else
scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
}
else
{
if (SCM_UNPACK (g_vector_set_x))
- scm_apply_generic (g_vector_set_x,
- scm_list_3 (v, scm_from_size_t (k), obj));
+ scm_wta_dispatch_n (g_vector_set_x,
+ scm_list_3 (v, scm_from_size_t (k), obj),
+ 0,
+ "vector-set!");
else
scm_wrong_type_arg_msg (NULL, 0, v, "vector");
}
scm_c_make_vector (size_t k, SCM fill)
#define FUNC_NAME s_scm_make_vector
{
- SCM *vector;
-
- vector = (SCM *)
- scm_gc_malloc ((k + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM),
- "vector");
+ SCM vector;
+ unsigned long int j;
- if (k > 0)
- {
- SCM *base;
- unsigned long int j;
-
- SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
+ SCM_ASSERT_RANGE (1, scm_from_size_t (k), k <= VECTOR_MAX_LENGTH);
- base = vector + SCM_I_VECTOR_HEADER_SIZE;
- for (j = 0; j != k; ++j)
- base[j] = fill;
- }
+ vector = scm_words ((k << 8) | scm_tc7_vector, k + 1);
- ((scm_t_bits *) vector)[0] = (k << 8) | scm_tc7_vector;
- ((scm_t_bits *) vector)[1] = 0;
+ for (j = 0; j < k; ++j)
+ SCM_SIMPLE_VECTOR_SET (vector, j, fill);
- return PTR2SCM (vector);
+ return vector;
}
#undef FUNC_NAME
#undef FUNC_NAME
\f
-/* Weak vectors. */
-
-/* Allocate memory for the elements of a weak vector on behalf of the
- caller. */
-static SCM
-make_weak_vector (scm_t_bits type, size_t c_size)
-{
- SCM *vector;
- size_t total_size;
-
- total_size = (c_size + SCM_I_VECTOR_HEADER_SIZE) * sizeof (SCM);
- vector = (SCM *) scm_gc_malloc_pointerless (total_size, "weak vector");
-
- ((scm_t_bits *) vector)[0] = (c_size << 8) | scm_tc7_wvect;
- ((scm_t_bits *) vector)[1] = type;
-
- return PTR2SCM (vector);
-}
-
-/* Return a new weak vector. The allocated vector will be of the given weak
- vector subtype. It will contain SIZE elements which are initialized with
- the FILL object, or, if FILL is undefined, with an unspecified object. */
-SCM
-scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill)
-{
- SCM wv, *base;
- size_t c_size, j;
-
- if (SCM_UNBNDP (fill))
- fill = SCM_UNSPECIFIED;
-
- c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
- wv = make_weak_vector (type, c_size);
- base = SCM_I_WVECT_GC_WVELTS (wv);
-
- for (j = 0; j != c_size; ++j)
- base[j] = fill;
-
- return wv;
-}
-
-/* Return a new weak vector with type TYPE and whose content are taken from
- list LST. */
-SCM
-scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst)
-{
- SCM wv, *elt;
- long c_size;
-
- c_size = scm_ilength (lst);
- SCM_ASSERT (c_size >= 0, lst, SCM_ARG2, "scm_i_make_weak_vector_from_list");
-
- wv = make_weak_vector(type, (size_t) c_size);
-
- for (elt = SCM_I_WVECT_GC_WVELTS (wv);
- scm_is_pair (lst);
- lst = SCM_CDR (lst), elt++)
- {
- *elt = SCM_CAR (lst);
- }
-
- return wv;
-}
-
-
-\f
SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
(SCM v),
"Return a newly allocated list composed of the elements of @var{v}.\n"
#ifndef SCM_VECTORS_H
#define SCM_VECTORS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
\f
/* Internals */
-/* Vectors have a 2-word header: 1 for the type tag, and 1 for the weak
- vector extra data (see below.) */
-#define SCM_I_VECTOR_HEADER_SIZE 2U
-
-#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
-#define SCM_I_IS_NONWEAK_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7(x)==scm_tc7_vector))
+#define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7S (x, scm_tc7_vector))
+#define SCM_I_IS_NONWEAK_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector))
#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x))
-#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, SCM_I_VECTOR_HEADER_SIZE))
+#define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1))
#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
SCM_INTERNAL SCM scm_i_vector_equal_p (SCM x, SCM y);
-/* Weak vectors share implementation details with ordinary vectors,
- but no one else should. */
-
-#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \
- SCM_TYP7 (x) == scm_tc7_wvect)
-#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
-#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
-#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
-#define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_1 (x))
-#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_1 ((x),(t)))
-
-SCM_INTERNAL SCM scm_i_make_weak_vector (scm_t_bits type, SCM size, SCM fill);
-SCM_INTERNAL SCM scm_i_make_weak_vector_from_list (scm_t_bits type, SCM lst);
SCM_INTERNAL void scm_init_vectors (void);
}
\f
+/*
+ * Strings
+ */
+
+VM_DEFINE_FUNCTION (163, string_length, "string-length", 1)
+{
+ ARGS1 (str);
+ if (SCM_LIKELY (scm_is_string (str)))
+ RETURN (SCM_I_MAKINUM (scm_i_string_length (str)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_length (str));
+ }
+}
+
+VM_DEFINE_FUNCTION (164, string_ref, "string-ref", 2)
+{
+ scm_t_signed_bits i = 0;
+ ARGS2 (str, idx);
+ if (SCM_LIKELY (scm_is_string (str)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < scm_i_string_length (str)))
+ RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_string_ref (str, idx));
+ }
+}
+
+/* No string-set! instruction, as there is no good fast path there. */
+
+\f
/*
* Vectors and arrays
*/
-VM_DEFINE_FUNCTION (163, vector_ref, "vector-ref", 2)
+VM_DEFINE_FUNCTION (165, vector_length, "vector-length", 1)
+{
+ ARGS1 (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)))
+ RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect)));
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_length (vect));
+ }
+}
+
+VM_DEFINE_FUNCTION (166, vector_ref, "vector-ref", 2)
{
scm_t_signed_bits i = 0;
ARGS2 (vect, idx);
}
}
-VM_DEFINE_INSTRUCTION (164, vector_set, "vector-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (167, vector_set, "vector-set", 0, 3, 0)
{
scm_t_signed_bits i = 0;
SCM vect, idx, val;
NEXT;
}
-VM_DEFINE_INSTRUCTION (165, make_array, "make-array", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (168, make_array, "make-array", 3, -1, 1)
{
scm_t_uint32 len;
SCM shape, ret;
goto vm_error_not_a_struct; \
}
-VM_DEFINE_FUNCTION (166, struct_p, "struct?", 1)
+VM_DEFINE_FUNCTION (169, struct_p, "struct?", 1)
{
ARGS1 (obj);
RETURN (scm_from_bool (SCM_STRUCTP (obj)));
}
-VM_DEFINE_FUNCTION (167, struct_vtable, "struct-vtable", 1)
+VM_DEFINE_FUNCTION (170, struct_vtable, "struct-vtable", 1)
{
ARGS1 (obj);
VM_VALIDATE_STRUCT (obj, "struct_vtable");
RETURN (SCM_STRUCT_VTABLE (obj));
}
-VM_DEFINE_INSTRUCTION (168, make_struct, "make-struct", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (171, make_struct, "make-struct", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
NEXT;
}
-VM_DEFINE_FUNCTION (169, struct_ref, "struct-ref", 2)
+VM_DEFINE_FUNCTION (172, struct_ref, "struct-ref", 2)
{
ARGS2 (obj, pos);
RETURN (scm_struct_ref (obj, pos));
}
-VM_DEFINE_FUNCTION (170, struct_set, "struct-set", 3)
+VM_DEFINE_FUNCTION (173, struct_set, "struct-set", 3)
{
ARGS3 (obj, pos, val);
/*
* GOOPS support
*/
-VM_DEFINE_FUNCTION (171, class_of, "class-of", 1)
+VM_DEFINE_FUNCTION (174, class_of, "class-of", 1)
{
ARGS1 (obj);
if (SCM_INSTANCEP (obj))
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_FUNCTION (172, slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (175, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
}
/* FIXME: No checking whatsoever. */
-VM_DEFINE_INSTRUCTION (173, slot_set, "slot-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (176, slot_set, "slot-set", 0, 3, 0)
{
SCM instance, idx, val;
size_t slot;
#define ALIGNED_P(ptr, type) \
((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
-VM_DEFINE_FUNCTION (174, bv_u16_ref, "bv-u16-ref", 3)
+VM_DEFINE_FUNCTION (177, bv_u16_ref, "bv-u16-ref", 3)
BV_REF_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_FUNCTION (175, bv_s16_ref, "bv-s16-ref", 3)
+VM_DEFINE_FUNCTION (178, bv_s16_ref, "bv-s16-ref", 3)
BV_REF_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_FUNCTION (176, bv_u32_ref, "bv-u32-ref", 3)
+VM_DEFINE_FUNCTION (179, bv_u32_ref, "bv-u32-ref", 3)
BV_REF_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_FUNCTION (177, bv_s32_ref, "bv-s32-ref", 3)
+VM_DEFINE_FUNCTION (180, bv_s32_ref, "bv-s32-ref", 3)
BV_REF_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_FUNCTION (178, bv_u64_ref, "bv-u64-ref", 3)
+VM_DEFINE_FUNCTION (181, bv_u64_ref, "bv-u64-ref", 3)
BV_REF_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_FUNCTION (179, bv_s64_ref, "bv-s64-ref", 3)
+VM_DEFINE_FUNCTION (182, bv_s64_ref, "bv-s64-ref", 3)
BV_REF_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_FUNCTION (180, bv_f32_ref, "bv-f32-ref", 3)
+VM_DEFINE_FUNCTION (183, bv_f32_ref, "bv-f32-ref", 3)
BV_REF_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_FUNCTION (181, bv_f64_ref, "bv-f64-ref", 3)
+VM_DEFINE_FUNCTION (184, bv_f64_ref, "bv-f64-ref", 3)
BV_REF_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_REF_WITH_ENDIANNESS
RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \
}
-VM_DEFINE_FUNCTION (182, bv_u8_ref, "bv-u8-ref", 2)
+VM_DEFINE_FUNCTION (185, bv_u8_ref, "bv-u8-ref", 2)
BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
-VM_DEFINE_FUNCTION (183, bv_s8_ref, "bv-s8-ref", 2)
+VM_DEFINE_FUNCTION (186, bv_s8_ref, "bv-s8-ref", 2)
BV_FIXABLE_INT_REF (s8, s8, int8, 1)
-VM_DEFINE_FUNCTION (184, bv_u16_native_ref, "bv-u16-native-ref", 2)
+VM_DEFINE_FUNCTION (187, bv_u16_native_ref, "bv-u16-native-ref", 2)
BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
-VM_DEFINE_FUNCTION (185, bv_s16_native_ref, "bv-s16-native-ref", 2)
+VM_DEFINE_FUNCTION (188, bv_s16_native_ref, "bv-s16-native-ref", 2)
BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
-VM_DEFINE_FUNCTION (186, bv_u32_native_ref, "bv-u32-native-ref", 2)
+VM_DEFINE_FUNCTION (189, bv_u32_native_ref, "bv-u32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4)
#else
BV_INT_REF (u32, uint32, 4)
#endif
-VM_DEFINE_FUNCTION (187, bv_s32_native_ref, "bv-s32-native-ref", 2)
+VM_DEFINE_FUNCTION (190, bv_s32_native_ref, "bv-s32-native-ref", 2)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_REF (s32, s32_native, int32, 4)
#else
BV_INT_REF (s32, int32, 4)
#endif
-VM_DEFINE_FUNCTION (188, bv_u64_native_ref, "bv-u64-native-ref", 2)
+VM_DEFINE_FUNCTION (191, bv_u64_native_ref, "bv-u64-native-ref", 2)
BV_INT_REF (u64, uint64, 8)
-VM_DEFINE_FUNCTION (189, bv_s64_native_ref, "bv-s64-native-ref", 2)
+VM_DEFINE_FUNCTION (192, bv_s64_native_ref, "bv-s64-native-ref", 2)
BV_INT_REF (s64, int64, 8)
-VM_DEFINE_FUNCTION (190, bv_f32_native_ref, "bv-f32-native-ref", 2)
+VM_DEFINE_FUNCTION (193, bv_f32_native_ref, "bv-f32-native-ref", 2)
BV_FLOAT_REF (f32, ieee_single, float, 4)
-VM_DEFINE_FUNCTION (191, bv_f64_native_ref, "bv-f64-native-ref", 2)
+VM_DEFINE_FUNCTION (194, bv_f64_native_ref, "bv-f64-native-ref", 2)
BV_FLOAT_REF (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_REF
} \
}
-VM_DEFINE_INSTRUCTION (192, bv_u16_set, "bv-u16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (195, bv_u16_set, "bv-u16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u16, u16)
-VM_DEFINE_INSTRUCTION (193, bv_s16_set, "bv-s16-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (196, bv_s16_set, "bv-s16-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s16, s16)
-VM_DEFINE_INSTRUCTION (194, bv_u32_set, "bv-u32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (197, bv_u32_set, "bv-u32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u32, u32)
-VM_DEFINE_INSTRUCTION (195, bv_s32_set, "bv-s32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (198, bv_s32_set, "bv-s32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s32, s32)
-VM_DEFINE_INSTRUCTION (196, bv_u64_set, "bv-u64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (199, bv_u64_set, "bv-u64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (u64, u64)
-VM_DEFINE_INSTRUCTION (197, bv_s64_set, "bv-s64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (200, bv_s64_set, "bv-s64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (s64, s64)
-VM_DEFINE_INSTRUCTION (198, bv_f32_set, "bv-f32-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (201, bv_f32_set, "bv-f32-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f32, ieee_single)
-VM_DEFINE_INSTRUCTION (199, bv_f64_set, "bv-f64-set", 0, 4, 0)
+VM_DEFINE_INSTRUCTION (202, bv_f64_set, "bv-f64-set", 0, 4, 0)
BV_SET_WITH_ENDIANNESS (f64, ieee_double)
#undef BV_SET_WITH_ENDIANNESS
NEXT; \
}
-VM_DEFINE_INSTRUCTION (200, bv_u8_set, "bv-u8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (203, bv_u8_set, "bv-u8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (201, bv_s8_set, "bv-s8-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (204, bv_s8_set, "bv-s8-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
-VM_DEFINE_INSTRUCTION (202, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (205, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (203, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (206, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
-VM_DEFINE_INSTRUCTION (204, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (207, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4)
#else
BV_INT_SET (u32, uint32, 4)
#endif
-VM_DEFINE_INSTRUCTION (205, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (208, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
#if SIZEOF_VOID_P > 4
BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4)
#else
BV_INT_SET (s32, int32, 4)
#endif
-VM_DEFINE_INSTRUCTION (206, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (209, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
BV_INT_SET (u64, uint64, 8)
-VM_DEFINE_INSTRUCTION (207, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (210, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
BV_INT_SET (s64, int64, 8)
-VM_DEFINE_INSTRUCTION (208, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (211, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
BV_FLOAT_SET (f32, ieee_single, float, 4)
-VM_DEFINE_INSTRUCTION (209, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+VM_DEFINE_INSTRUCTION (212, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_FIXABLE_INT_SET
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_tail_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
goto vm_mv_call;
}
- else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
+ else if (SCM_HAS_TYP7 (program, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (program))
{
SYNC_REGISTER ();
void
scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<vm-continuation ", port);
+ scm_puts_unlocked ("#<vm-continuation ", port);
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
/* In theory, a number of vm instances can be active in the call trace, and we
frame = (scm_t_cell *) ROUND_UP ((scm_t_uintptr) frame, 8UL);
frame->word_0 = SCM_PACK (scm_tc7_frame);
- frame->word_1 = PTR2SCM (&c_frame);
- args[0] = PTR2SCM (frame);
+ frame->word_1 = SCM_PACK_POINTER (&c_frame);
+ args[0] = SCM_PACK_POINTER (frame);
scm_c_run_hookn (hook, args, 1);
vm = SCM_VM_DATA (x);
- scm_puts ("#<vm ", port);
+ scm_puts_unlocked ("#<vm ", port);
switch (vm->engine)
{
case SCM_VM_REGULAR_ENGINE:
- scm_puts ("regular-engine ", port);
+ scm_puts_unlocked ("regular-engine ", port);
break;
case SCM_VM_DEBUG_ENGINE:
- scm_puts ("debug-engine ", port);
+ scm_puts_unlocked ("debug-engine ", port);
break;
default:
- scm_puts ("unknown-engine ", port);
+ scm_puts_unlocked ("unknown-engine ", port);
}
scm_uintprint (SCM_UNPACK (x), 16, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
static SCM
bp->metalen = 0;
u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
- sizeof (struct scm_objcode) + sizeof (text));
+ sizeof (struct scm_objcode) + sizeof (text),
+ SCM_BOOL_F);
ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
/* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack
top is. */
- *vp->stack_base = PTR2SCM (vp);
+ *vp->stack_base = SCM_PACK_POINTER (vp);
vp->stack_base++;
vp->stack_size--;
#else
SCM_API SCM scm_the_vm_fluid;
-#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
+#define SCM_VM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_vm))
#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_CELL_WORD_1 (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
scm_t_uint32 flags;
};
-#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) == scm_tc7_vm_cont)
+#define SCM_VM_CONT_P(OBJ) (SCM_HAS_TYP7 (OBJ, scm_tc7_vm_cont))
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
#define SCM_VM_CONT_PARTIAL_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_PARTIAL)
#define SCM_VM_CONT_REWINDABLE_P(CONT) (SCM_VM_CONT_DATA (CONT)->flags & SCM_F_VM_CONT_REWINDABLE)
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
return *pt->read_buf;
}
else
- scm_ungetc (SCM_CHAR (ans), port);
+ scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
#define FUNC_NAME s_scm_make_soft_port
{
int vlen;
- scm_t_port *pt;
SCM z;
SCM_VALIDATE_VECTOR (1, pv);
SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
SCM_VALIDATE_STRING (2, modes);
- scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
- z = scm_new_port_table_entry (scm_tc16_sfport);
- pt = SCM_PTAB_ENTRY (z);
- scm_port_non_buffer (pt);
- SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes));
-
- SCM_SETSTREAM (z, SCM_UNPACK (pv));
- scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ z = scm_c_make_port (scm_tc16_sfport, scm_i_mode_bits (modes),
+ SCM_UNPACK (pv));
+ scm_port_non_buffer (SCM_PTAB_ENTRY (z));
+
return z;
}
#undef FUNC_NAME
--- /dev/null
+/* Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/bdw-gc.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-set.h"
+
+
+/* Weak Sets
+
+ This file implements weak sets. One example of a weak set is the
+ symbol table, where you want all instances of the `foo' symbol to map
+ to one object. So when you load a file and it wants a symbol with
+ the characters "foo", you one up in the table, using custom hash and
+ equality predicates. Only if one is not found will you bother to
+ cons one up and intern it.
+
+ Another use case for weak sets is the set of open ports. Guile needs
+ to be able to flush them all when the process exits, but the set
+ shouldn't prevent the GC from collecting the port (and thus closing
+ it).
+
+ Weak sets are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated as an "atomic" piece of memory, so
+ that the GC doesn't trace it. When an item is added to the set, a
+ disappearing link is registered to its location. If the item is
+ collected, then that link will be zeroed out.
+
+ An entry is not just an item, though; the hash code is also stored in
+ the entry. We munge hash codes so that they are never 0. In this
+ way we can detect removed entries (key of zero but nonzero hash
+ code), and can then reshuffle elements as needed to maintain the
+ robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the "keys" (the objects in the set) are stored in an
+ atomic region with disappearing links, they need to be accessed
+ with the GC alloc lock. `copy_weak_entry' will do that for
+ you. The hash code itself can be read outside the lock,
+ though.
+*/
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+
+typedef struct {
+ scm_t_weak_entry *entries; /* the data */
+ scm_i_pthread_mutex_t lock; /* the lock */
+ unsigned long size; /* total number of slots. */
+ unsigned long n_items; /* number of items in set */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashset_size */
+ int min_size_index; /* minimum size_index */
+} scm_t_weak_set;
+
+
+#define SCM_WEAK_SET_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_set))
+#define SCM_VALIDATE_WEAK_SET(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_SET_P, "weak-set")
+#define SCM_WEAK_SET(x) ((scm_t_weak_set *) SCM_CELL_WORD_1 (x))
+
+
+static unsigned long
+hash_to_index (unsigned long hash, unsigned long size)
+{
+ return (hash >> 1) % size;
+}
+
+static unsigned long
+entry_distance (unsigned long hash, unsigned long k, unsigned long size)
+{
+ unsigned long origin = hash_to_index (hash, size);
+
+ if (k >= origin)
+ return k - origin;
+ else
+ /* The other key was displaced and wrapped around. */
+ return size - origin + k;
+}
+
+static void
+move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to)
+{
+ if (from->hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (from, ©);
+ to->hash = copy.hash;
+ to->key = copy.key;
+
+ if (copy.key && SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
+ GC_unregister_disappearing_link ((GC_PTR) &from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &to->key,
+ (GC_PTR) to->key);
+#endif
+ }
+ }
+ else
+ {
+ to->hash = 0;
+ to->key = 0;
+ }
+}
+
+static void
+rob_from_rich (scm_t_weak_set *set, unsigned long k)
+{
+ unsigned long empty, size;
+
+ size = set->size;
+
+ /* If we are to free up slot K in the set, we need room to do so. */
+ assert (set->n_items < size);
+
+ empty = k;
+ do
+ empty = (empty + 1) % size;
+ /* Here we access key outside the lock. Is this a problem? At first
+ glance, I wouldn't think so. */
+ while (set->entries[empty].key);
+
+ do
+ {
+ unsigned long last = empty ? (empty - 1) : (size - 1);
+ move_weak_entry (&set->entries[last], &set->entries[empty]);
+ empty = last;
+ }
+ while (empty != k);
+
+ /* Just for sanity. */
+ set->entries[empty].hash = 0;
+ set->entries[empty].key = 0;
+}
+
+static void
+give_to_poor (scm_t_weak_set *set, unsigned long k)
+{
+ /* Slot K was just freed up; possibly shuffle others down. */
+ unsigned long size = set->size;
+
+ while (1)
+ {
+ unsigned long next = (k + 1) % size;
+ unsigned long hash;
+ scm_t_weak_entry copy;
+
+ hash = set->entries[next].hash;
+
+ if (!hash || hash_to_index (hash, size) == next)
+ break;
+
+ copy_weak_entry (&set->entries[next], ©);
+
+ if (!copy.key)
+ /* Lost weak reference. */
+ {
+ give_to_poor (set, next);
+ set->n_items--;
+ continue;
+ }
+
+ move_weak_entry (&set->entries[next], &set->entries[k]);
+
+ k = next;
+ }
+
+ /* We have shuffled down any entries that should be shuffled down; now
+ free the end. */
+ set->entries[k].hash = 0;
+ set->entries[k].key = 0;
+}
+
+
+\f
+
+/* Growing or shrinking is triggered when the load factor
+ *
+ * L = N / S (N: number of items in set, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.2.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashset object.
+ *
+ * Possible hash set sizes (primes) are stored in the array
+ * hashset_size.
+ */
+
+static unsigned long hashset_size[] = {
+ 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
+ 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
+ 57524111, 115048217, 230096423
+};
+
+#define HASHSET_SIZE_N (sizeof(hashset_size)/sizeof(unsigned long))
+
+static int
+compute_size_index (scm_t_weak_set *set)
+{
+ int i = set->size_index;
+
+ if (set->n_items < set->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ do
+ --i;
+ while (i > set->min_size_index
+ && set->n_items < hashset_size[i] / 5);
+ }
+ else if (set->n_items > set->upper)
+ {
+ ++i;
+ if (i >= HASHSET_SIZE_N)
+ /* The biggest size currently is 230096423, which for a 32-bit
+ machine will occupy 1.5GB of memory at a load of 80%. There
+ is probably something better to do here, but if you have a
+ weak map of that size, you are hosed in any case. */
+ abort ();
+ }
+
+ return i;
+}
+
+static int
+is_acceptable_size_index (scm_t_weak_set *set, int size_index)
+{
+ int computed = compute_size_index (set);
+
+ if (size_index == computed)
+ /* We were going to grow or shrink, and allocating the new vector
+ didn't change the target size. */
+ return 1;
+
+ if (size_index == computed + 1)
+ {
+ /* We were going to enlarge the set, but allocating the new
+ vector finalized some objects, making an enlargement
+ unnecessary. It might still be a good idea to use the larger
+ set, though. (This branch also gets hit if, while allocating
+ the vector, some other thread was actively removing items from
+ the set. That is less likely, though.) */
+ unsigned long new_lower = hashset_size[size_index] / 5;
+
+ return set->size > new_lower;
+ }
+
+ if (size_index == computed - 1)
+ {
+ /* We were going to shrink the set, but when we dropped the lock
+ to allocate the new vector, some other thread added elements to
+ the set. */
+ return 0;
+ }
+
+ /* The computed size differs from our newly allocated size by more
+ than one size index -- recalculate. */
+ return 0;
+}
+
+static void
+resize_set (scm_t_weak_set *set)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int new_size_index;
+ unsigned long old_size, new_size, old_k;
+
+ do
+ {
+ new_size_index = compute_size_index (set);
+ if (new_size_index == set->size_index)
+ return;
+ new_size = hashset_size[new_size_index];
+ scm_i_pthread_mutex_unlock (&set->lock);
+ /* Allocating memory might cause finalizers to run, which could
+ run anything, so drop our lock to avoid deadlocks. */
+ new_entries = scm_gc_malloc_pointerless (new_size * sizeof(scm_t_weak_entry),
+ "weak set");
+ scm_i_pthread_mutex_unlock (&set->lock);
+ }
+ while (!is_acceptable_size_index (set, new_size_index));
+
+ old_entries = set->entries;
+ old_size = set->size;
+
+ memset (new_entries, 0, new_size * sizeof(scm_t_weak_entry));
+
+ set->size_index = new_size_index;
+ set->size = new_size;
+ if (new_size_index <= set->min_size_index)
+ set->lower = 0;
+ else
+ set->lower = new_size / 5;
+ set->upper = 9 * new_size / 10;
+ set->n_items = 0;
+ set->entries = new_entries;
+
+ for (old_k = 0; old_k < old_size; old_k++)
+ {
+ scm_t_weak_entry copy;
+ unsigned long new_k, distance;
+
+ if (!old_entries[old_k].hash)
+ continue;
+
+ copy_weak_entry (&old_entries[old_k], ©);
+
+ if (!copy.key)
+ continue;
+
+ new_k = hash_to_index (copy.hash, new_size);
+
+ for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
+ {
+ unsigned long other_hash = new_entries[new_k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, new_k, new_size) < distance)
+ {
+ rob_from_rich (set, new_k);
+ break;
+ }
+ }
+
+ set->n_items++;
+ new_entries[new_k].hash = copy.hash;
+ new_entries[new_k].key = copy.key;
+
+ if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &new_entries[new_k].key,
+ (GC_PTR) new_entries[new_k].key);
+ }
+}
+
+/* Run after GC via do_vacuum_weak_set, this function runs over the
+ whole table, removing lost weak references, reshuffling the set as it
+ goes. It might resize the set if it reaps enough entries. */
+static void
+vacuum_weak_set (scm_t_weak_set *set)
+{
+ scm_t_weak_entry *entries = set->entries;
+ unsigned long size = set->size;
+ unsigned long k;
+
+ for (k = 0; k < size; k++)
+ {
+ unsigned long hash = entries[k].hash;
+
+ if (hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ }
+ }
+ }
+
+ if (set->n_items < set->lower)
+ resize_set (set);
+}
+
+
+\f
+
+static SCM
+weak_set_lookup (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure,
+ SCM dflt)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return dflt;
+
+ if (hash == other_hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found. */
+ return SCM_PACK (copy.key);
+ }
+
+ /* If the entry's distance is less, our key is not in the set. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return dflt;
+ }
+
+ /* If we got here, then we were unfortunate enough to loop through the
+ whole set. Shouldn't happen, but hey. */
+ return dflt;
+}
+
+
+static SCM
+weak_set_add_x (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure,
+ SCM obj)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; ; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found an entry with this key. */
+ return SCM_PACK (copy.key);
+ }
+
+ if (set->n_items > set->upper)
+ /* Full set, time to resize. */
+ {
+ resize_set (set);
+ return weak_set_add_x (set, hash >> 1, pred, closure, obj);
+ }
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, k, size) < distance)
+ {
+ rob_from_rich (set, k);
+ break;
+ }
+ }
+
+ set->n_items++;
+ entries[k].hash = hash;
+ entries[k].key = SCM_UNPACK (obj);
+
+ if (SCM_HEAP_OBJECT_P (obj))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entries[k].key,
+ (GC_PTR) SCM2PTR (obj));
+
+ return obj;
+}
+
+
+static void
+weak_set_remove_x (scm_t_weak_set *set, unsigned long hash,
+ scm_t_set_predicate_fn pred, void *closure)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = set->size;
+ entries = set->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (set, k);
+ set->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), closure))
+ /* Found an entry with this key. */
+ {
+ entries[k].hash = 0;
+ entries[k].key = 0;
+
+ if (SCM_HEAP_OBJECT_P (SCM_PACK (copy.key)))
+ GC_unregister_disappearing_link ((GC_PTR) &entries[k].key);
+
+ if (--set->n_items < set->lower)
+ resize_set (set);
+ else
+ give_to_poor (set, k);
+
+ return;
+ }
+ }
+
+ /* If the entry's distance is less, our key is not in the set. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return;
+ }
+}
+
+
+\f
+
+static void
+lock_weak_set (scm_t_weak_set *set)
+{
+ scm_i_pthread_mutex_lock (&set->lock);
+}
+
+static void
+unlock_weak_set (scm_t_weak_set *set)
+{
+ scm_i_pthread_mutex_unlock (&set->lock);
+}
+
+/* A weak set of weak sets, for use in the pthread_atfork handler. */
+static SCM all_weak_sets = SCM_BOOL_F;
+
+#if SCM_USE_PTHREAD_THREADS
+
+static void
+lock_all_weak_sets (void)
+{
+ scm_t_weak_set *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+ scm_t_weak_entry copy;
+
+ s = SCM_WEAK_SET (all_weak_sets);
+ lock_weak_set (s);
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash)
+ {
+ copy_weak_entry (&entries[k], ©);
+ if (copy.key)
+ lock_weak_set (SCM_WEAK_SET (SCM_PACK (copy.key)));
+ }
+}
+
+static void
+unlock_all_weak_sets (void)
+{
+ scm_t_weak_set *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+ scm_t_weak_entry copy;
+
+ s = SCM_WEAK_SET (all_weak_sets);
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash)
+ {
+ copy_weak_entry (&entries[k], ©);
+ if (copy.key)
+ unlock_weak_set (SCM_WEAK_SET (SCM_PACK (copy.key)));
+ }
+
+ unlock_weak_set (s);
+}
+
+#endif /* SCM_USE_PTHREAD_THREADS */
+
+
+\f
+
+static SCM
+make_weak_set (unsigned long k)
+{
+ scm_t_weak_set *set;
+
+ int i = 0, n = k ? k : 31;
+ while (i + 1 < HASHSET_SIZE_N && n > hashset_size[i])
+ ++i;
+ n = hashset_size[i];
+
+ set = scm_gc_malloc (sizeof (*set), "weak-set");
+ set->entries = scm_gc_malloc_pointerless (n * sizeof(scm_t_weak_entry),
+ "weak-set");
+ memset (set->entries, 0, n * sizeof(scm_t_weak_entry));
+ set->n_items = 0;
+ set->size = n;
+ set->lower = 0;
+ set->upper = 9 * n / 10;
+ set->size_index = i;
+ set->min_size_index = i;
+ scm_i_pthread_mutex_init (&set->lock, NULL);
+
+ return scm_cell (scm_tc7_weak_set, (scm_t_bits)set);
+}
+
+void
+scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-set ", port);
+ scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port);
+ scm_putc_unlocked ('/', port);
+ scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port);
+ scm_puts_unlocked (">", port);
+}
+
+static void
+do_vacuum_weak_set (SCM set)
+{
+ scm_t_weak_set *s;
+
+ s = SCM_WEAK_SET (set);
+
+ if (scm_i_pthread_mutex_trylock (&s->lock) == 0)
+ {
+ vacuum_weak_set (s);
+ unlock_weak_set (s);
+ }
+
+ return;
+}
+
+/* The before-gc C hook only runs if GC_set_start_callback is available,
+ so if not, fall back on a finalizer-based implementation. */
+static int
+weak_gc_callback (void **weak)
+{
+ void *val = weak[0];
+ void (*callback) (SCM) = weak[1];
+
+ if (!val)
+ return 0;
+
+ callback (SCM_PACK_POINTER (val));
+
+ return 1;
+}
+
+#ifdef HAVE_GC_SET_START_CALLBACK
+static void*
+weak_gc_hook (void *hook_data, void *fn_data, void *data)
+{
+ if (!weak_gc_callback (fn_data))
+ scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
+
+ return NULL;
+}
+#else
+static void
+weak_gc_finalizer (void *ptr, void *data)
+{
+ if (weak_gc_callback (ptr))
+ scm_i_set_finalizer (ptr, weak_gc_finalizer, data);
+}
+#endif
+
+static void
+scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+{
+ void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
+
+ weak[0] = SCM_UNPACK_POINTER (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+
+#ifdef HAVE_GC_SET_START_CALLBACK
+ scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ scm_i_set_finalizer (weak, weak_gc_finalizer, NULL);
+#endif
+}
+
+SCM
+scm_c_make_weak_set (unsigned long k)
+{
+ SCM ret;
+
+ ret = make_weak_set (k);
+
+ scm_c_register_weak_gc_callback (ret, do_vacuum_weak_set);
+
+ if (scm_is_true (all_weak_sets))
+ scm_weak_set_add_x (all_weak_sets, ret);
+
+ return ret;
+}
+
+SCM
+scm_weak_set_p (SCM obj)
+{
+ return scm_from_bool (SCM_WEAK_SET_P (obj));
+}
+
+SCM
+scm_weak_set_clear_x (SCM set)
+{
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ lock_weak_set (s);
+
+ memset (s->entries, 0, sizeof (scm_t_weak_entry) * s->size);
+ s->n_items = 0;
+
+ unlock_weak_set (s);
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM dflt)
+{
+ SCM ret;
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ lock_weak_set (s);
+
+ ret = weak_set_lookup (s, raw_hash, pred, closure, dflt);
+
+ unlock_weak_set (s);
+
+ return ret;
+}
+
+SCM
+scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM obj)
+{
+ SCM ret;
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ lock_weak_set (s);
+
+ ret = weak_set_add_x (s, raw_hash, pred, closure, obj);
+
+ unlock_weak_set (s);
+
+ return ret;
+}
+
+void
+scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure)
+{
+ scm_t_weak_set *s = SCM_WEAK_SET (set);
+
+ lock_weak_set (s);
+
+ weak_set_remove_x (s, raw_hash, pred, closure);
+
+ unlock_weak_set (s);
+}
+
+static int
+eq_predicate (SCM x, void *closure)
+{
+ return scm_is_eq (x, SCM_PACK_POINTER (closure));
+}
+
+SCM
+scm_weak_set_add_x (SCM set, SCM obj)
+{
+ return scm_c_weak_set_add_x (set, scm_ihashq (obj, -1),
+ eq_predicate, SCM_UNPACK_POINTER (obj), obj);
+}
+
+SCM
+scm_weak_set_remove_x (SCM set, SCM obj)
+{
+ scm_c_weak_set_remove_x (set, scm_ihashq (obj, -1),
+ eq_predicate, SCM_UNPACK_POINTER (obj));
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
+ SCM init, SCM set)
+{
+ scm_t_weak_set *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+
+ s = SCM_WEAK_SET (set);
+
+ lock_weak_set (s);
+
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ {
+ if (entries[k].hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (copy.key)
+ {
+ /* Release set lock while we call the function. */
+ unlock_weak_set (s);
+ init = proc (closure, SCM_PACK (copy.key), init);
+ lock_weak_set (s);
+ }
+ }
+ }
+
+ unlock_weak_set (s);
+
+ return init;
+}
+
+static SCM
+fold_trampoline (void *closure, SCM item, SCM init)
+{
+ return scm_call_2 (SCM_PACK_POINTER (closure), item, init);
+}
+
+SCM
+scm_weak_set_fold (SCM proc, SCM init, SCM set)
+{
+ return scm_c_weak_set_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, set);
+}
+
+static SCM
+for_each_trampoline (void *closure, SCM item, SCM seed)
+{
+ scm_call_1 (SCM_PACK_POINTER (closure), item);
+ return seed;
+}
+
+SCM
+scm_weak_set_for_each (SCM proc, SCM set)
+{
+ scm_c_weak_set_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, set);
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+map_trampoline (void *closure, SCM item, SCM seed)
+{
+ return scm_cons (scm_call_1 (SCM_PACK_POINTER (closure), item), seed);
+}
+
+SCM
+scm_weak_set_map_to_list (SCM proc, SCM set)
+{
+ return scm_c_weak_set_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, set);
+}
+
+
+\f
+
+void
+scm_weak_set_prehistory (void)
+{
+#if SCM_USE_PTHREAD_THREADS
+ all_weak_sets = scm_c_make_weak_set (0);
+ pthread_atfork (lock_all_weak_sets, unlock_all_weak_sets, unlock_all_weak_sets);
+#endif
+}
+
+void
+scm_init_weak_set ()
+{
+#include "libguile/weak-set.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_SET_H
+#define SCM_WEAK_SET_H
+
+/* Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* The weak set API is currently only used internally. We could make it
+ public later, after some API review. */
+
+/* Function that returns nonzero if the given object is the one we are
+ looking for. */
+typedef int (*scm_t_set_predicate_fn) (SCM obj, void *closure);
+
+/* Function to fold over the elements of a set. */
+typedef SCM (*scm_t_set_fold_fn) (void *closure, SCM key, SCM result);
+
+SCM_INTERNAL SCM scm_c_make_weak_set (unsigned long k);
+SCM_INTERNAL SCM scm_weak_set_p (SCM h);
+SCM_INTERNAL SCM scm_c_weak_set_lookup (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM dflt);
+SCM_INTERNAL SCM scm_c_weak_set_add_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure, SCM obj);
+SCM_INTERNAL void scm_c_weak_set_remove_x (SCM set, unsigned long raw_hash,
+ scm_t_set_predicate_fn pred,
+ void *closure);
+SCM_INTERNAL SCM scm_weak_set_add_x (SCM set, SCM obj);
+SCM_INTERNAL SCM scm_weak_set_remove_x (SCM set, SCM obj);
+SCM_INTERNAL SCM scm_weak_set_clear_x (SCM set);
+SCM_INTERNAL SCM scm_c_weak_set_fold (scm_t_set_fold_fn proc, void *closure,
+ SCM init, SCM set);
+SCM_INTERNAL SCM scm_weak_set_fold (SCM proc, SCM init, SCM set);
+SCM_INTERNAL SCM scm_weak_set_for_each (SCM proc, SCM set);
+SCM_INTERNAL SCM scm_weak_set_map_to_list (SCM proc, SCM set);
+
+SCM_INTERNAL void scm_i_weak_set_lock (SCM set);
+SCM_INTERNAL void scm_i_weak_set_unlock (SCM set);
+SCM_INTERNAL void scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_weak_set_prehistory (void);
+SCM_INTERNAL void scm_init_weak_set (void);
+
+#endif /* SCM_WEAK_SET_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2011, 2012 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/bdw-gc.h"
+#include <gc/gc_mark.h>
+
+#include "libguile/_scm.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+
+#include "libguile/validate.h"
+#include "libguile/weak-table.h"
+
+
+/* Weak Tables
+
+ This file implements weak hash tables. Weak hash tables are
+ generally used when you want to augment some object with additional
+ data, but when you don't have space to store the data in the object.
+ For example, procedure properties are implemented with weak tables.
+
+ Weak tables are implemented using an open-addressed hash table.
+ Basically this means that there is an array of entries, and the item
+ is expected to be found the slot corresponding to its hash code,
+ modulo the length of the array.
+
+ Collisions are handled using linear probing with the Robin Hood
+ technique. See Pedro Celis' paper, "Robin Hood Hashing":
+
+ http://www.cs.uwaterloo.ca/research/tr/1986/CS-86-14.pdf
+
+ The vector of entries is allocated in such a way that the GC doesn't
+ trace the weak values. For doubly-weak tables, this means that the
+ entries are allocated as an "atomic" piece of memory. Key-weak and
+ value-weak tables use a special GC kind with a custom mark procedure.
+ When items are added weakly into table, a disappearing link is
+ registered to their locations. If the referent is collected, then
+ that link will be zeroed out.
+
+ An entry in the table consists of the key and the value, together
+ with the hash code of the key. We munge hash codes so that they are
+ never 0. In this way we can detect removed entries (key of zero but
+ nonzero hash code), and can then reshuffle elements as needed to
+ maintain the robin hood ordering.
+
+ Compared to buckets-and-chains hash tables, open addressing has the
+ advantage that it is very cache-friendly. It also uses less memory.
+
+ Implementation-wise, there are two things to note.
+
+ 1. We assume that hash codes are evenly distributed across the
+ range of unsigned longs. The actual hash code stored in the
+ entry is left-shifted by 1 bit (losing 1 bit of hash precision),
+ and then or'd with 1. In this way we ensure that the hash field
+ of an occupied entry is nonzero. To map to an index, we
+ right-shift the hash by one, divide by the size, and take the
+ remainder.
+
+ 2. Since the weak references are stored in an atomic region with
+ disappearing links, they need to be accessed with the GC alloc
+ lock. `copy_weak_entry' will do that for you. The hash code
+ itself can be read outside the lock, though.
+ */
+
+
+typedef struct {
+ unsigned long hash;
+ scm_t_bits key;
+ scm_t_bits value;
+} scm_t_weak_entry;
+
+
+struct weak_entry_data {
+ scm_t_weak_entry *in;
+ scm_t_weak_entry *out;
+};
+
+static void*
+do_copy_weak_entry (void *data)
+{
+ struct weak_entry_data *e = data;
+
+ e->out->hash = e->in->hash;
+ e->out->key = e->in->key;
+ e->out->value = e->in->value;
+
+ return NULL;
+}
+
+static void
+copy_weak_entry (scm_t_weak_entry *src, scm_t_weak_entry *dst)
+{
+ struct weak_entry_data data;
+
+ data.in = src;
+ data.out = dst;
+
+ GC_call_with_alloc_lock (do_copy_weak_entry, &data);
+}
+
+static void
+register_disappearing_links (scm_t_weak_entry *entry,
+ SCM k, SCM v,
+ scm_t_weak_table_kind kind)
+{
+ if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
+ && (kind == SCM_WEAK_TABLE_KIND_KEY
+ || kind == SCM_WEAK_TABLE_KIND_BOTH))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->key,
+ (GC_PTR) SCM2PTR (k));
+
+ if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
+ && (kind == SCM_WEAK_TABLE_KIND_VALUE
+ || kind == SCM_WEAK_TABLE_KIND_BOTH))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &entry->value,
+ (GC_PTR) SCM2PTR (v));
+}
+
+static void
+unregister_disappearing_links (scm_t_weak_entry *entry,
+ scm_t_weak_table_kind kind)
+{
+ if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ GC_unregister_disappearing_link ((GC_PTR) &entry->key);
+
+ if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ GC_unregister_disappearing_link ((GC_PTR) &entry->value);
+}
+
+static void
+move_disappearing_links (scm_t_weak_entry *from, scm_t_weak_entry *to,
+ SCM key, SCM value, scm_t_weak_table_kind kind)
+{
+ if ((kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (key))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->key, (GC_PTR) &to->key);
+#else
+ GC_unregister_disappearing_link (&from->key);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->key, SCM2PTR (key));
+#endif
+ }
+
+ if ((kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
+ && SCM_HEAP_OBJECT_P (value))
+ {
+#ifdef HAVE_GC_MOVE_DISAPPEARING_LINK
+ GC_move_disappearing_link ((GC_PTR) &from->value, (GC_PTR) &to->value);
+#else
+ GC_unregister_disappearing_link (&from->value);
+ SCM_I_REGISTER_DISAPPEARING_LINK (&to->value, SCM2PTR (value));
+#endif
+ }
+}
+
+static void
+move_weak_entry (scm_t_weak_entry *from, scm_t_weak_entry *to,
+ scm_t_weak_table_kind kind)
+{
+ if (from->hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (from, ©);
+ to->hash = copy.hash;
+ to->key = copy.key;
+ to->value = copy.value;
+
+ move_disappearing_links (from, to,
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ kind);
+ }
+ else
+ {
+ to->hash = 0;
+ to->key = 0;
+ to->value = 0;
+ }
+}
+
+
+typedef struct {
+ scm_t_weak_entry *entries; /* the data */
+ scm_i_pthread_mutex_t lock; /* the lock */
+ scm_t_weak_table_kind kind; /* what kind of table it is */
+ unsigned long size; /* total number of slots. */
+ unsigned long n_items; /* number of items in table */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashtable_size */
+ int min_size_index; /* minimum size_index */
+} scm_t_weak_table;
+
+
+#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
+#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
+#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
+
+
+static unsigned long
+hash_to_index (unsigned long hash, unsigned long size)
+{
+ return (hash >> 1) % size;
+}
+
+static unsigned long
+entry_distance (unsigned long hash, unsigned long k, unsigned long size)
+{
+ unsigned long origin = hash_to_index (hash, size);
+
+ if (k >= origin)
+ return k - origin;
+ else
+ /* The other key was displaced and wrapped around. */
+ return size - origin + k;
+}
+
+static void
+rob_from_rich (scm_t_weak_table *table, unsigned long k)
+{
+ unsigned long empty, size;
+
+ size = table->size;
+
+ /* If we are to free up slot K in the table, we need room to do so. */
+ assert (table->n_items < size);
+
+ empty = k;
+ do
+ empty = (empty + 1) % size;
+ while (table->entries[empty].hash);
+
+ do
+ {
+ unsigned long last = empty ? (empty - 1) : (size - 1);
+ move_weak_entry (&table->entries[last], &table->entries[empty],
+ table->kind);
+ empty = last;
+ }
+ while (empty != k);
+
+ table->entries[empty].hash = 0;
+ table->entries[empty].key = 0;
+ table->entries[empty].value = 0;
+}
+
+static void
+give_to_poor (scm_t_weak_table *table, unsigned long k)
+{
+ /* Slot K was just freed up; possibly shuffle others down. */
+ unsigned long size = table->size;
+
+ while (1)
+ {
+ unsigned long next = (k + 1) % size;
+ unsigned long hash;
+ scm_t_weak_entry copy;
+
+ hash = table->entries[next].hash;
+
+ if (!hash || hash_to_index (hash, size) == next)
+ break;
+
+ copy_weak_entry (&table->entries[next], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference. */
+ {
+ give_to_poor (table, next);
+ table->n_items--;
+ continue;
+ }
+
+ move_weak_entry (&table->entries[next], &table->entries[k],
+ table->kind);
+
+ k = next;
+ }
+
+ /* We have shuffled down any entries that should be shuffled down; now
+ free the end. */
+ table->entries[k].hash = 0;
+ table->entries[k].key = 0;
+ table->entries[k].value = 0;
+}
+
+
+\f
+
+/* The GC "kinds" for singly-weak tables. */
+static int weak_key_gc_kind;
+static int weak_value_gc_kind;
+
+static struct GC_ms_entry *
+mark_weak_key_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
+ unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash && entries[k].key)
+ {
+ SCM value = SCM_PACK (entries[k].value);
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (value),
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+
+ return mark_stack_ptr;
+}
+
+static struct GC_ms_entry *
+mark_weak_value_table (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
+ struct GC_ms_entry *mark_stack_limit, GC_word env)
+{
+ scm_t_weak_entry *entries = (scm_t_weak_entry*) addr;
+ unsigned long k, size = GC_size (addr) / sizeof (scm_t_weak_entry);
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash && entries[k].value)
+ {
+ SCM key = SCM_PACK (entries[k].key);
+ mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word*) SCM2PTR (key),
+ mark_stack_ptr, mark_stack_limit,
+ NULL);
+ }
+
+ return mark_stack_ptr;
+}
+
+static scm_t_weak_entry *
+allocate_entries (unsigned long size, scm_t_weak_table_kind kind)
+{
+ scm_t_weak_entry *ret;
+ size_t bytes = size * sizeof (*ret);
+
+ switch (kind)
+ {
+ case SCM_WEAK_TABLE_KIND_KEY:
+ ret = GC_generic_malloc (bytes, weak_key_gc_kind);
+ break;
+ case SCM_WEAK_TABLE_KIND_VALUE:
+ ret = GC_generic_malloc (bytes, weak_value_gc_kind);
+ break;
+ case SCM_WEAK_TABLE_KIND_BOTH:
+ ret = scm_gc_malloc_pointerless (bytes, "weak-table");
+ break;
+ default:
+ abort ();
+ }
+
+ memset (ret, 0, bytes);
+
+ return ret;
+}
+
+\f
+
+/* Growing or shrinking is triggered when the load factor
+ *
+ * L = N / S (N: number of items in table, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.2.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashtable object.
+ *
+ * Possible hash table sizes (primes) are stored in the array
+ * hashtable_size.
+ */
+
+static unsigned long hashtable_size[] = {
+ 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
+ 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081,
+ 57524111, 115048217, 230096423
+};
+
+#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
+
+static int
+compute_size_index (scm_t_weak_table *table)
+{
+ int i = table->size_index;
+
+ if (table->n_items < table->lower)
+ {
+ /* rehashing is not triggered when i <= min_size */
+ do
+ --i;
+ while (i > table->min_size_index
+ && table->n_items < hashtable_size[i] / 5);
+ }
+ else if (table->n_items > table->upper)
+ {
+ ++i;
+ if (i >= HASHTABLE_SIZE_N)
+ /* The biggest size currently is 230096423, which for a 32-bit
+ machine will occupy 2.3GB of memory at a load of 80%. There
+ is probably something better to do here, but if you have a
+ weak map of that size, you are hosed in any case. */
+ abort ();
+ }
+
+ return i;
+}
+
+static int
+is_acceptable_size_index (scm_t_weak_table *table, int size_index)
+{
+ int computed = compute_size_index (table);
+
+ if (size_index == computed)
+ /* We were going to grow or shrink, and allocating the new vector
+ didn't change the target size. */
+ return 1;
+
+ if (size_index == computed + 1)
+ {
+ /* We were going to enlarge the table, but allocating the new
+ vector finalized some objects, making an enlargement
+ unnecessary. It might still be a good idea to use the larger
+ table, though. (This branch also gets hit if, while allocating
+ the vector, some other thread was actively removing items from
+ the table. That is less likely, though.) */
+ unsigned long new_lower = hashtable_size[size_index] / 5;
+
+ return table->size > new_lower;
+ }
+
+ if (size_index == computed - 1)
+ {
+ /* We were going to shrink the table, but when we dropped the lock
+ to allocate the new vector, some other thread added elements to
+ the table. */
+ return 0;
+ }
+
+ /* The computed size differs from our newly allocated size by more
+ than one size index -- recalculate. */
+ return 0;
+}
+
+static void
+resize_table (scm_t_weak_table *table)
+{
+ scm_t_weak_entry *old_entries, *new_entries;
+ int new_size_index;
+ unsigned long old_size, new_size, old_k;
+
+ do
+ {
+ new_size_index = compute_size_index (table);
+ if (new_size_index == table->size_index)
+ return;
+ new_size = hashtable_size[new_size_index];
+ scm_i_pthread_mutex_unlock (&table->lock);
+ /* Allocating memory might cause finalizers to run, which could
+ run anything, so drop our lock to avoid deadlocks. */
+ new_entries = allocate_entries (new_size, table->kind);
+ scm_i_pthread_mutex_unlock (&table->lock);
+ }
+ while (!is_acceptable_size_index (table, new_size_index));
+
+ old_entries = table->entries;
+ old_size = table->size;
+
+ table->size_index = new_size_index;
+ table->size = new_size;
+ if (new_size_index <= table->min_size_index)
+ table->lower = 0;
+ else
+ table->lower = new_size / 5;
+ table->upper = 9 * new_size / 10;
+ table->n_items = 0;
+ table->entries = new_entries;
+
+ for (old_k = 0; old_k < old_size; old_k++)
+ {
+ scm_t_weak_entry copy;
+ unsigned long new_k, distance;
+
+ if (!old_entries[old_k].hash)
+ continue;
+
+ copy_weak_entry (&old_entries[old_k], ©);
+
+ if (!copy.key || !copy.value)
+ continue;
+
+ new_k = hash_to_index (copy.hash, new_size);
+
+ for (distance = 0; ; distance++, new_k = (new_k + 1) % new_size)
+ {
+ unsigned long other_hash = new_entries[new_k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, new_k, new_size) < distance)
+ {
+ rob_from_rich (table, new_k);
+ break;
+ }
+ }
+
+ table->n_items++;
+ new_entries[new_k].hash = copy.hash;
+ new_entries[new_k].key = copy.key;
+ new_entries[new_k].value = copy.value;
+
+ register_disappearing_links (&new_entries[new_k],
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ table->kind);
+ }
+}
+
+/* Run after GC via do_vacuum_weak_table, this function runs over the
+ whole table, removing lost weak references, reshuffling the table as it
+ goes. It might resize the table if it reaps enough entries. */
+static void
+vacuum_weak_table (scm_t_weak_table *table)
+{
+ scm_t_weak_entry *entries = table->entries;
+ unsigned long size = table->size;
+ unsigned long k;
+
+ for (k = 0; k < size; k++)
+ {
+ unsigned long hash = entries[k].hash;
+
+ if (hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ }
+ }
+ }
+
+ if (table->n_items < table->lower)
+ resize_table (table);
+}
+
+
+\f
+
+static SCM
+weak_table_ref (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure,
+ SCM dflt)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return dflt;
+
+ if (hash == other_hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found. */
+ return SCM_PACK (copy.value);
+ }
+
+ /* If the entry's distance is less, our key is not in the table. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return dflt;
+ }
+
+ /* If we got here, then we were unfortunate enough to loop through the
+ whole table. Shouldn't happen, but hey. */
+ return dflt;
+}
+
+
+static void
+weak_table_put_x (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure,
+ SCM key, SCM value)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; ; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Found an empty entry. */
+ break;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found an entry with this key. */
+ break;
+ }
+
+ if (table->n_items > table->upper)
+ /* Full table, time to resize. */
+ {
+ resize_table (table);
+ return weak_table_put_x (table, hash >> 1, pred, closure, key, value);
+ }
+
+ /* Displace the entry if our distance is less, otherwise keep
+ looking. */
+ if (entry_distance (other_hash, k, size) < distance)
+ {
+ rob_from_rich (table, k);
+ break;
+ }
+ }
+
+ if (entries[k].hash)
+ unregister_disappearing_links (&entries[k], table->kind);
+ else
+ table->n_items++;
+
+ entries[k].hash = hash;
+ entries[k].key = SCM_UNPACK (key);
+ entries[k].value = SCM_UNPACK (value);
+
+ register_disappearing_links (&entries[k], key, value, table->kind);
+}
+
+
+static void
+weak_table_remove_x (scm_t_weak_table *table, unsigned long hash,
+ scm_t_table_predicate_fn pred, void *closure)
+{
+ unsigned long k, distance, size;
+ scm_t_weak_entry *entries;
+
+ size = table->size;
+ entries = table->entries;
+
+ hash = (hash << 1) | 0x1;
+ k = hash_to_index (hash, size);
+
+ for (distance = 0; distance < size; distance++, k = (k + 1) % size)
+ {
+ unsigned long other_hash;
+
+ retry:
+ other_hash = entries[k].hash;
+
+ if (!other_hash)
+ /* Not found. */
+ return;
+
+ if (other_hash == hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (!copy.key || !copy.value)
+ /* Lost weak reference; reshuffle. */
+ {
+ give_to_poor (table, k);
+ table->n_items--;
+ goto retry;
+ }
+
+ if (pred (SCM_PACK (copy.key), SCM_PACK (copy.value), closure))
+ /* Found an entry with this key. */
+ {
+ entries[k].hash = 0;
+ entries[k].key = 0;
+ entries[k].value = 0;
+
+ unregister_disappearing_links (&entries[k], table->kind);
+
+ if (--table->n_items < table->lower)
+ resize_table (table);
+ else
+ give_to_poor (table, k);
+
+ return;
+ }
+ }
+
+ /* If the entry's distance is less, our key is not in the table. */
+ if (entry_distance (other_hash, k, size) < distance)
+ return;
+ }
+}
+
+
+\f
+
+static void
+lock_weak_table (scm_t_weak_table *table)
+{
+ scm_i_pthread_mutex_lock (&table->lock);
+}
+
+static void
+unlock_weak_table (scm_t_weak_table *table)
+{
+ scm_i_pthread_mutex_unlock (&table->lock);
+}
+
+/* A weak table of weak tables, for use in the pthread_atfork handler. */
+static SCM all_weak_tables = SCM_BOOL_F;
+
+#if SCM_USE_PTHREAD_THREADS
+
+static void
+lock_all_weak_tables (void)
+{
+ scm_t_weak_table *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+ scm_t_weak_entry copy;
+
+ s = SCM_WEAK_TABLE (all_weak_tables);
+ lock_weak_table (s);
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash)
+ {
+ copy_weak_entry (&entries[k], ©);
+ if (copy.key)
+ lock_weak_table (SCM_WEAK_TABLE (SCM_PACK (copy.key)));
+ }
+}
+
+static void
+unlock_all_weak_tables (void)
+{
+ scm_t_weak_table *s;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+ scm_t_weak_entry copy;
+
+ s = SCM_WEAK_TABLE (all_weak_tables);
+ size = s->size;
+ entries = s->entries;
+
+ for (k = 0; k < size; k++)
+ if (entries[k].hash)
+ {
+ copy_weak_entry (&entries[k], ©);
+ if (copy.key)
+ unlock_weak_table (SCM_WEAK_TABLE (SCM_PACK (copy.key)));
+ }
+
+ unlock_weak_table (s);
+}
+
+#endif /* SCM_USE_PTHREAD_THREADS */
+
+
+\f
+
+static SCM
+make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
+{
+ scm_t_weak_table *table;
+ SCM ret;
+
+ int i = 0, n = k ? k : 31;
+ while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
+ ++i;
+ n = hashtable_size[i];
+
+ table = scm_gc_malloc (sizeof (*table), "weak-table");
+ table->entries = allocate_entries (n, kind);
+ table->kind = kind;
+ table->n_items = 0;
+ table->size = n;
+ table->lower = 0;
+ table->upper = 9 * n / 10;
+ table->size_index = i;
+ table->min_size_index = i;
+ scm_i_pthread_mutex_init (&table->lock, NULL);
+
+ ret = scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
+
+ if (scm_is_true (all_weak_tables))
+ scm_weak_table_putq_x (all_weak_tables, ret, SCM_BOOL_T);
+
+ return ret;
+}
+
+void
+scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts_unlocked ("#<", port);
+ scm_puts_unlocked ("weak-table ", port);
+ scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
+ scm_putc_unlocked ('/', port);
+ scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port);
+ scm_puts_unlocked (">", port);
+}
+
+static void
+do_vacuum_weak_table (SCM table)
+{
+ scm_t_weak_table *t;
+
+ t = SCM_WEAK_TABLE (table);
+
+ if (scm_i_pthread_mutex_trylock (&t->lock) == 0)
+ {
+ vacuum_weak_table (t);
+ unlock_weak_table (t);
+ }
+
+ return;
+}
+
+/* The before-gc C hook only runs if GC_table_start_callback is available,
+ so if not, fall back on a finalizer-based implementation. */
+static int
+weak_gc_callback (void **weak)
+{
+ void *val = weak[0];
+ void (*callback) (SCM) = weak[1];
+
+ if (!val)
+ return 0;
+
+ callback (SCM_PACK_POINTER (val));
+
+ return 1;
+}
+
+#ifdef HAVE_GC_TABLE_START_CALLBACK
+static void*
+weak_gc_hook (void *hook_data, void *fn_data, void *data)
+{
+ if (!weak_gc_callback (fn_data))
+ scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data);
+
+ return NULL;
+}
+#else
+static void
+weak_gc_finalizer (void *ptr, void *data)
+{
+ if (weak_gc_callback (ptr))
+ scm_i_set_finalizer (ptr, weak_gc_finalizer, data);
+}
+#endif
+
+static void
+scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
+{
+ void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2);
+
+ weak[0] = SCM_UNPACK_POINTER (obj);
+ weak[1] = (void*)callback;
+ GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
+
+#ifdef HAVE_GC_TABLE_START_CALLBACK
+ scm_c_hook_add (&scm_after_gc_c_hook, weak_gc_hook, weak, 0);
+#else
+ scm_i_set_finalizer (weak, weak_gc_finalizer, NULL);
+#endif
+}
+
+SCM
+scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
+{
+ SCM ret;
+
+ ret = make_weak_table (k, kind);
+
+ scm_c_register_weak_gc_callback (ret, do_vacuum_weak_table);
+
+ return ret;
+}
+
+SCM
+scm_weak_table_p (SCM obj)
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj));
+}
+
+SCM
+scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM dflt)
+#define FUNC_NAME "weak-table-ref"
+{
+ SCM ret;
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ lock_weak_table (t);
+
+ ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
+
+ unlock_weak_table (t);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+void
+scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM key, SCM value)
+#define FUNC_NAME "weak-table-put!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ lock_weak_table (t);
+
+ weak_table_put_x (t, raw_hash, pred, closure, key, value);
+
+ unlock_weak_table (t);
+}
+#undef FUNC_NAME
+
+void
+scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure)
+#define FUNC_NAME "weak-table-remove!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ lock_weak_table (t);
+
+ weak_table_remove_x (t, raw_hash, pred, closure);
+
+ unlock_weak_table (t);
+}
+#undef FUNC_NAME
+
+static int
+assq_predicate (SCM x, SCM y, void *closure)
+{
+ return scm_is_eq (x, SCM_PACK_POINTER (closure));
+}
+
+SCM
+scm_weak_table_refq (SCM table, SCM key, SCM dflt)
+{
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+
+ return scm_c_weak_table_ref (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key),
+ dflt);
+}
+
+SCM
+scm_weak_table_putq_x (SCM table, SCM key, SCM value)
+{
+ scm_c_weak_table_put_x (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key),
+ key, value);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_weak_table_remq_x (SCM table, SCM key)
+{
+ scm_c_weak_table_remove_x (table, scm_ihashq (key, -1),
+ assq_predicate, SCM_UNPACK_POINTER (key));
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_weak_table_clear_x (SCM table)
+#define FUNC_NAME "weak-table-clear!"
+{
+ scm_t_weak_table *t;
+
+ SCM_VALIDATE_WEAK_TABLE (1, table);
+
+ t = SCM_WEAK_TABLE (table);
+
+ lock_weak_table (t);
+
+ memset (t->entries, 0, sizeof (scm_t_weak_entry) * t->size);
+ t->n_items = 0;
+
+ unlock_weak_table (t);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
+ SCM init, SCM table)
+{
+ scm_t_weak_table *t;
+ scm_t_weak_entry *entries;
+ unsigned long k, size;
+
+ t = SCM_WEAK_TABLE (table);
+
+ lock_weak_table (t);
+
+ size = t->size;
+ entries = t->entries;
+
+ for (k = 0; k < size; k++)
+ {
+ if (entries[k].hash)
+ {
+ scm_t_weak_entry copy;
+
+ copy_weak_entry (&entries[k], ©);
+
+ if (copy.key && copy.value)
+ {
+ /* Release table lock while we call the function. */
+ unlock_weak_table (t);
+ init = proc (closure,
+ SCM_PACK (copy.key), SCM_PACK (copy.value),
+ init);
+ lock_weak_table (t);
+ }
+ }
+ }
+
+ unlock_weak_table (t);
+
+ return init;
+}
+
+static SCM
+fold_trampoline (void *closure, SCM k, SCM v, SCM init)
+{
+ return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init);
+}
+
+SCM
+scm_weak_table_fold (SCM proc, SCM init, SCM table)
+#define FUNC_NAME "weak-table-fold"
+{
+ SCM_VALIDATE_WEAK_TABLE (3, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table);
+}
+#undef FUNC_NAME
+
+static SCM
+for_each_trampoline (void *closure, SCM k, SCM v, SCM seed)
+{
+ scm_call_2 (SCM_PACK_POINTER (closure), k, v);
+ return seed;
+}
+
+SCM
+scm_weak_table_for_each (SCM proc, SCM table)
+#define FUNC_NAME "weak-table-for-each"
+{
+ SCM_VALIDATE_WEAK_TABLE (2, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+map_trampoline (void *closure, SCM k, SCM v, SCM seed)
+{
+ return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed);
+}
+
+SCM
+scm_weak_table_map_to_list (SCM proc, SCM table)
+#define FUNC_NAME "weak-table-map->list"
+{
+ SCM_VALIDATE_WEAK_TABLE (2, table);
+ SCM_VALIDATE_PROC (1, proc);
+
+ return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table);
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* Legacy interface. */
+
+SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
+ (SCM n),
+ "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
+ "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
+ "Return a weak hash table with @var{size} buckets.\n"
+ "\n"
+ "You can modify weak hash tables in exactly the same way you\n"
+ "would modify regular hash tables. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_key_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_KEY);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
+ (SCM n),
+ "Return a hash table with weak values with @var{size} buckets.\n"
+ "(@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_value_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_VALUE);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
+ (SCM n),
+ "Return a hash table with weak keys and values with @var{size}\n"
+ "buckets. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_doubly_weak_hash_table
+{
+ return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
+ SCM_WEAK_TABLE_KIND_BOTH);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
+ "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
+ "Return @code{#t} if @var{obj} is the specified weak hash\n"
+ "table. Note that a doubly weak hash table is neither a weak key\n"
+ "nor a weak value hash table.")
+#define FUNC_NAME s_scm_weak_key_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak value hash table.")
+#define FUNC_NAME s_scm_weak_value_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a doubly weak hash table.")
+#define FUNC_NAME s_scm_doubly_weak_hash_table_p
+{
+ return scm_from_bool (SCM_WEAK_TABLE_P (obj) &&
+ SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH);
+}
+#undef FUNC_NAME
+
+
+
+\f
+
+void
+scm_weak_table_prehistory (void)
+{
+ weak_key_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (mark_weak_key_table), 0),
+ 0, 0);
+ weak_value_gc_kind =
+ GC_new_kind (GC_new_free_list (),
+ GC_MAKE_PROC (GC_new_proc (mark_weak_value_table), 0),
+ 0, 0);
+
+#if SCM_USE_PTHREAD_THREADS
+ all_weak_tables = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
+ pthread_atfork (lock_all_weak_tables, unlock_all_weak_tables,
+ unlock_all_weak_tables);
+#endif
+}
+
+void
+scm_init_weak_table ()
+{
+#include "libguile/weak-table.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_TABLE_H
+#define SCM_WEAK_TABLE_H
+
+/* Copyright (C) 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* The weak table API is currently only used internally. We could make it
+ public later, after some API review. */
+
+typedef enum {
+ SCM_WEAK_TABLE_KIND_KEY,
+ SCM_WEAK_TABLE_KIND_VALUE,
+ SCM_WEAK_TABLE_KIND_BOTH,
+} scm_t_weak_table_kind;
+
+/* Function that returns nonzero if the given mapping is the one we are
+ looking for. */
+typedef int (*scm_t_table_predicate_fn) (SCM k, SCM v, void *closure);
+
+/* Function to fold over the elements of a set. */
+typedef SCM (*scm_t_table_fold_fn) (void *closure, SCM k, SCM v, SCM result);
+
+SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k,
+ scm_t_weak_table_kind kind);
+SCM_INTERNAL SCM scm_weak_table_p (SCM h);
+
+SCM_INTERNAL SCM scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM dflt);
+SCM_INTERNAL void scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure, SCM key, SCM value);
+SCM_INTERNAL void scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
+ scm_t_table_predicate_fn pred,
+ void *closure);
+
+SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt);
+SCM_INTERNAL SCM scm_weak_table_putq_x (SCM table, SCM key, SCM value);
+SCM_INTERNAL SCM scm_weak_table_remq_x (SCM table, SCM key);
+
+SCM_INTERNAL SCM scm_weak_table_clear_x (SCM table);
+
+SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
+ SCM init, SCM table);
+SCM_INTERNAL SCM scm_weak_table_fold (SCM proc, SCM init, SCM table);
+SCM_INTERNAL SCM scm_weak_table_for_each (SCM proc, SCM table);
+SCM_INTERNAL SCM scm_weak_table_map_to_list (SCM proc, SCM table);
+
+\f
+
+/* Legacy interface. */
+SCM_API SCM scm_make_weak_key_hash_table (SCM k);
+SCM_API SCM scm_make_weak_value_hash_table (SCM k);
+SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
+SCM_API SCM scm_weak_key_hash_table_p (SCM h);
+SCM_API SCM scm_weak_value_hash_table_p (SCM h);
+SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
+
+\f
+
+SCM_INTERNAL void scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate);
+SCM_INTERNAL void scm_weak_table_prehistory (void);
+SCM_INTERNAL void scm_init_weak_table (void);
+
+#endif /* SCM_WEAK_TABLE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+
+\f
+
+/* {Weak Vectors}
+ */
+
+#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
+
+static SCM
+make_weak_vector (size_t len, SCM fill)
+#define FUNC_NAME "make-weak-vector"
+{
+ SCM wv;
+ size_t j;
+
+ SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH);
+
+ if (SCM_UNBNDP (fill))
+ fill = SCM_UNSPECIFIED;
+
+ wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM),
+ "weak vector"));
+
+ SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect);
+
+ if (SCM_HEAP_OBJECT_P (fill))
+ {
+ memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM));
+ for (j = 0; j < len; j++)
+ scm_c_weak_vector_set_x (wv, j, fill);
+ }
+ else
+ for (j = 0; j < len; j++)
+ SCM_SIMPLE_VECTOR_SET (wv, j, fill);
+
+ return wv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
+ (SCM size, SCM fill),
+ "Return a weak vector with @var{size} elements. If the optional\n"
+ "argument @var{fill} is given, all entries in the vector will be\n"
+ "set to @var{fill}. The default value for @var{fill} is the\n"
+ "empty list.")
+#define FUNC_NAME s_scm_make_weak_vector
+{
+ return make_weak_vector (scm_to_size_t (size), fill);
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
+
+SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
+ (SCM lst),
+ "@deffnx {Scheme Procedure} list->weak-vector lst\n"
+ "Construct a weak vector from a list: @code{weak-vector} uses\n"
+ "the list of its arguments while @code{list->weak-vector} uses\n"
+ "its only argument @var{l} (a list) to construct a weak vector\n"
+ "the same way @code{list->vector} would.")
+#define FUNC_NAME s_scm_weak_vector
+{
+ SCM wv;
+ size_t i;
+ long c_size;
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size);
+
+ wv = make_weak_vector ((size_t) c_size, SCM_BOOL_F);
+
+ for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++)
+ scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst));
+
+ return wv;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
+ "weak hashes are also weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_p
+{
+ return scm_from_bool (SCM_I_WVECTP (obj));
+}
+#undef FUNC_NAME
+
+
+struct weak_vector_ref_data
+{
+ SCM wv;
+ size_t k;
+};
+
+static void*
+weak_vector_ref (void *data)
+{
+ struct weak_vector_ref_data *d = data;
+
+ return SCM_SIMPLE_VECTOR_REF (d->wv, d->k);
+}
+
+SCM
+scm_c_weak_vector_ref (SCM wv, size_t k)
+{
+ struct weak_vector_ref_data d;
+ void *ret;
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ ret = GC_call_with_alloc_lock (weak_vector_ref, &d);
+
+ if (ret)
+ return SCM_PACK_POINTER (ret);
+ else
+ return SCM_BOOL_F;
+}
+
+
+void
+scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x)
+{
+ SCM *elts;
+ struct weak_vector_ref_data d;
+ void *prev;
+
+ d.wv = wv;
+ d.k = k;
+
+ if (k >= SCM_I_VECTOR_LENGTH (wv))
+ scm_out_of_range (NULL, scm_from_size_t (k));
+
+ prev = GC_call_with_alloc_lock (weak_vector_ref, &d);
+
+ elts = SCM_I_VECTOR_WELTS (wv);
+
+ if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev)))
+ GC_unregister_disappearing_link ((GC_PTR) &elts[k]);
+
+ elts[k] = x;
+
+ if (SCM_HEAP_OBJECT_P (x))
+ SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &elts[k],
+ (GC_PTR) SCM2PTR (x));
+}
+
+
+\f
+static void
+scm_init_weak_vector_builtins (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/weak-vector.x"
+#endif
+}
+
+void
+scm_init_weak_vectors ()
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_weak_vector_builtins",
+ (scm_t_extension_init_func)scm_init_weak_vector_builtins,
+ NULL);
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAK_VECTOR_H
+#define SCM_WEAK_VECTOR_H
+
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+/* Weak vectors. */
+
+#define SCM_I_WVECTP(x) (SCM_HAS_TYP7 (x, scm_tc7_wvect))
+
+SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
+SCM_API SCM scm_weak_vector (SCM l);
+SCM_API SCM scm_weak_vector_p (SCM x);
+SCM_INTERNAL SCM scm_c_weak_vector_ref (SCM v, size_t k);
+SCM_INTERNAL void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x);
+
+SCM_INTERNAL void scm_init_weak_vectors (void);
+
+
+#endif /* SCM_WEAK_VECTOR_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+++ /dev/null
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-
-\f
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include <stdio.h>
-
-#include "libguile/_scm.h"
-#include "libguile/vectors.h"
-#include "libguile/hashtab.h"
-
-#include "libguile/validate.h"
-#include "libguile/weaks.h"
-
-#include "libguile/bdw-gc.h"
-#include <gc/gc_typed.h>
-
-
-\f
-/* Weak pairs for use in weak alist vectors and weak hash tables.
-
- We have weal-car pairs, weak-cdr pairs, and doubly weak pairs. In weak
- pairs, the weak component(s) are not scanned for pointers and are
- registered as disapperaring links; therefore, the weak component may be
- set to NULL by the garbage collector when no other reference to that word
- exist. Thus, users should only access weak pairs via the
- `SCM_WEAK_PAIR_C[AD]R ()' macros. See also `scm_fixup_weak_alist ()' in
- `hashtab.c'. */
-
-/* Type descriptors for weak-c[ad]r pairs. */
-static GC_descr wcar_pair_descr, wcdr_pair_descr;
-
-
-SCM
-scm_weak_car_pair (SCM car, SCM cdr)
-{
- scm_t_cell *cell;
-
- cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
- wcar_pair_descr);
-
- cell->word_0 = car;
- cell->word_1 = cdr;
-
- if (SCM_NIMP (car))
- /* Weak car cells make sense iff the car is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM2PTR (car));
-
- return (SCM_PACK (cell));
-}
-
-SCM
-scm_weak_cdr_pair (SCM car, SCM cdr)
-{
- scm_t_cell *cell;
-
- cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
- wcdr_pair_descr);
-
- cell->word_0 = car;
- cell->word_1 = cdr;
-
- if (SCM_NIMP (cdr))
- /* Weak cdr cells make sense iff the cdr is non-immediate. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM2PTR (cdr));
-
- return (SCM_PACK (cell));
-}
-
-SCM
-scm_doubly_weak_pair (SCM car, SCM cdr)
-{
- /* Doubly weak cells shall not be scanned at all for pointers. */
- scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
- "weak cell");
-
- cell->word_0 = car;
- cell->word_1 = cdr;
-
- if (SCM_NIMP (car))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_0,
- (GC_PTR) SCM2PTR (car));
- if (SCM_NIMP (cdr))
- SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) &cell->word_1,
- (GC_PTR) SCM2PTR (cdr));
-
- return (SCM_PACK (cell));
-}
-
-
-\f
-
-/* 1. The current hash table implementation in hashtab.c uses weak alist
- * vectors (formerly called weak hash tables) internally.
- *
- * 2. All hash table operations still work on alist vectors.
- *
- * 3. The weak vector and alist vector Scheme API is accessed through
- * the module (ice-9 weak-vector).
- */
-
-
-/* {Weak Vectors}
- */
-
-
-SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
- (SCM size, SCM fill),
- "Return a weak vector with @var{size} elements. If the optional\n"
- "argument @var{fill} is given, all entries in the vector will be\n"
- "set to @var{fill}. The default value for @var{fill} is the\n"
- "empty list.")
-#define FUNC_NAME s_scm_make_weak_vector
-{
- return scm_i_make_weak_vector (0, size, fill);
-}
-#undef FUNC_NAME
-
-
-SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
-
-SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
- (SCM l),
- "@deffnx {Scheme Procedure} list->weak-vector l\n"
- "Construct a weak vector from a list: @code{weak-vector} uses\n"
- "the list of its arguments while @code{list->weak-vector} uses\n"
- "its only argument @var{l} (a list) to construct a weak vector\n"
- "the same way @code{list->vector} would.")
-#define FUNC_NAME s_scm_weak_vector
-{
- return scm_i_make_weak_vector_from_list (0, l);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
- "weak hashes are also weak vectors.")
-#define FUNC_NAME s_scm_weak_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
-}
-#undef FUNC_NAME
-
-\f
-/* Weak alist vectors, i.e., vectors of alists.
-
- The alist vector themselves are _not_ weak. The `car' (or `cdr', or both)
- of the pairs within it are weak. See `hashtab.c' for details. */
-
-
-/* FIXME: We used to have two implementations of weak hash tables: the one in
- here and the one in `hashtab.c'. The difference is that weak alist
- vectors could be used as vectors while (weak) hash tables can't. We need
- to unify that. */
-
-SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
- (SCM size),
- "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
- "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
- "Return a weak hash table with @var{size} buckets. As with any\n"
- "hash table, choosing a good size for the table requires some\n"
- "caution.\n"
- "\n"
- "You can modify weak hash tables in exactly the same way you\n"
- "would modify regular hash tables. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_key_alist_vector
-{
- return scm_make_weak_key_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
- (SCM size),
- "Return a hash table with weak values with @var{size} buckets.\n"
- "(@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_value_alist_vector
-{
- return scm_make_weak_value_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
- (SCM size),
- "Return a hash table with weak keys and values with @var{size}\n"
- "buckets. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
-{
- return scm_make_doubly_weak_hash_table (size);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
- (SCM obj),
- "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
- "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
- "Return @code{#t} if @var{obj} is the specified weak hash\n"
- "table. Note that a doubly weak hash table is neither a weak key\n"
- "nor a weak value hash table.")
-#define FUNC_NAME s_scm_weak_key_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak value hash table.")
-#define FUNC_NAME s_scm_weak_value_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a doubly weak hash table.")
-#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
-{
- return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
-}
-#undef FUNC_NAME
-
-
-
-\f
-SCM
-scm_init_weaks_builtins ()
-{
-#include "libguile/weaks.x"
- return SCM_UNSPECIFIED;
-}
-
-void
-scm_weaks_prehistory ()
-{
- /* Initialize weak pairs. */
- GC_word wcar_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
- GC_word wcdr_pair_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
-
- /* In a weak-car pair, only the second word must be scanned for
- pointers. */
- GC_set_bit (wcar_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
- wcar_pair_descr = GC_make_descriptor (wcar_pair_bitmap,
- GC_WORD_LEN (scm_t_cell));
-
- /* Conversely, in a weak-cdr pair, only the first word must be scanned for
- pointers. */
- GC_set_bit (wcdr_pair_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
- wcdr_pair_descr = GC_make_descriptor (wcdr_pair_bitmap,
- GC_WORD_LEN (scm_t_cell));
-
-}
-
-void
-scm_init_weaks ()
-{
- scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
- scm_init_weaks_builtins);
-}
-
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+++ /dev/null
-/* classes: h_files */
-
-#ifndef SCM_WEAKS_H
-#define SCM_WEAKS_H
-
-/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008, 2009, 2011 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-\f
-
-#include "libguile/__scm.h"
-
-\f
-
-#define SCM_WVECTF_WEAK_KEY 1
-#define SCM_WVECTF_WEAK_VALUE 2
-
-#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
-#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)
-
-#define SCM_I_WVECT_TYPE(x) (SCM_I_WVECT_EXTRA(x) & 7)
-#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA \
- ((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
-#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
-#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
-#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
-#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
-
-\f
-/* Weak pairs. */
-
-SCM_INTERNAL SCM scm_weak_car_pair (SCM car, SCM cdr);
-SCM_INTERNAL SCM scm_weak_cdr_pair (SCM car, SCM cdr);
-SCM_INTERNAL SCM scm_doubly_weak_pair (SCM car, SCM cdr);
-
-/* Testing the weak component(s) of a cell for reachability. */
-#define SCM_WEAK_PAIR_WORD_DELETED_P(_cell, _word) \
- (SCM_UNPACK (SCM_CELL_OBJECT ((_cell), (_word))) == 0)
-#define SCM_WEAK_PAIR_CAR_DELETED_P(_cell) \
- (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 0))
-#define SCM_WEAK_PAIR_CDR_DELETED_P(_cell) \
- (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), 1))
-
-#define SCM_WEAK_PAIR_DELETED_P(_cell) \
- ((SCM_WEAK_PAIR_CAR_DELETED_P (_cell)) \
- || (SCM_WEAK_PAIR_CDR_DELETED_P (_cell)))
-
-/* Accessing the components of a weak cell. These return `SCM_UNDEFINED' if
- the car/cdr has been collected. */
-#define SCM_WEAK_PAIR_WORD(_cell, _word) \
- (SCM_WEAK_PAIR_WORD_DELETED_P ((_cell), (_word)) \
- ? SCM_UNDEFINED \
- : SCM_CELL_OBJECT ((_cell), (_word)))
-#define SCM_WEAK_PAIR_CAR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 0))
-#define SCM_WEAK_PAIR_CDR(_cell) (SCM_WEAK_PAIR_WORD ((_cell), 1))
-
-
-\f
-/* Weak vectors and weak hash tables. */
-
-SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
-SCM_API SCM scm_weak_vector (SCM l);
-SCM_API SCM scm_weak_vector_p (SCM x);
-SCM_API SCM scm_make_weak_key_alist_vector (SCM k);
-SCM_API SCM scm_make_weak_value_alist_vector (SCM k);
-SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
-SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
-SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
-SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
-SCM_INTERNAL SCM scm_init_weaks_builtins (void);
-SCM_INTERNAL void scm_weaks_prehistory (void);
-SCM_INTERNAL void scm_init_weaks (void);
-
-SCM_INTERNAL void scm_i_init_weak_vectors_for_gc (void);
-SCM_INTERNAL void scm_i_mark_weak_vector (SCM w);
-SCM_INTERNAL int scm_i_mark_weak_vectors_non_weaks (void);
-SCM_INTERNAL void scm_i_remove_weaks_from_weak_vectors (void);
-
-
-#endif /* SCM_WEAKS_H */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
inet_pton
isinf
isnan
+ largefile
ldexp
lib-symbol-versions
lib-symbol-visibility
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))
;; properties within the object itself.
(define (make-object-property)
- (define-syntax-rule (with-mutex lock exp)
- (dynamic-wind (lambda () (lock-mutex lock))
- (lambda () exp)
- (lambda () (unlock-mutex lock))))
- (let ((prop (make-weak-key-hash-table))
- (lock (make-mutex)))
+ ;; Weak tables are thread-safe.
+ (let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
- (lambda (obj) (with-mutex lock (hashq-ref prop obj)))
- (lambda (obj val) (with-mutex lock (hashq-set! prop obj val))))))
+ (lambda (obj) (hashq-ref prop obj))
+ (lambda (obj val) (hashq-set! prop obj val)))))
\f
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
- ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
- ;; that we need to expose the bare vtable-vtable to Scheme.
- (make-vtable-vtable "prprpw" 0
- (lambda (s p)
- (cond ((eq? s record-type-vtable)
- (display "#<record-type-vtable>" p))
- (else
- (display "#<record-type " p)
- (display (record-type-name s) p)
- (display ">" p))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+ (lambda (s p)
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p)))))
+ (set-struct-vtable-name! s 'record-type)
+ s))
(define (record-type? obj)
(and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
((define-record-type
(lambda (x)
(define (make-id scope . fragments)
- (datum->syntax #'scope
+ (datum->syntax scope
(apply symbol-append
(map (lambda (x)
(if (symbol? x) x (syntax->datum x)))
;; initial uses list, or binding procedure.
;;
(define* (make-module #:optional (size 31) (uses '()) (binder #f))
- (define %default-import-size
- ;; Typical number of imported bindings actually used by a module.
- 600)
-
(if (not (integer? size))
(error "Illegal size to make-module." size))
(if (not (and (list? uses)
(let ((module (module-constructor (make-hash-table size)
uses binder #f macroexpand
#f #f #f
- (make-hash-table %default-import-size)
+ (make-hash-table)
'()
(make-weak-key-hash-table 31) #f
(make-hash-table 7) #f #f #f)))
(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-rule (use-syntax spec ...)
- (begin
- (eval-when (eval load compile expand)
- (issue-deprecation-warning
- "`use-syntax' is deprecated. Please contact guile-devel for more info."))
- (use-modules spec ...)))
-
(include-from-path "ice-9/r6rs-libraries")
(define-syntax-rule (define-private foo bar)
-;;;; Copyright (C) 2003, 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-
-(define-module (ice-9 deprecated)
- #:export (substring-move-left! substring-move-right!
- dynamic-maybe-call dynamic-maybe-link
- try-module-linked try-module-dynamic-link
- list* feature? eval-case unmemoize-expr
- $asinh
- $acosh
- $atanh
- $sqrt
- $abs
- $exp
- $expt
- $log
- $sin
- $cos
- $tan
- $asin
- $acos
- $atan
- $sinh
- $cosh
- $tanh
- closure?
- %nil
- @bind
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl
- apply-to-args
- has-suffix?
- scheme-file-suffix
- get-option
- for-next-option
- display-usage-report
- transform-usage-lambda
- collect
- assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
- set-repl-prompt!
- set-batch-mode?!
- repl
- pre-unwind-handler-dispatch
- default-pre-unwind-handler
- handle-system-error
- stack-saved?
- the-last-stack
- save-stack
- named-module-use!
- top-repl
- turn-on-debugging
- read-hash-procedures
- process-define-module
- fluid-let-syntax))
-
-
-;;;; Deprecated definitions.
-
-(define substring-move-left!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-left!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-(define substring-move-right!
- (lambda args
- (issue-deprecation-warning
- "`substring-move-right!' is deprecated. Use `substring-move!' instead.")
- (apply substring-move! args)))
-
-
-\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 ($expt z1 z2)
- (issue-deprecation-warning
- "`$expt' is deprecated. Use `expt' instead.")
- (expt z1 z2))
-(define ($log z)
- (issue-deprecation-warning
- "`$log' is deprecated. Use `log' instead.")
- (log z))
-(define ($sin z)
- (issue-deprecation-warning
- "`$sin' is deprecated. Use `sin' instead.")
- (sin z))
-(define ($cos z)
- (issue-deprecation-warning
- "`$cos' is deprecated. Use `cos' instead.")
- (cos z))
-(define ($tan z)
- (issue-deprecation-warning
- "`$tan' is deprecated. Use `tan' instead.")
- (tan z))
-(define ($asin z)
- (issue-deprecation-warning
- "`$asin' is deprecated. Use `asin' instead.")
- (asin z))
-(define ($acos z)
- (issue-deprecation-warning
- "`$acos' is deprecated. Use `acos' instead.")
- (acos z))
-(define ($atan z)
- (issue-deprecation-warning
- "`$atan' is deprecated. Use `atan' instead.")
- (atan z))
-(define ($sinh z)
- (issue-deprecation-warning
- "`$sinh' is deprecated. Use `sinh' instead.")
- (sinh z))
-(define ($cosh z)
- (issue-deprecation-warning
- "`$cosh' is deprecated. Use `cosh' instead.")
- (cosh z))
-(define ($tanh z)
- (issue-deprecation-warning
- "`$tanh' is deprecated. Use `tanh' instead.")
- (tanh z))
-
-(define (closure? x)
- (issue-deprecation-warning
- "`closure?' is deprecated. Use `procedure?' instead.")
- (procedure? x))
-
-(define %nil #nil)
-
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (issue-deprecation-warning
- "`@bind' is deprecated. Use `with-fluids' instead.")
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-;; There are deprecated definitions for module-ref-submodule and
-;; module-define-submodule! in boot-9.scm.
-
-;; Define (%app) and (%app modules), and have (app) alias (%app). This
-;; side-effects the-root-module, both to the submodules table and (through
-;; module-define-submodule! above) the obarray.
-;;
-(let ((%app (make-module 31)))
- (set-module-name! %app '(%app))
- (module-define-submodule! the-root-module '%app %app)
- (module-define-submodule! the-root-module 'app %app)
- (module-define-submodule! %app 'modules (resolve-module '() #f)))
-
-;; Allow code that poked %module-public-interface to keep on working.
-;;
-(set! module-public-interface
- (let ((getter module-public-interface))
- (lambda (mod)
- (or (getter mod)
- (cond
- ((and=> (module-local-variable mod '%module-public-interface)
- variable-ref)
- => (lambda (iface)
- (issue-deprecation-warning
-"Setting a module's public interface via munging %module-public-interface is
-deprecated. Use set-module-public-interface! instead.")
- (set-module-public-interface! mod iface)
- iface))
- (else #f))))))
-
-(set! set-module-public-interface!
- (let ((setter set-module-public-interface!))
- (lambda (mod iface)
- (setter mod iface)
- (module-define! mod '%module-public-interface iface))))
-
-(define (bad-throw key . args)
- (issue-deprecation-warning
- "`bad-throw' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- (apply (@ (ice-9 scm-style-repl) bad-throw) key args))
-
-(define (error-catching-loop thunk)
- (issue-deprecation-warning
- "`error-catching-loop' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-loop) thunk))
-
-(define (error-catching-repl r e p)
- (issue-deprecation-warning
- "`error-catching-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead.")
- ((@ (ice-9 scm-style-repl) error-catching-repl) r e p))
-
-(define (scm-style-repl)
- (issue-deprecation-warning
- "`scm-style-repl' in the default environment is deprecated.
-Find it in the `(ice-9 scm-style-repl)' module instead, or
-better yet, use the repl from `(system repl repl)'.")
- ((@ (ice-9 scm-style-repl) scm-style-repl)))
-
-
-;;; Apply-to-args had the following comment attached to it in boot-9, but it's
-;;; wrong-headed: in the mentioned case, a point should either be a record or
-;;; multiple values.
-;;;
-;;; apply-to-args is functionally redundant with apply and, worse,
-;;; is less general than apply since it only takes two arguments.
-;;;
-;;; On the other hand, apply-to-args is a syntacticly convenient way to
-;;; perform binding in many circumstances when the "let" family of
-;;; of forms don't cut it. E.g.:
-;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
-;;;
-
-(define (apply-to-args args fn)
- (issue-deprecation-warning
- "`apply-to-args' is deprecated. Include a local copy in your program.")
- (apply fn args))
-
-(define (has-suffix? str suffix)
- (issue-deprecation-warning
- "`has-suffix?' is deprecated. Use `string-suffix?' instead (args reversed).")
- (string-suffix? suffix str))
-
-(define scheme-file-suffix
- (lambda ()
- (issue-deprecation-warning
- "`scheme-file-suffix' is deprecated. Use `%load-extensions' instead.")
- ".scm"))
-
-\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)))))))
-
-(define-syntax fluid-let-syntax
- (lambda (x)
- (issue-deprecation-warning
- "`fluid-let-syntax' is deprecated. Use syntax parameters instead.")
- (syntax-case x ()
- ((_ ((k v) ...) body0 body ...)
- #'(syntax-parameterize ((k v) ...)
- body0 body ...)))))
+;;;; 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)))
t)
patterns))))
(else
- (error "what" type val))))))))))
+ ;; Interestingly, this case can include globals (and
+ ;; global macros), now that Guile tracks which globals it
+ ;; introduces. Not sure what to do here! For now, punt.
+ ;;
+ (lp ids capture formals wrappers patterns))))))))))
(define-syntax the-environment
(lambda (x)
;; poll
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(off (pollfd-offset idx))
(fd (if (integer? fd-or-port)
fd-or-port
- (port->fdes fd-or-port))))
-
- (if (port? fd-or-port)
- ;; As we store the port in the fdset, there is no need to
- ;; increment the revealed count to prevent the fd from being
- ;; closed by a gc'd port.
- (release-port-handle fd-or-port))
+ (fileno fd-or-port))))
(ensure-pset-size! set (1+ idx))
(bytevector-s32-native-set! (pset-pollfds set) off fd)
(eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
(if #f #f)
-(let ((session-id-4256 (if #f #f))
- (transformer-environment-4317 (if #f #f)))
+(let ((session-id-4308 (if #f #f))
+ (transformer-environment-4369 (if #f #f)))
(letrec*
- ((top-level-eval-hook-4254
- (lambda (x-27424 mod-27425)
- (primitive-eval x-27424)))
- (get-global-definition-hook-4258
- (lambda (symbol-15687 module-15688)
- (begin
- (if (if (not module-15688) (current-module) #f)
- (warn "module system is booted, we should have a module"
- symbol-15687))
- (let ((v-15689
- (module-variable
- (if module-15688
- (resolve-module (cdr module-15688))
- (current-module))
- symbol-15687)))
- (if v-15689
- (if (variable-bound? v-15689)
- (let ((val-15691 (variable-ref v-15689)))
- (if (macro? val-15691)
- (if (macro-type val-15691)
- (cons (macro-type val-15691)
- (macro-binding val-15691))
- #f)
- #f))
- #f)
- #f)))))
- (maybe-name-value!-4260
- (lambda (name-15968 val-15969)
- (if (if (struct? val-15969)
- (eq? (struct-vtable val-15969)
- (vector-ref %expanded-vtables 13))
+ ((top-level-eval-hook-4306
+ (lambda (x-34042 mod-34043)
+ (primitive-eval x-34042)))
+ (maybe-name-value!-4312
+ (lambda (name-17933 val-17934)
+ (if (if (struct? val-17934)
+ (eq? (struct-vtable val-17934)
+ (vector-ref %expanded-vtables 14))
#f)
- (let ((meta-15976 (struct-ref val-15969 1)))
- (if (not (assq 'name meta-15976))
- (let ((v-15981
- (cons (cons 'name name-15968) meta-15976)))
- (struct-set! val-15969 1 v-15981)))))))
- (build-application-4262
- (lambda (source-15693 fun-exp-15694 arg-exps-15695)
+ (let ((meta-17941 (struct-ref val-17934 1)))
+ (if (not (assq 'name meta-17941))
+ (let ((v-17946
+ (cons (cons 'name name-17933) meta-17941)))
+ (struct-set! val-17934 1 v-17946)))))))
+ (build-call-4314
+ (lambda (source-17748 fun-exp-17749 arg-exps-17750)
(make-struct/no-tail
(vector-ref %expanded-vtables 11)
- source-15693
- fun-exp-15694
- arg-exps-15695)))
- (build-conditional-4263
- (lambda (source-15701
- test-exp-15702
- then-exp-15703
- else-exp-15704)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- source-15701
- test-exp-15702
- then-exp-15703
- else-exp-15704)))
- (build-dynlet-4264
- (lambda (source-15711 fluids-15712 vals-15713 body-15714)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 17)
- source-15711
- fluids-15712
- vals-15713
- body-15714)))
- (build-lexical-reference-4265
- (lambda (type-27426 source-27427 name-27428 var-27429)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- source-27427
- name-27428
- var-27429)))
- (build-lexical-assignment-4266
- (lambda (source-15721 name-15722 var-15723 exp-15724)
- (begin
- (if (if (struct? exp-15724)
- (eq? (struct-vtable exp-15724)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15740 (struct-ref exp-15724 1)))
- (if (not (assq 'name meta-15740))
- (let ((v-15747
- (cons (cons 'name name-15722) meta-15740)))
- (struct-set! exp-15724 1 v-15747)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 4)
- source-15721
- name-15722
- var-15723
- exp-15724))))
- (analyze-variable-4267
- (lambda (mod-27435
- var-27436
- modref-cont-27437
- bare-cont-27438)
- (if (not mod-27435)
- (bare-cont-27438 var-27436)
- (let ((kind-27439 (car mod-27435))
- (mod-27440 (cdr mod-27435)))
- (if (eqv? kind-27439 'public)
- (modref-cont-27437 mod-27440 var-27436 #t)
- (if (eqv? kind-27439 'private)
- (if (not (equal? mod-27440 (module-name (current-module))))
- (modref-cont-27437 mod-27440 var-27436 #f)
- (bare-cont-27438 var-27436))
- (if (eqv? kind-27439 'bare)
- (bare-cont-27438 var-27436)
- (if (eqv? kind-27439 'hygiene)
+ source-17748
+ fun-exp-17749
+ arg-exps-17750)))
+ (analyze-variable-4319
+ (lambda (mod-17756
+ var-17757
+ modref-cont-17758
+ bare-cont-17759)
+ (if (not mod-17756)
+ (bare-cont-17759 var-17757)
+ (let ((kind-17760 (car mod-17756))
+ (mod-17761 (cdr mod-17756)))
+ (if (eqv? kind-17760 'public)
+ (modref-cont-17758 mod-17761 var-17757 #t)
+ (if (eqv? kind-17760 'private)
+ (if (not (equal? mod-17761 (module-name (current-module))))
+ (modref-cont-17758 mod-17761 var-17757 #f)
+ (bare-cont-17759 var-17757))
+ (if (eqv? kind-17760 'bare)
+ (bare-cont-17759 var-17757)
+ (if (eqv? kind-17760 'hygiene)
(if (if (not (equal?
- mod-27440
+ mod-17761
(module-name (current-module))))
(module-variable
- (resolve-module mod-27440)
- var-27436)
+ (resolve-module mod-17761)
+ var-17757)
#f)
- (modref-cont-27437 mod-27440 var-27436 #f)
- (bare-cont-27438 var-27436))
+ (modref-cont-17758 mod-17761 var-17757 #f)
+ (bare-cont-17759 var-17757))
(syntax-violation
#f
"bad module kind"
- var-27436
- mod-27440)))))))))
- (build-global-reference-4268
- (lambda (source-27467 var-27468 mod-27469)
- (analyze-variable-4267
- mod-27469
- var-27468
- (lambda (mod-27472 var-27473 public?-27474)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- source-27467
- mod-27472
- var-27473
- public?-27474))
- (lambda (var-27482)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- source-27467
- var-27482)))))
- (build-global-assignment-4269
- (lambda (source-15756 var-15757 exp-15758 mod-15759)
- (begin
- (if (if (struct? exp-15758)
- (eq? (struct-vtable exp-15758)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-15775 (struct-ref exp-15758 1)))
- (if (not (assq 'name meta-15775))
- (let ((v-15782
- (cons (cons 'name var-15757) meta-15775)))
- (struct-set! exp-15758 1 v-15782)))))
- (analyze-variable-4267
- mod-15759
- var-15757
- (lambda (mod-15787 var-15788 public?-15789)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 6)
- source-15756
- mod-15787
- var-15788
- public?-15789
- exp-15758))
- (lambda (var-15797)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 8)
- source-15756
- var-15797
- exp-15758))))))
- (build-global-definition-4270
- (lambda (source-27488 var-27489 exp-27490)
- (begin
- (if (if (struct? exp-27490)
- (eq? (struct-vtable exp-27490)
- (vector-ref %expanded-vtables 13))
- #f)
- (let ((meta-27506 (struct-ref exp-27490 1)))
- (if (not (assq 'name meta-27506))
- (let ((v-27513
- (cons (cons 'name var-27489) meta-27506)))
- (struct-set! exp-27490 1 v-27513)))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 9)
- source-27488
- var-27489
- exp-27490))))
- (build-simple-lambda-4271
- (lambda (src-15803
- req-15804
- rest-15805
- vars-15806
- meta-15807
- exp-15808)
- (let ((body-15814
+ var-17757
+ mod-17761)))))))))
+ (build-simple-lambda-4323
+ (lambda (src-17788
+ req-17789
+ rest-17790
+ vars-17791
+ meta-17792
+ exp-17793)
+ (let ((body-17799
(make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-15803
- req-15804
+ (vector-ref %expanded-vtables 15)
+ src-17788
+ req-17789
#f
- rest-15805
+ rest-17790
#f
'()
- vars-15806
- exp-15808
+ vars-17791
+ exp-17793
#f)))
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- src-15803
- meta-15807
- body-15814))))
- (build-sequence-4276
- (lambda (src-27521 exps-27522)
- (if (null? (cdr exps-27522))
- (car exps-27522)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 12)
- src-27521
- exps-27522))))
- (build-let-4277
- (lambda (src-15826
- ids-15827
- vars-15828
- val-exps-15829
- body-exp-15830)
- (begin
- (for-each
- maybe-name-value!-4260
- ids-15827
- val-exps-15829)
- (if (null? vars-15828)
- body-exp-15830
+ (vector-ref %expanded-vtables 14)
+ src-17788
+ meta-17792
+ body-17799))))
+ (build-primcall-4326
+ (lambda (src-17811 name-17812 args-17813)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ src-17811
+ name-17812
+ args-17813)))
+ (build-sequence-4329
+ (lambda (src-34044 exps-34045)
+ (if (null? (cdr exps-34045))
+ (car exps-34045)
+ (let ((head-34049 (car exps-34045))
+ (tail-34050
+ (build-sequence-4329 #f (cdr exps-34045))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 15)
- src-15826
- ids-15827
- vars-15828
- val-exps-15829
- body-exp-15830)))))
- (build-named-let-4278
- (lambda (src-15854
- ids-15855
- vars-15856
- val-exps-15857
- body-exp-15858)
- (let ((f-15859 (car vars-15856))
- (f-name-15860 (car ids-15855))
- (vars-15861 (cdr vars-15856))
- (ids-15862 (cdr ids-15855)))
- (let ((proc-15863
- (let ((body-15883
+ (vector-ref %expanded-vtables 13)
+ src-34044
+ head-34049
+ tail-34050)))))
+ (build-named-let-4331
+ (lambda (src-17819
+ ids-17820
+ vars-17821
+ val-exps-17822
+ body-exp-17823)
+ (let ((f-17824 (car vars-17821))
+ (f-name-17825 (car ids-17820))
+ (vars-17826 (cdr vars-17821))
+ (ids-17827 (cdr ids-17820)))
+ (let ((proc-17828
+ (let ((body-17848
(make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- src-15854
- ids-15862
+ (vector-ref %expanded-vtables 15)
+ src-17819
+ ids-17827
#f
#f
#f
'()
- vars-15861
- body-exp-15858
+ vars-17826
+ body-exp-17823
#f)))
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- src-15854
+ (vector-ref %expanded-vtables 14)
+ src-17819
'()
- body-15883))))
+ body-17848))))
(begin
- (if (if (struct? proc-15863)
- (eq? (struct-vtable proc-15863)
- (vector-ref %expanded-vtables 13))
+ (if (if (struct? proc-17828)
+ (eq? (struct-vtable proc-17828)
+ (vector-ref %expanded-vtables 14))
#f)
- (let ((meta-15907 (struct-ref proc-15863 1)))
- (if (not (assq 'name meta-15907))
- (let ((v-15914
- (cons (cons 'name f-name-15860) meta-15907)))
- (struct-set! proc-15863 1 v-15914)))))
+ (let ((meta-17872 (struct-ref proc-17828 1)))
+ (if (not (assq 'name meta-17872))
+ (let ((v-17879
+ (cons (cons 'name f-name-17825) meta-17872)))
+ (struct-set! proc-17828 1 v-17879)))))
(for-each
- maybe-name-value!-4260
- ids-15862
- val-exps-15857)
- (let ((names-15938 (list f-name-15860))
- (gensyms-15939 (list f-15859))
- (vals-15940 (list proc-15863))
- (body-15941
- (let ((fun-exp-15945
+ maybe-name-value!-4312
+ ids-17827
+ val-exps-17822)
+ (let ((names-17903 (list f-name-17825))
+ (gensyms-17904 (list f-17824))
+ (vals-17905 (list proc-17828))
+ (body-17906
+ (let ((fun-exp-17910
(make-struct/no-tail
(vector-ref %expanded-vtables 3)
- src-15854
- f-name-15860
- f-15859)))
+ src-17819
+ f-name-17825
+ f-17824)))
(make-struct/no-tail
(vector-ref %expanded-vtables 11)
- src-15854
- fun-exp-15945
- val-exps-15857))))
+ src-17819
+ fun-exp-17910
+ val-exps-17822))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- src-15854
+ (vector-ref %expanded-vtables 17)
+ src-17819
#f
- names-15938
- gensyms-15939
- vals-15940
- body-15941)))))))
- (build-letrec-4279
- (lambda (src-15961
- in-order?-15962
- ids-15963
- vars-15964
- val-exps-15965
- body-exp-15966)
- (if (null? vars-15964)
- body-exp-15966
+ names-17903
+ gensyms-17904
+ vals-17905
+ body-17906)))))))
+ (build-letrec-4332
+ (lambda (src-17926
+ in-order?-17927
+ ids-17928
+ vars-17929
+ val-exps-17930
+ body-exp-17931)
+ (if (null? vars-17929)
+ body-exp-17931
(begin
(for-each
- maybe-name-value!-4260
- ids-15963
- val-exps-15965)
+ maybe-name-value!-4312
+ ids-17928
+ val-exps-17930)
(make-struct/no-tail
- (vector-ref %expanded-vtables 16)
- src-15961
- in-order?-15962
- ids-15963
- vars-15964
- val-exps-15965
- body-exp-15966)))))
- (source-annotation-4288
- (lambda (x-15992)
- (if (if (vector? x-15992)
- (if (= (vector-length x-15992) 4)
- (eq? (vector-ref x-15992 0) 'syntax-object)
- #f)
- #f)
- (source-annotation-4288 (vector-ref x-15992 1))
- (let ((props-16007 (source-properties x-15992)))
- (if (pair? props-16007) props-16007 #f)))))
- (extend-env-4289
- (lambda (labels-16009 bindings-16010 r-16011)
- (if (null? labels-16009)
- r-16011
- (extend-env-4289
- (cdr labels-16009)
- (cdr bindings-16010)
- (cons (cons (car labels-16009) (car bindings-16010))
- r-16011)))))
- (extend-var-env-4290
- (lambda (labels-16012 vars-16013 r-16014)
- (if (null? labels-16012)
- r-16014
- (extend-var-env-4290
- (cdr labels-16012)
- (cdr vars-16013)
- (cons (cons (car labels-16012)
- (cons 'lexical (car vars-16013)))
- r-16014)))))
- (macros-only-env-4291
- (lambda (r-16015)
- (if (null? r-16015)
+ (vector-ref %expanded-vtables 17)
+ src-17926
+ in-order?-17927
+ ids-17928
+ vars-17929
+ val-exps-17930
+ body-exp-17931)))))
+ (make-syntax-object-4333
+ (lambda (expression-17957 wrap-17958 module-17959)
+ (vector
+ 'syntax-object
+ expression-17957
+ wrap-17958
+ module-17959)))
+ (extend-env-4342
+ (lambda (labels-17961 bindings-17962 r-17963)
+ (if (null? labels-17961)
+ r-17963
+ (extend-env-4342
+ (cdr labels-17961)
+ (cdr bindings-17962)
+ (cons (cons (car labels-17961) (car bindings-17962))
+ r-17963)))))
+ (extend-var-env-4343
+ (lambda (labels-17964 vars-17965 r-17966)
+ (if (null? labels-17964)
+ r-17966
+ (extend-var-env-4343
+ (cdr labels-17964)
+ (cdr vars-17965)
+ (cons (cons (car labels-17964)
+ (cons 'lexical (car vars-17965)))
+ r-17966)))))
+ (macros-only-env-4344
+ (lambda (r-17967)
+ (if (null? r-17967)
'()
- (let ((a-16016 (car r-16015)))
- (if (eq? (car (cdr a-16016)) 'macro)
- (cons a-16016
- (macros-only-env-4291 (cdr r-16015)))
- (macros-only-env-4291 (cdr r-16015)))))))
- (global-extend-4293
- (lambda (type-16018 sym-16019 val-16020)
+ (let ((a-17968 (car r-17967)))
+ (if (let ((t-17971 (car (cdr a-17968))))
+ (if (eq? t-17971 'macro)
+ #t
+ (eq? t-17971 'syntax-parameter)))
+ (cons a-17968
+ (macros-only-env-4344 (cdr r-17967)))
+ (macros-only-env-4344 (cdr r-17967)))))))
+ (global-extend-4345
+ (lambda (type-17973 sym-17974 val-17975)
(module-define!
(current-module)
- sym-16019
+ sym-17974
(make-syntax-transformer
- sym-16019
- type-16018
- val-16020))))
- (id?-4295
- (lambda (x-9601)
- (if (symbol? x-9601)
+ sym-17974
+ type-17973
+ val-17975))))
+ (id?-4347
+ (lambda (x-11477)
+ (if (symbol? x-11477)
#t
- (if (if (vector? x-9601)
- (if (= (vector-length x-9601) 4)
- (eq? (vector-ref x-9601 0) 'syntax-object)
+ (if (if (vector? x-11477)
+ (if (= (vector-length x-11477) 4)
+ (eq? (vector-ref x-11477 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-9601 1))
+ (symbol? (vector-ref x-11477 1))
#f))))
- (gen-labels-4298
- (lambda (ls-16030)
- (if (null? ls-16030)
+ (gen-labels-4350
+ (lambda (ls-17985)
+ (if (null? ls-17985)
'()
(cons (string-append
"l-"
- (session-id-4256)
+ (session-id-4308)
(symbol->string (gensym "-")))
- (gen-labels-4298 (cdr ls-16030))))))
- (make-binding-wrap-4309
- (lambda (ids-16034 labels-16035 w-16036)
- (if (null? ids-16034)
- w-16036
- (cons (car w-16036)
- (cons (let ((labelvec-16037 (list->vector labels-16035)))
- (let ((n-16038 (vector-length labelvec-16037)))
- (let ((symnamevec-16039 (make-vector n-16038))
- (marksvec-16040 (make-vector n-16038)))
+ (gen-labels-4350 (cdr ls-17985))))))
+ (make-binding-wrap-4361
+ (lambda (ids-17989 labels-17990 w-17991)
+ (if (null? ids-17989)
+ w-17991
+ (cons (car w-17991)
+ (cons (let ((labelvec-17992 (list->vector labels-17990)))
+ (let ((n-17993 (vector-length labelvec-17992)))
+ (let ((symnamevec-17994 (make-vector n-17993))
+ (marksvec-17995 (make-vector n-17993)))
(begin
(letrec*
- ((f-16041
- (lambda (ids-16044 i-16045)
- (if (not (null? ids-16044))
+ ((f-17996
+ (lambda (ids-18193 i-18194)
+ (if (not (null? ids-18193))
(call-with-values
(lambda ()
- (let ((x-16048 (car ids-16044)))
- (if (if (vector? x-16048)
+ (let ((x-18197 (car ids-18193)))
+ (if (if (vector? x-18197)
(if (= (vector-length
- x-16048)
+ x-18197)
4)
(eq? (vector-ref
- x-16048
+ x-18197
0)
'syntax-object)
#f)
#f)
(values
- (vector-ref x-16048 1)
- (let ((m1-16064
- (car w-16036))
- (m2-16065
+ (vector-ref x-18197 1)
+ (let ((m1-18213
+ (car w-17991))
+ (m2-18214
(car (vector-ref
- x-16048
+ x-18197
2))))
- (if (null? m2-16065)
- m1-16064
+ (if (null? m2-18214)
+ m1-18213
(append
- m1-16064
- m2-16065))))
+ m1-18213
+ m2-18214))))
(values
- x-16048
- (car w-16036)))))
- (lambda (symname-16085 marks-16086)
+ x-18197
+ (car w-17991)))))
+ (lambda (symname-18234 marks-18235)
(begin
(vector-set!
- symnamevec-16039
- i-16045
- symname-16085)
+ symnamevec-17994
+ i-18194
+ symname-18234)
(vector-set!
- marksvec-16040
- i-16045
- marks-16086)
- (f-16041
- (cdr ids-16044)
- (#{1+}# i-16045)))))))))
- (f-16041 ids-16034 0))
+ marksvec-17995
+ i-18194
+ marks-18235)
+ (f-17996
+ (cdr ids-18193)
+ (#{1+}# i-18194)))))))))
+ (f-17996 ids-17989 0))
(vector
'ribcage
- symnamevec-16039
- marksvec-16040
- labelvec-16037)))))
- (cdr w-16036))))))
- (join-wraps-4311
- (lambda (w1-16095 w2-16096)
- (let ((m1-16097 (car w1-16095))
- (s1-16098 (cdr w1-16095)))
- (if (null? m1-16097)
- (if (null? s1-16098)
- w2-16096
- (cons (car w2-16096)
- (let ((m2-16105 (cdr w2-16096)))
- (if (null? m2-16105)
- s1-16098
- (append s1-16098 m2-16105)))))
- (cons (let ((m2-16114 (car w2-16096)))
- (if (null? m2-16114)
- m1-16097
- (append m1-16097 m2-16114)))
- (let ((m2-16123 (cdr w2-16096)))
- (if (null? m2-16123)
- s1-16098
- (append s1-16098 m2-16123))))))))
- (same-marks?-4313
- (lambda (x-16128 y-16129)
- (if (eq? x-16128 y-16129)
- (eq? x-16128 y-16129)
- (if (not (null? x-16128))
- (if (not (null? y-16129))
- (if (eq? (car x-16128) (car y-16129))
- (same-marks?-4313 (cdr x-16128) (cdr y-16129))
+ symnamevec-17994
+ marksvec-17995
+ labelvec-17992)))))
+ (cdr w-17991))))))
+ (same-marks?-4365
+ (lambda (x-34051 y-34052)
+ (if (eq? x-34051 y-34052)
+ (eq? x-34051 y-34052)
+ (if (not (null? x-34051))
+ (if (not (null? y-34052))
+ (if (eq? (car x-34051) (car y-34052))
+ (same-marks?-4365 (cdr x-34051) (cdr y-34052))
#f)
#f)
#f))))
- (id-var-name-4314
- (lambda (id-16137 w-16138)
+ (id-var-name-4366
+ (lambda (id-34060 w-34061 mod-34062)
(letrec*
- ((search-16139
- (lambda (sym-16200 subst-16201 marks-16202)
- (if (null? subst-16201)
- (values #f marks-16202)
- (let ((fst-16203 (car subst-16201)))
- (if (eq? fst-16203 'shift)
- (search-16139
- sym-16200
- (cdr subst-16201)
- (cdr marks-16202))
- (let ((symnames-16205 (vector-ref fst-16203 1)))
- (if (vector? symnames-16205)
- (let ((n-16217 (vector-length symnames-16205)))
- (letrec*
- ((f-16218
- (lambda (i-16220)
- (if (= i-16220 n-16217)
- (search-16139
- sym-16200
- (cdr subst-16201)
- marks-16202)
- (if (if (eq? (vector-ref
- symnames-16205
- i-16220)
- sym-16200)
- (same-marks?-4313
- marks-16202
- (vector-ref
- (vector-ref fst-16203 2)
- i-16220))
- #f)
- (values
- (vector-ref
- (vector-ref fst-16203 3)
- i-16220)
- marks-16202)
- (f-16218 (#{1+}# i-16220)))))))
- (f-16218 0)))
- (letrec*
- ((f-16253
- (lambda (symnames-16255 i-16256)
- (if (null? symnames-16255)
- (search-16139
- sym-16200
- (cdr subst-16201)
- marks-16202)
- (if (if (eq? (car symnames-16255) sym-16200)
- (same-marks?-4313
- marks-16202
- (list-ref
- (vector-ref fst-16203 2)
- i-16256))
- #f)
- (values
- (list-ref
- (vector-ref fst-16203 3)
- i-16256)
- marks-16202)
- (f-16253
- (cdr symnames-16255)
- (#{1+}# i-16256)))))))
- (f-16253 symnames-16205 0))))))))))
- (if (symbol? id-16137)
- (let ((t-16142
- (search-16139
- id-16137
- (cdr w-16138)
- (car w-16138))))
- (if t-16142 t-16142 id-16137))
- (if (if (vector? id-16137)
- (if (= (vector-length id-16137) 4)
- (eq? (vector-ref id-16137 0) 'syntax-object)
+ ((search-34063
+ (lambda (sym-34129 subst-34130 marks-34131 mod-34132)
+ (if (null? subst-34130)
+ (values #f marks-34131)
+ (let ((fst-34133 (car subst-34130)))
+ (if (eq? fst-34133 'shift)
+ (search-34063
+ sym-34129
+ (cdr subst-34130)
+ (cdr marks-34131)
+ mod-34132)
+ (let ((symnames-34135 (vector-ref fst-34133 1)))
+ (if (vector? symnames-34135)
+ (search-vector-rib-34065
+ sym-34129
+ subst-34130
+ marks-34131
+ symnames-34135
+ fst-34133
+ mod-34132)
+ (search-list-rib-34064
+ sym-34129
+ subst-34130
+ marks-34131
+ symnames-34135
+ fst-34133
+ mod-34132))))))))
+ (search-list-rib-34064
+ (lambda (sym-34310
+ subst-34311
+ marks-34312
+ symnames-34313
+ ribcage-34314
+ mod-34315)
+ (letrec*
+ ((f-34316
+ (lambda (symnames-34319 i-34320)
+ (if (null? symnames-34319)
+ (search-34063
+ sym-34310
+ (cdr subst-34311)
+ marks-34312
+ mod-34315)
+ (if (if (eq? (car symnames-34319) sym-34310)
+ (same-marks?-4365
+ marks-34312
+ (list-ref
+ (vector-ref ribcage-34314 2)
+ i-34320))
+ #f)
+ (let ((n-34466
+ (list-ref
+ (vector-ref ribcage-34314 3)
+ i-34320)))
+ (if (pair? n-34466)
+ (if (equal? mod-34315 (car n-34466))
+ (values (cdr n-34466) marks-34312)
+ (f-34316
+ (cdr symnames-34319)
+ (#{1+}# i-34320)))
+ (values n-34466 marks-34312)))
+ (f-34316 (cdr symnames-34319) (#{1+}# i-34320)))))))
+ (f-34316 symnames-34313 0))))
+ (search-vector-rib-34065
+ (lambda (sym-34471
+ subst-34472
+ marks-34473
+ symnames-34474
+ ribcage-34475
+ mod-34476)
+ (let ((n-34477 (vector-length symnames-34474)))
+ (letrec*
+ ((f-34478
+ (lambda (i-34481)
+ (if (= i-34481 n-34477)
+ (search-34063
+ sym-34471
+ (cdr subst-34472)
+ marks-34473
+ mod-34476)
+ (if (if (eq? (vector-ref symnames-34474 i-34481)
+ sym-34471)
+ (same-marks?-4365
+ marks-34473
+ (vector-ref
+ (vector-ref ribcage-34475 2)
+ i-34481))
+ #f)
+ (let ((n-34628
+ (vector-ref
+ (vector-ref ribcage-34475 3)
+ i-34481)))
+ (if (pair? n-34628)
+ (if (equal? mod-34476 (car n-34628))
+ (values (cdr n-34628) marks-34473)
+ (f-34478 (#{1+}# i-34481)))
+ (values n-34628 marks-34473)))
+ (f-34478 (#{1+}# i-34481)))))))
+ (f-34478 0))))))
+ (if (symbol? id-34060)
+ (let ((t-34066
+ (search-34063
+ id-34060
+ (cdr w-34061)
+ (car w-34061)
+ mod-34062)))
+ (if t-34066 t-34066 id-34060))
+ (if (if (vector? id-34060)
+ (if (= (vector-length id-34060) 4)
+ (eq? (vector-ref id-34060 0) 'syntax-object)
#f)
#f)
- (let ((id-16157 (vector-ref id-16137 1))
- (w1-16158 (vector-ref id-16137 2)))
- (let ((marks-16159
- (let ((m1-16169 (car w-16138))
- (m2-16170 (car w1-16158)))
- (if (null? m2-16170)
- m1-16169
- (append m1-16169 m2-16170)))))
+ (let ((id-34081 (vector-ref id-34060 1))
+ (w1-34082 (vector-ref id-34060 2))
+ (mod-34083 (vector-ref id-34060 3)))
+ (let ((marks-34084
+ (let ((m1-34094 (car w-34061))
+ (m2-34095 (car w1-34082)))
+ (if (null? m2-34095)
+ m1-34094
+ (append m1-34094 m2-34095)))))
(call-with-values
(lambda ()
- (search-16139 id-16157 (cdr w-16138) marks-16159))
- (lambda (new-id-16186 marks-16187)
- (if new-id-16186
- new-id-16186
- (let ((t-16195
- (search-16139
- id-16157
- (cdr w1-16158)
- marks-16187)))
- (if t-16195 t-16195 id-16157)))))))
+ (search-34063
+ id-34081
+ (cdr w-34061)
+ marks-34084
+ mod-34083))
+ (lambda (new-id-34115 marks-34116)
+ (if new-id-34115
+ new-id-34115
+ (let ((t-34124
+ (search-34063
+ id-34081
+ (cdr w1-34082)
+ marks-34116
+ mod-34083)))
+ (if t-34124 t-34124 id-34081)))))))
(syntax-violation
'id-var-name
"invalid id"
- id-16137))))))
- (locally-bound-identifiers-4315
- (lambda (w-16278 mod-16279)
+ id-34060))))))
+ (locally-bound-identifiers-4367
+ (lambda (w-18242 mod-18243)
(letrec*
- ((scan-16280
- (lambda (subst-16285 results-16286)
- (if (null? subst-16285)
- results-16286
- (let ((fst-16287 (car subst-16285)))
- (if (eq? fst-16287 'shift)
- (scan-16280 (cdr subst-16285) results-16286)
- (let ((symnames-16289 (vector-ref fst-16287 1))
- (marks-16290 (vector-ref fst-16287 2)))
- (if (vector? symnames-16289)
- (scan-vector-rib-16282
- subst-16285
- symnames-16289
- marks-16290
- results-16286)
- (scan-list-rib-16281
- subst-16285
- symnames-16289
- marks-16290
- results-16286))))))))
- (scan-list-rib-16281
- (lambda (subst-16388
- symnames-16389
- marks-16390
- results-16391)
+ ((scan-18244
+ (lambda (subst-18249 results-18250)
+ (if (null? subst-18249)
+ results-18250
+ (let ((fst-18251 (car subst-18249)))
+ (if (eq? fst-18251 'shift)
+ (scan-18244 (cdr subst-18249) results-18250)
+ (let ((symnames-18253 (vector-ref fst-18251 1))
+ (marks-18254 (vector-ref fst-18251 2)))
+ (if (vector? symnames-18253)
+ (scan-vector-rib-18246
+ subst-18249
+ symnames-18253
+ marks-18254
+ results-18250)
+ (scan-list-rib-18245
+ subst-18249
+ symnames-18253
+ marks-18254
+ results-18250))))))))
+ (scan-list-rib-18245
+ (lambda (subst-18371
+ symnames-18372
+ marks-18373
+ results-18374)
(letrec*
- ((f-16392
- (lambda (symnames-16492 marks-16493 results-16494)
- (if (null? symnames-16492)
- (scan-16280 (cdr subst-16388) results-16494)
- (f-16392
- (cdr symnames-16492)
- (cdr marks-16493)
- (cons (wrap-4324
- (car symnames-16492)
- (let ((w-16502
- (cons (car marks-16493)
- subst-16388)))
- (cons (cons #f (car w-16502))
- (cons 'shift (cdr w-16502))))
- mod-16279)
- results-16494))))))
- (f-16392
- symnames-16389
- marks-16390
- results-16391))))
- (scan-vector-rib-16282
- (lambda (subst-16503
- symnames-16504
- marks-16505
- results-16506)
- (let ((n-16507 (vector-length symnames-16504)))
+ ((f-18375
+ (lambda (symnames-18560 marks-18561 results-18562)
+ (if (null? symnames-18560)
+ (scan-18244 (cdr subst-18371) results-18562)
+ (f-18375
+ (cdr symnames-18560)
+ (cdr marks-18561)
+ (cons (let ((x-18568 (car symnames-18560))
+ (w-18569
+ (let ((w-18573
+ (cons (car marks-18561)
+ subst-18371)))
+ (cons (cons #f (car w-18573))
+ (cons 'shift
+ (cdr w-18573))))))
+ (if (if (null? (car w-18569))
+ (null? (cdr w-18569))
+ #f)
+ x-18568
+ (if (if (vector? x-18568)
+ (if (= (vector-length x-18568) 4)
+ (eq? (vector-ref x-18568 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-18585
+ (vector-ref x-18568 1))
+ (wrap-18586
+ (let ((w2-18594
+ (vector-ref x-18568 2)))
+ (let ((m1-18595 (car w-18569))
+ (s1-18596
+ (cdr w-18569)))
+ (if (null? m1-18595)
+ (if (null? s1-18596)
+ w2-18594
+ (cons (car w2-18594)
+ (let ((m2-18607
+ (cdr w2-18594)))
+ (if (null? m2-18607)
+ s1-18596
+ (append
+ s1-18596
+ m2-18607)))))
+ (cons (let ((m2-18615
+ (car w2-18594)))
+ (if (null? m2-18615)
+ m1-18595
+ (append
+ m1-18595
+ m2-18615)))
+ (let ((m2-18623
+ (cdr w2-18594)))
+ (if (null? m2-18623)
+ s1-18596
+ (append
+ s1-18596
+ m2-18623))))))))
+ (module-18587
+ (vector-ref x-18568 3)))
+ (vector
+ 'syntax-object
+ expression-18585
+ wrap-18586
+ module-18587))
+ (if (null? x-18568)
+ x-18568
+ (vector
+ 'syntax-object
+ x-18568
+ w-18569
+ mod-18243)))))
+ results-18562))))))
+ (f-18375
+ symnames-18372
+ marks-18373
+ results-18374))))
+ (scan-vector-rib-18246
+ (lambda (subst-18636
+ symnames-18637
+ marks-18638
+ results-18639)
+ (let ((n-18640 (vector-length symnames-18637)))
(letrec*
- ((f-16508
- (lambda (i-16591 results-16592)
- (if (= i-16591 n-16507)
- (scan-16280 (cdr subst-16503) results-16592)
- (f-16508
- (#{1+}# i-16591)
- (cons (wrap-4324
- (vector-ref symnames-16504 i-16591)
- (let ((w-16600
- (cons (vector-ref
- marks-16505
- i-16591)
- subst-16503)))
- (cons (cons #f (car w-16600))
- (cons 'shift (cdr w-16600))))
- mod-16279)
- results-16592))))))
- (f-16508 0 results-16506))))))
- (scan-16280 (cdr w-16278) '()))))
- (valid-bound-ids?-4321
- (lambda (ids-16601)
+ ((f-18641
+ (lambda (i-18812 results-18813)
+ (if (= i-18812 n-18640)
+ (scan-18244 (cdr subst-18636) results-18813)
+ (f-18641
+ (#{1+}# i-18812)
+ (cons (let ((x-18819
+ (vector-ref symnames-18637 i-18812))
+ (w-18820
+ (let ((w-18824
+ (cons (vector-ref
+ marks-18638
+ i-18812)
+ subst-18636)))
+ (cons (cons #f (car w-18824))
+ (cons 'shift
+ (cdr w-18824))))))
+ (if (if (null? (car w-18820))
+ (null? (cdr w-18820))
+ #f)
+ x-18819
+ (if (if (vector? x-18819)
+ (if (= (vector-length x-18819) 4)
+ (eq? (vector-ref x-18819 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-18836
+ (vector-ref x-18819 1))
+ (wrap-18837
+ (let ((w2-18845
+ (vector-ref
+ x-18819
+ 2)))
+ (let ((m1-18846
+ (car w-18820))
+ (s1-18847
+ (cdr w-18820)))
+ (if (null? m1-18846)
+ (if (null? s1-18847)
+ w2-18845
+ (cons (car w2-18845)
+ (let ((m2-18858
+ (cdr w2-18845)))
+ (if (null? m2-18858)
+ s1-18847
+ (append
+ s1-18847
+ m2-18858)))))
+ (cons (let ((m2-18866
+ (car w2-18845)))
+ (if (null? m2-18866)
+ m1-18846
+ (append
+ m1-18846
+ m2-18866)))
+ (let ((m2-18874
+ (cdr w2-18845)))
+ (if (null? m2-18874)
+ s1-18847
+ (append
+ s1-18847
+ m2-18874))))))))
+ (module-18838
+ (vector-ref x-18819 3)))
+ (vector
+ 'syntax-object
+ expression-18836
+ wrap-18837
+ module-18838))
+ (if (null? x-18819)
+ x-18819
+ (vector
+ 'syntax-object
+ x-18819
+ w-18820
+ mod-18243)))))
+ results-18813))))))
+ (f-18641 0 results-18639))))))
+ (scan-18244 (cdr w-18242) '()))))
+ (resolve-identifier-4368
+ (lambda (id-18887
+ w-18888
+ r-18889
+ mod-18890
+ resolve-syntax-parameters?-18891)
+ (let ((n-18895
+ (id-var-name-4366 id-18887 w-18888 mod-18890)))
+ (if (if (vector? n-18895)
+ (if (= (vector-length n-18895) 4)
+ (eq? (vector-ref n-18895 0) 'syntax-object)
+ #f)
+ #f)
+ (resolve-identifier-4368
+ n-18895
+ w-18888
+ r-18889
+ mod-18890
+ resolve-syntax-parameters?-18891)
+ (if (symbol? n-18895)
+ (let ((mod-18910
+ (if (if (vector? id-18887)
+ (if (= (vector-length id-18887) 4)
+ (eq? (vector-ref id-18887 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref id-18887 3)
+ mod-18890)))
+ (let ((b-18911
+ (let ((b-18914
+ (let ((t-18915
+ (begin
+ (if (if (not mod-18910)
+ (current-module)
+ #f)
+ (warn "module system is booted, we should have a module"
+ n-18895))
+ (let ((v-18964
+ (module-variable
+ (if mod-18910
+ (resolve-module
+ (cdr mod-18910))
+ (current-module))
+ n-18895)))
+ (if v-18964
+ (if (variable-bound? v-18964)
+ (let ((val-18973
+ (variable-ref
+ v-18964)))
+ (if (macro? val-18973)
+ (if (macro-type val-18973)
+ (cons (macro-type
+ val-18973)
+ (macro-binding
+ val-18973))
+ #f)
+ #f))
+ #f)
+ #f)))))
+ (if t-18915 t-18915 '(global)))))
+ (if (if resolve-syntax-parameters?-18891
+ (eq? (car b-18914) 'syntax-parameter)
+ #f)
+ (let ((t-18982 (assq-ref r-18889 (cdr b-18914))))
+ (if t-18982
+ t-18982
+ (cons 'macro (car (cdr b-18914)))))
+ b-18914))))
+ (if (eq? (car b-18911) 'global)
+ (values 'global n-18895 mod-18910)
+ (values (car b-18911) (cdr b-18911) mod-18910))))
+ (if (string? n-18895)
+ (let ((mod-18988
+ (if (if (vector? id-18887)
+ (if (= (vector-length id-18887) 4)
+ (eq? (vector-ref id-18887 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref id-18887 3)
+ mod-18890)))
+ (let ((b-18989
+ (let ((b-18992
+ (let ((t-18993 (assq-ref r-18889 n-18895)))
+ (if t-18993
+ t-18993
+ '(displaced-lexical)))))
+ (if (if resolve-syntax-parameters?-18891
+ (eq? (car b-18992) 'syntax-parameter)
+ #f)
+ (let ((t-18994
+ (assq-ref r-18889 (cdr b-18992))))
+ (if t-18994
+ t-18994
+ (cons 'macro (car (cdr b-18992)))))
+ b-18992))))
+ (values (car b-18989) (cdr b-18989) mod-18988)))
+ (error "unexpected id-var-name"
+ id-18887
+ w-18888
+ n-18895)))))))
+ (free-id=?-4371
+ (lambda (i-19007 j-19008)
+ (let ((mi-19009
+ (if (if (vector? i-19007)
+ (if (= (vector-length i-19007) 4)
+ (eq? (vector-ref i-19007 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref i-19007 3)
+ #f)))
+ (let ((mj-19010
+ (if (if (vector? j-19008)
+ (if (= (vector-length j-19008) 4)
+ (eq? (vector-ref j-19008 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref j-19008 3)
+ #f)))
+ (let ((ni-19011
+ (id-var-name-4366 i-19007 '(()) mi-19009)))
+ (let ((nj-19012
+ (id-var-name-4366 j-19008 '(()) mj-19010)))
+ (if (if (vector? ni-19011)
+ (if (= (vector-length ni-19011) 4)
+ (eq? (vector-ref ni-19011 0) 'syntax-object)
+ #f)
+ #f)
+ (free-id=?-4371 ni-19011 j-19008)
+ (if (if (vector? nj-19012)
+ (if (= (vector-length nj-19012) 4)
+ (eq? (vector-ref nj-19012 0) 'syntax-object)
+ #f)
+ #f)
+ (free-id=?-4371 i-19007 nj-19012)
+ (if (symbol? ni-19011)
+ (if (eq? nj-19012
+ (if (if (vector? j-19008)
+ (if (= (vector-length j-19008) 4)
+ (eq? (vector-ref j-19008 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref j-19008 1)
+ j-19008))
+ (if (let ((bi-19084
+ (module-variable
+ (if mi-19009
+ (resolve-module (cdr mi-19009))
+ (current-module))
+ (if (if (vector? i-19007)
+ (if (= (vector-length i-19007) 4)
+ (eq? (vector-ref i-19007 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref i-19007 1)
+ i-19007))))
+ (if bi-19084
+ (eq? bi-19084
+ (module-variable
+ (if mj-19010
+ (resolve-module (cdr mj-19010))
+ (current-module))
+ (if (if (vector? j-19008)
+ (if (= (vector-length j-19008) 4)
+ (eq? (vector-ref j-19008 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref j-19008 1)
+ j-19008)))
+ (if (not (module-variable
+ (if mj-19010
+ (resolve-module (cdr mj-19010))
+ (current-module))
+ (if (if (vector? j-19008)
+ (if (= (vector-length
+ j-19008)
+ 4)
+ (eq? (vector-ref j-19008 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref j-19008 1)
+ j-19008)))
+ (eq? ni-19011 nj-19012)
+ #f)))
+ (eq? (module-variable
+ (if mi-19009
+ (resolve-module (cdr mi-19009))
+ (current-module))
+ (if (if (vector? i-19007)
+ (if (= (vector-length i-19007) 4)
+ (eq? (vector-ref i-19007 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref i-19007 1)
+ i-19007))
+ (module-variable
+ (if mj-19010
+ (resolve-module (cdr mj-19010))
+ (current-module))
+ (if (if (vector? j-19008)
+ (if (= (vector-length j-19008) 4)
+ (eq? (vector-ref j-19008 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref j-19008 1)
+ j-19008)))
+ #f)
+ #f)
+ (equal? ni-19011 nj-19012))))))))))
+ (bound-id=?-4372
+ (lambda (i-19277 j-19278)
+ (if (if (if (vector? i-19277)
+ (if (= (vector-length i-19277) 4)
+ (eq? (vector-ref i-19277 0) 'syntax-object)
+ #f)
+ #f)
+ (if (vector? j-19278)
+ (if (= (vector-length j-19278) 4)
+ (eq? (vector-ref j-19278 0) 'syntax-object)
+ #f)
+ #f)
+ #f)
+ (if (eq? (vector-ref i-19277 1)
+ (vector-ref j-19278 1))
+ (same-marks?-4365
+ (car (vector-ref i-19277 2))
+ (car (vector-ref j-19278 2)))
+ #f)
+ (eq? i-19277 j-19278))))
+ (valid-bound-ids?-4373
+ (lambda (ids-19447)
(if (letrec*
- ((all-ids?-16602
- (lambda (ids-16764)
- (if (null? ids-16764)
- (null? ids-16764)
- (if (let ((x-16775 (car ids-16764)))
- (if (symbol? x-16775)
+ ((all-ids?-19448
+ (lambda (ids-19645)
+ (if (null? ids-19645)
+ (null? ids-19645)
+ (if (let ((x-19656 (car ids-19645)))
+ (if (symbol? x-19656)
#t
- (if (if (vector? x-16775)
- (if (= (vector-length x-16775) 4)
- (eq? (vector-ref x-16775 0)
+ (if (if (vector? x-19656)
+ (if (= (vector-length x-19656) 4)
+ (eq? (vector-ref x-19656 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-16775 1))
+ (symbol? (vector-ref x-19656 1))
#f)))
- (all-ids?-16602 (cdr ids-16764))
+ (all-ids?-19448 (cdr ids-19645))
#f)))))
- (all-ids?-16602 ids-16601))
- (distinct-bound-ids?-4322 ids-16601)
+ (all-ids?-19448 ids-19447))
+ (distinct-bound-ids?-4374 ids-19447)
#f)))
- (distinct-bound-ids?-4322
- (lambda (ids-16903)
+ (distinct-bound-ids?-4374
+ (lambda (ids-19777)
(letrec*
- ((distinct?-16904
- (lambda (ids-17016)
- (if (null? ids-17016)
- (null? ids-17016)
- (if (not (bound-id-member?-4323
- (car ids-17016)
- (cdr ids-17016)))
- (distinct?-16904 (cdr ids-17016))
+ ((distinct?-19778
+ (lambda (ids-19883)
+ (if (null? ids-19883)
+ (null? ids-19883)
+ (if (not (bound-id-member?-4375
+ (car ids-19883)
+ (cdr ids-19883)))
+ (distinct?-19778 (cdr ids-19883))
#f)))))
- (distinct?-16904 ids-16903))))
- (bound-id-member?-4323
- (lambda (x-17226 list-17227)
- (if (not (null? list-17227))
- (let ((t-17228
- (let ((j-17309 (car list-17227)))
- (if (if (if (vector? x-17226)
- (if (= (vector-length x-17226) 4)
- (eq? (vector-ref x-17226 0) 'syntax-object)
- #f)
- #f)
- (if (vector? j-17309)
- (if (= (vector-length j-17309) 4)
- (eq? (vector-ref j-17309 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref x-17226 1)
- (vector-ref j-17309 1))
- (same-marks?-4313
- (car (vector-ref x-17226 2))
- (car (vector-ref j-17309 2)))
- #f)
- (eq? x-17226 j-17309)))))
- (if t-17228
- t-17228
- (bound-id-member?-4323 x-17226 (cdr list-17227))))
+ (distinct?-19778 ids-19777))))
+ (bound-id-member?-4375
+ (lambda (x-19979 list-19980)
+ (if (not (null? list-19980))
+ (let ((t-19981
+ (bound-id=?-4372 x-19979 (car list-19980))))
+ (if t-19981
+ t-19981
+ (bound-id-member?-4375 x-19979 (cdr list-19980))))
#f)))
- (wrap-4324
- (lambda (x-17353 w-17354 defmod-17355)
- (if (if (null? (car w-17354))
- (null? (cdr w-17354))
- #f)
- x-17353
- (if (if (vector? x-17353)
- (if (= (vector-length x-17353) 4)
- (eq? (vector-ref x-17353 0) 'syntax-object)
- #f)
+ (source-wrap-4377
+ (lambda (x-20159 w-20160 s-20161 defmod-20162)
+ (let ((x-20166
+ (begin
+ (if (if s-20161
+ (supports-source-properties? x-20159)
+ #f)
+ (set-source-properties! x-20159 s-20161))
+ x-20159)))
+ (if (if (null? (car w-20160))
+ (null? (cdr w-20160))
#f)
- (let ((expression-17369 (vector-ref x-17353 1))
- (wrap-17370
- (join-wraps-4311 w-17354 (vector-ref x-17353 2)))
- (module-17371 (vector-ref x-17353 3)))
- (vector
- 'syntax-object
- expression-17369
- wrap-17370
- module-17371))
- (if (null? x-17353)
- x-17353
- (vector
- 'syntax-object
- x-17353
- w-17354
- defmod-17355))))))
- (source-wrap-4325
- (lambda (x-17388 w-17389 s-17390 defmod-17391)
- (wrap-4324
- (begin
- (if (if s-17390
- (supports-source-properties? x-17388)
+ x-20166
+ (if (if (vector? x-20166)
+ (if (= (vector-length x-20166) 4)
+ (eq? (vector-ref x-20166 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! x-17388 s-17390))
- x-17388)
- w-17389
- defmod-17391)))
- (expand-sequence-4326
- (lambda (body-27527 r-27528 w-27529 s-27530 mod-27531)
- (build-sequence-4276
- s-27530
+ (let ((expression-20198 (vector-ref x-20166 1))
+ (wrap-20199
+ (let ((w2-20207 (vector-ref x-20166 2)))
+ (let ((m1-20208 (car w-20160))
+ (s1-20209 (cdr w-20160)))
+ (if (null? m1-20208)
+ (if (null? s1-20209)
+ w2-20207
+ (cons (car w2-20207)
+ (let ((m2-20224 (cdr w2-20207)))
+ (if (null? m2-20224)
+ s1-20209
+ (append s1-20209 m2-20224)))))
+ (cons (let ((m2-20232 (car w2-20207)))
+ (if (null? m2-20232)
+ m1-20208
+ (append m1-20208 m2-20232)))
+ (let ((m2-20240 (cdr w2-20207)))
+ (if (null? m2-20240)
+ s1-20209
+ (append s1-20209 m2-20240))))))))
+ (module-20200 (vector-ref x-20166 3)))
+ (vector
+ 'syntax-object
+ expression-20198
+ wrap-20199
+ module-20200))
+ (if (null? x-20166)
+ x-20166
+ (vector
+ 'syntax-object
+ x-20166
+ w-20160
+ defmod-20162)))))))
+ (expand-sequence-4378
+ (lambda (body-34633 r-34634 w-34635 s-34636 mod-34637)
+ (build-sequence-4329
+ s-34636
(letrec*
- ((dobody-27611
- (lambda (body-27951 r-27952 w-27953 mod-27954)
- (if (null? body-27951)
+ ((dobody-34772
+ (lambda (body-35078 r-35079 w-35080 mod-35081)
+ (if (null? body-35078)
'()
- (let ((first-27955
- (let ((e-27959 (car body-27951)))
+ (let ((first-35082
+ (let ((e-35086 (car body-35078)))
(call-with-values
(lambda ()
- (syntax-type-4330
- e-27959
- r-27952
- w-27953
- (source-annotation-4288 e-27959)
+ (syntax-type-4382
+ e-35086
+ r-35079
+ w-35080
+ (let ((props-35096
+ (source-properties
+ (if (if (vector? e-35086)
+ (if (= (vector-length
+ e-35086)
+ 4)
+ (eq? (vector-ref
+ e-35086
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-35086 1)
+ e-35086))))
+ (if (pair? props-35096) props-35096 #f))
#f
- mod-27954
+ mod-35081
#f))
- (lambda (type-27966
- value-27967
- form-27968
- e-27969
- w-27970
- s-27971
- mod-27972)
- (expand-expr-4332
- type-27966
- value-27967
- form-27968
- e-27969
- r-27952
- w-27970
- s-27971
- mod-27972))))))
- (cons first-27955
- (dobody-27611
- (cdr body-27951)
- r-27952
- w-27953
- mod-27954)))))))
- (dobody-27611
- body-27527
- r-27528
- w-27529
- mod-27531)))))
- (expand-top-sequence-4327
- (lambda (body-17409
- r-17410
- w-17411
- s-17412
- m-17413
- esew-17414
- mod-17415)
- (letrec*
- ((scan-17416
- (lambda (body-17547
- r-17548
- w-17549
- s-17550
- m-17551
- esew-17552
- mod-17553
- exps-17554)
- (if (null? body-17547)
- exps-17554
- (call-with-values
- (lambda ()
+ (lambda (type-35119
+ value-35120
+ form-35121
+ e-35122
+ w-35123
+ s-35124
+ mod-35125)
+ (expand-expr-4384
+ type-35119
+ value-35120
+ form-35121
+ e-35122
+ r-35079
+ w-35123
+ s-35124
+ mod-35125))))))
+ (cons first-35082
+ (dobody-34772
+ (cdr body-35078)
+ r-35079
+ w-35080
+ mod-35081)))))))
+ (dobody-34772
+ body-34633
+ r-34634
+ w-34635
+ mod-34637)))))
+ (expand-top-sequence-4379
+ (lambda (body-20269
+ r-20270
+ w-20271
+ s-20272
+ m-20273
+ esew-20274
+ mod-20275)
+ (let ((r-20276
+ (cons '("placeholder" placeholder) r-20270)))
+ (let ((ribcage-20277 (vector 'ribcage '() '() '())))
+ (let ((w-20278
+ (cons (car w-20271)
+ (cons ribcage-20277 (cdr w-20271)))))
+ (letrec*
+ ((record-definition!-20279
+ (lambda (id-23483 var-23484)
+ (let ((mod-23485
+ (cons 'hygiene (module-name (current-module)))))
+ (let ((label-23491
+ (cons (vector-ref id-23483 3)
+ (if (if (vector? var-23484)
+ (if (= (vector-length var-23484) 4)
+ (eq? (vector-ref var-23484 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-23553
+ (vector-ref var-23484 1))
+ (wrap-23554
+ (let ((w2-23564
+ (vector-ref
+ var-23484
+ 2)))
+ (cons (let ((m2-23571
+ (car w2-23564)))
+ (if (null? m2-23571)
+ '(top)
+ (append
+ '(top)
+ m2-23571)))
+ (let ((m2-23580
+ (cdr w2-23564)))
+ (if (null? m2-23580)
+ '()
+ (append
+ '()
+ m2-23580))))))
+ (module-23555
+ (vector-ref var-23484 3)))
+ (vector
+ 'syntax-object
+ expression-23553
+ wrap-23554
+ module-23555))
+ (if (null? var-23484)
+ var-23484
+ (vector
+ 'syntax-object
+ var-23484
+ '((top))
+ mod-23485))))))
+ (begin
+ (let ((update-23494
+ (cons (vector-ref id-23483 1)
+ (vector-ref ribcage-20277 1))))
+ (vector-set! ribcage-20277 1 update-23494))
+ (let ((update-23509
+ (cons (car (vector-ref id-23483 2))
+ (vector-ref ribcage-20277 2))))
+ (vector-set! ribcage-20277 2 update-23509))
+ (let ((update-23524
+ (cons label-23491
+ (vector-ref ribcage-20277 3))))
+ (vector-set! ribcage-20277 3 update-23524)))))))
+ (parse-20282
+ (lambda (body-20479
+ r-20480
+ w-20481
+ s-20482
+ m-20483
+ esew-20484
+ mod-20485)
+ (letrec*
+ ((lp-20486
+ (lambda (body-20726 exps-20727)
+ (if (null? body-20726)
+ exps-20727
+ (lp-20486
+ (cdr body-20726)
+ (append
+ (parse1-20283
+ (car body-20726)
+ r-20480
+ w-20481
+ s-20482
+ m-20483
+ esew-20484
+ mod-20485)
+ exps-20727))))))
+ (lp-20486 body-20479 '()))))
+ (parse1-20283
+ (lambda (x-20969
+ r-20970
+ w-20971
+ s-20972
+ m-20973
+ esew-20974
+ mod-20975)
(call-with-values
(lambda ()
- (let ((e-17555 (car body-17547)))
- (syntax-type-4330
- e-17555
- r-17548
- w-17549
- (let ((t-17559 (source-annotation-4288 e-17555)))
- (if t-17559 t-17559 s-17550))
- #f
- mod-17553
- #f)))
- (lambda (type-17794
- value-17795
- form-17796
- e-17797
- w-17798
- s-17799
- mod-17800)
- (if (eqv? type-17794 'begin-form)
- (let ((tmp-17809 ($sc-dispatch e-17797 '(_))))
- (if tmp-17809
- (@apply (lambda () exps-17554) tmp-17809)
- (let ((tmp-17813
- ($sc-dispatch
- e-17797
- '(_ any . each-any))))
- (if tmp-17813
- (@apply
- (lambda (e1-17817 e2-17818)
- (scan-17416
- (cons e1-17817 e2-17818)
- r-17548
- w-17798
- s-17799
- m-17551
- esew-17552
- mod-17800
- exps-17554))
- tmp-17813)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-17797)))))
- (if (eqv? type-17794 'local-syntax-form)
- (expand-local-syntax-4336
- value-17795
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800
- (lambda (body-17836
- r-17837
- w-17838
- s-17839
- mod-17840)
- (scan-17416
- body-17836
- r-17837
- w-17838
- s-17839
- m-17551
- esew-17552
- mod-17840
- exps-17554)))
- (if (eqv? type-17794 'eval-when-form)
- (let ((tmp-17848
- ($sc-dispatch
- e-17797
- '(_ each-any any . each-any))))
- (if tmp-17848
- (@apply
- (lambda (x-17852 e1-17853 e2-17854)
- (let ((when-list-17855
- (parse-when-list-4329
- e-17797
- x-17852))
- (body-17856
- (cons e1-17853 e2-17854)))
- (if (eq? m-17551 'e)
- (if (memq 'eval when-list-17855)
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- (if (memq 'expand
- when-list-17855)
- 'c&e
- 'e)
- '(eval)
- mod-17800
- exps-17554)
+ (syntax-type-4382
+ x-20969
+ r-20970
+ w-20971
+ (let ((props-20982
+ (source-properties
+ (if (if (vector? x-20969)
+ (if (= (vector-length x-20969) 4)
+ (eq? (vector-ref x-20969 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-20969 1)
+ x-20969))))
+ (if (pair? props-20982) props-20982 #f))
+ ribcage-20277
+ mod-20975
+ #f))
+ (lambda (type-21005
+ value-21006
+ form-21007
+ e-21008
+ w-21009
+ s-21010
+ mod-21011)
+ (if (eqv? type-21005 'define-form)
+ (let ((id-21019
+ (if (if (null? (car w-21009))
+ (null? (cdr w-21009))
+ #f)
+ value-21006
+ (if (if (vector? value-21006)
+ (if (= (vector-length value-21006)
+ 4)
+ (eq? (vector-ref value-21006 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-21069
+ (vector-ref value-21006 1))
+ (wrap-21070
+ (let ((w2-21080
+ (vector-ref
+ value-21006
+ 2)))
+ (let ((m1-21081
+ (car w-21009))
+ (s1-21082
+ (cdr w-21009)))
+ (if (null? m1-21081)
+ (if (null? s1-21082)
+ w2-21080
+ (cons (car w2-21080)
+ (let ((m2-21099
+ (cdr w2-21080)))
+ (if (null? m2-21099)
+ s1-21082
+ (append
+ s1-21082
+ m2-21099)))))
+ (cons (let ((m2-21107
+ (car w2-21080)))
+ (if (null? m2-21107)
+ m1-21081
+ (append
+ m1-21081
+ m2-21107)))
+ (let ((m2-21115
+ (cdr w2-21080)))
+ (if (null? m2-21115)
+ s1-21082
+ (append
+ s1-21082
+ m2-21115))))))))
+ (module-21071
+ (vector-ref value-21006 3)))
+ (vector
+ 'syntax-object
+ expression-21069
+ wrap-21070
+ module-21071))
+ (if (null? value-21006)
+ value-21006
+ (vector
+ 'syntax-object
+ value-21006
+ w-21009
+ mod-21011))))))
+ (begin
+ (string-append
+ "l-"
+ (session-id-4308)
+ (symbol->string (gensym "-")))
+ (let ((var-21021
+ (if (not (equal?
+ (car (vector-ref
+ id-21019
+ 2))
+ '(top)))
+ (symbol-append
+ (vector-ref id-21019 1)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum x-20969)
+ most-positive-fixnum)
+ 16)))
+ (vector-ref id-21019 1))))
+ (begin
+ (record-definition!-20279
+ id-21019
+ var-21021)
+ (list (if (eq? m-20973 'c&e)
+ (let ((x-21241
+ (let ((exp-21251
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-21272
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-21272)
+ props-21272
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-21305
+ value-21306
+ form-21307
+ e-21308
+ w-21309
+ s-21310
+ mod-21311)
+ (expand-expr-4384
+ type-21305
+ value-21306
+ form-21307
+ e-21308
+ r-20970
+ w-21309
+ s-21310
+ mod-21311)))))
+ (begin
+ (if (if (struct?
+ exp-21251)
+ (eq? (struct-vtable
+ exp-21251)
+ (vector-ref
+ %expanded-vtables
+ 14))
+ #f)
+ (let ((meta-21323
+ (struct-ref
+ exp-21251
+ 1)))
+ (if (not (assq 'name
+ meta-21323))
+ (let ((v-21330
+ (cons (cons 'name
+ var-21021)
+ meta-21323)))
+ (struct-set!
+ exp-21251
+ 1
+ v-21330)))))
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 9)
+ s-21010
+ var-21021
+ exp-21251)))))
(begin
- (if (memq 'expand
- when-list-17855)
- (let ((x-17933
- (expand-top-sequence-4327
- body-17856
- r-17548
- w-17798
- s-17799
- 'e
- '(eval)
- mod-17800)))
- (primitive-eval x-17933)))
- exps-17554))
- (if (memq 'load when-list-17855)
- (if (let ((t-17959
- (memq 'compile
- when-list-17855)))
- (if t-17959
- t-17959
- (let ((t-18008
- (memq 'expand
- when-list-17855)))
- (if t-18008
- t-18008
- (if (eq? m-17551
- 'c&e)
- (memq 'eval
- when-list-17855)
- #f)))))
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- 'c&e
- '(compile load)
- mod-17800
- exps-17554)
- (if (if (eq? m-17551 'c)
- #t
- (eq? m-17551 'c&e))
- (scan-17416
- body-17856
- r-17548
- w-17798
- s-17799
- 'c
- '(load)
- mod-17800
- exps-17554)
- exps-17554))
- (if (let ((t-18137
- (memq 'compile
- when-list-17855)))
- (if t-18137
- t-18137
- (let ((t-18186
- (memq 'expand
- when-list-17855)))
- (if t-18186
- t-18186
- (if (eq? m-17551
- 'c&e)
- (memq 'eval
- when-list-17855)
- #f)))))
+ (primitive-eval x-21241)
+ (lambda () x-21241)))
+ (lambda ()
+ (let ((exp-21346
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-21367
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-21367)
+ props-21367
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-21400
+ value-21401
+ form-21402
+ e-21403
+ w-21404
+ s-21405
+ mod-21406)
+ (expand-expr-4384
+ type-21400
+ value-21401
+ form-21402
+ e-21403
+ r-20970
+ w-21404
+ s-21405
+ mod-21406)))))
(begin
- (let ((x-18310
- (expand-top-sequence-4327
- body-17856
- r-17548
- w-17798
- s-17799
- 'e
- '(eval)
- mod-17800)))
- (primitive-eval x-18310))
- exps-17554)
- exps-17554)))))
- tmp-17848)
+ (if (if (struct? exp-21346)
+ (eq? (struct-vtable
+ exp-21346)
+ (vector-ref
+ %expanded-vtables
+ 14))
+ #f)
+ (let ((meta-21418
+ (struct-ref
+ exp-21346
+ 1)))
+ (if (not (assq 'name
+ meta-21418))
+ (let ((v-21425
+ (cons (cons 'name
+ var-21021)
+ meta-21418)))
+ (struct-set!
+ exp-21346
+ 1
+ v-21425)))))
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 9)
+ s-21010
+ var-21021
+ exp-21346))))))))))
+ (if (if (eqv? type-21005 'define-syntax-form)
+ #t
+ (eqv? type-21005
+ 'define-syntax-parameter-form))
+ (let ((id-21450
+ (if (if (null? (car w-21009))
+ (null? (cdr w-21009))
+ #f)
+ value-21006
+ (if (if (vector? value-21006)
+ (if (= (vector-length
+ value-21006)
+ 4)
+ (eq? (vector-ref value-21006 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-21500
+ (vector-ref value-21006 1))
+ (wrap-21501
+ (let ((w2-21511
+ (vector-ref
+ value-21006
+ 2)))
+ (let ((m1-21512
+ (car w-21009))
+ (s1-21513
+ (cdr w-21009)))
+ (if (null? m1-21512)
+ (if (null? s1-21513)
+ w2-21511
+ (cons (car w2-21511)
+ (let ((m2-21530
+ (cdr w2-21511)))
+ (if (null? m2-21530)
+ s1-21513
+ (append
+ s1-21513
+ m2-21530)))))
+ (cons (let ((m2-21538
+ (car w2-21511)))
+ (if (null? m2-21538)
+ m1-21512
+ (append
+ m1-21512
+ m2-21538)))
+ (let ((m2-21546
+ (cdr w2-21511)))
+ (if (null? m2-21546)
+ s1-21513
+ (append
+ s1-21513
+ m2-21546))))))))
+ (module-21502
+ (vector-ref value-21006 3)))
+ (vector
+ 'syntax-object
+ expression-21500
+ wrap-21501
+ module-21502))
+ (if (null? value-21006)
+ value-21006
+ (vector
+ 'syntax-object
+ value-21006
+ w-21009
+ mod-21011))))))
+ (begin
+ (string-append
+ "l-"
+ (session-id-4308)
+ (symbol->string (gensym "-")))
+ (let ((var-21452
+ (if (not (equal?
+ (car (vector-ref
+ id-21450
+ 2))
+ '(top)))
+ (symbol-append
+ (vector-ref id-21450 1)
+ '-
+ (string->symbol
+ (number->string
+ (hash (syntax->datum x-20969)
+ most-positive-fixnum)
+ 16)))
+ (vector-ref id-21450 1))))
+ (begin
+ (record-definition!-20279
+ id-21450
+ var-21452)
+ (if (eqv? m-20973 'c)
+ (if (memq 'compile esew-20974)
+ (let ((e-21679
+ (expand-install-global-4380
+ var-21452
+ type-21005
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-21939
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-21939)
+ props-21939
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-21972
+ value-21973
+ form-21974
+ e-21975
+ w-21976
+ s-21977
+ mod-21978)
+ (expand-expr-4384
+ type-21972
+ value-21973
+ form-21974
+ e-21975
+ r-20970
+ w-21976
+ s-21977
+ mod-21978))))))
+ (begin
+ (top-level-eval-hook-4306
+ e-21679
+ mod-21011)
+ (if (memq 'load esew-20974)
+ (list (lambda () e-21679))
+ '())))
+ (if (memq 'load esew-20974)
+ (list (lambda ()
+ (expand-install-global-4380
+ var-21452
+ type-21005
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-22095
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-22095)
+ props-22095
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-22128
+ value-22129
+ form-22130
+ e-22131
+ w-22132
+ s-22133
+ mod-22134)
+ (expand-expr-4384
+ type-22128
+ value-22129
+ form-22130
+ e-22131
+ r-20970
+ w-22132
+ s-22133
+ mod-22134))))))
+ '()))
+ (if (eqv? m-20973 'c&e)
+ (let ((e-22144
+ (expand-install-global-4380
+ var-21452
+ type-21005
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-22404
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-22404)
+ props-22404
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-22437
+ value-22438
+ form-22439
+ e-22440
+ w-22441
+ s-22442
+ mod-22443)
+ (expand-expr-4384
+ type-22437
+ value-22438
+ form-22439
+ e-22440
+ r-20970
+ w-22441
+ s-22442
+ mod-22443))))))
+ (begin
+ (top-level-eval-hook-4306
+ e-22144
+ mod-21011)
+ (list (lambda () e-22144))))
+ (begin
+ (if (memq 'eval esew-20974)
+ (top-level-eval-hook-4306
+ (expand-install-global-4380
+ var-21452
+ type-21005
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-21008
+ r-20970
+ w-21009
+ (let ((props-22662
+ (source-properties
+ (if (if (vector?
+ e-21008)
+ (if (= (vector-length
+ e-21008)
+ 4)
+ (eq? (vector-ref
+ e-21008
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-21008
+ 1)
+ e-21008))))
+ (if (pair? props-22662)
+ props-22662
+ #f))
+ #f
+ mod-21011
+ #f))
+ (lambda (type-22695
+ value-22696
+ form-22697
+ e-22698
+ w-22699
+ s-22700
+ mod-22701)
+ (expand-expr-4384
+ type-22695
+ value-22696
+ form-22697
+ e-22698
+ r-20970
+ w-22699
+ s-22700
+ mod-22701))))
+ mod-21011))
+ '())))))))
+ (if (eqv? type-21005 'begin-form)
+ (let ((tmp-22715
+ ($sc-dispatch
+ e-21008
+ '(_ . each-any))))
+ (if tmp-22715
+ (@apply
+ (lambda (e1-22719)
+ (parse-20282
+ e1-22719
+ r-20970
+ w-21009
+ s-21010
+ m-20973
+ esew-20974
+ mod-21011))
+ tmp-22715)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-17797)))
- (if (if (eqv? type-17794 'define-syntax-form)
- #t
- (eqv? type-17794
- 'define-syntax-parameter-form))
- (let ((n-18359
- (id-var-name-4314
- value-17795
- w-17798))
- (r-18360
- (macros-only-env-4291 r-17548)))
- (if (eqv? m-17551 'c)
- (if (memq 'compile esew-17552)
- (let ((e-18368
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))))
- (begin
- (top-level-eval-hook-4254
- e-18368
- mod-17800)
- (if (memq 'load esew-17552)
- (cons e-18368 exps-17554)
- exps-17554)))
- (if (memq 'load esew-17552)
- (cons (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))
- exps-17554)
- exps-17554))
- (if (eqv? m-17551 'c&e)
- (let ((e-19013
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))))
- (begin
- (top-level-eval-hook-4254
- e-19013
- mod-17800)
- (cons e-19013 exps-17554)))
- (begin
- (if (memq 'eval esew-17552)
- (top-level-eval-hook-4254
- (expand-install-global-4328
- n-18359
- (expand-4331
- e-17797
- r-18360
- w-17798
- mod-17800))
- mod-17800))
- exps-17554))))
- (if (eqv? type-17794 'define-form)
- (let ((n-19690
- (id-var-name-4314
- value-17795
- w-17798)))
- (let ((type-19691
- (car (let ((t-19699
- (assq n-19690
- r-17548)))
- (if t-19699
- (cdr t-19699)
- (if (symbol? n-19690)
- (let ((t-19705
- (get-global-definition-hook-4258
- n-19690
- mod-17800)))
- (if t-19705
- t-19705
- '(global)))
- '(displaced-lexical)))))))
- (if (if (eqv? type-19691 'global)
- #t
- (if (eqv? type-19691 'core)
- #t
- (if (eqv? type-19691 'macro)
- #t
- (eqv? type-19691
- 'module-ref))))
- (begin
- (if (if (if (eq? m-17551 'c)
- #t
- (eq? m-17551 'c&e))
- (if (not (module-local-variable
- (current-module)
- n-19690))
- (current-module)
- #f)
- #f)
- (let ((old-19738
- (module-variable
- (current-module)
- n-19690)))
- (if (if (variable? old-19738)
- (variable-bound?
- old-19738)
- #f)
- (module-define!
- (current-module)
- n-19690
- (variable-ref old-19738))
- (module-add!
- (current-module)
- n-19690
- (make-undefined-variable)))))
- (cons (if (eq? m-17551 'c&e)
- (let ((x-20179
- (build-global-definition-4270
- s-17799
- n-19690
- (expand-4331
- e-17797
- r-17548
- w-17798
- mod-17800))))
+ e-21008)))
+ (if (eqv? type-21005 'local-syntax-form)
+ (expand-local-syntax-4388
+ value-21006
+ e-21008
+ r-20970
+ w-21009
+ s-21010
+ mod-21011
+ (lambda (forms-22765
+ r-22766
+ w-22767
+ s-22768
+ mod-22769)
+ (parse-20282
+ forms-22765
+ r-22766
+ w-22767
+ s-22768
+ m-20973
+ esew-20974
+ mod-22769)))
+ (if (eqv? type-21005 'eval-when-form)
+ (let ((tmp-22808
+ ($sc-dispatch
+ e-21008
+ '(_ each-any any . each-any))))
+ (if tmp-22808
+ (@apply
+ (lambda (x-22812 e1-22813 e2-22814)
+ (let ((when-list-22815
+ (parse-when-list-4381
+ e-21008
+ x-22812))
+ (body-22816
+ (cons e1-22813 e2-22814)))
+ (letrec*
+ ((recurse-22817
+ (lambda (m-23403 esew-23404)
+ (parse-20282
+ body-22816
+ r-20970
+ w-21009
+ s-21010
+ m-23403
+ esew-23404
+ mod-21011))))
+ (if (eq? m-20973 'e)
+ (if (memq 'eval
+ when-list-22815)
+ (recurse-22817
+ (if (memq 'expand
+ when-list-22815)
+ 'c&e
+ 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand
+ when-list-22815)
+ (let ((x-22924
+ (expand-top-sequence-4379
+ body-22816
+ r-20970
+ w-21009
+ s-21010
+ 'e
+ '(eval)
+ mod-21011)))
+ (primitive-eval
+ x-22924)))
+ '()))
+ (if (memq 'load
+ when-list-22815)
+ (if (let ((t-22952
+ (memq 'compile
+ when-list-22815)))
+ (if t-22952
+ t-22952
+ (let ((t-23005
+ (memq 'expand
+ when-list-22815)))
+ (if t-23005
+ t-23005
+ (if (eq? m-20973
+ 'c&e)
+ (memq 'eval
+ when-list-22815)
+ #f)))))
+ (recurse-22817
+ 'c&e
+ '(compile load))
+ (if (if (eq? m-20973 'c)
+ #t
+ (eq? m-20973 'c&e))
+ (recurse-22817
+ 'c
+ '(load))
+ '()))
+ (if (let ((t-23214
+ (memq 'compile
+ when-list-22815)))
+ (if t-23214
+ t-23214
+ (let ((t-23267
+ (memq 'expand
+ when-list-22815)))
+ (if t-23267
+ t-23267
+ (if (eq? m-20973
+ 'c&e)
+ (memq 'eval
+ when-list-22815)
+ #f)))))
(begin
- (top-level-eval-hook-4254
- x-20179
- mod-17800)
- x-20179))
- (lambda ()
- (build-global-definition-4270
- s-17799
- n-19690
- (expand-4331
- e-17797
- r-17548
- w-17798
- mod-17800))))
- exps-17554))
- (if (eqv? type-19691
- 'displaced-lexical)
- (syntax-violation
- #f
- "identifier out of context"
- (wrap-4324
- (begin
- (if (if s-17799
- (supports-source-properties?
- form-17796)
- #f)
- (set-source-properties!
- form-17796
- s-17799))
- form-17796)
- w-17798
- mod-17800)
- (wrap-4324
- value-17795
- w-17798
- mod-17800))
- (syntax-violation
- #f
- "cannot define keyword at top level"
- (wrap-4324
- (begin
- (if (if s-17799
- (supports-source-properties?
- form-17796)
- #f)
- (set-source-properties!
- form-17796
- s-17799))
- form-17796)
- w-17798
- mod-17800)
- (wrap-4324
- value-17795
- w-17798
- mod-17800))))))
- (cons (if (eq? m-17551 'c&e)
- (let ((x-20681
- (expand-expr-4332
- type-17794
- value-17795
- form-17796
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800)))
+ (let ((x-23401
+ (expand-top-sequence-4379
+ body-22816
+ r-20970
+ w-21009
+ s-21010
+ 'e
+ '(eval)
+ mod-21011)))
+ (primitive-eval
+ x-23401))
+ '())
+ '()))))))
+ tmp-22808)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-21008)))
+ (list (if (eq? m-20973 'c&e)
+ (let ((x-23474
+ (expand-expr-4384
+ type-21005
+ value-21006
+ form-21007
+ e-21008
+ r-20970
+ w-21009
+ s-21010
+ mod-21011)))
(begin
- (primitive-eval x-20681)
- x-20681))
+ (primitive-eval x-23474)
+ (lambda () x-23474)))
(lambda ()
- (expand-expr-4332
- type-17794
- value-17795
- form-17796
- e-17797
- r-17548
- w-17798
- s-17799
- mod-17800)))
- exps-17554)))))))))
- (lambda (exps-20686)
- (scan-17416
- (cdr body-17547)
- r-17548
- w-17549
- s-17550
- m-17551
- esew-17552
- mod-17553
- exps-20686)))))))
- (call-with-values
- (lambda ()
- (scan-17416
- body-17409
- r-17410
- w-17411
- s-17412
- m-17413
- esew-17414
- mod-17415
- '()))
- (lambda (exps-17419)
- (if (null? exps-17419)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- s-17412)
- (build-sequence-4276
- s-17412
- (letrec*
- ((lp-17459
- (lambda (in-17543 out-17544)
- (if (null? in-17543)
- out-17544
- (let ((e-17545 (car in-17543)))
- (lp-17459
- (cdr in-17543)
- (cons (if (procedure? e-17545)
- (e-17545)
- e-17545)
- out-17544)))))))
- (lp-17459 exps-17419 '())))))))))
- (expand-install-global-4328
- (lambda (name-20687 e-20688)
- (let ((exp-20694
- (let ((fun-exp-20704
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'make-syntax-transformer)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'make-syntax-transformer
- #f)))
- (arg-exps-20705
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- name-20687)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- 'macro)
- e-20688)))
+ (expand-expr-4384
+ type-21005
+ value-21006
+ form-21007
+ e-21008
+ r-20970
+ w-21009
+ s-21010
+ mod-21011))))))))))))))
+ (let ((exps-20284
+ (map (lambda (x-20408) (x-20408))
+ (reverse
+ (parse-20282
+ body-20269
+ r-20276
+ w-20278
+ s-20272
+ m-20273
+ esew-20274
+ mod-20275)))))
+ (if (null? exps-20284)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ s-20272)
+ (build-sequence-4329 s-20272 exps-20284)))))))))
+ (expand-install-global-4380
+ (lambda (name-23602 type-23603 e-23604)
+ (let ((exp-23610
+ (let ((args-23621
+ (if (eq? type-23603 'define-syntax-parameter-form)
+ (list (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ name-23602)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ 'syntax-parameter)
+ (let ((args-23644 (list e-23604)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'list
+ args-23644)))
+ (list (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ name-23602)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ 'macro)
+ e-23604))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 11)
+ (vector-ref %expanded-vtables 12)
#f
- fun-exp-20704
- arg-exps-20705))))
+ 'make-syntax-transformer
+ args-23621))))
(begin
- (if (if (struct? exp-20694)
- (eq? (struct-vtable exp-20694)
- (vector-ref %expanded-vtables 13))
+ (if (if (struct? exp-23610)
+ (eq? (struct-vtable exp-23610)
+ (vector-ref %expanded-vtables 14))
#f)
- (let ((meta-20746 (struct-ref exp-20694 1)))
- (if (not (assq 'name meta-20746))
- (let ((v-20753
- (cons (cons 'name name-20687) meta-20746)))
- (struct-set! exp-20694 1 v-20753)))))
+ (let ((meta-23671 (struct-ref exp-23610 1)))
+ (if (not (assq 'name meta-23671))
+ (let ((v-23678
+ (cons (cons 'name name-23602) meta-23671)))
+ (struct-set! exp-23610 1 v-23678)))))
(make-struct/no-tail
(vector-ref %expanded-vtables 9)
#f
- name-20687
- exp-20694)))))
- (parse-when-list-4329
- (lambda (e-20764 when-list-20765)
- (let ((result-20766 (strip-4344 when-list-20765 '(()))))
+ name-23602
+ exp-23610)))))
+ (parse-when-list-4381
+ (lambda (e-23689 when-list-23690)
+ (let ((result-23691 (strip-4396 when-list-23690 '(()))))
(letrec*
- ((lp-20767
- (lambda (l-20821)
- (if (null? l-20821)
- result-20766
- (if (let ((t-20823 (car l-20821)))
- (if (eq? t-20823 'compile)
+ ((lp-23692
+ (lambda (l-23758)
+ (if (null? l-23758)
+ result-23691
+ (if (let ((t-23760 (car l-23758)))
+ (if (eq? t-23760 'compile)
#t
- (if (eq? t-20823 'load)
+ (if (eq? t-23760 'load)
#t
- (if (eq? t-20823 'eval)
+ (if (eq? t-23760 'eval)
#t
- (eq? t-20823 'expand)))))
- (lp-20767 (cdr l-20821))
+ (eq? t-23760 'expand)))))
+ (lp-23692 (cdr l-23758))
(syntax-violation
'eval-when
"invalid situation"
- e-20764
- (car l-20821)))))))
- (lp-20767 result-20766)))))
- (syntax-type-4330
- (lambda (e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830
- for-car?-20831)
- (if (symbol? e-20825)
- (let ((n-20832 (id-var-name-4314 e-20825 w-20827)))
- (let ((b-20833
- (let ((t-20842 (assq n-20832 r-20826)))
- (if t-20842
- (cdr t-20842)
- (if (symbol? n-20832)
- (let ((t-20848
- (get-global-definition-hook-4258
- n-20832
- mod-20830)))
- (if t-20848 t-20848 '(global)))
- '(displaced-lexical))))))
- (let ((type-20834 (car b-20833)))
- (if (eqv? type-20834 'lexical)
+ e-23689
+ (car l-23758)))))))
+ (lp-23692 result-23691)))))
+ (syntax-type-4382
+ (lambda (e-23762
+ r-23763
+ w-23764
+ s-23765
+ rib-23766
+ mod-23767
+ for-car?-23768)
+ (if (symbol? e-23762)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier-4368
+ e-23762
+ w-23764
+ r-23763
+ mod-23767
+ #t))
+ (lambda (type-23771 value-23772 mod*-23773)
+ (if (eqv? type-23771 'macro)
+ (if for-car?-23768
(values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? type-20834 'global)
- (values
- type-20834
- n-20832
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? type-20834 'macro)
- (if for-car?-20831
- (values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (syntax-type-4330
- (expand-macro-4334
- (cdr b-20833)
- e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830)
- r-20826
- '(())
- s-20828
- rib-20829
- mod-20830
- #f))
- (values
- type-20834
- (cdr b-20833)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))
- (if (pair? e-20825)
- (let ((first-20876 (car e-20825)))
+ type-23771
+ value-23772
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (syntax-type-4382
+ (expand-macro-4386
+ value-23772
+ e-23762
+ r-23763
+ w-23764
+ s-23765
+ rib-23766
+ mod-23767)
+ r-23763
+ '(())
+ s-23765
+ rib-23766
+ mod-23767
+ #f))
+ (if (eqv? type-23771 'global)
+ (values
+ type-23771
+ value-23772
+ e-23762
+ value-23772
+ w-23764
+ s-23765
+ mod*-23773)
+ (values
+ type-23771
+ value-23772
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)))))
+ (if (pair? e-23762)
+ (let ((first-23789 (car e-23762)))
(call-with-values
(lambda ()
- (syntax-type-4330
- first-20876
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830
+ (syntax-type-4382
+ first-23789
+ r-23763
+ w-23764
+ s-23765
+ rib-23766
+ mod-23767
#t))
- (lambda (ftype-20878
- fval-20879
- fform-20880
- fe-20881
- fw-20882
- fs-20883
- fmod-20884)
- (if (eqv? ftype-20878 'lexical)
+ (lambda (ftype-23791
+ fval-23792
+ fform-23793
+ fe-23794
+ fw-23795
+ fs-23796
+ fmod-23797)
+ (if (eqv? ftype-23791 'lexical)
(values
'lexical-call
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'global)
+ fval-23792
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'global)
(values
'global-call
(vector
'syntax-object
- fval-20879
- w-20827
- fmod-20884)
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'macro)
- (syntax-type-4330
- (expand-macro-4334
- fval-20879
- e-20825
- r-20826
- w-20827
- s-20828
- rib-20829
- mod-20830)
- r-20826
+ fval-23792
+ w-23764
+ fmod-23797)
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'macro)
+ (syntax-type-4382
+ (expand-macro-4386
+ fval-23792
+ e-23762
+ r-23763
+ w-23764
+ s-23765
+ rib-23766
+ mod-23767)
+ r-23763
'(())
- s-20828
- rib-20829
- mod-20830
- for-car?-20831)
- (if (eqv? ftype-20878 'module-ref)
+ s-23765
+ rib-23766
+ mod-23767
+ for-car?-23768)
+ (if (eqv? ftype-23791 'module-ref)
(call-with-values
- (lambda () (fval-20879 e-20825 r-20826 w-20827))
- (lambda (e-20918
- r-20919
- w-20920
- s-20921
- mod-20922)
- (syntax-type-4330
- e-20918
- r-20919
- w-20920
- s-20921
- rib-20829
- mod-20922
- for-car?-20831)))
- (if (eqv? ftype-20878 'core)
+ (lambda () (fval-23792 e-23762 r-23763 w-23764))
+ (lambda (e-23831
+ r-23832
+ w-23833
+ s-23834
+ mod-23835)
+ (syntax-type-4382
+ e-23831
+ r-23832
+ w-23833
+ s-23834
+ rib-23766
+ mod-23835
+ for-car?-23768)))
+ (if (eqv? ftype-23791 'core)
(values
'core-form
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'local-syntax)
+ fval-23792
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'local-syntax)
(values
'local-syntax-form
- fval-20879
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'begin)
+ fval-23792
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'begin)
(values
'begin-form
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'eval-when)
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'eval-when)
(values
'eval-when-form
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
- (if (eqv? ftype-20878 'define)
- (let ((tmp-20954
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
+ (if (eqv? ftype-23791 'define)
+ (let ((tmp-23867
($sc-dispatch
- e-20825
+ e-23762
'(_ any any))))
- (if (if tmp-20954
+ (if (if tmp-23867
(@apply
- (lambda (name-20958 val-20959)
- (if (symbol? name-20958)
+ (lambda (name-23871 val-23872)
+ (if (symbol? name-23871)
#t
- (if (if (vector? name-20958)
+ (if (if (vector? name-23871)
(if (= (vector-length
- name-20958)
+ name-23871)
4)
(eq? (vector-ref
- name-20958
+ name-23871
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- name-20958
+ name-23871
1))
#f)))
- tmp-20954)
+ tmp-23867)
#f)
(@apply
- (lambda (name-20986 val-20987)
+ (lambda (name-23899 val-23900)
(values
'define-form
- name-20986
- e-20825
- val-20987
- w-20827
- s-20828
- mod-20830))
- tmp-20954)
- (let ((tmp-20988
+ name-23899
+ e-23762
+ val-23900
+ w-23764
+ s-23765
+ mod-23767))
+ tmp-23867)
+ (let ((tmp-23901
($sc-dispatch
- e-20825
+ e-23762
'(_ (any . any)
any
.
each-any))))
- (if (if tmp-20988
+ (if (if tmp-23901
(@apply
- (lambda (name-20992
- args-20993
- e1-20994
- e2-20995)
+ (lambda (name-23905
+ args-23906
+ e1-23907
+ e2-23908)
(if (if (symbol?
- name-20992)
+ name-23905)
#t
(if (if (vector?
- name-20992)
+ name-23905)
(if (= (vector-length
- name-20992)
+ name-23905)
4)
(eq? (vector-ref
- name-20992
+ name-23905
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- name-20992
+ name-23905
1))
#f))
- (valid-bound-ids?-4321
- (letrec*
- ((lvl-21144
- (lambda (vars-21146
- ls-21147
- w-21148)
- (if (pair? vars-21146)
- (lvl-21144
- (cdr vars-21146)
- (cons (wrap-4324
- (car vars-21146)
- w-21148
- #f)
- ls-21147)
- w-21148)
- (if (if (symbol?
- vars-21146)
- #t
- (if (if (vector?
- vars-21146)
- (if (= (vector-length
- vars-21146)
- 4)
- (eq? (vector-ref
- vars-21146
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref
- vars-21146
- 1))
- #f))
- (cons (wrap-4324
- vars-21146
- w-21148
- #f)
- ls-21147)
- (if (null? vars-21146)
- ls-21147
- (if (if (vector?
- vars-21146)
- (if (= (vector-length
- vars-21146)
- 4)
- (eq? (vector-ref
- vars-21146
- 0)
- 'syntax-object)
- #f)
- #f)
- (lvl-21144
- (vector-ref
- vars-21146
- 1)
- ls-21147
- (join-wraps-4311
- w-21148
- (vector-ref
- vars-21146
- 2)))
- (cons vars-21146
- ls-21147))))))))
- (lvl-21144
- args-20993
- '()
- '(()))))
+ (valid-bound-ids?-4373
+ (lambda-var-list-4398
+ args-23906))
#f))
- tmp-20988)
+ tmp-23901)
#f)
(@apply
- (lambda (name-21192
- args-21193
- e1-21194
- e2-21195)
+ (lambda (name-24371
+ args-24372
+ e1-24373
+ e2-24374)
(values
'define-form
- (wrap-4324
- name-21192
- w-20827
- mod-20830)
- (wrap-4324
- e-20825
- w-20827
- mod-20830)
- (let ((e-21203
- (cons '#(syntax-object
- lambda
- ((top)
- #(ribcage
- #(name
- args
- e1
- e2)
- #((top)
- (top)
- (top)
- (top))
- #("l-*-1902"
- "l-*-1903"
- "l-*-1904"
- "l-*-1905"))
- #(ribcage
- ()
- ()
- ())
+ (if (if (null? (car w-23764))
+ (null? (cdr w-23764))
+ #f)
+ name-24371
+ (if (if (vector?
+ name-24371)
+ (if (= (vector-length
+ name-24371)
+ 4)
+ (eq? (vector-ref
+ name-24371
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-24404
+ (vector-ref
+ name-24371
+ 1))
+ (wrap-24405
+ (let ((w2-24415
+ (vector-ref
+ name-24371
+ 2)))
+ (let ((m1-24416
+ (car w-23764))
+ (s1-24417
+ (cdr w-23764)))
+ (if (null? m1-24416)
+ (if (null? s1-24417)
+ w2-24415
+ (cons (car w2-24415)
+ (let ((m2-24434
+ (cdr w2-24415)))
+ (if (null? m2-24434)
+ s1-24417
+ (append
+ s1-24417
+ m2-24434)))))
+ (cons (let ((m2-24442
+ (car w2-24415)))
+ (if (null? m2-24442)
+ m1-24416
+ (append
+ m1-24416
+ m2-24442)))
+ (let ((m2-24450
+ (cdr w2-24415)))
+ (if (null? m2-24450)
+ s1-24417
+ (append
+ s1-24417
+ m2-24450))))))))
+ (module-24406
+ (vector-ref
+ name-24371
+ 3)))
+ (vector
+ 'syntax-object
+ expression-24404
+ wrap-24405
+ module-24406))
+ (if (null? name-24371)
+ name-24371
+ (vector
+ 'syntax-object
+ name-24371
+ w-23764
+ mod-23767))))
+ (if (if (null? (car w-23764))
+ (null? (cdr w-23764))
+ #f)
+ e-23762
+ (if (if (vector? e-23762)
+ (if (= (vector-length
+ e-23762)
+ 4)
+ (eq? (vector-ref
+ e-23762
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-24502
+ (vector-ref
+ e-23762
+ 1))
+ (wrap-24503
+ (let ((w2-24513
+ (vector-ref
+ e-23762
+ 2)))
+ (let ((m1-24514
+ (car w-23764))
+ (s1-24515
+ (cdr w-23764)))
+ (if (null? m1-24514)
+ (if (null? s1-24515)
+ w2-24513
+ (cons (car w2-24513)
+ (let ((m2-24532
+ (cdr w2-24513)))
+ (if (null? m2-24532)
+ s1-24515
+ (append
+ s1-24515
+ m2-24532)))))
+ (cons (let ((m2-24540
+ (car w2-24513)))
+ (if (null? m2-24540)
+ m1-24514
+ (append
+ m1-24514
+ m2-24540)))
+ (let ((m2-24548
+ (cdr w2-24513)))
+ (if (null? m2-24548)
+ s1-24515
+ (append
+ s1-24515
+ m2-24548))))))))
+ (module-24504
+ (vector-ref
+ e-23762
+ 3)))
+ (vector
+ 'syntax-object
+ expression-24502
+ wrap-24503
+ module-24504))
+ (if (null? e-23762)
+ e-23762
+ (vector
+ 'syntax-object
+ e-23762
+ w-23764
+ mod-23767))))
+ (let ((e-24574
+ (cons '#(syntax-object
+ lambda
+ ((top)
+ #(ribcage
+ #(name
+ args
+ e1
+ e2)
+ #((top)
+ (top)
+ (top)
+ (top))
+ #("l-*-1960"
+ "l-*-1961"
+ "l-*-1962"
+ "l-*-1963"))
+ #(ribcage
+ ()
+ ()
+ ())
#(ribcage
#(key)
- #((m-*-1867
+ #((m-*-1925
top))
- #("l-*-1868"))
+ #("l-*-1926"))
#(ribcage
()
()
(top)
(top)
(top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
+ #("l-*-1918"
+ "l-*-1919"
+ "l-*-1920"
+ "l-*-1921"
+ "l-*-1922"
+ "l-*-1923"
+ "l-*-1924"))
#(ribcage
()
()
#(ribcage
#(first)
#((top))
- #("l-*-1851"))
+ #("l-*-1909"))
#(ribcage
()
()
(top)
(top)
(top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
+ #("l-*-1891"
+ "l-*-1892"
+ "l-*-1893"
+ "l-*-1894"
+ "l-*-1895"
+ "l-*-1896"
+ "l-*-1897"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
(top))
("l-*-47"
"l-*-46"
- "l-*-45")))
+ "l-*-45"))
+ #(ribcage
+ ()
+ ()
+ ()))
(hygiene
guile))
- (wrap-4324
- (cons args-21193
- (cons e1-21194
- e2-21195))
- w-20827
- mod-20830))))
+ (let ((x-24580
+ (cons args-24372
+ (cons e1-24373
+ e2-24374))))
+ (if (if (null? (car w-23764))
+ (null? (cdr w-23764))
+ #f)
+ x-24580
+ (if (if (vector?
+ x-24580)
+ (if (= (vector-length
+ x-24580)
+ 4)
+ (eq? (vector-ref
+ x-24580
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-24598
+ (vector-ref
+ x-24580
+ 1))
+ (wrap-24599
+ (let ((w2-24607
+ (vector-ref
+ x-24580
+ 2)))
+ (let ((m1-24608
+ (car w-23764))
+ (s1-24609
+ (cdr w-23764)))
+ (if (null? m1-24608)
+ (if (null? s1-24609)
+ w2-24607
+ (cons (car w2-24607)
+ (let ((m2-24624
+ (cdr w2-24607)))
+ (if (null? m2-24624)
+ s1-24609
+ (append
+ s1-24609
+ m2-24624)))))
+ (cons (let ((m2-24632
+ (car w2-24607)))
+ (if (null? m2-24632)
+ m1-24608
+ (append
+ m1-24608
+ m2-24632)))
+ (let ((m2-24640
+ (cdr w2-24607)))
+ (if (null? m2-24640)
+ s1-24609
+ (append
+ s1-24609
+ m2-24640))))))))
+ (module-24600
+ (vector-ref
+ x-24580
+ 3)))
+ (vector
+ 'syntax-object
+ expression-24598
+ wrap-24599
+ module-24600))
+ (if (null? x-24580)
+ x-24580
+ (vector
+ 'syntax-object
+ x-24580
+ w-23764
+ mod-23767))))))))
(begin
- (if (if s-20828
+ (if (if s-23765
(supports-source-properties?
- e-21203)
+ e-24574)
#f)
(set-source-properties!
- e-21203
- s-20828))
- e-21203))
+ e-24574
+ s-23765))
+ e-24574))
'(())
- s-20828
- mod-20830))
- tmp-20988)
- (let ((tmp-21210
+ s-23765
+ mod-23767))
+ tmp-23901)
+ (let ((tmp-24657
($sc-dispatch
- e-20825
+ e-23762
'(_ any))))
- (if (if tmp-21210
+ (if (if tmp-24657
(@apply
- (lambda (name-21214)
+ (lambda (name-24661)
(if (symbol?
- name-21214)
+ name-24661)
#t
(if (if (vector?
- name-21214)
+ name-24661)
(if (= (vector-length
- name-21214)
+ name-24661)
4)
(eq? (vector-ref
- name-21214
+ name-24661
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- name-21214
+ name-24661
1))
#f)))
- tmp-21210)
+ tmp-24657)
#f)
(@apply
- (lambda (name-21241)
+ (lambda (name-24688)
(values
'define-form
- (wrap-4324
- name-21241
- w-20827
- mod-20830)
- (wrap-4324
- e-20825
- w-20827
- mod-20830)
+ (if (if (null? (car w-23764))
+ (null? (cdr w-23764))
+ #f)
+ name-24688
+ (if (if (vector?
+ name-24688)
+ (if (= (vector-length
+ name-24688)
+ 4)
+ (eq? (vector-ref
+ name-24688
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-24718
+ (vector-ref
+ name-24688
+ 1))
+ (wrap-24719
+ (let ((w2-24729
+ (vector-ref
+ name-24688
+ 2)))
+ (let ((m1-24730
+ (car w-23764))
+ (s1-24731
+ (cdr w-23764)))
+ (if (null? m1-24730)
+ (if (null? s1-24731)
+ w2-24729
+ (cons (car w2-24729)
+ (let ((m2-24748
+ (cdr w2-24729)))
+ (if (null? m2-24748)
+ s1-24731
+ (append
+ s1-24731
+ m2-24748)))))
+ (cons (let ((m2-24756
+ (car w2-24729)))
+ (if (null? m2-24756)
+ m1-24730
+ (append
+ m1-24730
+ m2-24756)))
+ (let ((m2-24764
+ (cdr w2-24729)))
+ (if (null? m2-24764)
+ s1-24731
+ (append
+ s1-24731
+ m2-24764))))))))
+ (module-24720
+ (vector-ref
+ name-24688
+ 3)))
+ (vector
+ 'syntax-object
+ expression-24718
+ wrap-24719
+ module-24720))
+ (if (null? name-24688)
+ name-24688
+ (vector
+ 'syntax-object
+ name-24688
+ w-23764
+ mod-23767))))
+ (if (if (null? (car w-23764))
+ (null? (cdr w-23764))
+ #f)
+ e-23762
+ (if (if (vector?
+ e-23762)
+ (if (= (vector-length
+ e-23762)
+ 4)
+ (eq? (vector-ref
+ e-23762
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-24816
+ (vector-ref
+ e-23762
+ 1))
+ (wrap-24817
+ (let ((w2-24827
+ (vector-ref
+ e-23762
+ 2)))
+ (let ((m1-24828
+ (car w-23764))
+ (s1-24829
+ (cdr w-23764)))
+ (if (null? m1-24828)
+ (if (null? s1-24829)
+ w2-24827
+ (cons (car w2-24827)
+ (let ((m2-24846
+ (cdr w2-24827)))
+ (if (null? m2-24846)
+ s1-24829
+ (append
+ s1-24829
+ m2-24846)))))
+ (cons (let ((m2-24854
+ (car w2-24827)))
+ (if (null? m2-24854)
+ m1-24828
+ (append
+ m1-24828
+ m2-24854)))
+ (let ((m2-24862
+ (cdr w2-24827)))
+ (if (null? m2-24862)
+ s1-24829
+ (append
+ s1-24829
+ m2-24862))))))))
+ (module-24818
+ (vector-ref
+ e-23762
+ 3)))
+ (vector
+ 'syntax-object
+ expression-24816
+ wrap-24817
+ module-24818))
+ (if (null? e-23762)
+ e-23762
+ (vector
+ 'syntax-object
+ e-23762
+ w-23764
+ mod-23767))))
'(#(syntax-object
if
((top)
#(ribcage
#(name)
#((top))
- #("l-*-1915"))
+ #("l-*-1973"))
#(ribcage () () ())
#(ribcage
#(key)
- #((m-*-1867 top))
- #("l-*-1868"))
+ #((m-*-1925 top))
+ #("l-*-1926"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
+ #("l-*-1918"
+ "l-*-1919"
+ "l-*-1920"
+ "l-*-1921"
+ "l-*-1922"
+ "l-*-1923"
+ "l-*-1924"))
#(ribcage () () ())
#(ribcage
#(first)
#((top))
- #("l-*-1851"))
+ #("l-*-1909"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
+ #("l-*-1891"
+ "l-*-1892"
+ "l-*-1893"
+ "l-*-1894"
+ "l-*-1895"
+ "l-*-1896"
+ "l-*-1897"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
(top))
("l-*-47"
"l-*-46"
- "l-*-45")))
+ "l-*-45"))
+ #(ribcage
+ ()
+ ()
+ ()))
(hygiene guile))
#(syntax-object
#f
#(ribcage
#(name)
#((top))
- #("l-*-1915"))
+ #("l-*-1973"))
#(ribcage () () ())
#(ribcage
#(key)
- #((m-*-1867 top))
- #("l-*-1868"))
+ #((m-*-1925 top))
+ #("l-*-1926"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
+ #("l-*-1918"
+ "l-*-1919"
+ "l-*-1920"
+ "l-*-1921"
+ "l-*-1922"
+ "l-*-1923"
+ "l-*-1924"))
#(ribcage () () ())
#(ribcage
#(first)
#((top))
- #("l-*-1851"))
+ #("l-*-1909"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
+ #("l-*-1891"
+ "l-*-1892"
+ "l-*-1893"
+ "l-*-1894"
+ "l-*-1895"
+ "l-*-1896"
+ "l-*-1897"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
(top))
("l-*-47"
"l-*-46"
- "l-*-45")))
+ "l-*-45"))
+ #(ribcage
+ ()
+ ()
+ ()))
(hygiene guile))
#(syntax-object
#f
#(ribcage
#(name)
#((top))
- #("l-*-1915"))
+ #("l-*-1973"))
#(ribcage () () ())
#(ribcage
#(key)
- #((m-*-1867 top))
- #("l-*-1868"))
+ #((m-*-1925 top))
+ #("l-*-1926"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1860"
- "l-*-1861"
- "l-*-1862"
- "l-*-1863"
- "l-*-1864"
- "l-*-1865"
- "l-*-1866"))
+ #("l-*-1918"
+ "l-*-1919"
+ "l-*-1920"
+ "l-*-1921"
+ "l-*-1922"
+ "l-*-1923"
+ "l-*-1924"))
#(ribcage () () ())
#(ribcage
#(first)
#((top))
- #("l-*-1851"))
+ #("l-*-1909"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
(top)
(top)
(top))
- #("l-*-1827"
- "l-*-1828"
- "l-*-1829"
- "l-*-1830"
- "l-*-1831"
- "l-*-1832"
- "l-*-1833"))
+ #("l-*-1891"
+ "l-*-1892"
+ "l-*-1893"
+ "l-*-1894"
+ "l-*-1895"
+ "l-*-1896"
+ "l-*-1897"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
(top))
("l-*-47"
"l-*-46"
- "l-*-45")))
+ "l-*-45"))
+ #(ribcage
+ ()
+ ()
+ ()))
(hygiene guile)))
'(())
- s-20828
- mod-20830))
- tmp-21210)
+ s-23765
+ mod-23767))
+ tmp-24657)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-20825)))))))
- (if (eqv? ftype-20878 'define-syntax)
- (let ((tmp-21265
+ e-23762)))))))
+ (if (eqv? ftype-23791 'define-syntax)
+ (let ((tmp-24904
($sc-dispatch
- e-20825
+ e-23762
'(_ any any))))
- (if (if tmp-21265
+ (if (if tmp-24904
(@apply
- (lambda (name-21269 val-21270)
- (if (symbol? name-21269)
+ (lambda (name-24908 val-24909)
+ (if (symbol? name-24908)
#t
(if (if (vector?
- name-21269)
+ name-24908)
(if (= (vector-length
- name-21269)
+ name-24908)
4)
(eq? (vector-ref
- name-21269
+ name-24908
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- name-21269
+ name-24908
1))
#f)))
- tmp-21265)
+ tmp-24904)
#f)
(@apply
- (lambda (name-21297 val-21298)
+ (lambda (name-24936 val-24937)
(values
'define-syntax-form
- name-21297
- e-20825
- val-21298
- w-20827
- s-20828
- mod-20830))
- tmp-21265)
+ name-24936
+ e-23762
+ val-24937
+ w-23764
+ s-23765
+ mod-23767))
+ tmp-24904)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-20825)))
- (if (eqv? ftype-20878
+ e-23762)))
+ (if (eqv? ftype-23791
'define-syntax-parameter)
- (let ((tmp-21312
+ (let ((tmp-24951
($sc-dispatch
- e-20825
+ e-23762
'(_ any any))))
- (if (if tmp-21312
+ (if (if tmp-24951
(@apply
- (lambda (name-21316
- val-21317)
- (if (symbol? name-21316)
+ (lambda (name-24955
+ val-24956)
+ (if (symbol? name-24955)
#t
(if (if (vector?
- name-21316)
+ name-24955)
(if (= (vector-length
- name-21316)
+ name-24955)
4)
(eq? (vector-ref
- name-21316
+ name-24955
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- name-21316
+ name-24955
1))
#f)))
- tmp-21312)
+ tmp-24951)
#f)
(@apply
- (lambda (name-21344 val-21345)
+ (lambda (name-24983 val-24984)
(values
'define-syntax-parameter-form
- name-21344
- e-20825
- val-21345
- w-20827
- s-20828
- mod-20830))
- tmp-21312)
+ name-24983
+ e-23762
+ val-24984
+ w-23764
+ s-23765
+ mod-23767))
+ tmp-24951)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-20825)))
+ e-23762)))
(values
'call
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))))))))))
- (if (if (vector? e-20825)
- (if (= (vector-length e-20825) 4)
- (eq? (vector-ref e-20825 0) 'syntax-object)
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)))))))))))))))
+ (if (if (vector? e-23762)
+ (if (= (vector-length e-23762) 4)
+ (eq? (vector-ref e-23762 0) 'syntax-object)
#f)
#f)
- (syntax-type-4330
- (vector-ref e-20825 1)
- r-20826
- (join-wraps-4311 w-20827 (vector-ref e-20825 2))
- (let ((t-21372 (source-annotation-4288 e-20825)))
- (if t-21372 t-21372 s-20828))
- rib-20829
- (let ((t-21607 (vector-ref e-20825 3)))
- (if t-21607 t-21607 mod-20830))
- for-car?-20831)
- (if (self-evaluating? e-20825)
+ (syntax-type-4382
+ (vector-ref e-23762 1)
+ r-23763
+ (let ((w2-25009 (vector-ref e-23762 2)))
+ (let ((m1-25010 (car w-23764))
+ (s1-25011 (cdr w-23764)))
+ (if (null? m1-25010)
+ (if (null? s1-25011)
+ w2-25009
+ (cons (car w2-25009)
+ (let ((m2-25022 (cdr w2-25009)))
+ (if (null? m2-25022)
+ s1-25011
+ (append s1-25011 m2-25022)))))
+ (cons (let ((m2-25030 (car w2-25009)))
+ (if (null? m2-25030)
+ m1-25010
+ (append m1-25010 m2-25030)))
+ (let ((m2-25038 (cdr w2-25009)))
+ (if (null? m2-25038)
+ s1-25011
+ (append s1-25011 m2-25038)))))))
+ (let ((t-25043
+ (let ((props-25075
+ (source-properties
+ (if (if (vector? e-23762)
+ (if (= (vector-length e-23762) 4)
+ (eq? (vector-ref e-23762 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-23762 1)
+ e-23762))))
+ (if (pair? props-25075) props-25075 #f))))
+ (if t-25043 t-25043 s-23765))
+ rib-23766
+ (let ((t-25098 (vector-ref e-23762 3)))
+ (if t-25098 t-25098 mod-23767))
+ for-car?-23768)
+ (if (self-evaluating? e-23762)
(values
'constant
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)
(values
'other
#f
- e-20825
- e-20825
- w-20827
- s-20828
- mod-20830)))))))
- (expand-4331
- (lambda (e-21616 r-21617 w-21618 mod-21619)
+ e-23762
+ e-23762
+ w-23764
+ s-23765
+ mod-23767)))))))
+ (expand-4383
+ (lambda (e-25107 r-25108 w-25109 mod-25110)
(call-with-values
(lambda ()
- (syntax-type-4330
- e-21616
- r-21617
- w-21618
- (source-annotation-4288 e-21616)
+ (syntax-type-4382
+ e-25107
+ r-25108
+ w-25109
+ (let ((props-25117
+ (source-properties
+ (if (if (vector? e-25107)
+ (if (= (vector-length e-25107) 4)
+ (eq? (vector-ref e-25107 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-25107 1)
+ e-25107))))
+ (if (pair? props-25117) props-25117 #f))
#f
- mod-21619
+ mod-25110
#f))
- (lambda (type-21774
- value-21775
- form-21776
- e-21777
- w-21778
- s-21779
- mod-21780)
- (expand-expr-4332
- type-21774
- value-21775
- form-21776
- e-21777
- r-21617
- w-21778
- s-21779
- mod-21780)))))
- (expand-expr-4332
- (lambda (type-21783
- value-21784
- form-21785
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'lexical)
+ (lambda (type-25140
+ value-25141
+ form-25142
+ e-25143
+ w-25144
+ s-25145
+ mod-25146)
+ (expand-expr-4384
+ type-25140
+ value-25141
+ form-25142
+ e-25143
+ r-25108
+ w-25144
+ s-25145
+ mod-25146)))))
+ (expand-expr-4384
+ (lambda (type-25149
+ value-25150
+ form-25151
+ e-25152
+ r-25153
+ w-25154
+ s-25155
+ mod-25156)
+ (if (eqv? type-25149 'lexical)
(make-struct/no-tail
(vector-ref %expanded-vtables 3)
- s-21789
- e-21786
- value-21784)
- (if (if (eqv? type-21783 'core)
+ s-25155
+ e-25152
+ value-25150)
+ (if (if (eqv? type-25149 'core)
#t
- (eqv? type-21783 'core-form))
- (value-21784
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'module-ref)
+ (eqv? type-25149 'core-form))
+ (value-25150
+ e-25152
+ r-25153
+ w-25154
+ s-25155
+ mod-25156)
+ (if (eqv? type-25149 'module-ref)
(call-with-values
- (lambda () (value-21784 e-21786 r-21787 w-21788))
- (lambda (e-21826 r-21827 w-21828 s-21829 mod-21830)
- (expand-4331 e-21826 r-21827 w-21828 mod-21830)))
- (if (eqv? type-21783 'lexical-call)
- (expand-application-4333
- (let ((id-21908 (car e-21786)))
- (build-lexical-reference-4265
- 'fun
- (source-annotation-4288 id-21908)
- (if (if (vector? id-21908)
- (if (= (vector-length id-21908) 4)
- (eq? (vector-ref id-21908 0) 'syntax-object)
- #f)
- #f)
- (syntax->datum id-21908)
- id-21908)
- value-21784))
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'global-call)
- (expand-application-4333
- (build-global-reference-4268
- (source-annotation-4288 (car e-21786))
- (if (if (vector? value-21784)
- (if (= (vector-length value-21784) 4)
- (eq? (vector-ref value-21784 0) 'syntax-object)
- #f)
- #f)
- (vector-ref value-21784 1)
- value-21784)
- (if (if (vector? value-21784)
- (if (= (vector-length value-21784) 4)
- (eq? (vector-ref value-21784 0) 'syntax-object)
- #f)
- #f)
- (vector-ref value-21784 3)
- mod-21790))
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'constant)
- (let ((exp-22251
- (strip-4344
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties? e-21786)
+ (lambda () (value-25150 e-25152 r-25153 w-25154))
+ (lambda (e-25192 r-25193 w-25194 s-25195 mod-25196)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-25192
+ r-25193
+ w-25194
+ (let ((props-25212
+ (source-properties
+ (if (if (vector? e-25192)
+ (if (= (vector-length e-25192) 4)
+ (eq? (vector-ref e-25192 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-25192 1)
+ e-25192))))
+ (if (pair? props-25212) props-25212 #f))
+ #f
+ mod-25196
+ #f))
+ (lambda (type-25245
+ value-25246
+ form-25247
+ e-25248
+ w-25249
+ s-25250
+ mod-25251)
+ (expand-expr-4384
+ type-25245
+ value-25246
+ form-25247
+ e-25248
+ r-25193
+ w-25249
+ s-25250
+ mod-25251)))))
+ (if (eqv? type-25149 'lexical-call)
+ (let ((x-25263
+ (let ((id-25284 (car e-25152)))
+ (let ((source-25288
+ (let ((props-25298
+ (source-properties
+ (if (if (vector? id-25284)
+ (if (= (vector-length
+ id-25284)
+ 4)
+ (eq? (vector-ref
+ id-25284
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref id-25284 1)
+ id-25284))))
+ (if (pair? props-25298) props-25298 #f)))
+ (name-25289
+ (if (if (vector? id-25284)
+ (if (= (vector-length id-25284) 4)
+ (eq? (vector-ref id-25284 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (syntax->datum id-25284)
+ id-25284)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 3)
+ source-25288
+ name-25289
+ value-25150)))))
+ (let ((tmp-25270
+ ($sc-dispatch e-25152 '(any . each-any))))
+ (if tmp-25270
+ (@apply
+ (lambda (e0-25273 e1-25274)
+ (let ((arg-exps-25279
+ (map (lambda (e-25330)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-25330
+ r-25153
+ w-25154
+ (let ((props-25345
+ (source-properties
+ (if (if (vector?
+ e-25330)
+ (if (= (vector-length
+ e-25330)
+ 4)
+ (eq? (vector-ref
+ e-25330
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-25330
+ 1)
+ e-25330))))
+ (if (pair? props-25345)
+ props-25345
+ #f))
+ #f
+ mod-25156
+ #f))
+ (lambda (type-25378
+ value-25379
+ form-25380
+ e-25381
+ w-25382
+ s-25383
+ mod-25384)
+ (expand-expr-4384
+ type-25378
+ value-25379
+ form-25380
+ e-25381
+ r-25153
+ w-25382
+ s-25383
+ mod-25384))))
+ e1-25274)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ s-25155
+ x-25263
+ arg-exps-25279)))
+ tmp-25270)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-25152))))
+ (if (eqv? type-25149 'global-call)
+ (let ((x-25400
+ (let ((source-25423
+ (let ((x-25461 (car e-25152)))
+ (let ((props-25462
+ (source-properties
+ (if (if (vector? x-25461)
+ (if (= (vector-length
+ x-25461)
+ 4)
+ (eq? (vector-ref
+ x-25461
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-25461 1)
+ x-25461))))
+ (if (pair? props-25462)
+ props-25462
+ #f))))
+ (var-25424
+ (if (if (vector? value-25150)
+ (if (= (vector-length value-25150) 4)
+ (eq? (vector-ref value-25150 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-21786 s-21789))
- e-21786)
- w-21788
- mod-21790)
+ (vector-ref value-25150 1)
+ value-25150))
+ (mod-25425
+ (if (if (vector? value-25150)
+ (if (= (vector-length value-25150) 4)
+ (eq? (vector-ref value-25150 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref value-25150 3)
+ mod-25156)))
+ (analyze-variable-4319
+ mod-25425
+ var-25424
+ (lambda (mod-25451 var-25452 public?-25453)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 5)
+ source-25423
+ mod-25451
+ var-25452
+ public?-25453))
+ (lambda (var-25475)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 7)
+ source-25423
+ var-25475))))))
+ (let ((tmp-25407
+ ($sc-dispatch e-25152 '(any . each-any))))
+ (if tmp-25407
+ (@apply
+ (lambda (e0-25410 e1-25411)
+ (let ((arg-exps-25416
+ (map (lambda (e-25479)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-25479
+ r-25153
+ w-25154
+ (let ((props-25494
+ (source-properties
+ (if (if (vector?
+ e-25479)
+ (if (= (vector-length
+ e-25479)
+ 4)
+ (eq? (vector-ref
+ e-25479
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-25479
+ 1)
+ e-25479))))
+ (if (pair? props-25494)
+ props-25494
+ #f))
+ #f
+ mod-25156
+ #f))
+ (lambda (type-25527
+ value-25528
+ form-25529
+ e-25530
+ w-25531
+ s-25532
+ mod-25533)
+ (expand-expr-4384
+ type-25527
+ value-25528
+ form-25529
+ e-25530
+ r-25153
+ w-25531
+ s-25532
+ mod-25533))))
+ e1-25411)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ s-25155
+ x-25400
+ arg-exps-25416)))
+ tmp-25407)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-25152))))
+ (if (eqv? type-25149 'constant)
+ (let ((exp-25550
+ (strip-4396
+ (let ((x-25563
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ e-25152)
+ #f)
+ (set-source-properties!
+ e-25152
+ s-25155))
+ e-25152)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-25563
+ (if (if (vector? x-25563)
+ (if (= (vector-length x-25563) 4)
+ (eq? (vector-ref x-25563 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-25595
+ (vector-ref x-25563 1))
+ (wrap-25596
+ (let ((w2-25604
+ (vector-ref x-25563 2)))
+ (let ((m1-25605 (car w-25154))
+ (s1-25606 (cdr w-25154)))
+ (if (null? m1-25605)
+ (if (null? s1-25606)
+ w2-25604
+ (cons (car w2-25604)
+ (let ((m2-25621
+ (cdr w2-25604)))
+ (if (null? m2-25621)
+ s1-25606
+ (append
+ s1-25606
+ m2-25621)))))
+ (cons (let ((m2-25629
+ (car w2-25604)))
+ (if (null? m2-25629)
+ m1-25605
+ (append
+ m1-25605
+ m2-25629)))
+ (let ((m2-25637
+ (cdr w2-25604)))
+ (if (null? m2-25637)
+ s1-25606
+ (append
+ s1-25606
+ m2-25637))))))))
+ (module-25597
+ (vector-ref x-25563 3)))
+ (vector
+ 'syntax-object
+ expression-25595
+ wrap-25596
+ module-25597))
+ (if (null? x-25563)
+ x-25563
+ (vector
+ 'syntax-object
+ x-25563
+ w-25154
+ mod-25156)))))
'(()))))
(make-struct/no-tail
(vector-ref %expanded-vtables 1)
- s-21789
- exp-22251))
- (if (eqv? type-21783 'global)
- (analyze-variable-4267
- mod-21790
- value-21784
- (lambda (mod-22290 var-22291 public?-22292)
+ s-25155
+ exp-25550))
+ (if (eqv? type-25149 'global)
+ (analyze-variable-4319
+ mod-25156
+ value-25150
+ (lambda (mod-25665 var-25666 public?-25667)
(make-struct/no-tail
(vector-ref %expanded-vtables 5)
- s-21789
- mod-22290
- var-22291
- public?-22292))
- (lambda (var-22301)
+ s-25155
+ mod-25665
+ var-25666
+ public?-25667))
+ (lambda (var-25675)
(make-struct/no-tail
(vector-ref %expanded-vtables 7)
- s-21789
- var-22301)))
- (if (eqv? type-21783 'call)
- (expand-application-4333
- (expand-4331
- (car e-21786)
- r-21787
- w-21788
- mod-21790)
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790)
- (if (eqv? type-21783 'begin-form)
- (let ((tmp-22382
- ($sc-dispatch e-21786 '(_ any . each-any))))
- (if tmp-22382
+ s-25155
+ var-25675)))
+ (if (eqv? type-25149 'call)
+ (let ((x-25690
+ (let ((e-25713 (car e-25152)))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-25713
+ r-25153
+ w-25154
+ (let ((props-25723
+ (source-properties
+ (if (if (vector? e-25713)
+ (if (= (vector-length
+ e-25713)
+ 4)
+ (eq? (vector-ref
+ e-25713
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-25713 1)
+ e-25713))))
+ (if (pair? props-25723)
+ props-25723
+ #f))
+ #f
+ mod-25156
+ #f))
+ (lambda (type-25746
+ value-25747
+ form-25748
+ e-25749
+ w-25750
+ s-25751
+ mod-25752)
+ (expand-expr-4384
+ type-25746
+ value-25747
+ form-25748
+ e-25749
+ r-25153
+ w-25750
+ s-25751
+ mod-25752))))))
+ (let ((tmp-25697
+ ($sc-dispatch e-25152 '(any . each-any))))
+ (if tmp-25697
+ (@apply
+ (lambda (e0-25700 e1-25701)
+ (let ((arg-exps-25706
+ (map (lambda (e-25755)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-25755
+ r-25153
+ w-25154
+ (let ((props-25770
+ (source-properties
+ (if (if (vector?
+ e-25755)
+ (if (= (vector-length
+ e-25755)
+ 4)
+ (eq? (vector-ref
+ e-25755
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-25755
+ 1)
+ e-25755))))
+ (if (pair? props-25770)
+ props-25770
+ #f))
+ #f
+ mod-25156
+ #f))
+ (lambda (type-25803
+ value-25804
+ form-25805
+ e-25806
+ w-25807
+ s-25808
+ mod-25809)
+ (expand-expr-4384
+ type-25803
+ value-25804
+ form-25805
+ e-25806
+ r-25153
+ w-25807
+ s-25808
+ mod-25809))))
+ e1-25701)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ s-25155
+ x-25690
+ arg-exps-25706)))
+ tmp-25697)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-25152))))
+ (if (eqv? type-25149 'begin-form)
+ (let ((tmp-25823
+ ($sc-dispatch e-25152 '(_ any . each-any))))
+ (if tmp-25823
(@apply
- (lambda (e1-22386 e2-22387)
- (expand-sequence-4326
- (cons e1-22386 e2-22387)
- r-21787
- w-21788
- s-21789
- mod-21790))
- tmp-22382)
- (let ((tmp-22474 ($sc-dispatch e-21786 '(_))))
- (if tmp-22474
+ (lambda (e1-25827 e2-25828)
+ (expand-sequence-4378
+ (cons e1-25827 e2-25828)
+ r-25153
+ w-25154
+ s-25155
+ mod-25156))
+ tmp-25823)
+ (let ((tmp-25968 ($sc-dispatch e-25152 '(_))))
+ (if tmp-25968
(@apply
(lambda ()
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f))
- (syntax-violation
- #f
- "sequence of zero expressions"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
+ (syntax-violation
+ #f
+ "sequence of zero expressions"
+ (let ((x-25981
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ e-25152)
+ #f)
+ (set-source-properties!
+ e-25152
+ s-25155))
+ e-25152)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-25981
+ (if (if (vector? x-25981)
+ (if (= (vector-length
+ x-25981)
+ 4)
+ (eq? (vector-ref
+ x-25981
+ 0)
+ 'syntax-object)
#f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))))
- tmp-22474)
+ #f)
+ (let ((expression-26013
+ (vector-ref x-25981 1))
+ (wrap-26014
+ (let ((w2-26022
+ (vector-ref
+ x-25981
+ 2)))
+ (let ((m1-26023
+ (car w-25154))
+ (s1-26024
+ (cdr w-25154)))
+ (if (null? m1-26023)
+ (if (null? s1-26024)
+ w2-26022
+ (cons (car w2-26022)
+ (let ((m2-26039
+ (cdr w2-26022)))
+ (if (null? m2-26039)
+ s1-26024
+ (append
+ s1-26024
+ m2-26039)))))
+ (cons (let ((m2-26047
+ (car w2-26022)))
+ (if (null? m2-26047)
+ m1-26023
+ (append
+ m1-26023
+ m2-26047)))
+ (let ((m2-26055
+ (cdr w2-26022)))
+ (if (null? m2-26055)
+ s1-26024
+ (append
+ s1-26024
+ m2-26055))))))))
+ (module-26015
+ (vector-ref x-25981 3)))
+ (vector
+ 'syntax-object
+ expression-26013
+ wrap-26014
+ module-26015))
+ (if (null? x-25981)
+ x-25981
+ (vector
+ 'syntax-object
+ x-25981
+ w-25154
+ mod-25156)))))))
+ tmp-25968)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-21786)))))
- (if (eqv? type-21783 'local-syntax-form)
- (expand-local-syntax-4336
- value-21784
- e-21786
- r-21787
- w-21788
- s-21789
- mod-21790
- expand-sequence-4326)
- (if (eqv? type-21783 'eval-when-form)
- (let ((tmp-22591
+ e-25152)))))
+ (if (eqv? type-25149 'local-syntax-form)
+ (expand-local-syntax-4388
+ value-25150
+ e-25152
+ r-25153
+ w-25154
+ s-25155
+ mod-25156
+ expand-sequence-4378)
+ (if (eqv? type-25149 'eval-when-form)
+ (let ((tmp-26155
($sc-dispatch
- e-21786
+ e-25152
'(_ each-any any . each-any))))
- (if tmp-22591
+ (if tmp-26155
(@apply
- (lambda (x-22595 e1-22596 e2-22597)
- (let ((when-list-22598
- (parse-when-list-4329
- e-21786
- x-22595)))
- (if (memq 'eval when-list-22598)
- (expand-sequence-4326
- (cons e1-22596 e2-22597)
- r-21787
- w-21788
- s-21789
- mod-21790)
+ (lambda (x-26159 e1-26160 e2-26161)
+ (let ((when-list-26162
+ (parse-when-list-4381
+ e-25152
+ x-26159)))
+ (if (memq 'eval when-list-26162)
+ (expand-sequence-4378
+ (cons e1-26160 e2-26161)
+ r-25153
+ w-25154
+ s-25155
+ mod-25156)
(make-struct/no-tail
(vector-ref %expanded-vtables 0)
#f))))
- tmp-22591)
+ tmp-26155)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-21786)))
- (if (if (eqv? type-21783 'define-form)
+ e-25152)))
+ (if (if (eqv? type-25149 'define-form)
#t
- (if (eqv? type-21783 'define-syntax-form)
+ (if (eqv? type-25149 'define-syntax-form)
#t
- (eqv? type-21783
+ (eqv? type-25149
'define-syntax-parameter-form)))
(syntax-violation
#f
"definition in expression context, where definitions are not allowed,"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- form-21785)
+ (let ((x-26396
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ form-25151)
+ #f)
+ (set-source-properties!
+ form-25151
+ s-25155))
+ form-25151)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-26396
+ (if (if (vector? x-26396)
+ (if (= (vector-length x-26396) 4)
+ (eq? (vector-ref x-26396 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- form-21785
- s-21789))
- form-21785)
- w-21788
- mod-21790))
- (if (eqv? type-21783 'syntax)
+ (let ((expression-26428
+ (vector-ref x-26396 1))
+ (wrap-26429
+ (let ((w2-26437
+ (vector-ref
+ x-26396
+ 2)))
+ (let ((m1-26438
+ (car w-25154))
+ (s1-26439
+ (cdr w-25154)))
+ (if (null? m1-26438)
+ (if (null? s1-26439)
+ w2-26437
+ (cons (car w2-26437)
+ (let ((m2-26454
+ (cdr w2-26437)))
+ (if (null? m2-26454)
+ s1-26439
+ (append
+ s1-26439
+ m2-26454)))))
+ (cons (let ((m2-26462
+ (car w2-26437)))
+ (if (null? m2-26462)
+ m1-26438
+ (append
+ m1-26438
+ m2-26462)))
+ (let ((m2-26470
+ (cdr w2-26437)))
+ (if (null? m2-26470)
+ s1-26439
+ (append
+ s1-26439
+ m2-26470))))))))
+ (module-26430
+ (vector-ref x-26396 3)))
+ (vector
+ 'syntax-object
+ expression-26428
+ wrap-26429
+ module-26430))
+ (if (null? x-26396)
+ x-26396
+ (vector
+ 'syntax-object
+ x-26396
+ w-25154
+ mod-25156))))))
+ (if (eqv? type-25149 'syntax)
(syntax-violation
#f
"reference to pattern variable outside syntax form"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
+ (let ((x-26500
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ e-25152)
+ #f)
+ (set-source-properties!
+ e-25152
+ s-25155))
+ e-25152)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-26500
+ (if (if (vector? x-26500)
+ (if (= (vector-length x-26500)
+ 4)
+ (eq? (vector-ref x-26500 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))
- (if (eqv? type-21783 'displaced-lexical)
+ (let ((expression-26532
+ (vector-ref x-26500 1))
+ (wrap-26533
+ (let ((w2-26541
+ (vector-ref
+ x-26500
+ 2)))
+ (let ((m1-26542
+ (car w-25154))
+ (s1-26543
+ (cdr w-25154)))
+ (if (null? m1-26542)
+ (if (null? s1-26543)
+ w2-26541
+ (cons (car w2-26541)
+ (let ((m2-26558
+ (cdr w2-26541)))
+ (if (null? m2-26558)
+ s1-26543
+ (append
+ s1-26543
+ m2-26558)))))
+ (cons (let ((m2-26566
+ (car w2-26541)))
+ (if (null? m2-26566)
+ m1-26542
+ (append
+ m1-26542
+ m2-26566)))
+ (let ((m2-26574
+ (cdr w2-26541)))
+ (if (null? m2-26574)
+ s1-26543
+ (append
+ s1-26543
+ m2-26574))))))))
+ (module-26534
+ (vector-ref x-26500 3)))
+ (vector
+ 'syntax-object
+ expression-26532
+ wrap-26533
+ module-26534))
+ (if (null? x-26500)
+ x-26500
+ (vector
+ 'syntax-object
+ x-26500
+ w-25154
+ mod-25156))))))
+ (if (eqv? type-25149 'displaced-lexical)
(syntax-violation
#f
"reference to identifier outside its scope"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
+ (let ((x-26604
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ e-25152)
+ #f)
+ (set-source-properties!
+ e-25152
+ s-25155))
+ e-25152)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-26604
+ (if (if (vector? x-26604)
+ (if (= (vector-length x-26604)
+ 4)
+ (eq? (vector-ref x-26604 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))
+ (let ((expression-26636
+ (vector-ref x-26604 1))
+ (wrap-26637
+ (let ((w2-26645
+ (vector-ref
+ x-26604
+ 2)))
+ (let ((m1-26646
+ (car w-25154))
+ (s1-26647
+ (cdr w-25154)))
+ (if (null? m1-26646)
+ (if (null? s1-26647)
+ w2-26645
+ (cons (car w2-26645)
+ (let ((m2-26662
+ (cdr w2-26645)))
+ (if (null? m2-26662)
+ s1-26647
+ (append
+ s1-26647
+ m2-26662)))))
+ (cons (let ((m2-26670
+ (car w2-26645)))
+ (if (null? m2-26670)
+ m1-26646
+ (append
+ m1-26646
+ m2-26670)))
+ (let ((m2-26678
+ (cdr w2-26645)))
+ (if (null? m2-26678)
+ s1-26647
+ (append
+ s1-26647
+ m2-26678))))))))
+ (module-26638
+ (vector-ref x-26604 3)))
+ (vector
+ 'syntax-object
+ expression-26636
+ wrap-26637
+ module-26638))
+ (if (null? x-26604)
+ x-26604
+ (vector
+ 'syntax-object
+ x-26604
+ w-25154
+ mod-25156))))))
(syntax-violation
#f
"unexpected syntax"
- (wrap-4324
- (begin
- (if (if s-21789
- (supports-source-properties?
- e-21786)
+ (let ((x-26702
+ (begin
+ (if (if s-25155
+ (supports-source-properties?
+ e-25152)
+ #f)
+ (set-source-properties!
+ e-25152
+ s-25155))
+ e-25152)))
+ (if (if (null? (car w-25154))
+ (null? (cdr w-25154))
+ #f)
+ x-26702
+ (if (if (vector? x-26702)
+ (if (= (vector-length x-26702)
+ 4)
+ (eq? (vector-ref x-26702 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- e-21786
- s-21789))
- e-21786)
- w-21788
- mod-21790))))))))))))))))))
- (expand-application-4333
- (lambda (x-22867
- e-22868
- r-22869
- w-22870
- s-22871
- mod-22872)
- (let ((tmp-22874
- ($sc-dispatch e-22868 '(any . each-any))))
- (if tmp-22874
- (@apply
- (lambda (e0-22878 e1-22879)
- (build-application-4262
- s-22871
- x-22867
- (map (lambda (e-22959)
- (expand-4331 e-22959 r-22869 w-22870 mod-22872))
- e1-22879)))
- tmp-22874)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-22868)))))
- (expand-macro-4334
- (lambda (p-23035
- e-23036
- r-23037
- w-23038
- s-23039
- rib-23040
- mod-23041)
+ (let ((expression-26734
+ (vector-ref x-26702 1))
+ (wrap-26735
+ (let ((w2-26743
+ (vector-ref
+ x-26702
+ 2)))
+ (let ((m1-26744
+ (car w-25154))
+ (s1-26745
+ (cdr w-25154)))
+ (if (null? m1-26744)
+ (if (null? s1-26745)
+ w2-26743
+ (cons (car w2-26743)
+ (let ((m2-26760
+ (cdr w2-26743)))
+ (if (null? m2-26760)
+ s1-26745
+ (append
+ s1-26745
+ m2-26760)))))
+ (cons (let ((m2-26768
+ (car w2-26743)))
+ (if (null? m2-26768)
+ m1-26744
+ (append
+ m1-26744
+ m2-26768)))
+ (let ((m2-26776
+ (cdr w2-26743)))
+ (if (null? m2-26776)
+ s1-26745
+ (append
+ s1-26745
+ m2-26776))))))))
+ (module-26736
+ (vector-ref x-26702 3)))
+ (vector
+ 'syntax-object
+ expression-26734
+ wrap-26735
+ module-26736))
+ (if (null? x-26702)
+ x-26702
+ (vector
+ 'syntax-object
+ x-26702
+ w-25154
+ mod-25156))))))))))))))))))))))
+ (expand-macro-4386
+ (lambda (p-26791
+ e-26792
+ r-26793
+ w-26794
+ s-26795
+ rib-26796
+ mod-26797)
(letrec*
- ((rebuild-macro-output-23042
- (lambda (x-23075 m-23076)
- (if (pair? x-23075)
- (let ((e-23080
- (cons (rebuild-macro-output-23042
- (car x-23075)
- m-23076)
- (rebuild-macro-output-23042
- (cdr x-23075)
- m-23076))))
+ ((rebuild-macro-output-26798
+ (lambda (x-26907 m-26908)
+ (if (pair? x-26907)
+ (let ((e-26912
+ (cons (rebuild-macro-output-26798
+ (car x-26907)
+ m-26908)
+ (rebuild-macro-output-26798
+ (cdr x-26907)
+ m-26908))))
(begin
- (if (if s-23039
- (supports-source-properties? e-23080)
+ (if (if s-26795
+ (supports-source-properties? e-26912)
#f)
- (set-source-properties! e-23080 s-23039))
- e-23080))
- (if (if (vector? x-23075)
- (if (= (vector-length x-23075) 4)
- (eq? (vector-ref x-23075 0) 'syntax-object)
+ (set-source-properties! e-26912 s-26795))
+ e-26912))
+ (if (if (vector? x-26907)
+ (if (= (vector-length x-26907) 4)
+ (eq? (vector-ref x-26907 0) 'syntax-object)
#f)
#f)
- (let ((w-23096 (vector-ref x-23075 2)))
- (let ((ms-23097 (car w-23096))
- (ss-23098 (cdr w-23096)))
- (if (if (pair? ms-23097) (eq? (car ms-23097) #f) #f)
- (let ((expression-23106 (vector-ref x-23075 1))
- (wrap-23107
- (cons (cdr ms-23097)
- (if rib-23040
- (cons rib-23040 (cdr ss-23098))
- (cdr ss-23098))))
- (module-23108 (vector-ref x-23075 3)))
+ (let ((w-26928 (vector-ref x-26907 2)))
+ (let ((ms-26929 (car w-26928))
+ (ss-26930 (cdr w-26928)))
+ (if (if (pair? ms-26929) (eq? (car ms-26929) #f) #f)
+ (let ((expression-26938 (vector-ref x-26907 1))
+ (wrap-26939
+ (cons (cdr ms-26929)
+ (if rib-26796
+ (cons rib-26796 (cdr ss-26930))
+ (cdr ss-26930))))
+ (module-26940 (vector-ref x-26907 3)))
(vector
'syntax-object
- expression-23106
- wrap-23107
- module-23108))
- (let ((expression-23118
- (let ((e-23123 (vector-ref x-23075 1)))
+ expression-26938
+ wrap-26939
+ module-26940))
+ (let ((expression-26950
+ (let ((e-26955 (vector-ref x-26907 1)))
(begin
- (if (if s-23039
+ (if (if s-26795
(supports-source-properties?
- e-23123)
+ e-26955)
#f)
(set-source-properties!
- e-23123
- s-23039))
- e-23123)))
- (wrap-23119
- (cons (cons m-23076 ms-23097)
- (if rib-23040
- (cons rib-23040
- (cons 'shift ss-23098))
- (cons 'shift ss-23098))))
- (module-23120 (vector-ref x-23075 3)))
+ e-26955
+ s-26795))
+ e-26955)))
+ (wrap-26951
+ (cons (cons m-26908 ms-26929)
+ (if rib-26796
+ (cons rib-26796
+ (cons 'shift ss-26930))
+ (cons 'shift ss-26930))))
+ (module-26952 (vector-ref x-26907 3)))
(vector
'syntax-object
- expression-23118
- wrap-23119
- module-23120)))))
- (if (vector? x-23075)
- (let ((n-23135 (vector-length x-23075)))
- (let ((v-23136
- (let ((e-23144 (make-vector n-23135)))
+ expression-26950
+ wrap-26951
+ module-26952)))))
+ (if (vector? x-26907)
+ (let ((n-26967 (vector-length x-26907)))
+ (let ((v-26968
+ (let ((e-27033 (make-vector n-26967)))
(begin
- (if (if s-23039
- (supports-source-properties? e-23144)
+ (if (if s-26795
+ (supports-source-properties? e-27033)
#f)
- (set-source-properties! e-23144 s-23039))
- e-23144))))
+ (set-source-properties! e-27033 s-26795))
+ e-27033))))
(letrec*
- ((loop-23137
- (lambda (i-23189)
- (if (= i-23189 n-23135)
- v-23136
+ ((loop-26969
+ (lambda (i-27029)
+ (if (= i-27029 n-26967)
+ v-26968
(begin
(vector-set!
- v-23136
- i-23189
- (rebuild-macro-output-23042
- (vector-ref x-23075 i-23189)
- m-23076))
- (loop-23137 (#{1+}# i-23189)))))))
- (loop-23137 0))))
- (if (symbol? x-23075)
+ v-26968
+ i-27029
+ (rebuild-macro-output-26798
+ (vector-ref x-26907 i-27029)
+ m-26908))
+ (loop-26969 (#{1+}# i-27029)))))))
+ (loop-26969 0))))
+ (if (symbol? x-26907)
(syntax-violation
#f
"encountered raw symbol in macro output"
- (let ((s-23195 (cdr w-23038)))
- (wrap-4324
- (begin
- (if (if s-23195
- (supports-source-properties? e-23036)
+ (let ((s-27044 (cdr w-26794)))
+ (let ((x-27048
+ (begin
+ (if (if s-27044
+ (supports-source-properties?
+ e-26792)
+ #f)
+ (set-source-properties!
+ e-26792
+ s-27044))
+ e-26792)))
+ (if (if (null? (car w-26794))
+ (null? (cdr w-26794))
+ #f)
+ x-27048
+ (if (if (vector? x-27048)
+ (if (= (vector-length x-27048) 4)
+ (eq? (vector-ref x-27048 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-23036 s-23195))
- e-23036)
- w-23038
- mod-23041))
- x-23075)
+ (let ((expression-27080
+ (vector-ref x-27048 1))
+ (wrap-27081
+ (let ((w2-27089
+ (vector-ref x-27048 2)))
+ (let ((m1-27090 (car w-26794))
+ (s1-27091 (cdr w-26794)))
+ (if (null? m1-27090)
+ (if (null? s1-27091)
+ w2-27089
+ (cons (car w2-27089)
+ (let ((m2-27106
+ (cdr w2-27089)))
+ (if (null? m2-27106)
+ s1-27091
+ (append
+ s1-27091
+ m2-27106)))))
+ (cons (let ((m2-27114
+ (car w2-27089)))
+ (if (null? m2-27114)
+ m1-27090
+ (append
+ m1-27090
+ m2-27114)))
+ (let ((m2-27122
+ (cdr w2-27089)))
+ (if (null? m2-27122)
+ s1-27091
+ (append
+ s1-27091
+ m2-27122))))))))
+ (module-27082 (vector-ref x-27048 3)))
+ (vector
+ 'syntax-object
+ expression-27080
+ wrap-27081
+ module-27082))
+ (if (null? x-27048)
+ x-27048
+ (vector
+ 'syntax-object
+ x-27048
+ w-26794
+ mod-26797))))))
+ x-26907)
(begin
- (if (if s-23039
- (supports-source-properties? x-23075)
+ (if (if s-26795
+ (supports-source-properties? x-26907)
#f)
- (set-source-properties! x-23075 s-23039))
- x-23075))))))))
+ (set-source-properties! x-26907 s-26795))
+ x-26907))))))))
(with-fluids
- ((transformer-environment-4317
- (lambda (k-23043)
- (k-23043
- e-23036
- r-23037
- w-23038
- s-23039
- rib-23040
- mod-23041))))
- (rebuild-macro-output-23042
- (p-23035
- (let ((w-23050
- (cons (cons #f (car w-23038))
- (cons 'shift (cdr w-23038)))))
- (wrap-4324
- (begin
- (if (if s-23039
- (supports-source-properties? e-23036)
+ ((transformer-environment-4369
+ (lambda (k-26799)
+ (k-26799
+ e-26792
+ r-26793
+ w-26794
+ s-26795
+ rib-26796
+ mod-26797))))
+ (rebuild-macro-output-26798
+ (p-26791
+ (let ((w-26806
+ (cons (cons #f (car w-26794))
+ (cons 'shift (cdr w-26794)))))
+ (let ((x-26811
+ (begin
+ (if (if s-26795
+ (supports-source-properties? e-26792)
+ #f)
+ (set-source-properties! e-26792 s-26795))
+ e-26792)))
+ (if (if (null? (car w-26806))
+ (null? (cdr w-26806))
+ #f)
+ x-26811
+ (if (if (vector? x-26811)
+ (if (= (vector-length x-26811) 4)
+ (eq? (vector-ref x-26811 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-23036 s-23039))
- e-23036)
- w-23050
- mod-23041)))
+ (let ((expression-26850 (vector-ref x-26811 1))
+ (wrap-26851
+ (let ((w2-26859 (vector-ref x-26811 2)))
+ (let ((m1-26860 (car w-26806))
+ (s1-26861 (cdr w-26806)))
+ (if (null? m1-26860)
+ (if (null? s1-26861)
+ w2-26859
+ (cons (car w2-26859)
+ (let ((m2-26876 (cdr w2-26859)))
+ (if (null? m2-26876)
+ s1-26861
+ (append
+ s1-26861
+ m2-26876)))))
+ (cons (let ((m2-26884 (car w2-26859)))
+ (if (null? m2-26884)
+ m1-26860
+ (append m1-26860 m2-26884)))
+ (let ((m2-26892 (cdr w2-26859)))
+ (if (null? m2-26892)
+ s1-26861
+ (append
+ s1-26861
+ m2-26892))))))))
+ (module-26852 (vector-ref x-26811 3)))
+ (vector
+ 'syntax-object
+ expression-26850
+ wrap-26851
+ module-26852))
+ (if (null? x-26811)
+ x-26811
+ (vector
+ 'syntax-object
+ x-26811
+ w-26806
+ mod-26797)))))))
(gensym
- (string-append "m-" (session-id-4256) "-")))))))
- (expand-body-4335
- (lambda (body-23227
- outer-form-23228
- r-23229
- w-23230
- mod-23231)
- (let ((r-23232
- (cons '("placeholder" placeholder) r-23229)))
- (let ((ribcage-23233 (vector 'ribcage '() '() '())))
- (let ((w-23234
- (cons (car w-23230)
- (cons ribcage-23233 (cdr w-23230)))))
+ (string-append "m-" (session-id-4308) "-")))))))
+ (expand-body-4387
+ (lambda (body-27152
+ outer-form-27153
+ r-27154
+ w-27155
+ mod-27156)
+ (let ((r-27157
+ (cons '("placeholder" placeholder) r-27154)))
+ (let ((ribcage-27158 (vector 'ribcage '() '() '())))
+ (let ((w-27159
+ (cons (car w-27155)
+ (cons ribcage-27158 (cdr w-27155)))))
(letrec*
- ((parse-23235
- (lambda (body-23248
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254)
- (if (null? body-23248)
+ ((parse-27160
+ (lambda (body-27268
+ ids-27269
+ labels-27270
+ var-ids-27271
+ vars-27272
+ vals-27273
+ bindings-27274)
+ (if (null? body-27268)
(syntax-violation
#f
"no expressions in body"
- outer-form-23228)
- (let ((e-23255 (cdr (car body-23248)))
- (er-23256 (car (car body-23248))))
+ outer-form-27153)
+ (let ((e-27275 (cdr (car body-27268)))
+ (er-27276 (car (car body-27268))))
(call-with-values
(lambda ()
- (syntax-type-4330
- e-23255
- er-23256
+ (syntax-type-4382
+ e-27275
+ er-27276
'(())
- (source-annotation-4288 er-23256)
- ribcage-23233
- mod-23231
+ (let ((props-27285
+ (source-properties
+ (if (if (vector? er-27276)
+ (if (= (vector-length er-27276)
+ 4)
+ (eq? (vector-ref er-27276 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref er-27276 1)
+ er-27276))))
+ (if (pair? props-27285) props-27285 #f))
+ ribcage-27158
+ mod-27156
#f))
- (lambda (type-23413
- value-23414
- form-23415
- e-23416
- w-23417
- s-23418
- mod-23419)
- (if (eqv? type-23413 'define-form)
- (let ((id-23427
- (wrap-4324
- value-23414
- w-23417
- mod-23419))
- (label-23428
+ (lambda (type-27308
+ value-27309
+ form-27310
+ e-27311
+ w-27312
+ s-27313
+ mod-27314)
+ (if (eqv? type-27308 'define-form)
+ (let ((id-27322
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ value-27309
+ (if (if (vector? value-27309)
+ (if (= (vector-length
+ value-27309)
+ 4)
+ (eq? (vector-ref
+ value-27309
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-27367
+ (vector-ref value-27309 1))
+ (wrap-27368
+ (let ((w2-27378
+ (vector-ref
+ value-27309
+ 2)))
+ (let ((m1-27379
+ (car w-27312))
+ (s1-27380
+ (cdr w-27312)))
+ (if (null? m1-27379)
+ (if (null? s1-27380)
+ w2-27378
+ (cons (car w2-27378)
+ (let ((m2-27397
+ (cdr w2-27378)))
+ (if (null? m2-27397)
+ s1-27380
+ (append
+ s1-27380
+ m2-27397)))))
+ (cons (let ((m2-27405
+ (car w2-27378)))
+ (if (null? m2-27405)
+ m1-27379
+ (append
+ m1-27379
+ m2-27405)))
+ (let ((m2-27413
+ (cdr w2-27378)))
+ (if (null? m2-27413)
+ s1-27380
+ (append
+ s1-27380
+ m2-27413))))))))
+ (module-27369
+ (vector-ref
+ value-27309
+ 3)))
+ (vector
+ 'syntax-object
+ expression-27367
+ wrap-27368
+ module-27369))
+ (if (null? value-27309)
+ value-27309
+ (vector
+ 'syntax-object
+ value-27309
+ w-27312
+ mod-27314)))))
+ (label-27323
(string-append
"l-"
- (session-id-4256)
+ (session-id-4308)
(symbol->string (gensym "-")))))
- (let ((var-23429
- (let ((id-23489
- (if (if (vector? id-23427)
+ (let ((var-27324
+ (let ((id-27474
+ (if (if (vector? id-27322)
(if (= (vector-length
- id-23427)
+ id-27322)
4)
(eq? (vector-ref
- id-23427
+ id-27322
0)
'syntax-object)
#f)
#f)
- (vector-ref id-23427 1)
- id-23427)))
+ (vector-ref id-27322 1)
+ id-27322)))
(gensym
(string-append
- (symbol->string id-23489)
+ (symbol->string id-27474)
"-")))))
(begin
- (let ((update-23479
- (cons (vector-ref id-23427 1)
- (vector-ref
- ribcage-23233
- 1))))
- (vector-set!
- ribcage-23233
- 1
- update-23479))
- (let ((update-23481
- (cons (car (vector-ref
- id-23427
- 2))
- (vector-ref
- ribcage-23233
- 2))))
- (vector-set!
- ribcage-23233
- 2
- update-23481))
- (let ((update-23483
- (cons label-23428
- (vector-ref
- ribcage-23233
- 3))))
- (vector-set!
- ribcage-23233
- 3
- update-23483))
- (parse-23235
- (cdr body-23248)
- (cons id-23427 ids-23249)
- (cons label-23428 labels-23250)
- (cons id-23427 var-ids-23251)
- (cons var-23429 vars-23252)
- (cons (cons er-23256
- (wrap-4324
- e-23416
- w-23417
- mod-23419))
- vals-23253)
- (cons (cons 'lexical var-23429)
- bindings-23254)))))
- (if (if (eqv? type-23413 'define-syntax-form)
+ (begin
+ (let ((update-27333
+ (cons (vector-ref id-27322 1)
+ (vector-ref
+ ribcage-27158
+ 1))))
+ (vector-set!
+ ribcage-27158
+ 1
+ update-27333))
+ (let ((update-27445
+ (cons (car (vector-ref
+ id-27322
+ 2))
+ (vector-ref
+ ribcage-27158
+ 2))))
+ (vector-set!
+ ribcage-27158
+ 2
+ update-27445))
+ (let ((update-27460
+ (cons label-27323
+ (vector-ref
+ ribcage-27158
+ 3))))
+ (vector-set!
+ ribcage-27158
+ 3
+ update-27460)))
+ (parse-27160
+ (cdr body-27268)
+ (cons id-27322 ids-27269)
+ (cons label-27323 labels-27270)
+ (cons id-27322 var-ids-27271)
+ (cons var-27324 vars-27272)
+ (cons (cons er-27276
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ e-27311
+ (if (if (vector? e-27311)
+ (if (= (vector-length
+ e-27311)
+ 4)
+ (eq? (vector-ref
+ e-27311
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-27526
+ (vector-ref
+ e-27311
+ 1))
+ (wrap-27527
+ (let ((w2-27537
+ (vector-ref
+ e-27311
+ 2)))
+ (let ((m1-27538
+ (car w-27312))
+ (s1-27539
+ (cdr w-27312)))
+ (if (null? m1-27538)
+ (if (null? s1-27539)
+ w2-27537
+ (cons (car w2-27537)
+ (let ((m2-27556
+ (cdr w2-27537)))
+ (if (null? m2-27556)
+ s1-27539
+ (append
+ s1-27539
+ m2-27556)))))
+ (cons (let ((m2-27564
+ (car w2-27537)))
+ (if (null? m2-27564)
+ m1-27538
+ (append
+ m1-27538
+ m2-27564)))
+ (let ((m2-27572
+ (cdr w2-27537)))
+ (if (null? m2-27572)
+ s1-27539
+ (append
+ s1-27539
+ m2-27572))))))))
+ (module-27528
+ (vector-ref
+ e-27311
+ 3)))
+ (vector
+ 'syntax-object
+ expression-27526
+ wrap-27527
+ module-27528))
+ (if (null? e-27311)
+ e-27311
+ (vector
+ 'syntax-object
+ e-27311
+ w-27312
+ mod-27314)))))
+ vals-27273)
+ (cons (cons 'lexical var-27324)
+ bindings-27274)))))
+ (if (if (eqv? type-27308 'define-syntax-form)
#t
- (eqv? type-23413
+ (eqv? type-27308
'define-syntax-parameter-form))
- (let ((id-23525
- (wrap-4324
- value-23414
- w-23417
- mod-23419))
- (label-23526
+ (let ((id-27606
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ value-27309
+ (if (if (vector? value-27309)
+ (if (= (vector-length
+ value-27309)
+ 4)
+ (eq? (vector-ref
+ value-27309
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-27650
+ (vector-ref
+ value-27309
+ 1))
+ (wrap-27651
+ (let ((w2-27661
+ (vector-ref
+ value-27309
+ 2)))
+ (let ((m1-27662
+ (car w-27312))
+ (s1-27663
+ (cdr w-27312)))
+ (if (null? m1-27662)
+ (if (null? s1-27663)
+ w2-27661
+ (cons (car w2-27661)
+ (let ((m2-27680
+ (cdr w2-27661)))
+ (if (null? m2-27680)
+ s1-27663
+ (append
+ s1-27663
+ m2-27680)))))
+ (cons (let ((m2-27688
+ (car w2-27661)))
+ (if (null? m2-27688)
+ m1-27662
+ (append
+ m1-27662
+ m2-27688)))
+ (let ((m2-27696
+ (cdr w2-27661)))
+ (if (null? m2-27696)
+ s1-27663
+ (append
+ s1-27663
+ m2-27696))))))))
+ (module-27652
+ (vector-ref
+ value-27309
+ 3)))
+ (vector
+ 'syntax-object
+ expression-27650
+ wrap-27651
+ module-27652))
+ (if (null? value-27309)
+ value-27309
+ (vector
+ 'syntax-object
+ value-27309
+ w-27312
+ mod-27314)))))
+ (label-27607
(string-append
"l-"
- (session-id-4256)
+ (session-id-4308)
(symbol->string (gensym "-")))))
(begin
- (let ((update-23576
- (cons (vector-ref id-23525 1)
- (vector-ref
- ribcage-23233
- 1))))
- (vector-set!
- ribcage-23233
- 1
- update-23576))
- (let ((update-23578
- (cons (car (vector-ref
- id-23525
- 2))
- (vector-ref
- ribcage-23233
- 2))))
- (vector-set!
- ribcage-23233
- 2
- update-23578))
- (let ((update-23580
- (cons label-23526
- (vector-ref
- ribcage-23233
- 3))))
- (vector-set!
- ribcage-23233
- 3
- update-23580))
- (parse-23235
- (cdr body-23248)
- (cons id-23525 ids-23249)
- (cons label-23526 labels-23250)
- var-ids-23251
- vars-23252
- vals-23253
- (cons (cons 'macro
- (cons er-23256
- (wrap-4324
- e-23416
- w-23417
- mod-23419)))
- bindings-23254))))
- (if (eqv? type-23413 'begin-form)
- (let ((tmp-23591
+ (begin
+ (let ((update-27616
+ (cons (vector-ref id-27606 1)
+ (vector-ref
+ ribcage-27158
+ 1))))
+ (vector-set!
+ ribcage-27158
+ 1
+ update-27616))
+ (let ((update-27728
+ (cons (car (vector-ref
+ id-27606
+ 2))
+ (vector-ref
+ ribcage-27158
+ 2))))
+ (vector-set!
+ ribcage-27158
+ 2
+ update-27728))
+ (let ((update-27743
+ (cons label-27607
+ (vector-ref
+ ribcage-27158
+ 3))))
+ (vector-set!
+ ribcage-27158
+ 3
+ update-27743)))
+ (parse-27160
+ (cdr body-27268)
+ (cons id-27606 ids-27269)
+ (cons label-27607 labels-27270)
+ var-ids-27271
+ vars-27272
+ vals-27273
+ (cons (cons (if (eq? type-27308
+ 'define-syntax-parameter-form)
+ 'syntax-parameter
+ 'macro)
+ (cons er-27276
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ e-27311
+ (if (if (vector?
+ e-27311)
+ (if (= (vector-length
+ e-27311)
+ 4)
+ (eq? (vector-ref
+ e-27311
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-27782
+ (vector-ref
+ e-27311
+ 1))
+ (wrap-27783
+ (let ((w2-27793
+ (vector-ref
+ e-27311
+ 2)))
+ (let ((m1-27794
+ (car w-27312))
+ (s1-27795
+ (cdr w-27312)))
+ (if (null? m1-27794)
+ (if (null? s1-27795)
+ w2-27793
+ (cons (car w2-27793)
+ (let ((m2-27812
+ (cdr w2-27793)))
+ (if (null? m2-27812)
+ s1-27795
+ (append
+ s1-27795
+ m2-27812)))))
+ (cons (let ((m2-27820
+ (car w2-27793)))
+ (if (null? m2-27820)
+ m1-27794
+ (append
+ m1-27794
+ m2-27820)))
+ (let ((m2-27828
+ (cdr w2-27793)))
+ (if (null? m2-27828)
+ s1-27795
+ (append
+ s1-27795
+ m2-27828))))))))
+ (module-27784
+ (vector-ref
+ e-27311
+ 3)))
+ (vector
+ 'syntax-object
+ expression-27782
+ wrap-27783
+ module-27784))
+ (if (null? e-27311)
+ e-27311
+ (vector
+ 'syntax-object
+ e-27311
+ w-27312
+ mod-27314))))))
+ bindings-27274))))
+ (if (eqv? type-27308 'begin-form)
+ (let ((tmp-27858
($sc-dispatch
- e-23416
+ e-27311
'(_ . each-any))))
- (if tmp-23591
+ (if tmp-27858
(@apply
- (lambda (e1-23595)
- (parse-23235
+ (lambda (e1-27862)
+ (parse-27160
(letrec*
- ((f-23596
- (lambda (forms-23659)
- (if (null? forms-23659)
- (cdr body-23248)
- (cons (cons er-23256
- (wrap-4324
- (car forms-23659)
- w-23417
- mod-23419))
- (f-23596
- (cdr forms-23659)))))))
- (f-23596 e1-23595))
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254))
- tmp-23591)
+ ((f-27863
+ (lambda (forms-28064)
+ (if (null? forms-28064)
+ (cdr body-27268)
+ (cons (cons er-27276
+ (let ((x-28068
+ (car forms-28064)))
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ x-28068
+ (if (if (vector?
+ x-28068)
+ (if (= (vector-length
+ x-28068)
+ 4)
+ (eq? (vector-ref
+ x-28068
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-28086
+ (vector-ref
+ x-28068
+ 1))
+ (wrap-28087
+ (let ((w2-28095
+ (vector-ref
+ x-28068
+ 2)))
+ (let ((m1-28096
+ (car w-27312))
+ (s1-28097
+ (cdr w-27312)))
+ (if (null? m1-28096)
+ (if (null? s1-28097)
+ w2-28095
+ (cons (car w2-28095)
+ (let ((m2-28112
+ (cdr w2-28095)))
+ (if (null? m2-28112)
+ s1-28097
+ (append
+ s1-28097
+ m2-28112)))))
+ (cons (let ((m2-28120
+ (car w2-28095)))
+ (if (null? m2-28120)
+ m1-28096
+ (append
+ m1-28096
+ m2-28120)))
+ (let ((m2-28128
+ (cdr w2-28095)))
+ (if (null? m2-28128)
+ s1-28097
+ (append
+ s1-28097
+ m2-28128))))))))
+ (module-28088
+ (vector-ref
+ x-28068
+ 3)))
+ (vector
+ 'syntax-object
+ expression-28086
+ wrap-28087
+ module-28088))
+ (if (null? x-28068)
+ x-28068
+ (vector
+ 'syntax-object
+ x-28068
+ w-27312
+ mod-27314))))))
+ (f-27863
+ (cdr forms-28064)))))))
+ (f-27863 e1-27862))
+ ids-27269
+ labels-27270
+ var-ids-27271
+ vars-27272
+ vals-27273
+ bindings-27274))
+ tmp-27858)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-23416)))
- (if (eqv? type-23413 'local-syntax-form)
- (expand-local-syntax-4336
- value-23414
- e-23416
- er-23256
- w-23417
- s-23418
- mod-23419
- (lambda (forms-23676
- er-23677
- w-23678
- s-23679
- mod-23680)
- (parse-23235
+ e-27311)))
+ (if (eqv? type-27308 'local-syntax-form)
+ (expand-local-syntax-4388
+ value-27309
+ e-27311
+ er-27276
+ w-27312
+ s-27313
+ mod-27314
+ (lambda (forms-28157
+ er-28158
+ w-28159
+ s-28160
+ mod-28161)
+ (parse-27160
(letrec*
- ((f-23681
- (lambda (forms-23744)
- (if (null? forms-23744)
- (cdr body-23248)
- (cons (cons er-23677
- (wrap-4324
- (car forms-23744)
- w-23678
- mod-23680))
- (f-23681
- (cdr forms-23744)))))))
- (f-23681 forms-23676))
- ids-23249
- labels-23250
- var-ids-23251
- vars-23252
- vals-23253
- bindings-23254)))
- (if (null? ids-23249)
- (build-sequence-4276
+ ((f-28162
+ (lambda (forms-28363)
+ (if (null? forms-28363)
+ (cdr body-27268)
+ (cons (cons er-28158
+ (let ((x-28367
+ (car forms-28363)))
+ (if (if (null? (car w-28159))
+ (null? (cdr w-28159))
+ #f)
+ x-28367
+ (if (if (vector?
+ x-28367)
+ (if (= (vector-length
+ x-28367)
+ 4)
+ (eq? (vector-ref
+ x-28367
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-28385
+ (vector-ref
+ x-28367
+ 1))
+ (wrap-28386
+ (let ((w2-28394
+ (vector-ref
+ x-28367
+ 2)))
+ (let ((m1-28395
+ (car w-28159))
+ (s1-28396
+ (cdr w-28159)))
+ (if (null? m1-28395)
+ (if (null? s1-28396)
+ w2-28394
+ (cons (car w2-28394)
+ (let ((m2-28411
+ (cdr w2-28394)))
+ (if (null? m2-28411)
+ s1-28396
+ (append
+ s1-28396
+ m2-28411)))))
+ (cons (let ((m2-28419
+ (car w2-28394)))
+ (if (null? m2-28419)
+ m1-28395
+ (append
+ m1-28395
+ m2-28419)))
+ (let ((m2-28427
+ (cdr w2-28394)))
+ (if (null? m2-28427)
+ s1-28396
+ (append
+ s1-28396
+ m2-28427))))))))
+ (module-28387
+ (vector-ref
+ x-28367
+ 3)))
+ (vector
+ 'syntax-object
+ expression-28385
+ wrap-28386
+ module-28387))
+ (if (null? x-28367)
+ x-28367
+ (vector
+ 'syntax-object
+ x-28367
+ w-28159
+ mod-28161))))))
+ (f-28162
+ (cdr forms-28363)))))))
+ (f-28162 forms-28157))
+ ids-27269
+ labels-27270
+ var-ids-27271
+ vars-27272
+ vals-27273
+ bindings-27274)))
+ (if (null? ids-27269)
+ (build-sequence-4329
#f
- (map (lambda (x-23809)
- (let ((e-23813 (cdr x-23809))
- (r-23814 (car x-23809)))
+ (map (lambda (x-28620)
+ (let ((e-28624 (cdr x-28620))
+ (r-28625 (car x-28620)))
(call-with-values
(lambda ()
- (syntax-type-4330
- e-23813
- r-23814
+ (syntax-type-4382
+ e-28624
+ r-28625
'(())
- (source-annotation-4288
- e-23813)
+ (let ((props-28632
+ (source-properties
+ (if (if (vector?
+ e-28624)
+ (if (= (vector-length
+ e-28624)
+ 4)
+ (eq? (vector-ref
+ e-28624
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-28624
+ 1)
+ e-28624))))
+ (if (pair? props-28632)
+ props-28632
+ #f))
#f
- mod-23419
+ mod-27314
#f))
- (lambda (type-23818
- value-23819
- form-23820
- e-23821
- w-23822
- s-23823
- mod-23824)
- (expand-expr-4332
- type-23818
- value-23819
- form-23820
- e-23821
- r-23814
- w-23822
- s-23823
- mod-23824)))))
- (cons (cons er-23256
- (wrap-4324
- (begin
- (if (if s-23418
- (supports-source-properties?
- e-23416)
+ (lambda (type-28655
+ value-28656
+ form-28657
+ e-28658
+ w-28659
+ s-28660
+ mod-28661)
+ (expand-expr-4384
+ type-28655
+ value-28656
+ form-28657
+ e-28658
+ r-28625
+ w-28659
+ s-28660
+ mod-28661)))))
+ (cons (cons er-27276
+ (let ((x-28672
+ (begin
+ (if (if s-27313
+ (supports-source-properties?
+ e-27311)
+ #f)
+ (set-source-properties!
+ e-27311
+ s-27313))
+ e-27311)))
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ x-28672
+ (if (if (vector?
+ x-28672)
+ (if (= (vector-length
+ x-28672)
+ 4)
+ (eq? (vector-ref
+ x-28672
+ 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- e-23416
- s-23418))
- e-23416)
- w-23417
- mod-23419))
- (cdr body-23248))))
+ (let ((expression-28704
+ (vector-ref
+ x-28672
+ 1))
+ (wrap-28705
+ (let ((w2-28713
+ (vector-ref
+ x-28672
+ 2)))
+ (let ((m1-28714
+ (car w-27312))
+ (s1-28715
+ (cdr w-27312)))
+ (if (null? m1-28714)
+ (if (null? s1-28715)
+ w2-28713
+ (cons (car w2-28713)
+ (let ((m2-28730
+ (cdr w2-28713)))
+ (if (null? m2-28730)
+ s1-28715
+ (append
+ s1-28715
+ m2-28730)))))
+ (cons (let ((m2-28738
+ (car w2-28713)))
+ (if (null? m2-28738)
+ m1-28714
+ (append
+ m1-28714
+ m2-28738)))
+ (let ((m2-28746
+ (cdr w2-28713)))
+ (if (null? m2-28746)
+ s1-28715
+ (append
+ s1-28715
+ m2-28746))))))))
+ (module-28706
+ (vector-ref
+ x-28672
+ 3)))
+ (vector
+ 'syntax-object
+ expression-28704
+ wrap-28705
+ module-28706))
+ (if (null? x-28672)
+ x-28672
+ (vector
+ 'syntax-object
+ x-28672
+ w-27312
+ mod-27314))))))
+ (cdr body-27268))))
(begin
- (if (not (valid-bound-ids?-4321
- ids-23249))
+ (if (not (valid-bound-ids?-4373
+ ids-27269))
(syntax-violation
#f
"invalid or duplicate identifier in definition"
- outer-form-23228))
+ outer-form-27153))
(letrec*
- ((loop-23925
- (lambda (bs-23928
- er-cache-23929
- r-cache-23930)
- (if (not (null? bs-23928))
- (let ((b-23931
- (car bs-23928)))
- (if (eq? (car b-23931)
- 'macro)
- (let ((er-23933
- (car (cdr b-23931))))
- (let ((r-cache-23934
- (if (eq? er-23933
- er-cache-23929)
- r-cache-23930
- (macros-only-env-4291
- er-23933))))
+ ((loop-28845
+ (lambda (bs-28848
+ er-cache-28849
+ r-cache-28850)
+ (if (not (null? bs-28848))
+ (let ((b-28851
+ (car bs-28848)))
+ (if (let ((t-28854
+ (car b-28851)))
+ (if (eq? t-28854
+ 'macro)
+ #t
+ (eq? t-28854
+ 'syntax-parameter)))
+ (let ((er-28856
+ (car (cdr b-28851))))
+ (let ((r-cache-28857
+ (if (eq? er-28856
+ er-cache-28849)
+ r-cache-28850
+ (macros-only-env-4344
+ er-28856))))
(begin
(set-cdr!
- b-23931
- (eval-local-transformer-4337
- (expand-4331
- (cdr (cdr b-23931))
- r-cache-23934
- '(())
- mod-23419)
- mod-23419))
- (loop-23925
- (cdr bs-23928)
- er-23933
- r-cache-23934))))
- (loop-23925
- (cdr bs-23928)
- er-cache-23929
- r-cache-23930)))))))
- (loop-23925 bindings-23254 #f #f))
+ b-28851
+ (eval-local-transformer-4389
+ (let ((e-28906
+ (cdr (cdr b-28851))))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-28906
+ r-cache-28857
+ '(())
+ (let ((props-28916
+ (source-properties
+ (if (if (vector?
+ e-28906)
+ (if (= (vector-length
+ e-28906)
+ 4)
+ (eq? (vector-ref
+ e-28906
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-28906
+ 1)
+ e-28906))))
+ (if (pair? props-28916)
+ props-28916
+ #f))
+ #f
+ mod-27314
+ #f))
+ (lambda (type-28939
+ value-28940
+ form-28941
+ e-28942
+ w-28943
+ s-28944
+ mod-28945)
+ (expand-expr-4384
+ type-28939
+ value-28940
+ form-28941
+ e-28942
+ r-cache-28857
+ w-28943
+ s-28944
+ mod-28945))))
+ mod-27314))
+ (if (eq? (car b-28851)
+ 'syntax-parameter)
+ (set-cdr!
+ b-28851
+ (list (cdr b-28851))))
+ (loop-28845
+ (cdr bs-28848)
+ er-28856
+ r-cache-28857))))
+ (loop-28845
+ (cdr bs-28848)
+ er-cache-28849
+ r-cache-28850)))))))
+ (loop-28845 bindings-27274 #f #f))
(set-cdr!
- r-23232
- (extend-env-4289
- labels-23250
- bindings-23254
- (cdr r-23232)))
- (build-letrec-4279
+ r-27157
+ (extend-env-4342
+ labels-27270
+ bindings-27274
+ (cdr r-27157)))
+ (build-letrec-4332
#f
#t
(reverse
(map syntax->datum
- var-ids-23251))
- (reverse vars-23252)
- (map (lambda (x-24277)
- (let ((e-24281
- (cdr x-24277))
- (r-24282
- (car x-24277)))
+ var-ids-27271))
+ (reverse vars-27272)
+ (map (lambda (x-29360)
+ (let ((e-29364
+ (cdr x-29360))
+ (r-29365
+ (car x-29360)))
(call-with-values
(lambda ()
- (syntax-type-4330
- e-24281
- r-24282
+ (syntax-type-4382
+ e-29364
+ r-29365
'(())
- (source-annotation-4288
- e-24281)
+ (let ((props-29372
+ (source-properties
+ (if (if (vector?
+ e-29364)
+ (if (= (vector-length
+ e-29364)
+ 4)
+ (eq? (vector-ref
+ e-29364
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-29364
+ 1)
+ e-29364))))
+ (if (pair? props-29372)
+ props-29372
+ #f))
#f
- mod-23419
+ mod-27314
#f))
- (lambda (type-24286
- value-24287
- form-24288
- e-24289
- w-24290
- s-24291
- mod-24292)
- (expand-expr-4332
- type-24286
- value-24287
- form-24288
- e-24289
- r-24282
- w-24290
- s-24291
- mod-24292)))))
- (reverse vals-23253))
- (let ((exps-24298
- (map (lambda (x-24299)
- (let ((e-24302
- (cdr x-24299))
- (r-24303
- (car x-24299)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-24302
- r-24303
- '(())
- (source-annotation-4288
- e-24302)
- #f
- mod-23419
- #f))
- (lambda (type-24307
- value-24308
- form-24309
- e-24310
- w-24311
- s-24312
- mod-24313)
- (expand-expr-4332
- type-24307
- value-24308
- form-24309
- e-24310
- r-24303
- w-24311
- s-24312
- mod-24313)))))
- (cons (cons er-23256
- (wrap-4324
+ (lambda (type-29395
+ value-29396
+ form-29397
+ e-29398
+ w-29399
+ s-29400
+ mod-29401)
+ (expand-expr-4384
+ type-29395
+ value-29396
+ form-29397
+ e-29398
+ r-29365
+ w-29399
+ s-29400
+ mod-29401)))))
+ (reverse vals-27273))
+ (build-sequence-4329
+ #f
+ (map (lambda (x-29581)
+ (let ((e-29585
+ (cdr x-29581))
+ (r-29586
+ (car x-29581)))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-29585
+ r-29586
+ '(())
+ (let ((props-29593
+ (source-properties
+ (if (if (vector?
+ e-29585)
+ (if (= (vector-length
+ e-29585)
+ 4)
+ (eq? (vector-ref
+ e-29585
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-29585
+ 1)
+ e-29585))))
+ (if (pair? props-29593)
+ props-29593
+ #f))
+ #f
+ mod-27314
+ #f))
+ (lambda (type-29616
+ value-29617
+ form-29618
+ e-29619
+ w-29620
+ s-29621
+ mod-29622)
+ (expand-expr-4384
+ type-29616
+ value-29617
+ form-29618
+ e-29619
+ r-29586
+ w-29620
+ s-29621
+ mod-29622)))))
+ (cons (cons er-27276
+ (let ((x-29633
(begin
- (if (if s-23418
+ (if (if s-27313
(supports-source-properties?
- e-23416)
+ e-27311)
#f)
(set-source-properties!
- e-23416
- s-23418))
- e-23416)
- w-23417
- mod-23419))
- (cdr body-23248)))))
- (if (null? (cdr exps-24298))
- (car exps-24298)
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 12)
- #f
- exps-24298)))))))))))))))))
- (parse-23235
- (map (lambda (x-23238)
- (cons r-23232
- (wrap-4324 x-23238 w-23234 mod-23231)))
- body-23227)
+ e-27311
+ s-27313))
+ e-27311)))
+ (if (if (null? (car w-27312))
+ (null? (cdr w-27312))
+ #f)
+ x-29633
+ (if (if (vector?
+ x-29633)
+ (if (= (vector-length
+ x-29633)
+ 4)
+ (eq? (vector-ref
+ x-29633
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-29665
+ (vector-ref
+ x-29633
+ 1))
+ (wrap-29666
+ (let ((w2-29674
+ (vector-ref
+ x-29633
+ 2)))
+ (let ((m1-29675
+ (car w-27312))
+ (s1-29676
+ (cdr w-27312)))
+ (if (null? m1-29675)
+ (if (null? s1-29676)
+ w2-29674
+ (cons (car w2-29674)
+ (let ((m2-29691
+ (cdr w2-29674)))
+ (if (null? m2-29691)
+ s1-29676
+ (append
+ s1-29676
+ m2-29691)))))
+ (cons (let ((m2-29699
+ (car w2-29674)))
+ (if (null? m2-29699)
+ m1-29675
+ (append
+ m1-29675
+ m2-29699)))
+ (let ((m2-29707
+ (cdr w2-29674)))
+ (if (null? m2-29707)
+ s1-29676
+ (append
+ s1-29676
+ m2-29707))))))))
+ (module-29667
+ (vector-ref
+ x-29633
+ 3)))
+ (vector
+ 'syntax-object
+ expression-29665
+ wrap-29666
+ module-29667))
+ (if (null? x-29633)
+ x-29633
+ (vector
+ 'syntax-object
+ x-29633
+ w-27312
+ mod-27314))))))
+ (cdr body-27268))))))))))))))))))
+ (parse-27160
+ (map (lambda (x-27163)
+ (cons r-27157
+ (if (if (null? (car w-27159))
+ (null? (cdr w-27159))
+ #f)
+ x-27163
+ (if (if (vector? x-27163)
+ (if (= (vector-length x-27163) 4)
+ (eq? (vector-ref x-27163 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-27199
+ (vector-ref x-27163 1))
+ (wrap-27200
+ (let ((w2-27210
+ (vector-ref x-27163 2)))
+ (let ((m1-27211 (car w-27159))
+ (s1-27212 (cdr w-27159)))
+ (if (null? m1-27211)
+ (if (null? s1-27212)
+ w2-27210
+ (cons (car w2-27210)
+ (let ((m2-27229
+ (cdr w2-27210)))
+ (if (null? m2-27229)
+ s1-27212
+ (append
+ s1-27212
+ m2-27229)))))
+ (cons (let ((m2-27237
+ (car w2-27210)))
+ (if (null? m2-27237)
+ m1-27211
+ (append
+ m1-27211
+ m2-27237)))
+ (let ((m2-27245
+ (cdr w2-27210)))
+ (if (null? m2-27245)
+ s1-27212
+ (append
+ s1-27212
+ m2-27245))))))))
+ (module-27201
+ (vector-ref x-27163 3)))
+ (vector
+ 'syntax-object
+ expression-27199
+ wrap-27200
+ module-27201))
+ (if (null? x-27163)
+ x-27163
+ (vector
+ 'syntax-object
+ x-27163
+ w-27159
+ mod-27156))))))
+ body-27152)
'()
'()
'()
'()
'()
'())))))))
- (expand-local-syntax-4336
- (lambda (rec?-24339
- e-24340
- r-24341
- w-24342
- s-24343
- mod-24344
- k-24345)
- (let ((tmp-24347
+ (expand-local-syntax-4388
+ (lambda (rec?-29722
+ e-29723
+ r-29724
+ w-29725
+ s-29726
+ mod-29727
+ k-29728)
+ (let ((tmp-29730
($sc-dispatch
- e-24340
+ e-29723
'(_ #(each (any any)) any . each-any))))
- (if tmp-24347
+ (if tmp-29730
(@apply
- (lambda (id-24351 val-24352 e1-24353 e2-24354)
- (if (not (valid-bound-ids?-4321 id-24351))
+ (lambda (id-29734 val-29735 e1-29736 e2-29737)
+ (if (not (valid-bound-ids?-4373 id-29734))
(syntax-violation
#f
"duplicate bound keyword"
- e-24340)
- (let ((labels-24444 (gen-labels-4298 id-24351)))
- (let ((new-w-24445
- (make-binding-wrap-4309
- id-24351
- labels-24444
- w-24342)))
- (k-24345
- (cons e1-24353 e2-24354)
- (extend-env-4289
- labels-24444
- (let ((trans-r-24481
- (macros-only-env-4291 r-24341)))
+ e-29723)
+ (let ((labels-29834 (gen-labels-4350 id-29734)))
+ (let ((new-w-29835
+ (make-binding-wrap-4361
+ id-29734
+ labels-29834
+ w-29725)))
+ (k-29728
+ (cons e1-29736 e2-29737)
+ (extend-env-4342
+ labels-29834
+ (let ((trans-r-29873
+ (macros-only-env-4344 r-29724)))
(begin
- (if rec?-24339 new-w-24445 w-24342)
- (map (lambda (x-24482)
+ (if rec?-29722 new-w-29835 w-29725)
+ (map (lambda (x-29874)
(cons 'macro
- (eval-local-transformer-4337
- (expand-4331
- x-24482
- trans-r-24481
- (values
- (if rec?-24339
- new-w-24445
- w-24342))
- mod-24344)
- mod-24344)))
- val-24352)))
- r-24341)
- new-w-24445
- s-24343
- mod-24344)))))
- tmp-24347)
+ (eval-local-transformer-4389
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ x-29874
+ trans-r-29873
+ (values
+ (if rec?-29722
+ new-w-29835
+ w-29725))
+ (let ((props-29940
+ (source-properties
+ (if (if (vector?
+ x-29874)
+ (if (= (vector-length
+ x-29874)
+ 4)
+ (eq? (vector-ref
+ x-29874
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ x-29874
+ 1)
+ x-29874))))
+ (if (pair? props-29940)
+ props-29940
+ #f))
+ #f
+ mod-29727
+ #f))
+ (lambda (type-29973
+ value-29974
+ form-29975
+ e-29976
+ w-29977
+ s-29978
+ mod-29979)
+ (expand-expr-4384
+ type-29973
+ value-29974
+ form-29975
+ e-29976
+ trans-r-29873
+ w-29977
+ s-29978
+ mod-29979)))
+ mod-29727)))
+ val-29735)))
+ r-29724)
+ new-w-29835
+ s-29726
+ mod-29727)))))
+ tmp-29730)
(syntax-violation
#f
"bad local syntax definition"
- (wrap-4324
- (begin
- (if (if s-24343
- (supports-source-properties? e-24340)
+ (let ((x-30161
+ (begin
+ (if (if s-29726
+ (supports-source-properties? e-29723)
+ #f)
+ (set-source-properties! e-29723 s-29726))
+ e-29723)))
+ (if (if (null? (car w-29725))
+ (null? (cdr w-29725))
+ #f)
+ x-30161
+ (if (if (vector? x-30161)
+ (if (= (vector-length x-30161) 4)
+ (eq? (vector-ref x-30161 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-24340 s-24343))
- e-24340)
- w-24342
- mod-24344))))))
- (eval-local-transformer-4337
- (lambda (expanded-24762 mod-24763)
- (let ((p-24764 (primitive-eval expanded-24762)))
- (if (procedure? p-24764)
- p-24764
- (syntax-violation
+ (let ((expression-30193 (vector-ref x-30161 1))
+ (wrap-30194
+ (let ((w2-30202 (vector-ref x-30161 2)))
+ (let ((m1-30203 (car w-29725))
+ (s1-30204 (cdr w-29725)))
+ (if (null? m1-30203)
+ (if (null? s1-30204)
+ w2-30202
+ (cons (car w2-30202)
+ (let ((m2-30219 (cdr w2-30202)))
+ (if (null? m2-30219)
+ s1-30204
+ (append s1-30204 m2-30219)))))
+ (cons (let ((m2-30227 (car w2-30202)))
+ (if (null? m2-30227)
+ m1-30203
+ (append m1-30203 m2-30227)))
+ (let ((m2-30235 (cdr w2-30202)))
+ (if (null? m2-30235)
+ s1-30204
+ (append s1-30204 m2-30235))))))))
+ (module-30195 (vector-ref x-30161 3)))
+ (vector
+ 'syntax-object
+ expression-30193
+ wrap-30194
+ module-30195))
+ (if (null? x-30161)
+ x-30161
+ (vector
+ 'syntax-object
+ x-30161
+ w-29725
+ mod-29727))))))))))
+ (eval-local-transformer-4389
+ (lambda (expanded-30253 mod-30254)
+ (let ((p-30255 (primitive-eval expanded-30253)))
+ (if (procedure? p-30255)
+ p-30255
+ (syntax-violation
#f
"nonprocedure transformer"
- p-24764)))))
- (ellipsis?-4339
- (lambda (x-5000)
- (if (if (if (vector? x-5000)
- (if (= (vector-length x-5000) 4)
- (eq? (vector-ref x-5000 0) 'syntax-object)
+ p-30255)))))
+ (ellipsis?-4391
+ (lambda (x-5924)
+ (if (if (if (vector? x-5924)
+ (if (= (vector-length x-5924) 4)
+ (eq? (vector-ref x-5924 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-5000 1))
+ (symbol? (vector-ref x-5924 1))
#f)
- (if (eq? (if (if (vector? x-5000)
- (if (= (vector-length x-5000) 4)
- (eq? (vector-ref x-5000 0) 'syntax-object)
- #f)
- #f)
- (vector-ref x-5000 1)
- x-5000)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 x-5000 '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
+ (free-id=?-4371
+ x-5924
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-2325"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
#f)))
- (lambda-formals-4340
- (lambda (orig-args-24769)
+ (lambda-formals-4392
+ (lambda (orig-args-30260)
(letrec*
- ((req-24770
- (lambda (args-24774 rreq-24775)
- (let ((tmp-24777 ($sc-dispatch args-24774 '())))
- (if tmp-24777
+ ((req-30261
+ (lambda (args-30265 rreq-30266)
+ (let ((tmp-30268 ($sc-dispatch args-30265 '())))
+ (if tmp-30268
(@apply
- (lambda () (check-24771 (reverse rreq-24775) #f))
- tmp-24777)
- (let ((tmp-24900
- ($sc-dispatch args-24774 '(any . any))))
- (if (if tmp-24900
+ (lambda () (check-30262 (reverse rreq-30266) #f))
+ tmp-30268)
+ (let ((tmp-30384
+ ($sc-dispatch args-30265 '(any . any))))
+ (if (if tmp-30384
(@apply
- (lambda (a-24904 b-24905)
- (if (symbol? a-24904)
+ (lambda (a-30388 b-30389)
+ (if (symbol? a-30388)
#t
- (if (if (vector? a-24904)
- (if (= (vector-length a-24904) 4)
- (eq? (vector-ref a-24904 0)
+ (if (if (vector? a-30388)
+ (if (= (vector-length a-30388) 4)
+ (eq? (vector-ref a-30388 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-24904 1))
+ (symbol? (vector-ref a-30388 1))
#f)))
- tmp-24900)
+ tmp-30384)
#f)
(@apply
- (lambda (a-24932 b-24933)
- (req-24770 b-24933 (cons a-24932 rreq-24775)))
- tmp-24900)
- (let ((tmp-24934 (list args-24774)))
+ (lambda (a-30416 b-30417)
+ (req-30261 b-30417 (cons a-30416 rreq-30266)))
+ tmp-30384)
+ (let ((tmp-30418 (list args-30265)))
(if (@apply
- (lambda (r-24936)
- (if (symbol? r-24936)
+ (lambda (r-30420)
+ (if (symbol? r-30420)
#t
- (if (if (vector? r-24936)
- (if (= (vector-length r-24936) 4)
- (eq? (vector-ref r-24936 0)
+ (if (if (vector? r-30420)
+ (if (= (vector-length r-30420) 4)
+ (eq? (vector-ref r-30420 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref r-24936 1))
+ (symbol? (vector-ref r-30420 1))
#f)))
- tmp-24934)
+ tmp-30418)
(@apply
- (lambda (r-24966)
- (check-24771 (reverse rreq-24775) r-24966))
- tmp-24934)
+ (lambda (r-30450)
+ (check-30262 (reverse rreq-30266) r-30450))
+ tmp-30418)
(syntax-violation
'lambda
"invalid argument list"
- orig-args-24769
- args-24774)))))))))
- (check-24771
- (lambda (req-25097 rest-25098)
- (if (distinct-bound-ids?-4322
- (if rest-25098
- (cons rest-25098 req-25097)
- req-25097))
- (values req-25097 #f rest-25098 #f)
+ orig-args-30260
+ args-30265)))))))))
+ (check-30262
+ (lambda (req-30574 rest-30575)
+ (if (distinct-bound-ids?-4374
+ (if rest-30575
+ (cons rest-30575 req-30574)
+ req-30574))
+ (values req-30574 #f rest-30575 #f)
(syntax-violation
'lambda
"duplicate identifier in argument list"
- orig-args-24769)))))
- (req-24770 orig-args-24769 '()))))
- (expand-simple-lambda-4341
- (lambda (e-25214
- r-25215
- w-25216
- s-25217
- mod-25218
- req-25219
- rest-25220
- meta-25221
- body-25222)
- (let ((ids-25223
- (if rest-25220
- (append req-25219 (list rest-25220))
- req-25219)))
- (let ((vars-25224 (map gen-var-4345 ids-25223)))
- (let ((labels-25225 (gen-labels-4298 ids-25223)))
- (build-simple-lambda-4271
- s-25217
- (map syntax->datum req-25219)
- (if rest-25220 (syntax->datum rest-25220) #f)
- vars-25224
- meta-25221
- (expand-body-4335
- body-25222
- (wrap-4324
- (begin
- (if (if s-25217
- (supports-source-properties? e-25214)
+ orig-args-30260)))))
+ (req-30261 orig-args-30260 '()))))
+ (expand-simple-lambda-4393
+ (lambda (e-30684
+ r-30685
+ w-30686
+ s-30687
+ mod-30688
+ req-30689
+ rest-30690
+ meta-30691
+ body-30692)
+ (let ((ids-30693
+ (if rest-30690
+ (append req-30689 (list rest-30690))
+ req-30689)))
+ (let ((vars-30694 (map gen-var-4397 ids-30693)))
+ (let ((labels-30695 (gen-labels-4350 ids-30693)))
+ (build-simple-lambda-4323
+ s-30687
+ (map syntax->datum req-30689)
+ (if rest-30690 (syntax->datum rest-30690) #f)
+ vars-30694
+ meta-30691
+ (expand-body-4387
+ body-30692
+ (let ((x-30878
+ (begin
+ (if (if s-30687
+ (supports-source-properties? e-30684)
+ #f)
+ (set-source-properties! e-30684 s-30687))
+ e-30684)))
+ (if (if (null? (car w-30686))
+ (null? (cdr w-30686))
+ #f)
+ x-30878
+ (if (if (vector? x-30878)
+ (if (= (vector-length x-30878) 4)
+ (eq? (vector-ref x-30878 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-25214 s-25217))
- e-25214)
- w-25216
- mod-25218)
- (extend-var-env-4290
- labels-25225
- vars-25224
- r-25215)
- (make-binding-wrap-4309
- ids-25223
- labels-25225
- w-25216)
- mod-25218)))))))
- (lambda*-formals-4342
- (lambda (orig-args-25505)
+ (let ((expression-30910 (vector-ref x-30878 1))
+ (wrap-30911
+ (let ((w2-30919 (vector-ref x-30878 2)))
+ (let ((m1-30920 (car w-30686))
+ (s1-30921 (cdr w-30686)))
+ (if (null? m1-30920)
+ (if (null? s1-30921)
+ w2-30919
+ (cons (car w2-30919)
+ (let ((m2-30936 (cdr w2-30919)))
+ (if (null? m2-30936)
+ s1-30921
+ (append
+ s1-30921
+ m2-30936)))))
+ (cons (let ((m2-30944 (car w2-30919)))
+ (if (null? m2-30944)
+ m1-30920
+ (append m1-30920 m2-30944)))
+ (let ((m2-30952 (cdr w2-30919)))
+ (if (null? m2-30952)
+ s1-30921
+ (append
+ s1-30921
+ m2-30952))))))))
+ (module-30912 (vector-ref x-30878 3)))
+ (vector
+ 'syntax-object
+ expression-30910
+ wrap-30911
+ module-30912))
+ (if (null? x-30878)
+ x-30878
+ (vector
+ 'syntax-object
+ x-30878
+ w-30686
+ mod-30688)))))
+ (extend-var-env-4343
+ labels-30695
+ vars-30694
+ r-30685)
+ (make-binding-wrap-4361
+ ids-30693
+ labels-30695
+ w-30686)
+ mod-30688)))))))
+ (lambda*-formals-4394
+ (lambda (orig-args-31161)
(letrec*
- ((req-25506
- (lambda (args-25513 rreq-25514)
- (let ((tmp-25516 ($sc-dispatch args-25513 '())))
- (if tmp-25516
+ ((req-31162
+ (lambda (args-31169 rreq-31170)
+ (let ((tmp-31172 ($sc-dispatch args-31169 '())))
+ (if tmp-31172
(@apply
(lambda ()
- (check-25510 (reverse rreq-25514) '() #f '()))
- tmp-25516)
- (let ((tmp-25522
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25522
+ (check-31166 (reverse rreq-31170) '() #f '()))
+ tmp-31172)
+ (let ((tmp-31291
+ ($sc-dispatch args-31169 '(any . any))))
+ (if (if tmp-31291
(@apply
- (lambda (a-25526 b-25527)
- (if (symbol? a-25526)
+ (lambda (a-31295 b-31296)
+ (if (symbol? a-31295)
#t
- (if (if (vector? a-25526)
- (if (= (vector-length a-25526) 4)
- (eq? (vector-ref a-25526 0)
+ (if (if (vector? a-31295)
+ (if (= (vector-length a-31295) 4)
+ (eq? (vector-ref a-31295 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-25526 1))
+ (symbol? (vector-ref a-31295 1))
#f)))
- tmp-25522)
+ tmp-31291)
#f)
(@apply
- (lambda (a-25554 b-25555)
- (req-25506 b-25555 (cons a-25554 rreq-25514)))
- tmp-25522)
- (let ((tmp-25556
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25556
+ (lambda (a-31323 b-31324)
+ (req-31162 b-31324 (cons a-31323 rreq-31170)))
+ tmp-31291)
+ (let ((tmp-31325
+ ($sc-dispatch args-31169 '(any . any))))
+ (if (if tmp-31325
(@apply
- (lambda (a-25560 b-25561)
- (eq? (syntax->datum a-25560) #:optional))
- tmp-25556)
+ (lambda (a-31329 b-31330)
+ (eq? (syntax->datum a-31329) #:optional))
+ tmp-31325)
#f)
(@apply
- (lambda (a-25562 b-25563)
- (opt-25507 b-25563 (reverse rreq-25514) '()))
- tmp-25556)
- (let ((tmp-25566
- ($sc-dispatch args-25513 '(any . any))))
- (if (if tmp-25566
+ (lambda (a-31331 b-31332)
+ (opt-31163 b-31332 (reverse rreq-31170) '()))
+ tmp-31325)
+ (let ((tmp-31335
+ ($sc-dispatch args-31169 '(any . any))))
+ (if (if tmp-31335
(@apply
- (lambda (a-25570 b-25571)
- (eq? (syntax->datum a-25570) #:key))
- tmp-25566)
+ (lambda (a-31339 b-31340)
+ (eq? (syntax->datum a-31339) #:key))
+ tmp-31335)
#f)
(@apply
- (lambda (a-25572 b-25573)
- (key-25508
- b-25573
- (reverse rreq-25514)
+ (lambda (a-31341 b-31342)
+ (key-31164
+ b-31342
+ (reverse rreq-31170)
'()
'()))
- tmp-25566)
- (let ((tmp-25576
- ($sc-dispatch args-25513 '(any any))))
- (if (if tmp-25576
+ tmp-31335)
+ (let ((tmp-31345
+ ($sc-dispatch args-31169 '(any any))))
+ (if (if tmp-31345
(@apply
- (lambda (a-25580 b-25581)
- (eq? (syntax->datum a-25580)
+ (lambda (a-31349 b-31350)
+ (eq? (syntax->datum a-31349)
#:rest))
- tmp-25576)
+ tmp-31345)
#f)
(@apply
- (lambda (a-25582 b-25583)
- (rest-25509
- b-25583
- (reverse rreq-25514)
+ (lambda (a-31351 b-31352)
+ (rest-31165
+ b-31352
+ (reverse rreq-31170)
'()
'()))
- tmp-25576)
- (let ((tmp-25586 (list args-25513)))
+ tmp-31345)
+ (let ((tmp-31355 (list args-31169)))
(if (@apply
- (lambda (r-25588)
- (if (symbol? r-25588)
+ (lambda (r-31357)
+ (if (symbol? r-31357)
#t
- (if (if (vector? r-25588)
+ (if (if (vector? r-31357)
(if (= (vector-length
- r-25588)
+ r-31357)
4)
(eq? (vector-ref
- r-25588
+ r-31357
0)
'syntax-object)
#f)
#f)
(symbol?
- (vector-ref r-25588 1))
+ (vector-ref r-31357 1))
#f)))
- tmp-25586)
+ tmp-31355)
(@apply
- (lambda (r-25618)
- (rest-25509
- r-25618
- (reverse rreq-25514)
+ (lambda (r-31387)
+ (rest-31165
+ r-31387
+ (reverse rreq-31170)
'()
'()))
- tmp-25586)
+ tmp-31355)
(syntax-violation
'lambda*
"invalid argument list"
- orig-args-25505
- args-25513)))))))))))))))
- (opt-25507
- (lambda (args-25637 req-25638 ropt-25639)
- (let ((tmp-25641 ($sc-dispatch args-25637 '())))
- (if tmp-25641
+ orig-args-31161
+ args-31169)))))))))))))))
+ (opt-31163
+ (lambda (args-31406 req-31407 ropt-31408)
+ (let ((tmp-31410 ($sc-dispatch args-31406 '())))
+ (if tmp-31410
(@apply
(lambda ()
- (check-25510
- req-25638
- (reverse ropt-25639)
+ (check-31166
+ req-31407
+ (reverse ropt-31408)
#f
'()))
- tmp-25641)
- (let ((tmp-25647
- ($sc-dispatch args-25637 '(any . any))))
- (if (if tmp-25647
+ tmp-31410)
+ (let ((tmp-31531
+ ($sc-dispatch args-31406 '(any . any))))
+ (if (if tmp-31531
(@apply
- (lambda (a-25651 b-25652)
- (if (symbol? a-25651)
+ (lambda (a-31535 b-31536)
+ (if (symbol? a-31535)
#t
- (if (if (vector? a-25651)
- (if (= (vector-length a-25651) 4)
- (eq? (vector-ref a-25651 0)
+ (if (if (vector? a-31535)
+ (if (= (vector-length a-31535) 4)
+ (eq? (vector-ref a-31535 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-25651 1))
+ (symbol? (vector-ref a-31535 1))
#f)))
- tmp-25647)
+ tmp-31531)
#f)
(@apply
- (lambda (a-25679 b-25680)
- (opt-25507
- b-25680
- req-25638
- (cons (cons a-25679
+ (lambda (a-31563 b-31564)
+ (opt-31163
+ b-31564
+ req-31407
+ (cons (cons a-31563
'(#(syntax-object
#f
((top)
#(ribcage
#(a b)
#((top) (top))
- #("l-*-2404" "l-*-2405"))
+ #("l-*-2462" "l-*-2463"))
#(ribcage () () ())
#(ribcage
#(args req ropt)
#((top) (top) (top))
- #("l-*-2394"
- "l-*-2395"
- "l-*-2396"))
+ #("l-*-2452"
+ "l-*-2453"
+ "l-*-2454"))
#(ribcage
(check rest key opt req)
((top)
(top)
(top)
(top))
- ("l-*-2340"
- "l-*-2338"
- "l-*-2336"
- "l-*-2334"
- "l-*-2332"))
+ ("l-*-2398"
+ "l-*-2396"
+ "l-*-2394"
+ "l-*-2392"
+ "l-*-2390"))
#(ribcage
#(orig-args)
#((top))
- #("l-*-2331"))
+ #("l-*-2389"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
define-expansion-accessors
define-expansion-constructors)
((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
(hygiene guile))))
- ropt-25639)))
- tmp-25647)
- (let ((tmp-25681
- ($sc-dispatch args-25637 '((any any) . any))))
- (if (if tmp-25681
+ ropt-31408)))
+ tmp-31531)
+ (let ((tmp-31565
+ ($sc-dispatch args-31406 '((any any) . any))))
+ (if (if tmp-31565
(@apply
- (lambda (a-25685 init-25686 b-25687)
- (if (symbol? a-25685)
+ (lambda (a-31569 init-31570 b-31571)
+ (if (symbol? a-31569)
#t
- (if (if (vector? a-25685)
- (if (= (vector-length a-25685) 4)
- (eq? (vector-ref a-25685 0)
+ (if (if (vector? a-31569)
+ (if (= (vector-length a-31569) 4)
+ (eq? (vector-ref a-31569 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-25685 1))
+ (symbol? (vector-ref a-31569 1))
#f)))
- tmp-25681)
+ tmp-31565)
#f)
(@apply
- (lambda (a-25714 init-25715 b-25716)
- (opt-25507
- b-25716
- req-25638
- (cons (list a-25714 init-25715) ropt-25639)))
- tmp-25681)
- (let ((tmp-25717
- ($sc-dispatch args-25637 '(any . any))))
- (if (if tmp-25717
+ (lambda (a-31598 init-31599 b-31600)
+ (opt-31163
+ b-31600
+ req-31407
+ (cons (list a-31598 init-31599) ropt-31408)))
+ tmp-31565)
+ (let ((tmp-31601
+ ($sc-dispatch args-31406 '(any . any))))
+ (if (if tmp-31601
(@apply
- (lambda (a-25721 b-25722)
- (eq? (syntax->datum a-25721) #:key))
- tmp-25717)
+ (lambda (a-31605 b-31606)
+ (eq? (syntax->datum a-31605) #:key))
+ tmp-31601)
#f)
(@apply
- (lambda (a-25723 b-25724)
- (key-25508
- b-25724
- req-25638
- (reverse ropt-25639)
+ (lambda (a-31607 b-31608)
+ (key-31164
+ b-31608
+ req-31407
+ (reverse ropt-31408)
'()))
- tmp-25717)
- (let ((tmp-25727
- ($sc-dispatch args-25637 '(any any))))
- (if (if tmp-25727
+ tmp-31601)
+ (let ((tmp-31611
+ ($sc-dispatch args-31406 '(any any))))
+ (if (if tmp-31611
(@apply
- (lambda (a-25731 b-25732)
- (eq? (syntax->datum a-25731)
+ (lambda (a-31615 b-31616)
+ (eq? (syntax->datum a-31615)
#:rest))
- tmp-25727)
+ tmp-31611)
#f)
(@apply
- (lambda (a-25733 b-25734)
- (rest-25509
- b-25734
- req-25638
- (reverse ropt-25639)
+ (lambda (a-31617 b-31618)
+ (rest-31165
+ b-31618
+ req-31407
+ (reverse ropt-31408)
'()))
- tmp-25727)
- (let ((tmp-25737 (list args-25637)))
+ tmp-31611)
+ (let ((tmp-31621 (list args-31406)))
(if (@apply
- (lambda (r-25739)
- (if (symbol? r-25739)
+ (lambda (r-31623)
+ (if (symbol? r-31623)
#t
- (if (if (vector? r-25739)
+ (if (if (vector? r-31623)
(if (= (vector-length
- r-25739)
+ r-31623)
4)
(eq? (vector-ref
- r-25739
+ r-31623
0)
'syntax-object)
#f)
#f)
(symbol?
- (vector-ref r-25739 1))
+ (vector-ref r-31623 1))
#f)))
- tmp-25737)
+ tmp-31621)
(@apply
- (lambda (r-25769)
- (rest-25509
- r-25769
- req-25638
- (reverse ropt-25639)
+ (lambda (r-31653)
+ (rest-31165
+ r-31653
+ req-31407
+ (reverse ropt-31408)
'()))
- tmp-25737)
+ tmp-31621)
(syntax-violation
'lambda*
"invalid optional argument list"
- orig-args-25505
- args-25637)))))))))))))))
- (key-25508
- (lambda (args-25788 req-25789 opt-25790 rkey-25791)
- (let ((tmp-25793 ($sc-dispatch args-25788 '())))
- (if tmp-25793
+ orig-args-31161
+ args-31406)))))))))))))))
+ (key-31164
+ (lambda (args-31672 req-31673 opt-31674 rkey-31675)
+ (let ((tmp-31677 ($sc-dispatch args-31672 '())))
+ (if tmp-31677
(@apply
(lambda ()
- (check-25510
- req-25789
- opt-25790
+ (check-31166
+ req-31673
+ opt-31674
#f
- (cons #f (reverse rkey-25791))))
- tmp-25793)
- (let ((tmp-25799
- ($sc-dispatch args-25788 '(any . any))))
- (if (if tmp-25799
+ (cons #f (reverse rkey-31675))))
+ tmp-31677)
+ (let ((tmp-31799
+ ($sc-dispatch args-31672 '(any . any))))
+ (if (if tmp-31799
(@apply
- (lambda (a-25803 b-25804)
- (if (symbol? a-25803)
+ (lambda (a-31803 b-31804)
+ (if (symbol? a-31803)
#t
- (if (if (vector? a-25803)
- (if (= (vector-length a-25803) 4)
- (eq? (vector-ref a-25803 0)
+ (if (if (vector? a-31803)
+ (if (= (vector-length a-31803) 4)
+ (eq? (vector-ref a-31803 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-25803 1))
+ (symbol? (vector-ref a-31803 1))
#f)))
- tmp-25799)
+ tmp-31799)
#f)
(@apply
- (lambda (a-25831 b-25832)
- (let ((tmp-25833
- (symbol->keyword (syntax->datum a-25831))))
- (key-25508
- b-25832
- req-25789
- opt-25790
- (cons (cons tmp-25833
- (cons a-25831
+ (lambda (a-31831 b-31832)
+ (let ((tmp-31833
+ (symbol->keyword (syntax->datum a-31831))))
+ (key-31164
+ b-31832
+ req-31673
+ opt-31674
+ (cons (cons tmp-31833
+ (cons a-31831
'(#(syntax-object
#f
((top)
#(ribcage
#(k)
#((top))
- #("l-*-2467"))
+ #("l-*-2525"))
#(ribcage
#(a b)
#((top) (top))
- #("l-*-2461"
- "l-*-2462"))
+ #("l-*-2519"
+ "l-*-2520"))
#(ribcage () () ())
#(ribcage
#(args req opt rkey)
(top)
(top)
(top))
- #("l-*-2450"
- "l-*-2451"
- "l-*-2452"
- "l-*-2453"))
+ #("l-*-2508"
+ "l-*-2509"
+ "l-*-2510"
+ "l-*-2511"))
#(ribcage
(check rest
key
(top)
(top)
(top))
- ("l-*-2340"
- "l-*-2338"
- "l-*-2336"
- "l-*-2334"
- "l-*-2332"))
+ ("l-*-2398"
+ "l-*-2396"
+ "l-*-2394"
+ "l-*-2392"
+ "l-*-2390"))
#(ribcage
#(orig-args)
#((top))
- #("l-*-2331"))
+ #("l-*-2389"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-317"
"l-*-315"
"l-*-313"
- "l-*-311"
- "l-*-309"
+ "l-*-310"
+ "l-*-308"
"l-*-306"
"l-*-304"
"l-*-302"
"l-*-262"
"l-*-260"
"l-*-258"
+ "l-*-257"
"l-*-256"
"l-*-255"
"l-*-254"
- "l-*-253"
"l-*-252"
"l-*-250"
"l-*-248"
- "l-*-246"
+ "l-*-245"
"l-*-243"
"l-*-241"
"l-*-239"
((top) (top) (top))
("l-*-47"
"l-*-46"
- "l-*-45")))
+ "l-*-45"))
+ #(ribcage () () ()))
(hygiene guile)))))
- rkey-25791))))
- tmp-25799)
- (let ((tmp-25836
- ($sc-dispatch args-25788 '((any any) . any))))
- (if (if tmp-25836
+ rkey-31675))))
+ tmp-31799)
+ (let ((tmp-31836
+ ($sc-dispatch args-31672 '((any any) . any))))
+ (if (if tmp-31836
(@apply
- (lambda (a-25840 init-25841 b-25842)
- (if (symbol? a-25840)
+ (lambda (a-31840 init-31841 b-31842)
+ (if (symbol? a-31840)
#t
- (if (if (vector? a-25840)
- (if (= (vector-length a-25840) 4)
- (eq? (vector-ref a-25840 0)
+ (if (if (vector? a-31840)
+ (if (= (vector-length a-31840) 4)
+ (eq? (vector-ref a-31840 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref a-25840 1))
+ (symbol? (vector-ref a-31840 1))
#f)))
- tmp-25836)
+ tmp-31836)
#f)
(@apply
- (lambda (a-25869 init-25870 b-25871)
- (let ((tmp-25872
+ (lambda (a-31869 init-31870 b-31871)
+ (let ((tmp-31872
(symbol->keyword
- (syntax->datum a-25869))))
- (key-25508
- b-25871
- req-25789
- opt-25790
- (cons (list tmp-25872 a-25869 init-25870)
- rkey-25791))))
- tmp-25836)
- (let ((tmp-25875
+ (syntax->datum a-31869))))
+ (key-31164
+ b-31871
+ req-31673
+ opt-31674
+ (cons (list tmp-31872 a-31869 init-31870)
+ rkey-31675))))
+ tmp-31836)
+ (let ((tmp-31875
($sc-dispatch
- args-25788
+ args-31672
'((any any any) . any))))
- (if (if tmp-25875
+ (if (if tmp-31875
(@apply
- (lambda (a-25879
- init-25880
- k-25881
- b-25882)
- (if (if (symbol? a-25879)
+ (lambda (a-31879
+ init-31880
+ k-31881
+ b-31882)
+ (if (if (symbol? a-31879)
#t
- (if (if (vector? a-25879)
+ (if (if (vector? a-31879)
(if (= (vector-length
- a-25879)
+ a-31879)
4)
(eq? (vector-ref
- a-25879
+ a-31879
0)
'syntax-object)
#f)
#f)
(symbol?
- (vector-ref a-25879 1))
+ (vector-ref a-31879 1))
#f))
- (keyword? (syntax->datum k-25881))
+ (keyword? (syntax->datum k-31881))
#f))
- tmp-25875)
+ tmp-31875)
#f)
(@apply
- (lambda (a-25909 init-25910 k-25911 b-25912)
- (key-25508
- b-25912
- req-25789
- opt-25790
- (cons (list k-25911 a-25909 init-25910)
- rkey-25791)))
- tmp-25875)
- (let ((tmp-25913
- ($sc-dispatch args-25788 '(any))))
- (if (if tmp-25913
+ (lambda (a-31909 init-31910 k-31911 b-31912)
+ (key-31164
+ b-31912
+ req-31673
+ opt-31674
+ (cons (list k-31911 a-31909 init-31910)
+ rkey-31675)))
+ tmp-31875)
+ (let ((tmp-31913
+ ($sc-dispatch args-31672 '(any))))
+ (if (if tmp-31913
(@apply
- (lambda (aok-25917)
- (eq? (syntax->datum aok-25917)
+ (lambda (aok-31917)
+ (eq? (syntax->datum aok-31917)
#:allow-other-keys))
- tmp-25913)
+ tmp-31913)
#f)
(@apply
- (lambda (aok-25918)
- (check-25510
- req-25789
- opt-25790
+ (lambda (aok-31918)
+ (check-31166
+ req-31673
+ opt-31674
#f
- (cons #t (reverse rkey-25791))))
- tmp-25913)
- (let ((tmp-25921
+ (cons #t (reverse rkey-31675))))
+ tmp-31913)
+ (let ((tmp-32037
($sc-dispatch
- args-25788
+ args-31672
'(any any any))))
- (if (if tmp-25921
+ (if (if tmp-32037
(@apply
- (lambda (aok-25925
- a-25926
- b-25927)
+ (lambda (aok-32041
+ a-32042
+ b-32043)
(if (eq? (syntax->datum
- aok-25925)
+ aok-32041)
#:allow-other-keys)
- (eq? (syntax->datum a-25926)
+ (eq? (syntax->datum a-32042)
#:rest)
#f))
- tmp-25921)
+ tmp-32037)
#f)
(@apply
- (lambda (aok-25928 a-25929 b-25930)
- (rest-25509
- b-25930
- req-25789
- opt-25790
- (cons #t (reverse rkey-25791))))
- tmp-25921)
- (let ((tmp-25933
+ (lambda (aok-32044 a-32045 b-32046)
+ (rest-31165
+ b-32046
+ req-31673
+ opt-31674
+ (cons #t (reverse rkey-31675))))
+ tmp-32037)
+ (let ((tmp-32049
($sc-dispatch
- args-25788
+ args-31672
'(any . any))))
- (if (if tmp-25933
+ (if (if tmp-32049
(@apply
- (lambda (aok-25937 r-25938)
+ (lambda (aok-32053 r-32054)
(if (eq? (syntax->datum
- aok-25937)
+ aok-32053)
#:allow-other-keys)
- (if (symbol? r-25938)
+ (if (symbol? r-32054)
#t
(if (if (vector?
- r-25938)
+ r-32054)
(if (= (vector-length
- r-25938)
+ r-32054)
4)
(eq? (vector-ref
- r-25938
+ r-32054
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- r-25938
+ r-32054
1))
#f))
#f))
- tmp-25933)
+ tmp-32049)
#f)
(@apply
- (lambda (aok-25965 r-25966)
- (rest-25509
- r-25966
- req-25789
- opt-25790
+ (lambda (aok-32081 r-32082)
+ (rest-31165
+ r-32082
+ req-31673
+ opt-31674
(cons #t
- (reverse rkey-25791))))
- tmp-25933)
- (let ((tmp-25969
+ (reverse rkey-31675))))
+ tmp-32049)
+ (let ((tmp-32085
($sc-dispatch
- args-25788
+ args-31672
'(any any))))
- (if (if tmp-25969
+ (if (if tmp-32085
(@apply
- (lambda (a-25973 b-25974)
+ (lambda (a-32089 b-32090)
(eq? (syntax->datum
- a-25973)
+ a-32089)
#:rest))
- tmp-25969)
+ tmp-32085)
#f)
(@apply
- (lambda (a-25975 b-25976)
- (rest-25509
- b-25976
- req-25789
- opt-25790
+ (lambda (a-32091 b-32092)
+ (rest-31165
+ b-32092
+ req-31673
+ opt-31674
(cons #f
(reverse
- rkey-25791))))
- tmp-25969)
- (let ((tmp-25979
- (list args-25788)))
+ rkey-31675))))
+ tmp-32085)
+ (let ((tmp-32095
+ (list args-31672)))
(if (@apply
- (lambda (r-25981)
- (if (symbol? r-25981)
+ (lambda (r-32097)
+ (if (symbol? r-32097)
#t
(if (if (vector?
- r-25981)
+ r-32097)
(if (= (vector-length
- r-25981)
+ r-32097)
4)
(eq? (vector-ref
- r-25981
+ r-32097
0)
'syntax-object)
#f)
#f)
(symbol?
(vector-ref
- r-25981
+ r-32097
1))
#f)))
- tmp-25979)
+ tmp-32095)
(@apply
- (lambda (r-26011)
- (rest-25509
- r-26011
- req-25789
- opt-25790
+ (lambda (r-32127)
+ (rest-31165
+ r-32127
+ req-31673
+ opt-31674
(cons #f
(reverse
- rkey-25791))))
- tmp-25979)
+ rkey-31675))))
+ tmp-32095)
(syntax-violation
'lambda*
"invalid keyword argument list"
- orig-args-25505
- args-25788)))))))))))))))))))))
- (rest-25509
- (lambda (args-26039 req-26040 opt-26041 kw-26042)
- (let ((tmp-26044 (list args-26039)))
+ orig-args-31161
+ args-31672)))))))))))))))))))))
+ (rest-31165
+ (lambda (args-32155 req-32156 opt-32157 kw-32158)
+ (let ((tmp-32160 (list args-32155)))
(if (@apply
- (lambda (r-26046)
- (if (symbol? r-26046)
+ (lambda (r-32162)
+ (if (symbol? r-32162)
#t
- (if (if (vector? r-26046)
- (if (= (vector-length r-26046) 4)
- (eq? (vector-ref r-26046 0) 'syntax-object)
+ (if (if (vector? r-32162)
+ (if (= (vector-length r-32162) 4)
+ (eq? (vector-ref r-32162 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref r-26046 1))
+ (symbol? (vector-ref r-32162 1))
#f)))
- tmp-26044)
+ tmp-32160)
(@apply
- (lambda (r-26076)
- (check-25510
- req-26040
- opt-26041
- r-26076
- kw-26042))
- tmp-26044)
+ (lambda (r-32192)
+ (check-31166
+ req-32156
+ opt-32157
+ r-32192
+ kw-32158))
+ tmp-32160)
(syntax-violation
'lambda*
"invalid rest argument"
- orig-args-25505
- args-26039)))))
- (check-25510
- (lambda (req-26080 opt-26081 rest-26082 kw-26083)
- (if (distinct-bound-ids?-4322
+ orig-args-31161
+ args-32155)))))
+ (check-31166
+ (lambda (req-32320 opt-32321 rest-32322 kw-32323)
+ (if (distinct-bound-ids?-4374
(append
- req-26080
- (map car opt-26081)
- (if rest-26082 (list rest-26082) '())
- (if (pair? kw-26083)
- (map cadr (cdr kw-26083))
+ req-32320
+ (map car opt-32321)
+ (if rest-32322 (list rest-32322) '())
+ (if (pair? kw-32323)
+ (map cadr (cdr kw-32323))
'())))
- (values req-26080 opt-26081 rest-26082 kw-26083)
+ (values req-32320 opt-32321 rest-32322 kw-32323)
(syntax-violation
'lambda*
"duplicate identifier in argument list"
- orig-args-25505)))))
- (req-25506 orig-args-25505 '()))))
- (expand-lambda-case-4343
- (lambda (e-26199
- r-26200
- w-26201
- s-26202
- mod-26203
- get-formals-26204
- clauses-26205)
+ orig-args-31161)))))
+ (req-31162 orig-args-31161 '()))))
+ (expand-lambda-case-4395
+ (lambda (e-32432
+ r-32433
+ w-32434
+ s-32435
+ mod-32436
+ get-formals-32437
+ clauses-32438)
(letrec*
- ((parse-req-26206
- (lambda (req-26337
- opt-26338
- rest-26339
- kw-26340
- body-26341)
- (let ((vars-26342 (map gen-var-4345 req-26337))
- (labels-26343 (gen-labels-4298 req-26337)))
- (let ((r*-26344
- (extend-var-env-4290
- labels-26343
- vars-26342
- r-26200))
- (w*-26345
- (make-binding-wrap-4309
- req-26337
- labels-26343
- w-26201)))
- (parse-opt-26207
- (map syntax->datum req-26337)
- opt-26338
- rest-26339
- kw-26340
- body-26341
- (reverse vars-26342)
- r*-26344
- w*-26345
+ ((parse-req-32439
+ (lambda (req-32572
+ opt-32573
+ rest-32574
+ kw-32575
+ body-32576)
+ (let ((vars-32577 (map gen-var-4397 req-32572))
+ (labels-32578 (gen-labels-4350 req-32572)))
+ (let ((r*-32579
+ (extend-var-env-4343
+ labels-32578
+ vars-32577
+ r-32433))
+ (w*-32580
+ (make-binding-wrap-4361
+ req-32572
+ labels-32578
+ w-32434)))
+ (parse-opt-32440
+ (map syntax->datum req-32572)
+ opt-32573
+ rest-32574
+ kw-32575
+ body-32576
+ (reverse vars-32577)
+ r*-32579
+ w*-32580
'()
'())))))
- (parse-opt-26207
- (lambda (req-26531
- opt-26532
- rest-26533
- kw-26534
- body-26535
- vars-26536
- r*-26537
- w*-26538
- out-26539
- inits-26540)
- (if (pair? opt-26532)
- (let ((tmp-26541 (car opt-26532)))
- (let ((tmp-26542 ($sc-dispatch tmp-26541 '(any any))))
- (if tmp-26542
+ (parse-opt-32440
+ (lambda (req-32777
+ opt-32778
+ rest-32779
+ kw-32780
+ body-32781
+ vars-32782
+ r*-32783
+ w*-32784
+ out-32785
+ inits-32786)
+ (if (pair? opt-32778)
+ (let ((tmp-32787 (car opt-32778)))
+ (let ((tmp-32788 ($sc-dispatch tmp-32787 '(any any))))
+ (if tmp-32788
(@apply
- (lambda (id-26544 i-26545)
- (let ((v-26546
- (let ((id-26554
- (if (if (vector? id-26544)
+ (lambda (id-32790 i-32791)
+ (let ((v-32792
+ (let ((id-32800
+ (if (if (vector? id-32790)
(if (= (vector-length
- id-26544)
+ id-32790)
4)
(eq? (vector-ref
- id-26544
+ id-32790
0)
'syntax-object)
#f)
#f)
- (vector-ref id-26544 1)
- id-26544)))
+ (vector-ref id-32790 1)
+ id-32790)))
(gensym
(string-append
- (symbol->string id-26554)
+ (symbol->string id-32800)
"-")))))
- (let ((l-26547 (gen-labels-4298 (list v-26546))))
- (let ((r**-26548
- (extend-var-env-4290
- l-26547
- (list v-26546)
- r*-26537)))
- (let ((w**-26549
- (make-binding-wrap-4309
- (list id-26544)
- l-26547
- w*-26538)))
- (parse-opt-26207
- req-26531
- (cdr opt-26532)
- rest-26533
- kw-26534
- body-26535
- (cons v-26546 vars-26536)
- r**-26548
- w**-26549
- (cons (syntax->datum id-26544) out-26539)
- (cons (expand-4331
- i-26545
- r*-26537
- w*-26538
- mod-26203)
- inits-26540)))))))
- tmp-26542)
+ (let ((l-32793 (gen-labels-4350 (list v-32792))))
+ (let ((r**-32794
+ (extend-var-env-4343
+ l-32793
+ (list v-32792)
+ r*-32783)))
+ (let ((w**-32795
+ (make-binding-wrap-4361
+ (list id-32790)
+ l-32793
+ w*-32784)))
+ (parse-opt-32440
+ req-32777
+ (cdr opt-32778)
+ rest-32779
+ kw-32780
+ body-32781
+ (cons v-32792 vars-32782)
+ r**-32794
+ w**-32795
+ (cons (syntax->datum id-32790) out-32785)
+ (cons (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ i-32791
+ r*-32783
+ w*-32784
+ (let ((props-32877
+ (source-properties
+ (if (if (vector?
+ i-32791)
+ (if (= (vector-length
+ i-32791)
+ 4)
+ (eq? (vector-ref
+ i-32791
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ i-32791
+ 1)
+ i-32791))))
+ (if (pair? props-32877)
+ props-32877
+ #f))
+ #f
+ mod-32436
+ #f))
+ (lambda (type-32910
+ value-32911
+ form-32912
+ e-32913
+ w-32914
+ s-32915
+ mod-32916)
+ (expand-expr-4384
+ type-32910
+ value-32911
+ form-32912
+ e-32913
+ r*-32783
+ w-32914
+ s-32915
+ mod-32916)))
+ inits-32786)))))))
+ tmp-32788)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-26541))))
- (if rest-26533
- (let ((v-26792
- (let ((id-26802
- (if (if (vector? rest-26533)
- (if (= (vector-length rest-26533) 4)
- (eq? (vector-ref rest-26533 0)
+ tmp-32787))))
+ (if rest-32779
+ (let ((v-33039
+ (let ((id-33049
+ (if (if (vector? rest-32779)
+ (if (= (vector-length rest-32779) 4)
+ (eq? (vector-ref rest-32779 0)
'syntax-object)
#f)
#f)
- (vector-ref rest-26533 1)
- rest-26533)))
+ (vector-ref rest-32779 1)
+ rest-32779)))
(gensym
(string-append
- (symbol->string id-26802)
+ (symbol->string id-33049)
"-")))))
- (let ((l-26793 (gen-labels-4298 (list v-26792))))
- (let ((r*-26794
- (extend-var-env-4290
- l-26793
- (list v-26792)
- r*-26537)))
- (let ((w*-26795
- (make-binding-wrap-4309
- (list rest-26533)
- l-26793
- w*-26538)))
- (parse-kw-26208
- req-26531
- (if (pair? out-26539) (reverse out-26539) #f)
- (syntax->datum rest-26533)
- (if (pair? kw-26534) (cdr kw-26534) kw-26534)
- body-26535
- (cons v-26792 vars-26536)
- r*-26794
- w*-26795
- (if (pair? kw-26534) (car kw-26534) #f)
+ (let ((l-33040 (gen-labels-4350 (list v-33039))))
+ (let ((r*-33041
+ (extend-var-env-4343
+ l-33040
+ (list v-33039)
+ r*-32783)))
+ (let ((w*-33042
+ (make-binding-wrap-4361
+ (list rest-32779)
+ l-33040
+ w*-32784)))
+ (parse-kw-32441
+ req-32777
+ (if (pair? out-32785) (reverse out-32785) #f)
+ (syntax->datum rest-32779)
+ (if (pair? kw-32780) (cdr kw-32780) kw-32780)
+ body-32781
+ (cons v-33039 vars-32782)
+ r*-33041
+ w*-33042
+ (if (pair? kw-32780) (car kw-32780) #f)
'()
- inits-26540)))))
- (parse-kw-26208
- req-26531
- (if (pair? out-26539) (reverse out-26539) #f)
+ inits-32786)))))
+ (parse-kw-32441
+ req-32777
+ (if (pair? out-32785) (reverse out-32785) #f)
#f
- (if (pair? kw-26534) (cdr kw-26534) kw-26534)
- body-26535
- vars-26536
- r*-26537
- w*-26538
- (if (pair? kw-26534) (car kw-26534) #f)
+ (if (pair? kw-32780) (cdr kw-32780) kw-32780)
+ body-32781
+ vars-32782
+ r*-32783
+ w*-32784
+ (if (pair? kw-32780) (car kw-32780) #f)
'()
- inits-26540)))))
- (parse-kw-26208
- (lambda (req-26973
- opt-26974
- rest-26975
- kw-26976
- body-26977
- vars-26978
- r*-26979
- w*-26980
- aok-26981
- out-26982
- inits-26983)
- (if (pair? kw-26976)
- (let ((tmp-26984 (car kw-26976)))
- (let ((tmp-26985
- ($sc-dispatch tmp-26984 '(any any any))))
- (if tmp-26985
+ inits-32786)))))
+ (parse-kw-32441
+ (lambda (req-33232
+ opt-33233
+ rest-33234
+ kw-33235
+ body-33236
+ vars-33237
+ r*-33238
+ w*-33239
+ aok-33240
+ out-33241
+ inits-33242)
+ (if (pair? kw-33235)
+ (let ((tmp-33243 (car kw-33235)))
+ (let ((tmp-33244
+ ($sc-dispatch tmp-33243 '(any any any))))
+ (if tmp-33244
(@apply
- (lambda (k-26987 id-26988 i-26989)
- (let ((v-26990
- (let ((id-26998
- (if (if (vector? id-26988)
+ (lambda (k-33246 id-33247 i-33248)
+ (let ((v-33249
+ (let ((id-33257
+ (if (if (vector? id-33247)
(if (= (vector-length
- id-26988)
+ id-33247)
4)
(eq? (vector-ref
- id-26988
+ id-33247
0)
'syntax-object)
#f)
#f)
- (vector-ref id-26988 1)
- id-26988)))
+ (vector-ref id-33247 1)
+ id-33247)))
(gensym
(string-append
- (symbol->string id-26998)
+ (symbol->string id-33257)
"-")))))
- (let ((l-26991 (gen-labels-4298 (list v-26990))))
- (let ((r**-26992
- (extend-var-env-4290
- l-26991
- (list v-26990)
- r*-26979)))
- (let ((w**-26993
- (make-binding-wrap-4309
- (list id-26988)
- l-26991
- w*-26980)))
- (parse-kw-26208
- req-26973
- opt-26974
- rest-26975
- (cdr kw-26976)
- body-26977
- (cons v-26990 vars-26978)
- r**-26992
- w**-26993
- aok-26981
- (cons (list (syntax->datum k-26987)
- (syntax->datum id-26988)
- v-26990)
- out-26982)
- (cons (expand-4331
- i-26989
- r*-26979
- w*-26980
- mod-26203)
- inits-26983)))))))
- tmp-26985)
+ (let ((l-33250 (gen-labels-4350 (list v-33249))))
+ (let ((r**-33251
+ (extend-var-env-4343
+ l-33250
+ (list v-33249)
+ r*-33238)))
+ (let ((w**-33252
+ (make-binding-wrap-4361
+ (list id-33247)
+ l-33250
+ w*-33239)))
+ (parse-kw-32441
+ req-33232
+ opt-33233
+ rest-33234
+ (cdr kw-33235)
+ body-33236
+ (cons v-33249 vars-33237)
+ r**-33251
+ w**-33252
+ aok-33240
+ (cons (list (syntax->datum k-33246)
+ (syntax->datum id-33247)
+ v-33249)
+ out-33241)
+ (cons (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ i-33248
+ r*-33238
+ w*-33239
+ (let ((props-33334
+ (source-properties
+ (if (if (vector?
+ i-33248)
+ (if (= (vector-length
+ i-33248)
+ 4)
+ (eq? (vector-ref
+ i-33248
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ i-33248
+ 1)
+ i-33248))))
+ (if (pair? props-33334)
+ props-33334
+ #f))
+ #f
+ mod-32436
+ #f))
+ (lambda (type-33367
+ value-33368
+ form-33369
+ e-33370
+ w-33371
+ s-33372
+ mod-33373)
+ (expand-expr-4384
+ type-33367
+ value-33368
+ form-33369
+ e-33370
+ r*-33238
+ w-33371
+ s-33372
+ mod-33373)))
+ inits-33242)))))))
+ tmp-33244)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-26984))))
- (parse-body-26209
- req-26973
- opt-26974
- rest-26975
- (if (if aok-26981 aok-26981 (pair? out-26982))
- (cons aok-26981 (reverse out-26982))
+ tmp-33243))))
+ (parse-body-32442
+ req-33232
+ opt-33233
+ rest-33234
+ (if (if aok-33240 aok-33240 (pair? out-33241))
+ (cons aok-33240 (reverse out-33241))
#f)
- body-26977
- (reverse vars-26978)
- r*-26979
- w*-26980
- (reverse inits-26983)
+ body-33236
+ (reverse vars-33237)
+ r*-33238
+ w*-33239
+ (reverse inits-33242)
'()))))
- (parse-body-26209
- (lambda (req-27245
- opt-27246
- rest-27247
- kw-27248
- body-27249
- vars-27250
- r*-27251
- w*-27252
- inits-27253
- meta-27254)
- (let ((tmp-27256
- ($sc-dispatch body-27249 '(any any . each-any))))
- (if (if tmp-27256
+ (parse-body-32442
+ (lambda (req-33505
+ opt-33506
+ rest-33507
+ kw-33508
+ body-33509
+ vars-33510
+ r*-33511
+ w*-33512
+ inits-33513
+ meta-33514)
+ (let ((tmp-33516
+ ($sc-dispatch body-33509 '(any any . each-any))))
+ (if (if tmp-33516
(@apply
- (lambda (docstring-27260 e1-27261 e2-27262)
- (string? (syntax->datum docstring-27260)))
- tmp-27256)
+ (lambda (docstring-33520 e1-33521 e2-33522)
+ (string? (syntax->datum docstring-33520)))
+ tmp-33516)
#f)
(@apply
- (lambda (docstring-27263 e1-27264 e2-27265)
- (parse-body-26209
- req-27245
- opt-27246
- rest-27247
- kw-27248
- (cons e1-27264 e2-27265)
- vars-27250
- r*-27251
- w*-27252
- inits-27253
+ (lambda (docstring-33523 e1-33524 e2-33525)
+ (parse-body-32442
+ req-33505
+ opt-33506
+ rest-33507
+ kw-33508
+ (cons e1-33524 e2-33525)
+ vars-33510
+ r*-33511
+ w*-33512
+ inits-33513
(append
- meta-27254
+ meta-33514
(list (cons 'documentation
- (syntax->datum docstring-27263))))))
- tmp-27256)
- (let ((tmp-27266
+ (syntax->datum docstring-33523))))))
+ tmp-33516)
+ (let ((tmp-33526
($sc-dispatch
- body-27249
+ body-33509
'(#(vector #(each (any . any)))
any
.
each-any))))
- (if tmp-27266
+ (if tmp-33526
(@apply
- (lambda (k-27270 v-27271 e1-27272 e2-27273)
- (parse-body-26209
- req-27245
- opt-27246
- rest-27247
- kw-27248
- (cons e1-27272 e2-27273)
- vars-27250
- r*-27251
- w*-27252
- inits-27253
+ (lambda (k-33530 v-33531 e1-33532 e2-33533)
+ (parse-body-32442
+ req-33505
+ opt-33506
+ rest-33507
+ kw-33508
+ (cons e1-33532 e2-33533)
+ vars-33510
+ r*-33511
+ w*-33512
+ inits-33513
(append
- meta-27254
- (syntax->datum (map cons k-27270 v-27271)))))
- tmp-27266)
- (let ((tmp-27274
- ($sc-dispatch body-27249 '(any . each-any))))
- (if tmp-27274
+ meta-33514
+ (syntax->datum (map cons k-33530 v-33531)))))
+ tmp-33526)
+ (let ((tmp-33534
+ ($sc-dispatch body-33509 '(any . each-any))))
+ (if tmp-33534
(@apply
- (lambda (e1-27278 e2-27279)
+ (lambda (e1-33538 e2-33539)
(values
- meta-27254
- req-27245
- opt-27246
- rest-27247
- kw-27248
- inits-27253
- vars-27250
- (expand-body-4335
- (cons e1-27278 e2-27279)
- (wrap-4324
- (begin
- (if (if s-26202
- (supports-source-properties?
- e-26199)
+ meta-33514
+ req-33505
+ opt-33506
+ rest-33507
+ kw-33508
+ inits-33513
+ vars-33510
+ (expand-body-4387
+ (cons e1-33538 e2-33539)
+ (let ((x-33551
+ (begin
+ (if (if s-32435
+ (supports-source-properties?
+ e-32432)
+ #f)
+ (set-source-properties!
+ e-32432
+ s-32435))
+ e-32432)))
+ (if (if (null? (car w-32434))
+ (null? (cdr w-32434))
+ #f)
+ x-33551
+ (if (if (vector? x-33551)
+ (if (= (vector-length x-33551) 4)
+ (eq? (vector-ref x-33551 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties!
- e-26199
- s-26202))
- e-26199)
- w-26201
- mod-26203)
- r*-27251
- w*-27252
- mod-26203)))
- tmp-27274)
+ (let ((expression-33583
+ (vector-ref x-33551 1))
+ (wrap-33584
+ (let ((w2-33592
+ (vector-ref
+ x-33551
+ 2)))
+ (let ((m1-33593
+ (car w-32434))
+ (s1-33594
+ (cdr w-32434)))
+ (if (null? m1-33593)
+ (if (null? s1-33594)
+ w2-33592
+ (cons (car w2-33592)
+ (let ((m2-33609
+ (cdr w2-33592)))
+ (if (null? m2-33609)
+ s1-33594
+ (append
+ s1-33594
+ m2-33609)))))
+ (cons (let ((m2-33617
+ (car w2-33592)))
+ (if (null? m2-33617)
+ m1-33593
+ (append
+ m1-33593
+ m2-33617)))
+ (let ((m2-33625
+ (cdr w2-33592)))
+ (if (null? m2-33625)
+ s1-33594
+ (append
+ s1-33594
+ m2-33625))))))))
+ (module-33585
+ (vector-ref x-33551 3)))
+ (vector
+ 'syntax-object
+ expression-33583
+ wrap-33584
+ module-33585))
+ (if (null? x-33551)
+ x-33551
+ (vector
+ 'syntax-object
+ x-33551
+ w-32434
+ mod-32436)))))
+ r*-33511
+ w*-33512
+ mod-32436)))
+ tmp-33534)
(syntax-violation
#f
"source expression failed to match any pattern"
- body-27249))))))))))
- (let ((tmp-26211 ($sc-dispatch clauses-26205 '())))
- (if tmp-26211
- (@apply (lambda () (values '() #f)) tmp-26211)
- (let ((tmp-26215
+ body-33509))))))))))
+ (let ((tmp-32444 ($sc-dispatch clauses-32438 '())))
+ (if tmp-32444
+ (@apply (lambda () (values '() #f)) tmp-32444)
+ (let ((tmp-32448
($sc-dispatch
- clauses-26205
+ clauses-32438
'((any any . each-any)
.
#(each (any any . each-any))))))
- (if tmp-26215
+ (if tmp-32448
(@apply
- (lambda (args-26219
- e1-26220
- e2-26221
- args*-26222
- e1*-26223
- e2*-26224)
+ (lambda (args-32452
+ e1-32453
+ e2-32454
+ args*-32455
+ e1*-32456
+ e2*-32457)
(call-with-values
- (lambda () (get-formals-26204 args-26219))
- (lambda (req-26225 opt-26226 rest-26227 kw-26228)
+ (lambda () (get-formals-32437 args-32452))
+ (lambda (req-32458 opt-32459 rest-32460 kw-32461)
(call-with-values
(lambda ()
- (parse-req-26206
- req-26225
- opt-26226
- rest-26227
- kw-26228
- (cons e1-26220 e2-26221)))
- (lambda (meta-26293
- req-26294
- opt-26295
- rest-26296
- kw-26297
- inits-26298
- vars-26299
- body-26300)
+ (parse-req-32439
+ req-32458
+ opt-32459
+ rest-32460
+ kw-32461
+ (cons e1-32453 e2-32454)))
+ (lambda (meta-32528
+ req-32529
+ opt-32530
+ rest-32531
+ kw-32532
+ inits-32533
+ vars-32534
+ body-32535)
(call-with-values
(lambda ()
- (expand-lambda-case-4343
- e-26199
- r-26200
- w-26201
- s-26202
- mod-26203
- get-formals-26204
- (map (lambda (tmp-2802-26301
- tmp-2801-26302
- tmp-2800-26303)
- (cons tmp-2800-26303
- (cons tmp-2801-26302
- tmp-2802-26301)))
- e2*-26224
- e1*-26223
- args*-26222)))
- (lambda (meta*-26304 else*-26305)
+ (expand-lambda-case-4395
+ e-32432
+ r-32433
+ w-32434
+ s-32435
+ mod-32436
+ get-formals-32437
+ (map (lambda (tmp-2860-32536
+ tmp-2859-32537
+ tmp-2858-32538)
+ (cons tmp-2858-32538
+ (cons tmp-2859-32537
+ tmp-2860-32536)))
+ e2*-32457
+ e1*-32456
+ args*-32455)))
+ (lambda (meta*-32539 else*-32540)
(values
- (append meta-26293 meta*-26304)
+ (append meta-32528 meta*-32539)
(make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- s-26202
- req-26294
- opt-26295
- rest-26296
- kw-26297
- inits-26298
- vars-26299
- body-26300
- else*-26305)))))))))
- tmp-26215)
+ (vector-ref %expanded-vtables 15)
+ s-32435
+ req-32529
+ opt-32530
+ rest-32531
+ kw-32532
+ inits-32533
+ vars-32534
+ body-32535
+ else*-32540)))))))))
+ tmp-32448)
(syntax-violation
#f
"source expression failed to match any pattern"
- clauses-26205))))))))
- (strip-4344
- (lambda (x-27316 w-27317)
- (if (memq 'top (car w-27317))
- x-27316
+ clauses-32438))))))))
+ (strip-4396
+ (lambda (x-33652 w-33653)
+ (if (memq 'top (car w-33653))
+ x-33652
(letrec*
- ((f-27318
- (lambda (x-27321)
- (if (if (vector? x-27321)
- (if (= (vector-length x-27321) 4)
- (eq? (vector-ref x-27321 0) 'syntax-object)
+ ((f-33654
+ (lambda (x-33657)
+ (if (if (vector? x-33657)
+ (if (= (vector-length x-33657) 4)
+ (eq? (vector-ref x-33657 0) 'syntax-object)
#f)
#f)
- (strip-4344
- (vector-ref x-27321 1)
- (vector-ref x-27321 2))
- (if (pair? x-27321)
- (let ((a-27340 (f-27318 (car x-27321)))
- (d-27341 (f-27318 (cdr x-27321))))
- (if (if (eq? a-27340 (car x-27321))
- (eq? d-27341 (cdr x-27321))
+ (strip-4396
+ (vector-ref x-33657 1)
+ (vector-ref x-33657 2))
+ (if (pair? x-33657)
+ (let ((a-33676 (f-33654 (car x-33657)))
+ (d-33677 (f-33654 (cdr x-33657))))
+ (if (if (eq? a-33676 (car x-33657))
+ (eq? d-33677 (cdr x-33657))
#f)
- x-27321
- (cons a-27340 d-27341)))
- (if (vector? x-27321)
- (let ((old-27344 (vector->list x-27321)))
- (let ((new-27345 (map f-27318 old-27344)))
+ x-33657
+ (cons a-33676 d-33677)))
+ (if (vector? x-33657)
+ (let ((old-33680 (vector->list x-33657)))
+ (let ((new-33681 (map f-33654 old-33680)))
(letrec*
- ((lp-27346
- (lambda (l1-27422 l2-27423)
- (if (null? l1-27422)
- x-27321
- (if (eq? (car l1-27422) (car l2-27423))
- (lp-27346 (cdr l1-27422) (cdr l2-27423))
- (list->vector new-27345))))))
- (lp-27346 old-27344 new-27345))))
- x-27321))))))
- (f-27318 x-27316)))))
- (gen-var-4345
- (lambda (id-26349)
- (let ((id-26350
- (if (if (vector? id-26349)
- (if (= (vector-length id-26349) 4)
- (eq? (vector-ref id-26349 0) 'syntax-object)
+ ((lp-33682
+ (lambda (l1-33779 l2-33780)
+ (if (null? l1-33779)
+ x-33657
+ (if (eq? (car l1-33779) (car l2-33780))
+ (lp-33682 (cdr l1-33779) (cdr l2-33780))
+ (list->vector new-33681))))))
+ (lp-33682 old-33680 new-33681))))
+ x-33657))))))
+ (f-33654 x-33652)))))
+ (gen-var-4397
+ (lambda (id-32584)
+ (let ((id-32585
+ (if (if (vector? id-32584)
+ (if (= (vector-length id-32584) 4)
+ (eq? (vector-ref id-32584 0) 'syntax-object)
#f)
#f)
- (vector-ref id-26349 1)
- id-26349)))
+ (vector-ref id-32584 1)
+ id-32584)))
(gensym
- (string-append (symbol->string id-26350) "-"))))))
+ (string-append (symbol->string id-32585) "-")))))
+ (lambda-var-list-4398
+ (lambda (vars-33781)
+ (letrec*
+ ((lvl-33782
+ (lambda (vars-33785 ls-33786 w-33787)
+ (if (pair? vars-33785)
+ (lvl-33782
+ (cdr vars-33785)
+ (cons (let ((x-33791 (car vars-33785)))
+ (if (if (null? (car w-33787))
+ (null? (cdr w-33787))
+ #f)
+ x-33791
+ (if (if (vector? x-33791)
+ (if (= (vector-length x-33791) 4)
+ (eq? (vector-ref x-33791 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-33809 (vector-ref x-33791 1))
+ (wrap-33810
+ (let ((w2-33818
+ (vector-ref x-33791 2)))
+ (let ((m1-33819 (car w-33787))
+ (s1-33820 (cdr w-33787)))
+ (if (null? m1-33819)
+ (if (null? s1-33820)
+ w2-33818
+ (cons (car w2-33818)
+ (let ((m2-33835
+ (cdr w2-33818)))
+ (if (null? m2-33835)
+ s1-33820
+ (append
+ s1-33820
+ m2-33835)))))
+ (cons (let ((m2-33843
+ (car w2-33818)))
+ (if (null? m2-33843)
+ m1-33819
+ (append
+ m1-33819
+ m2-33843)))
+ (let ((m2-33851
+ (cdr w2-33818)))
+ (if (null? m2-33851)
+ s1-33820
+ (append
+ s1-33820
+ m2-33851))))))))
+ (module-33811 (vector-ref x-33791 3)))
+ (vector
+ 'syntax-object
+ expression-33809
+ wrap-33810
+ module-33811))
+ (if (null? x-33791)
+ x-33791
+ (vector
+ 'syntax-object
+ x-33791
+ w-33787
+ #f)))))
+ ls-33786)
+ w-33787)
+ (if (if (symbol? vars-33785)
+ #t
+ (if (if (vector? vars-33785)
+ (if (= (vector-length vars-33785) 4)
+ (eq? (vector-ref vars-33785 0) 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref vars-33785 1))
+ #f))
+ (cons (if (if (null? (car w-33787))
+ (null? (cdr w-33787))
+ #f)
+ vars-33785
+ (if (if (vector? vars-33785)
+ (if (= (vector-length vars-33785) 4)
+ (eq? (vector-ref vars-33785 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-33921
+ (vector-ref vars-33785 1))
+ (wrap-33922
+ (let ((w2-33932
+ (vector-ref vars-33785 2)))
+ (let ((m1-33933 (car w-33787))
+ (s1-33934 (cdr w-33787)))
+ (if (null? m1-33933)
+ (if (null? s1-33934)
+ w2-33932
+ (cons (car w2-33932)
+ (let ((m2-33951
+ (cdr w2-33932)))
+ (if (null? m2-33951)
+ s1-33934
+ (append
+ s1-33934
+ m2-33951)))))
+ (cons (let ((m2-33959
+ (car w2-33932)))
+ (if (null? m2-33959)
+ m1-33933
+ (append
+ m1-33933
+ m2-33959)))
+ (let ((m2-33967
+ (cdr w2-33932)))
+ (if (null? m2-33967)
+ s1-33934
+ (append
+ s1-33934
+ m2-33967))))))))
+ (module-33923 (vector-ref vars-33785 3)))
+ (vector
+ 'syntax-object
+ expression-33921
+ wrap-33922
+ module-33923))
+ (if (null? vars-33785)
+ vars-33785
+ (vector
+ 'syntax-object
+ vars-33785
+ w-33787
+ #f))))
+ ls-33786)
+ (if (null? vars-33785)
+ ls-33786
+ (if (if (vector? vars-33785)
+ (if (= (vector-length vars-33785) 4)
+ (eq? (vector-ref vars-33785 0) 'syntax-object)
+ #f)
+ #f)
+ (lvl-33782
+ (vector-ref vars-33785 1)
+ ls-33786
+ (let ((w2-34008 (vector-ref vars-33785 2)))
+ (let ((m1-34009 (car w-33787))
+ (s1-34010 (cdr w-33787)))
+ (if (null? m1-34009)
+ (if (null? s1-34010)
+ w2-34008
+ (cons (car w2-34008)
+ (let ((m2-34021 (cdr w2-34008)))
+ (if (null? m2-34021)
+ s1-34010
+ (append s1-34010 m2-34021)))))
+ (cons (let ((m2-34029 (car w2-34008)))
+ (if (null? m2-34029)
+ m1-34009
+ (append m1-34009 m2-34029)))
+ (let ((m2-34037 (cdr w2-34008)))
+ (if (null? m2-34037)
+ s1-34010
+ (append s1-34010 m2-34037))))))))
+ (cons vars-33785 ls-33786))))))))
+ (lvl-33782 vars-33781 '() '(()))))))
(begin
- (set! session-id-4256
- (let ((v-15685
+ (lambda (x-17960) (vector-ref x-17960 3))
+ (set! session-id-4308
+ (let ((v-17746
(module-variable
(current-module)
'syntax-session-id)))
- (lambda () ((variable-ref v-15685)))))
- (set! transformer-environment-4317
+ (lambda () ((variable-ref v-17746)))))
+ (set! transformer-environment-4369
(make-fluid
- (lambda (k-14717)
+ (lambda (k-16379)
(error "called outside the dynamic extent of a syntax transformer"))))
(module-define!
(current-module)
'let-syntax
'local-syntax
#f))
- (global-extend-4293
+ (global-extend-4345
'core
'syntax-parameterize
- (lambda (e-4466 r-4467 w-4468 s-4469 mod-4470)
- (let ((tmp-4472
+ (lambda (e-4525 r-4526 w-4527 s-4528 mod-4529)
+ (let ((tmp-4531
($sc-dispatch
- e-4466
+ e-4525
'(_ #(each (any any)) any . each-any))))
- (if (if tmp-4472
+ (if (if tmp-4531
(@apply
- (lambda (var-4476 val-4477 e1-4478 e2-4479)
- (valid-bound-ids?-4321 var-4476))
- tmp-4472)
+ (lambda (var-4535 val-4536 e1-4537 e2-4538)
+ (valid-bound-ids?-4373 var-4535))
+ tmp-4531)
#f)
(@apply
- (lambda (var-4557 val-4558 e1-4559 e2-4560)
- (let ((names-4561
- (map (lambda (x-4611)
- (id-var-name-4314 x-4611 w-4468))
- var-4557)))
- (begin
- (for-each
- (lambda (id-4562 n-4563)
- (let ((key-4564
- (car (let ((t-4571 (assq n-4563 r-4467)))
- (if t-4571
- (cdr t-4571)
- (if (symbol? n-4563)
- (let ((t-4576
- (get-global-definition-hook-4258
- n-4563
- mod-4470)))
- (if t-4576 t-4576 '(global)))
- '(displaced-lexical)))))))
- (if (eqv? key-4564 'displaced-lexical)
- (syntax-violation
- 'syntax-parameterize
- "identifier out of context"
- e-4466
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? id-4562)
- #f)
- (set-source-properties! id-4562 s-4469))
- id-4562)
- w-4468
- mod-4470)))))
- var-4557
- names-4561)
- (expand-body-4335
- (cons e1-4559 e2-4560)
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? e-4466)
- #f)
- (set-source-properties! e-4466 s-4469))
- e-4466)
- w-4468
- mod-4470)
- (extend-env-4289
- names-4561
- (let ((trans-r-4697 (macros-only-env-4291 r-4467)))
- (map (lambda (x-4698)
+ (lambda (var-4623 val-4624 e1-4625 e2-4626)
+ (let ((names-4627
+ (map (lambda (x-4971)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier-4368
+ x-4971
+ w-4527
+ r-4526
+ mod-4529
+ #f))
+ (lambda (type-4974 value-4975 mod-4976)
+ (if (eqv? type-4974 'displaced-lexical)
+ (syntax-violation
+ 'syntax-parameterize
+ "identifier out of context"
+ e-4525
+ (let ((x-4993
+ (begin
+ (if (if s-4528
+ (supports-source-properties?
+ x-4971)
+ #f)
+ (set-source-properties!
+ x-4971
+ s-4528))
+ x-4971)))
+ (if (if (null? (car w-4527))
+ (null? (cdr w-4527))
+ #f)
+ x-4993
+ (if (if (vector? x-4993)
+ (if (= (vector-length
+ x-4993)
+ 4)
+ (eq? (vector-ref x-4993 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-5025
+ (vector-ref x-4993 1))
+ (wrap-5026
+ (let ((w2-5034
+ (vector-ref
+ x-4993
+ 2)))
+ (let ((m1-5035
+ (car w-4527))
+ (s1-5036
+ (cdr w-4527)))
+ (if (null? m1-5035)
+ (if (null? s1-5036)
+ w2-5034
+ (cons (car w2-5034)
+ (let ((m2-5051
+ (cdr w2-5034)))
+ (if (null? m2-5051)
+ s1-5036
+ (append
+ s1-5036
+ m2-5051)))))
+ (cons (let ((m2-5059
+ (car w2-5034)))
+ (if (null? m2-5059)
+ m1-5035
+ (append
+ m1-5035
+ m2-5059)))
+ (let ((m2-5067
+ (cdr w2-5034)))
+ (if (null? m2-5067)
+ s1-5036
+ (append
+ s1-5036
+ m2-5067))))))))
+ (module-5027
+ (vector-ref x-4993 3)))
+ (vector
+ 'syntax-object
+ expression-5025
+ wrap-5026
+ module-5027))
+ (if (null? x-4993)
+ x-4993
+ (vector
+ 'syntax-object
+ x-4993
+ w-4527
+ mod-4976))))))
+ (if (eqv? type-4974 'syntax-parameter)
+ value-4975
+ (syntax-violation
+ 'syntax-parameterize
+ "invalid syntax parameter"
+ e-4525
+ (let ((x-5097
+ (begin
+ (if (if s-4528
+ (supports-source-properties?
+ x-4971)
+ #f)
+ (set-source-properties!
+ x-4971
+ s-4528))
+ x-4971)))
+ (if (if (null? (car w-4527))
+ (null? (cdr w-4527))
+ #f)
+ x-5097
+ (if (if (vector? x-5097)
+ (if (= (vector-length
+ x-5097)
+ 4)
+ (eq? (vector-ref
+ x-5097
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-5129
+ (vector-ref x-5097 1))
+ (wrap-5130
+ (let ((w2-5138
+ (vector-ref
+ x-5097
+ 2)))
+ (let ((m1-5139
+ (car w-4527))
+ (s1-5140
+ (cdr w-4527)))
+ (if (null? m1-5139)
+ (if (null? s1-5140)
+ w2-5138
+ (cons (car w2-5138)
+ (let ((m2-5155
+ (cdr w2-5138)))
+ (if (null? m2-5155)
+ s1-5140
+ (append
+ s1-5140
+ m2-5155)))))
+ (cons (let ((m2-5163
+ (car w2-5138)))
+ (if (null? m2-5163)
+ m1-5139
+ (append
+ m1-5139
+ m2-5163)))
+ (let ((m2-5171
+ (cdr w2-5138)))
+ (if (null? m2-5171)
+ s1-5140
+ (append
+ s1-5140
+ m2-5171))))))))
+ (module-5131
+ (vector-ref
+ x-5097
+ 3)))
+ (vector
+ 'syntax-object
+ expression-5129
+ wrap-5130
+ module-5131))
+ (if (null? x-5097)
+ x-5097
+ (vector
+ 'syntax-object
+ x-5097
+ w-4527
+ mod-4976)))))))))))
+ var-4623))
+ (bindings-4628
+ (let ((trans-r-5186 (macros-only-env-4344 r-4526)))
+ (map (lambda (x-5187)
(cons 'macro
- (eval-local-transformer-4337
- (expand-4331
- x-4698
- trans-r-4697
- w-4468
- mod-4470)
- mod-4470)))
- val-4558))
- r-4467)
- w-4468
- mod-4470))))
- tmp-4472)
- (syntax-violation
- 'syntax-parameterize
+ (eval-local-transformer-4389
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ x-5187
+ trans-r-5186
+ w-4527
+ (let ((props-5250
+ (source-properties
+ (if (if (vector?
+ x-5187)
+ (if (= (vector-length
+ x-5187)
+ 4)
+ (eq? (vector-ref
+ x-5187
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ x-5187
+ 1)
+ x-5187))))
+ (if (pair? props-5250)
+ props-5250
+ #f))
+ #f
+ mod-4529
+ #f))
+ (lambda (type-5283
+ value-5284
+ form-5285
+ e-5286
+ w-5287
+ s-5288
+ mod-5289)
+ (expand-expr-4384
+ type-5283
+ value-5284
+ form-5285
+ e-5286
+ trans-r-5186
+ w-5287
+ s-5288
+ mod-5289)))
+ mod-4529)))
+ val-4624))))
+ (expand-body-4387
+ (cons e1-4625 e2-4626)
+ (let ((x-4640
+ (begin
+ (if (if s-4528
+ (supports-source-properties? e-4525)
+ #f)
+ (set-source-properties! e-4525 s-4528))
+ e-4525)))
+ (if (if (null? (car w-4527)) (null? (cdr w-4527)) #f)
+ x-4640
+ (if (if (vector? x-4640)
+ (if (= (vector-length x-4640) 4)
+ (eq? (vector-ref x-4640 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-4672 (vector-ref x-4640 1))
+ (wrap-4673
+ (let ((w2-4681 (vector-ref x-4640 2)))
+ (let ((m1-4682 (car w-4527))
+ (s1-4683 (cdr w-4527)))
+ (if (null? m1-4682)
+ (if (null? s1-4683)
+ w2-4681
+ (cons (car w2-4681)
+ (let ((m2-4698
+ (cdr w2-4681)))
+ (if (null? m2-4698)
+ s1-4683
+ (append
+ s1-4683
+ m2-4698)))))
+ (cons (let ((m2-4706 (car w2-4681)))
+ (if (null? m2-4706)
+ m1-4682
+ (append m1-4682 m2-4706)))
+ (let ((m2-4714 (cdr w2-4681)))
+ (if (null? m2-4714)
+ s1-4683
+ (append
+ s1-4683
+ m2-4714))))))))
+ (module-4674 (vector-ref x-4640 3)))
+ (vector
+ 'syntax-object
+ expression-4672
+ wrap-4673
+ module-4674))
+ (if (null? x-4640)
+ x-4640
+ (vector
+ 'syntax-object
+ x-4640
+ w-4527
+ mod-4529)))))
+ (extend-env-4342 names-4627 bindings-4628 r-4526)
+ w-4527
+ mod-4529)))
+ tmp-4531)
+ (syntax-violation
+ 'syntax-parameterize
"bad syntax"
- (wrap-4324
- (begin
- (if (if s-4469
- (supports-source-properties? e-4466)
+ (let ((x-5388
+ (begin
+ (if (if s-4528
+ (supports-source-properties? e-4525)
+ #f)
+ (set-source-properties! e-4525 s-4528))
+ e-4525)))
+ (if (if (null? (car w-4527)) (null? (cdr w-4527)) #f)
+ x-5388
+ (if (if (vector? x-5388)
+ (if (= (vector-length x-5388) 4)
+ (eq? (vector-ref x-5388 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-4466 s-4469))
- e-4466)
- w-4468
- mod-4470))))))
+ (let ((expression-5420 (vector-ref x-5388 1))
+ (wrap-5421
+ (let ((w2-5429 (vector-ref x-5388 2)))
+ (let ((m1-5430 (car w-4527))
+ (s1-5431 (cdr w-4527)))
+ (if (null? m1-5430)
+ (if (null? s1-5431)
+ w2-5429
+ (cons (car w2-5429)
+ (let ((m2-5446 (cdr w2-5429)))
+ (if (null? m2-5446)
+ s1-5431
+ (append s1-5431 m2-5446)))))
+ (cons (let ((m2-5454 (car w2-5429)))
+ (if (null? m2-5454)
+ m1-5430
+ (append m1-5430 m2-5454)))
+ (let ((m2-5462 (cdr w2-5429)))
+ (if (null? m2-5462)
+ s1-5431
+ (append s1-5431 m2-5462))))))))
+ (module-5422 (vector-ref x-5388 3)))
+ (vector
+ 'syntax-object
+ expression-5420
+ wrap-5421
+ module-5422))
+ (if (null? x-5388)
+ x-5388
+ (vector 'syntax-object x-5388 w-4527 mod-4529))))))))))
(module-define!
(current-module)
'quote
(make-syntax-transformer
'quote
'core
- (lambda (e-4907 r-4908 w-4909 s-4910 mod-4911)
- (let ((tmp-4913 ($sc-dispatch e-4907 '(_ any))))
- (if tmp-4913
+ (lambda (e-5490 r-5491 w-5492 s-5493 mod-5494)
+ (let ((tmp-5496 ($sc-dispatch e-5490 '(_ any))))
+ (if tmp-5496
(@apply
- (lambda (e-4916)
- (let ((exp-4920 (strip-4344 e-4916 w-4909)))
+ (lambda (e-5499)
+ (let ((exp-5503 (strip-4396 e-5499 w-5492)))
(make-struct/no-tail
(vector-ref %expanded-vtables 1)
- s-4910
- exp-4920)))
- tmp-4913)
+ s-5493
+ exp-5503)))
+ tmp-5496)
(syntax-violation
'quote
"bad syntax"
- (wrap-4324
- (begin
- (if (if s-4910
- (supports-source-properties? e-4907)
+ (let ((x-5517
+ (begin
+ (if (if s-5493
+ (supports-source-properties? e-5490)
+ #f)
+ (set-source-properties! e-5490 s-5493))
+ e-5490)))
+ (if (if (null? (car w-5492)) (null? (cdr w-5492)) #f)
+ x-5517
+ (if (if (vector? x-5517)
+ (if (= (vector-length x-5517) 4)
+ (eq? (vector-ref x-5517 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-4907 s-4910))
- e-4907)
- w-4909
- mod-4911)))))))
- (global-extend-4293
+ (let ((expression-5549 (vector-ref x-5517 1))
+ (wrap-5550
+ (let ((w2-5558 (vector-ref x-5517 2)))
+ (let ((m1-5559 (car w-5492))
+ (s1-5560 (cdr w-5492)))
+ (if (null? m1-5559)
+ (if (null? s1-5560)
+ w2-5558
+ (cons (car w2-5558)
+ (let ((m2-5575 (cdr w2-5558)))
+ (if (null? m2-5575)
+ s1-5560
+ (append s1-5560 m2-5575)))))
+ (cons (let ((m2-5583 (car w2-5558)))
+ (if (null? m2-5583)
+ m1-5559
+ (append m1-5559 m2-5583)))
+ (let ((m2-5591 (cdr w2-5558)))
+ (if (null? m2-5591)
+ s1-5560
+ (append s1-5560 m2-5591))))))))
+ (module-5551 (vector-ref x-5517 3)))
+ (vector
+ 'syntax-object
+ expression-5549
+ wrap-5550
+ module-5551))
+ (if (null? x-5517)
+ x-5517
+ (vector
+ 'syntax-object
+ x-5517
+ w-5492
+ mod-5494)))))))))))
+ (global-extend-4345
'core
'syntax
(letrec*
- ((gen-syntax-5140
- (lambda (src-5242
- e-5243
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247)
- (if (if (symbol? e-5243)
+ ((gen-syntax-5810
+ (lambda (src-6241
+ e-6242
+ r-6243
+ maps-6244
+ ellipsis?-6245
+ mod-6246)
+ (if (if (symbol? e-6242)
#t
- (if (if (vector? e-5243)
- (if (= (vector-length e-5243) 4)
- (eq? (vector-ref e-5243 0) 'syntax-object)
+ (if (if (vector? e-6242)
+ (if (= (vector-length e-6242) 4)
+ (eq? (vector-ref e-6242 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref e-5243 1))
+ (symbol? (vector-ref e-6242 1))
#f))
- (let ((label-5274 (id-var-name-4314 e-5243 '(()))))
- (let ((b-5275
- (let ((t-5282 (assq label-5274 r-5244)))
- (if t-5282
- (cdr t-5282)
- (if (symbol? label-5274)
- (let ((t-5288
- (get-global-definition-hook-4258
- label-5274
- mod-5247)))
- (if t-5288 t-5288 '(global)))
- '(displaced-lexical))))))
- (if (eq? (car b-5275) 'syntax)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier-4368
+ e-6242
+ '(())
+ r-6243
+ mod-6246
+ #f))
+ (lambda (type-6275 value-6276 mod-6277)
+ (if (eqv? type-6275 'syntax)
(call-with-values
(lambda ()
- (let ((var.lev-5297 (cdr b-5275)))
- (gen-ref-5141
- src-5242
- (car var.lev-5297)
- (cdr var.lev-5297)
- maps-5245)))
- (lambda (var-5301 maps-5302)
- (values (list 'ref var-5301) maps-5302)))
- (if (ellipsis?-5246 e-5243)
+ (gen-ref-5811
+ src-6241
+ (car value-6276)
+ (cdr value-6276)
+ maps-6244))
+ (lambda (var-6285 maps-6286)
+ (values (list 'ref var-6285) maps-6286)))
+ (if (ellipsis?-6245 e-6242)
(syntax-violation
'syntax
"misplaced ellipsis"
- src-5242)
- (values (list 'quote e-5243) maps-5245)))))
- (let ((tmp-5304 ($sc-dispatch e-5243 '(any any))))
- (if (if tmp-5304
+ src-6241)
+ (values (list 'quote e-6242) maps-6244)))))
+ (let ((tmp-6288 ($sc-dispatch e-6242 '(any any))))
+ (if (if tmp-6288
(@apply
- (lambda (dots-5308 e-5309)
- (ellipsis?-5246 dots-5308))
- tmp-5304)
+ (lambda (dots-6292 e-6293)
+ (ellipsis?-6245 dots-6292))
+ tmp-6288)
#f)
(@apply
- (lambda (dots-5310 e-5311)
- (gen-syntax-5140
- src-5242
- e-5311
- r-5244
- maps-5245
- (lambda (x-5312) #f)
- mod-5247))
- tmp-5304)
- (let ((tmp-5313 ($sc-dispatch e-5243 '(any any . any))))
- (if (if tmp-5313
+ (lambda (dots-6294 e-6295)
+ (gen-syntax-5810
+ src-6241
+ e-6295
+ r-6243
+ maps-6244
+ (lambda (x-6296) #f)
+ mod-6246))
+ tmp-6288)
+ (let ((tmp-6297 ($sc-dispatch e-6242 '(any any . any))))
+ (if (if tmp-6297
(@apply
- (lambda (x-5317 dots-5318 y-5319)
- (ellipsis?-5246 dots-5318))
- tmp-5313)
+ (lambda (x-6301 dots-6302 y-6303)
+ (ellipsis?-6245 dots-6302))
+ tmp-6297)
#f)
(@apply
- (lambda (x-5320 dots-5321 y-5322)
+ (lambda (x-6304 dots-6305 y-6306)
(letrec*
- ((f-5323
- (lambda (y-5331 k-5332)
- (let ((tmp-5334
+ ((f-6307
+ (lambda (y-6315 k-6316)
+ (let ((tmp-6318
($sc-dispatch
- y-5331
+ y-6315
'(any . any))))
- (if (if tmp-5334
+ (if (if tmp-6318
(@apply
- (lambda (dots-5338 y-5339)
- (ellipsis?-5246 dots-5338))
- tmp-5334)
+ (lambda (dots-6322 y-6323)
+ (ellipsis?-6245 dots-6322))
+ tmp-6318)
#f)
(@apply
- (lambda (dots-5340 y-5341)
- (f-5323
- y-5341
- (lambda (maps-5342)
+ (lambda (dots-6324 y-6325)
+ (f-6307
+ y-6325
+ (lambda (maps-6326)
(call-with-values
(lambda ()
- (k-5332
- (cons '() maps-5342)))
- (lambda (x-5343 maps-5344)
- (if (null? (car maps-5344))
+ (k-6316
+ (cons '() maps-6326)))
+ (lambda (x-6327 maps-6328)
+ (if (null? (car maps-6328))
(syntax-violation
'syntax
"extra ellipsis"
- src-5242)
+ src-6241)
(values
- (let ((map-env-5348
- (car maps-5344)))
+ (let ((map-env-6332
+ (car maps-6328)))
(list 'apply
'(primitive
append)
- (gen-map-5143
- x-5343
- map-env-5348)))
- (cdr maps-5344))))))))
- tmp-5334)
+ (gen-map-5813
+ x-6327
+ map-env-6332)))
+ (cdr maps-6328))))))))
+ tmp-6318)
(call-with-values
(lambda ()
- (gen-syntax-5140
- src-5242
- y-5331
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (y-5351 maps-5352)
+ (gen-syntax-5810
+ src-6241
+ y-6315
+ r-6243
+ maps-6244
+ ellipsis?-6245
+ mod-6246))
+ (lambda (y-6335 maps-6336)
(call-with-values
- (lambda () (k-5332 maps-5352))
- (lambda (x-5353 maps-5354)
+ (lambda () (k-6316 maps-6336))
+ (lambda (x-6337 maps-6338)
(values
- (if (equal? y-5351 ''())
- x-5353
+ (if (equal? y-6335 ''())
+ x-6337
(list 'append
- x-5353
- y-5351))
- maps-5354))))))))))
- (f-5323
- y-5322
- (lambda (maps-5326)
+ x-6337
+ y-6335))
+ maps-6338))))))))))
+ (f-6307
+ y-6306
+ (lambda (maps-6310)
(call-with-values
(lambda ()
- (gen-syntax-5140
- src-5242
- x-5320
- r-5244
- (cons '() maps-5326)
- ellipsis?-5246
- mod-5247))
- (lambda (x-5327 maps-5328)
- (if (null? (car maps-5328))
+ (gen-syntax-5810
+ src-6241
+ x-6304
+ r-6243
+ (cons '() maps-6310)
+ ellipsis?-6245
+ mod-6246))
+ (lambda (x-6311 maps-6312)
+ (if (null? (car maps-6312))
(syntax-violation
'syntax
"extra ellipsis"
- src-5242)
+ src-6241)
(values
- (gen-map-5143
- x-5327
- (car maps-5328))
- (cdr maps-5328)))))))))
- tmp-5313)
- (let ((tmp-5370 ($sc-dispatch e-5243 '(any . any))))
- (if tmp-5370
+ (gen-map-5813
+ x-6311
+ (car maps-6312))
+ (cdr maps-6312)))))))))
+ tmp-6297)
+ (let ((tmp-6354 ($sc-dispatch e-6242 '(any . any))))
+ (if tmp-6354
(@apply
- (lambda (x-5374 y-5375)
+ (lambda (x-6358 y-6359)
(call-with-values
(lambda ()
- (gen-syntax-5140
- src-5242
- x-5374
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (x-5376 maps-5377)
+ (gen-syntax-5810
+ src-6241
+ x-6358
+ r-6243
+ maps-6244
+ ellipsis?-6245
+ mod-6246))
+ (lambda (x-6360 maps-6361)
(call-with-values
(lambda ()
- (gen-syntax-5140
- src-5242
- y-5375
- r-5244
- maps-5377
- ellipsis?-5246
- mod-5247))
- (lambda (y-5378 maps-5379)
+ (gen-syntax-5810
+ src-6241
+ y-6359
+ r-6243
+ maps-6361
+ ellipsis?-6245
+ mod-6246))
+ (lambda (y-6362 maps-6363)
(values
- (let ((key-5384 (car y-5378)))
- (if (eqv? key-5384 'quote)
- (if (eq? (car x-5376) 'quote)
+ (let ((key-6368 (car y-6362)))
+ (if (eqv? key-6368 'quote)
+ (if (eq? (car x-6360) 'quote)
(list 'quote
- (cons (car (cdr x-5376))
- (car (cdr y-5378))))
- (if (eq? (car (cdr y-5378))
+ (cons (car (cdr x-6360))
+ (car (cdr y-6362))))
+ (if (eq? (car (cdr y-6362))
'())
- (list 'list x-5376)
- (list 'cons x-5376 y-5378)))
- (if (eqv? key-5384 'list)
+ (list 'list x-6360)
+ (list 'cons x-6360 y-6362)))
+ (if (eqv? key-6368 'list)
(cons 'list
- (cons x-5376
- (cdr y-5378)))
- (list 'cons x-5376 y-5378))))
- maps-5379))))))
- tmp-5370)
- (let ((tmp-5413
+ (cons x-6360
+ (cdr y-6362)))
+ (list 'cons x-6360 y-6362))))
+ maps-6363))))))
+ tmp-6354)
+ (let ((tmp-6397
($sc-dispatch
- e-5243
+ e-6242
'#(vector (any . each-any)))))
- (if tmp-5413
+ (if tmp-6397
(@apply
- (lambda (e1-5417 e2-5418)
+ (lambda (e1-6401 e2-6402)
(call-with-values
(lambda ()
- (gen-syntax-5140
- src-5242
- (cons e1-5417 e2-5418)
- r-5244
- maps-5245
- ellipsis?-5246
- mod-5247))
- (lambda (e-5419 maps-5420)
+ (gen-syntax-5810
+ src-6241
+ (cons e1-6401 e2-6402)
+ r-6243
+ maps-6244
+ ellipsis?-6245
+ mod-6246))
+ (lambda (e-6403 maps-6404)
(values
- (if (eq? (car e-5419) 'list)
- (cons 'vector (cdr e-5419))
- (if (eq? (car e-5419) 'quote)
+ (if (eq? (car e-6403) 'list)
+ (cons 'vector (cdr e-6403))
+ (if (eq? (car e-6403) 'quote)
(list 'quote
(list->vector
- (car (cdr e-5419))))
- (list 'list->vector e-5419)))
- maps-5420))))
- tmp-5413)
+ (car (cdr e-6403))))
+ (list 'list->vector e-6403)))
+ maps-6404))))
+ tmp-6397)
(values
- (list 'quote e-5243)
- maps-5245))))))))))))
- (gen-ref-5141
- (lambda (src-5447 var-5448 level-5449 maps-5450)
- (if (= level-5449 0)
- (values var-5448 maps-5450)
- (if (null? maps-5450)
+ (list 'quote e-6242)
+ maps-6244))))))))))))
+ (gen-ref-5811
+ (lambda (src-6431 var-6432 level-6433 maps-6434)
+ (if (= level-6433 0)
+ (values var-6432 maps-6434)
+ (if (null? maps-6434)
(syntax-violation
'syntax
"missing ellipsis"
- src-5447)
+ src-6431)
(call-with-values
(lambda ()
- (gen-ref-5141
- src-5447
- var-5448
- (#{1-}# level-5449)
- (cdr maps-5450)))
- (lambda (outer-var-5451 outer-maps-5452)
- (let ((b-5453 (assq outer-var-5451 (car maps-5450))))
- (if b-5453
- (values (cdr b-5453) maps-5450)
- (let ((inner-var-5455
+ (gen-ref-5811
+ src-6431
+ var-6432
+ (#{1-}# level-6433)
+ (cdr maps-6434)))
+ (lambda (outer-var-6435 outer-maps-6436)
+ (let ((b-6437 (assq outer-var-6435 (car maps-6434))))
+ (if b-6437
+ (values (cdr b-6437) maps-6434)
+ (let ((inner-var-6439
(gensym
(string-append
(symbol->string 'tmp)
"-"))))
(values
- inner-var-5455
- (cons (cons (cons outer-var-5451 inner-var-5455)
- (car maps-5450))
- outer-maps-5452)))))))))))
- (gen-map-5143
- (lambda (e-5469 map-env-5470)
- (let ((formals-5471 (map cdr map-env-5470))
- (actuals-5472
- (map (lambda (x-5474) (list 'ref (car x-5474)))
- map-env-5470)))
- (if (eq? (car e-5469) 'ref)
- (car actuals-5472)
+ inner-var-6439
+ (cons (cons (cons outer-var-6435 inner-var-6439)
+ (car maps-6434))
+ outer-maps-6436)))))))))))
+ (gen-map-5813
+ (lambda (e-6453 map-env-6454)
+ (let ((formals-6455 (map cdr map-env-6454))
+ (actuals-6456
+ (map (lambda (x-6458) (list 'ref (car x-6458)))
+ map-env-6454)))
+ (if (eq? (car e-6453) 'ref)
+ (car actuals-6456)
(if (and-map
- (lambda (x-5475)
- (if (eq? (car x-5475) 'ref)
- (memq (car (cdr x-5475)) formals-5471)
+ (lambda (x-6459)
+ (if (eq? (car x-6459) 'ref)
+ (memq (car (cdr x-6459)) formals-6455)
#f))
- (cdr e-5469))
+ (cdr e-6453))
(cons 'map
- (cons (list 'primitive (car e-5469))
- (map (let ((r-5477
+ (cons (list 'primitive (car e-6453))
+ (map (let ((r-6461
(map cons
- formals-5471
- actuals-5472)))
- (lambda (x-5478)
- (cdr (assq (car (cdr x-5478))
- r-5477))))
- (cdr e-5469))))
+ formals-6455
+ actuals-6456)))
+ (lambda (x-6462)
+ (cdr (assq (car (cdr x-6462))
+ r-6461))))
+ (cdr e-6453))))
(cons 'map
- (cons (list 'lambda formals-5471 e-5469)
- actuals-5472)))))))
- (regen-5147
- (lambda (x-5480)
- (let ((key-5481 (car x-5480)))
- (if (eqv? key-5481 'ref)
- (let ((name-5491 (car (cdr x-5480)))
- (var-5492 (car (cdr x-5480))))
+ (cons (list 'lambda formals-6455 e-6453)
+ actuals-6456)))))))
+ (regen-5817
+ (lambda (x-6464)
+ (let ((key-6465 (car x-6464)))
+ (if (eqv? key-6465 'ref)
+ (let ((name-6475 (car (cdr x-6464)))
+ (var-6476 (car (cdr x-6464))))
(make-struct/no-tail
(vector-ref %expanded-vtables 3)
#f
- name-5491
- var-5492))
- (if (eqv? key-5481 'primitive)
- (let ((name-5504 (car (cdr x-5480))))
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- name-5504)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- name-5504
- #f)))
- (if (eqv? key-5481 'quote)
- (let ((exp-5522 (car (cdr x-5480))))
+ name-6475
+ var-6476))
+ (if (eqv? key-6465 'primitive)
+ (let ((name-6487 (car (cdr x-6464))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 2)
+ #f
+ name-6487))
+ (if (eqv? key-6465 'quote)
+ (let ((exp-6498 (car (cdr x-6464))))
(make-struct/no-tail
(vector-ref %expanded-vtables 1)
#f
- exp-5522))
- (if (eqv? key-5481 'lambda)
- (if (list? (car (cdr x-5480)))
- (let ((req-5533 (car (cdr x-5480)))
- (vars-5535 (car (cdr x-5480)))
- (exp-5537
- (regen-5147 (car (cdr (cdr x-5480))))))
- (let ((body-5542
+ exp-6498))
+ (if (eqv? key-6465 'lambda)
+ (if (list? (car (cdr x-6464)))
+ (let ((req-6509 (car (cdr x-6464)))
+ (vars-6511 (car (cdr x-6464)))
+ (exp-6513
+ (regen-5817 (car (cdr (cdr x-6464))))))
+ (let ((body-6518
(make-struct/no-tail
- (vector-ref %expanded-vtables 14)
+ (vector-ref %expanded-vtables 15)
#f
- req-5533
+ req-6509
#f
#f
#f
'()
- vars-5535
- exp-5537
+ vars-6511
+ exp-6513
#f)))
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
+ (vector-ref %expanded-vtables 14)
#f
'()
- body-5542)))
- (error "how did we get here" x-5480))
- (let ((fun-exp-5558
- (let ((name-5567 (car x-5480)))
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- name-5567)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- name-5567
- #f))))
- (arg-exps-5559 (map regen-5147 (cdr x-5480))))
+ body-6518)))
+ (error "how did we get here" x-6464))
+ (let ((name-6534 (car x-6464))
+ (args-6535 (map regen-5817 (cdr x-6464))))
(make-struct/no-tail
- (vector-ref %expanded-vtables 11)
+ (vector-ref %expanded-vtables 12)
#f
- fun-exp-5558
- arg-exps-5559))))))))))
- (lambda (e-5148 r-5149 w-5150 s-5151 mod-5152)
- (let ((e-5153
- (wrap-4324
- (begin
- (if (if s-5151
- (supports-source-properties? e-5148)
+ name-6534
+ args-6535))))))))))
+ (lambda (e-5818 r-5819 w-5820 s-5821 mod-5822)
+ (let ((e-5823
+ (let ((x-6152
+ (begin
+ (if (if s-5821
+ (supports-source-properties? e-5818)
+ #f)
+ (set-source-properties! e-5818 s-5821))
+ e-5818)))
+ (if (if (null? (car w-5820)) (null? (cdr w-5820)) #f)
+ x-6152
+ (if (if (vector? x-6152)
+ (if (= (vector-length x-6152) 4)
+ (eq? (vector-ref x-6152 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-5148 s-5151))
- e-5148)
- w-5150
- mod-5152)))
- (let ((tmp-5155 ($sc-dispatch e-5153 '(_ any))))
- (if tmp-5155
- (@apply
- (lambda (x-5180)
- (call-with-values
- (lambda ()
- (gen-syntax-5140
- e-5153
- x-5180
- r-5149
- '()
- ellipsis?-4339
- mod-5152))
- (lambda (e-5234 maps-5235) (regen-5147 e-5234))))
- tmp-5155)
- (syntax-violation
- 'syntax
- "bad `syntax' form"
- e-5153)))))))
- (global-extend-4293
+ (let ((expression-6184 (vector-ref x-6152 1))
+ (wrap-6185
+ (let ((w2-6193 (vector-ref x-6152 2)))
+ (let ((m1-6194 (car w-5820))
+ (s1-6195 (cdr w-5820)))
+ (if (null? m1-6194)
+ (if (null? s1-6195)
+ w2-6193
+ (cons (car w2-6193)
+ (let ((m2-6210 (cdr w2-6193)))
+ (if (null? m2-6210)
+ s1-6195
+ (append
+ s1-6195
+ m2-6210)))))
+ (cons (let ((m2-6218 (car w2-6193)))
+ (if (null? m2-6218)
+ m1-6194
+ (append m1-6194 m2-6218)))
+ (let ((m2-6226 (cdr w2-6193)))
+ (if (null? m2-6226)
+ s1-6195
+ (append
+ s1-6195
+ m2-6226))))))))
+ (module-6186 (vector-ref x-6152 3)))
+ (vector
+ 'syntax-object
+ expression-6184
+ wrap-6185
+ module-6186))
+ (if (null? x-6152)
+ x-6152
+ (vector
+ 'syntax-object
+ x-6152
+ w-5820
+ mod-5822)))))))
+ (let ((tmp-5824 e-5823))
+ (let ((tmp-5825 ($sc-dispatch tmp-5824 '(_ any))))
+ (if tmp-5825
+ (@apply
+ (lambda (x-5873)
+ (call-with-values
+ (lambda ()
+ (gen-syntax-5810
+ e-5823
+ x-5873
+ r-5819
+ '()
+ ellipsis?-4391
+ mod-5822))
+ (lambda (e-5950 maps-5951) (regen-5817 e-5950))))
+ tmp-5825)
+ (syntax-violation
+ 'syntax
+ "bad `syntax' form"
+ e-5823))))))))
+ (global-extend-4345
'core
'lambda
- (lambda (e-5755 r-5756 w-5757 s-5758 mod-5759)
- (let ((tmp-5761
- ($sc-dispatch e-5755 '(_ any any . each-any))))
- (if tmp-5761
+ (lambda (e-6763 r-6764 w-6765 s-6766 mod-6767)
+ (let ((tmp-6769
+ ($sc-dispatch e-6763 '(_ any any . each-any))))
+ (if tmp-6769
(@apply
- (lambda (args-5765 e1-5766 e2-5767)
+ (lambda (args-6773 e1-6774 e2-6775)
(call-with-values
- (lambda () (lambda-formals-4340 args-5765))
- (lambda (req-5770 opt-5771 rest-5772 kw-5773)
+ (lambda () (lambda-formals-4392 args-6773))
+ (lambda (req-6778 opt-6779 rest-6780 kw-6781)
(letrec*
- ((lp-5774
- (lambda (body-5777 meta-5778)
- (let ((tmp-5780
+ ((lp-6782
+ (lambda (body-6785 meta-6786)
+ (let ((tmp-6788
($sc-dispatch
- body-5777
+ body-6785
'(any any . each-any))))
- (if (if tmp-5780
+ (if (if tmp-6788
(@apply
- (lambda (docstring-5784 e1-5785 e2-5786)
+ (lambda (docstring-6792 e1-6793 e2-6794)
(string?
- (syntax->datum docstring-5784)))
- tmp-5780)
+ (syntax->datum docstring-6792)))
+ tmp-6788)
#f)
(@apply
- (lambda (docstring-5787 e1-5788 e2-5789)
- (lp-5774
- (cons e1-5788 e2-5789)
+ (lambda (docstring-6795 e1-6796 e2-6797)
+ (lp-6782
+ (cons e1-6796 e2-6797)
(append
- meta-5778
+ meta-6786
(list (cons 'documentation
(syntax->datum
- docstring-5787))))))
- tmp-5780)
- (let ((tmp-5790
+ docstring-6795))))))
+ tmp-6788)
+ (let ((tmp-6798
($sc-dispatch
- body-5777
+ body-6785
'(#(vector #(each (any . any)))
any
.
each-any))))
- (if tmp-5790
+ (if tmp-6798
(@apply
- (lambda (k-5794 v-5795 e1-5796 e2-5797)
- (lp-5774
- (cons e1-5796 e2-5797)
+ (lambda (k-6802 v-6803 e1-6804 e2-6805)
+ (lp-6782
+ (cons e1-6804 e2-6805)
(append
- meta-5778
+ meta-6786
(syntax->datum
- (map cons k-5794 v-5795)))))
- tmp-5790)
- (expand-simple-lambda-4341
- e-5755
- r-5756
- w-5757
- s-5758
- mod-5759
- req-5770
- rest-5772
- meta-5778
- body-5777))))))))
- (lp-5774 (cons e1-5766 e2-5767) '())))))
- tmp-5761)
- (syntax-violation 'lambda "bad lambda" e-5755)))))
- (global-extend-4293
+ (map cons k-6802 v-6803)))))
+ tmp-6798)
+ (expand-simple-lambda-4393
+ e-6763
+ r-6764
+ w-6765
+ s-6766
+ mod-6767
+ req-6778
+ rest-6780
+ meta-6786
+ body-6785))))))))
+ (lp-6782 (cons e1-6774 e2-6775) '())))))
+ tmp-6769)
+ (syntax-violation 'lambda "bad lambda" e-6763)))))
+ (global-extend-4345
'core
'lambda*
- (lambda (e-6086 r-6087 w-6088 s-6089 mod-6090)
- (let ((tmp-6092
- ($sc-dispatch e-6086 '(_ any any . each-any))))
- (if tmp-6092
+ (lambda (e-7177 r-7178 w-7179 s-7180 mod-7181)
+ (let ((tmp-7183
+ ($sc-dispatch e-7177 '(_ any any . each-any))))
+ (if tmp-7183
(@apply
- (lambda (args-6096 e1-6097 e2-6098)
+ (lambda (args-7187 e1-7188 e2-7189)
(call-with-values
(lambda ()
- (expand-lambda-case-4343
- e-6086
- r-6087
- w-6088
- s-6089
- mod-6090
- lambda*-formals-4342
- (list (cons args-6096 (cons e1-6097 e2-6098)))))
- (lambda (meta-6101 lcase-6102)
+ (expand-lambda-case-4395
+ e-7177
+ r-7178
+ w-7179
+ s-7180
+ mod-7181
+ lambda*-formals-4394
+ (list (cons args-7187 (cons e1-7188 e2-7189)))))
+ (lambda (meta-7192 lcase-7193)
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6089
- meta-6101
- lcase-6102))))
- tmp-6092)
- (syntax-violation 'lambda "bad lambda*" e-6086)))))
- (global-extend-4293
+ (vector-ref %expanded-vtables 14)
+ s-7180
+ meta-7192
+ lcase-7193))))
+ tmp-7183)
+ (syntax-violation 'lambda "bad lambda*" e-7177)))))
+ (global-extend-4345
'core
'case-lambda
- (lambda (e-6272 r-6273 w-6274 s-6275 mod-6276)
- (let ((tmp-6278
+ (lambda (e-7356 r-7357 w-7358 s-7359 mod-7360)
+ (let ((tmp-7362
($sc-dispatch
- e-6272
+ e-7356
'(_ (any any . each-any)
.
#(each (any any . each-any))))))
- (if tmp-6278
+ (if tmp-7362
(@apply
- (lambda (args-6282
- e1-6283
- e2-6284
- args*-6285
- e1*-6286
- e2*-6287)
+ (lambda (args-7366
+ e1-7367
+ e2-7368
+ args*-7369
+ e1*-7370
+ e2*-7371)
(call-with-values
(lambda ()
- (expand-lambda-case-4343
- e-6272
- r-6273
- w-6274
- s-6275
- mod-6276
- lambda-formals-4340
- (cons (cons args-6282 (cons e1-6283 e2-6284))
- (map (lambda (tmp-3270-6290
- tmp-3269-6291
- tmp-3268-6292)
- (cons tmp-3268-6292
- (cons tmp-3269-6291 tmp-3270-6290)))
- e2*-6287
- e1*-6286
- args*-6285))))
- (lambda (meta-6293 lcase-6294)
+ (expand-lambda-case-4395
+ e-7356
+ r-7357
+ w-7358
+ s-7359
+ mod-7360
+ lambda-formals-4392
+ (cons (cons args-7366 (cons e1-7367 e2-7368))
+ (map (lambda (tmp-3330-7374
+ tmp-3329-7375
+ tmp-3328-7376)
+ (cons tmp-3328-7376
+ (cons tmp-3329-7375 tmp-3330-7374)))
+ e2*-7371
+ e1*-7370
+ args*-7369))))
+ (lambda (meta-7377 lcase-7378)
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6275
- meta-6293
- lcase-6294))))
- tmp-6278)
+ (vector-ref %expanded-vtables 14)
+ s-7359
+ meta-7377
+ lcase-7378))))
+ tmp-7362)
(syntax-violation
'case-lambda
"bad case-lambda"
- e-6272)))))
- (global-extend-4293
+ e-7356)))))
+ (global-extend-4345
'core
'case-lambda*
- (lambda (e-6456 r-6457 w-6458 s-6459 mod-6460)
- (let ((tmp-6462
+ (lambda (e-7547 r-7548 w-7549 s-7550 mod-7551)
+ (let ((tmp-7553
($sc-dispatch
- e-6456
+ e-7547
'(_ (any any . each-any)
.
#(each (any any . each-any))))))
- (if tmp-6462
+ (if tmp-7553
(@apply
- (lambda (args-6466
- e1-6467
- e2-6468
- args*-6469
- e1*-6470
- e2*-6471)
+ (lambda (args-7557
+ e1-7558
+ e2-7559
+ args*-7560
+ e1*-7561
+ e2*-7562)
(call-with-values
(lambda ()
- (expand-lambda-case-4343
- e-6456
- r-6457
- w-6458
- s-6459
- mod-6460
- lambda*-formals-4342
- (cons (cons args-6466 (cons e1-6467 e2-6468))
- (map (lambda (tmp-3305-6474
- tmp-3304-6475
- tmp-3303-6476)
- (cons tmp-3303-6476
- (cons tmp-3304-6475 tmp-3305-6474)))
- e2*-6471
- e1*-6470
- args*-6469))))
- (lambda (meta-6477 lcase-6478)
+ (expand-lambda-case-4395
+ e-7547
+ r-7548
+ w-7549
+ s-7550
+ mod-7551
+ lambda*-formals-4394
+ (cons (cons args-7557 (cons e1-7558 e2-7559))
+ (map (lambda (tmp-3365-7565
+ tmp-3364-7566
+ tmp-3363-7567)
+ (cons tmp-3363-7567
+ (cons tmp-3364-7566 tmp-3365-7565)))
+ e2*-7562
+ e1*-7561
+ args*-7560))))
+ (lambda (meta-7568 lcase-7569)
(make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- s-6459
- meta-6477
- lcase-6478))))
- tmp-6462)
+ (vector-ref %expanded-vtables 14)
+ s-7550
+ meta-7568
+ lcase-7569))))
+ tmp-7553)
(syntax-violation
'case-lambda
"bad case-lambda*"
- e-6456)))))
- (global-extend-4293
+ e-7547)))))
+ (global-extend-4345
'core
'let
(letrec*
- ((expand-let-6669
- (lambda (e-6818
- r-6819
- w-6820
- s-6821
- mod-6822
- constructor-6823
- ids-6824
- vals-6825
- exps-6826)
- (if (not (valid-bound-ids?-4321 ids-6824))
+ ((expand-let-7777
+ (lambda (e-7987
+ r-7988
+ w-7989
+ s-7990
+ mod-7991
+ constructor-7992
+ ids-7993
+ vals-7994
+ exps-7995)
+ (if (not (valid-bound-ids?-4373 ids-7993))
(syntax-violation
'let
"duplicate bound variable"
- e-6818)
- (let ((labels-6904 (gen-labels-4298 ids-6824))
- (new-vars-6905 (map gen-var-4345 ids-6824)))
- (let ((nw-6906
- (make-binding-wrap-4309
- ids-6824
- labels-6904
- w-6820))
- (nr-6907
- (extend-var-env-4290
- labels-6904
- new-vars-6905
- r-6819)))
- (constructor-6823
- s-6821
- (map syntax->datum ids-6824)
- new-vars-6905
- (map (lambda (x-6924)
- (expand-4331 x-6924 r-6819 w-6820 mod-6822))
- vals-6825)
- (expand-body-4335
- exps-6826
- (source-wrap-4325 e-6818 nw-6906 s-6821 mod-6822)
- nr-6907
- nw-6906
- mod-6822))))))))
- (lambda (e-6670 r-6671 w-6672 s-6673 mod-6674)
- (let ((tmp-6676
+ e-7987)
+ (let ((labels-8080 (gen-labels-4350 ids-7993))
+ (new-vars-8081 (map gen-var-4397 ids-7993)))
+ (let ((nw-8082
+ (make-binding-wrap-4361
+ ids-7993
+ labels-8080
+ w-7989))
+ (nr-8083
+ (extend-var-env-4343
+ labels-8080
+ new-vars-8081
+ r-7988)))
+ (constructor-7992
+ s-7990
+ (map syntax->datum ids-7993)
+ new-vars-8081
+ (map (lambda (x-8100)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ x-8100
+ r-7988
+ w-7989
+ (let ((props-8116
+ (source-properties
+ (if (if (vector? x-8100)
+ (if (= (vector-length
+ x-8100)
+ 4)
+ (eq? (vector-ref
+ x-8100
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-8100 1)
+ x-8100))))
+ (if (pair? props-8116) props-8116 #f))
+ #f
+ mod-7991
+ #f))
+ (lambda (type-8149
+ value-8150
+ form-8151
+ e-8152
+ w-8153
+ s-8154
+ mod-8155)
+ (expand-expr-4384
+ type-8149
+ value-8150
+ form-8151
+ e-8152
+ r-7988
+ w-8153
+ s-8154
+ mod-8155))))
+ vals-7994)
+ (expand-body-4387
+ exps-7995
+ (source-wrap-4377 e-7987 nw-8082 s-7990 mod-7991)
+ nr-8083
+ nw-8082
+ mod-7991))))))))
+ (lambda (e-7778 r-7779 w-7780 s-7781 mod-7782)
+ (let ((tmp-7784
($sc-dispatch
- e-6670
+ e-7778
'(_ #(each (any any)) any . each-any))))
- (if (if tmp-6676
+ (if (if tmp-7784
(@apply
- (lambda (id-6680 val-6681 e1-6682 e2-6683)
- (and-map id?-4295 id-6680))
- tmp-6676)
+ (lambda (id-7788 val-7789 e1-7790 e2-7791)
+ (and-map id?-4347 id-7788))
+ tmp-7784)
#f)
(@apply
- (lambda (id-6699 val-6700 e1-6701 e2-6702)
- (expand-let-6669
- e-6670
- r-6671
- w-6672
- s-6673
- mod-6674
- build-let-4277
- id-6699
- val-6700
- (cons e1-6701 e2-6702)))
- tmp-6676)
- (let ((tmp-6732
+ (lambda (id-7807 val-7808 e1-7809 e2-7810)
+ (expand-let-7777
+ e-7778
+ r-7779
+ w-7780
+ s-7781
+ mod-7782
+ (lambda (src-7814
+ ids-7815
+ vars-7816
+ val-exps-7817
+ body-exp-7818)
+ (begin
+ (for-each
+ maybe-name-value!-4312
+ ids-7815
+ val-exps-7817)
+ (if (null? vars-7816)
+ body-exp-7818
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 16)
+ src-7814
+ ids-7815
+ vars-7816
+ val-exps-7817
+ body-exp-7818))))
+ id-7807
+ val-7808
+ (cons e1-7809 e2-7810)))
+ tmp-7784)
+ (let ((tmp-7825
($sc-dispatch
- e-6670
+ e-7778
'(_ any #(each (any any)) any . each-any))))
- (if (if tmp-6732
+ (if (if tmp-7825
(@apply
- (lambda (f-6736 id-6737 val-6738 e1-6739 e2-6740)
- (if (if (symbol? f-6736)
+ (lambda (f-7829 id-7830 val-7831 e1-7832 e2-7833)
+ (if (if (symbol? f-7829)
#t
- (if (if (vector? f-6736)
- (if (= (vector-length f-6736) 4)
- (eq? (vector-ref f-6736 0)
+ (if (if (vector? f-7829)
+ (if (= (vector-length f-7829) 4)
+ (eq? (vector-ref f-7829 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref f-6736 1))
+ (symbol? (vector-ref f-7829 1))
#f))
- (and-map id?-4295 id-6737)
+ (and-map id?-4347 id-7830)
#f))
- tmp-6732)
+ tmp-7825)
#f)
(@apply
- (lambda (f-6782 id-6783 val-6784 e1-6785 e2-6786)
- (expand-let-6669
- e-6670
- r-6671
- w-6672
- s-6673
- mod-6674
- build-named-let-4278
- (cons f-6782 id-6783)
- val-6784
- (cons e1-6785 e2-6786)))
- tmp-6732)
+ (lambda (f-7875 id-7876 val-7877 e1-7878 e2-7879)
+ (expand-let-7777
+ e-7778
+ r-7779
+ w-7780
+ s-7781
+ mod-7782
+ build-named-let-4331
+ (cons f-7875 id-7876)
+ val-7877
+ (cons e1-7878 e2-7879)))
+ tmp-7825)
(syntax-violation
'let
"bad let"
- (wrap-4324
- (begin
- (if (if s-6673
- (supports-source-properties? e-6670)
+ (let ((x-7892
+ (begin
+ (if (if s-7781
+ (supports-source-properties? e-7778)
+ #f)
+ (set-source-properties! e-7778 s-7781))
+ e-7778)))
+ (if (if (null? (car w-7780)) (null? (cdr w-7780)) #f)
+ x-7892
+ (if (if (vector? x-7892)
+ (if (= (vector-length x-7892) 4)
+ (eq? (vector-ref x-7892 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-6670 s-6673))
- e-6670)
- w-6672
- mod-6674)))))))))
- (global-extend-4293
+ (let ((expression-7924 (vector-ref x-7892 1))
+ (wrap-7925
+ (let ((w2-7933 (vector-ref x-7892 2)))
+ (let ((m1-7934 (car w-7780))
+ (s1-7935 (cdr w-7780)))
+ (if (null? m1-7934)
+ (if (null? s1-7935)
+ w2-7933
+ (cons (car w2-7933)
+ (let ((m2-7950
+ (cdr w2-7933)))
+ (if (null? m2-7950)
+ s1-7935
+ (append
+ s1-7935
+ m2-7950)))))
+ (cons (let ((m2-7958 (car w2-7933)))
+ (if (null? m2-7958)
+ m1-7934
+ (append m1-7934 m2-7958)))
+ (let ((m2-7966 (cdr w2-7933)))
+ (if (null? m2-7966)
+ s1-7935
+ (append
+ s1-7935
+ m2-7966))))))))
+ (module-7926 (vector-ref x-7892 3)))
+ (vector
+ 'syntax-object
+ expression-7924
+ wrap-7925
+ module-7926))
+ (if (null? x-7892)
+ x-7892
+ (vector
+ 'syntax-object
+ x-7892
+ w-7780
+ mod-7782)))))))))))))
+ (global-extend-4345
'core
'letrec
- (lambda (e-7336 r-7337 w-7338 s-7339 mod-7340)
- (let ((tmp-7342
+ (lambda (e-8511 r-8512 w-8513 s-8514 mod-8515)
+ (let ((tmp-8517
($sc-dispatch
- e-7336
+ e-8511
'(_ #(each (any any)) any . each-any))))
- (if (if tmp-7342
+ (if (if tmp-8517
(@apply
- (lambda (id-7346 val-7347 e1-7348 e2-7349)
- (and-map id?-4295 id-7346))
- tmp-7342)
+ (lambda (id-8521 val-8522 e1-8523 e2-8524)
+ (and-map id?-4347 id-8521))
+ tmp-8517)
#f)
(@apply
- (lambda (id-7365 val-7366 e1-7367 e2-7368)
- (if (not (valid-bound-ids?-4321 id-7365))
+ (lambda (id-8540 val-8541 e1-8542 e2-8543)
+ (if (not (valid-bound-ids?-4373 id-8540))
(syntax-violation
'letrec
"duplicate bound variable"
- e-7336)
- (let ((labels-7458 (gen-labels-4298 id-7365))
- (new-vars-7459 (map gen-var-4345 id-7365)))
- (let ((w-7460
- (make-binding-wrap-4309
- id-7365
- labels-7458
- w-7338))
- (r-7461
- (extend-var-env-4290
- labels-7458
- new-vars-7459
- r-7337)))
- (build-letrec-4279
- s-7339
+ e-8511)
+ (let ((labels-8640 (gen-labels-4350 id-8540))
+ (new-vars-8641 (map gen-var-4397 id-8540)))
+ (let ((w-8642
+ (make-binding-wrap-4361
+ id-8540
+ labels-8640
+ w-8513))
+ (r-8643
+ (extend-var-env-4343
+ labels-8640
+ new-vars-8641
+ r-8512)))
+ (build-letrec-4332
+ s-8514
#f
- (map syntax->datum id-7365)
- new-vars-7459
- (map (lambda (x-7546)
- (expand-4331 x-7546 r-7461 w-7460 mod-7340))
- val-7366)
- (expand-body-4335
- (cons e1-7367 e2-7368)
- (wrap-4324
- (begin
- (if (if s-7339
- (supports-source-properties? e-7336)
+ (map syntax->datum id-8540)
+ new-vars-8641
+ (map (lambda (x-8720)
+ (expand-4383 x-8720 r-8643 w-8642 mod-8515))
+ val-8541)
+ (expand-body-4387
+ (cons e1-8542 e2-8543)
+ (let ((x-8782
+ (begin
+ (if (if s-8514
+ (supports-source-properties?
+ e-8511)
+ #f)
+ (set-source-properties! e-8511 s-8514))
+ e-8511)))
+ (if (if (null? (car w-8642))
+ (null? (cdr w-8642))
+ #f)
+ x-8782
+ (if (if (vector? x-8782)
+ (if (= (vector-length x-8782) 4)
+ (eq? (vector-ref x-8782 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-7336 s-7339))
- e-7336)
- w-7460
- mod-7340)
- r-7461
- w-7460
- mod-7340))))))
- tmp-7342)
+ (let ((expression-8814 (vector-ref x-8782 1))
+ (wrap-8815
+ (let ((w2-8823
+ (vector-ref x-8782 2)))
+ (let ((m1-8824 (car w-8642))
+ (s1-8825 (cdr w-8642)))
+ (if (null? m1-8824)
+ (if (null? s1-8825)
+ w2-8823
+ (cons (car w2-8823)
+ (let ((m2-8840
+ (cdr w2-8823)))
+ (if (null? m2-8840)
+ s1-8825
+ (append
+ s1-8825
+ m2-8840)))))
+ (cons (let ((m2-8848
+ (car w2-8823)))
+ (if (null? m2-8848)
+ m1-8824
+ (append
+ m1-8824
+ m2-8848)))
+ (let ((m2-8856
+ (cdr w2-8823)))
+ (if (null? m2-8856)
+ s1-8825
+ (append
+ s1-8825
+ m2-8856))))))))
+ (module-8816 (vector-ref x-8782 3)))
+ (vector
+ 'syntax-object
+ expression-8814
+ wrap-8815
+ module-8816))
+ (if (null? x-8782)
+ x-8782
+ (vector
+ 'syntax-object
+ x-8782
+ w-8642
+ mod-8515)))))
+ r-8643
+ w-8642
+ mod-8515))))))
+ tmp-8517)
(syntax-violation
'letrec
"bad letrec"
- (wrap-4324
- (begin
- (if (if s-7339
- (supports-source-properties? e-7336)
+ (let ((x-9067
+ (begin
+ (if (if s-8514
+ (supports-source-properties? e-8511)
+ #f)
+ (set-source-properties! e-8511 s-8514))
+ e-8511)))
+ (if (if (null? (car w-8513)) (null? (cdr w-8513)) #f)
+ x-9067
+ (if (if (vector? x-9067)
+ (if (= (vector-length x-9067) 4)
+ (eq? (vector-ref x-9067 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-7336 s-7339))
- e-7336)
- w-7338
- mod-7340))))))
- (global-extend-4293
+ (let ((expression-9099 (vector-ref x-9067 1))
+ (wrap-9100
+ (let ((w2-9108 (vector-ref x-9067 2)))
+ (let ((m1-9109 (car w-8513))
+ (s1-9110 (cdr w-8513)))
+ (if (null? m1-9109)
+ (if (null? s1-9110)
+ w2-9108
+ (cons (car w2-9108)
+ (let ((m2-9125 (cdr w2-9108)))
+ (if (null? m2-9125)
+ s1-9110
+ (append s1-9110 m2-9125)))))
+ (cons (let ((m2-9133 (car w2-9108)))
+ (if (null? m2-9133)
+ m1-9109
+ (append m1-9109 m2-9133)))
+ (let ((m2-9141 (cdr w2-9108)))
+ (if (null? m2-9141)
+ s1-9110
+ (append s1-9110 m2-9141))))))))
+ (module-9101 (vector-ref x-9067 3)))
+ (vector
+ 'syntax-object
+ expression-9099
+ wrap-9100
+ module-9101))
+ (if (null? x-9067)
+ x-9067
+ (vector 'syntax-object x-9067 w-8513 mod-8515))))))))))
+ (global-extend-4345
'core
'letrec*
- (lambda (e-7941 r-7942 w-7943 s-7944 mod-7945)
- (let ((tmp-7947
+ (lambda (e-9292 r-9293 w-9294 s-9295 mod-9296)
+ (let ((tmp-9298
($sc-dispatch
- e-7941
+ e-9292
'(_ #(each (any any)) any . each-any))))
- (if (if tmp-7947
+ (if (if tmp-9298
(@apply
- (lambda (id-7951 val-7952 e1-7953 e2-7954)
- (and-map id?-4295 id-7951))
- tmp-7947)
+ (lambda (id-9302 val-9303 e1-9304 e2-9305)
+ (and-map id?-4347 id-9302))
+ tmp-9298)
#f)
(@apply
- (lambda (id-7970 val-7971 e1-7972 e2-7973)
- (if (not (valid-bound-ids?-4321 id-7970))
+ (lambda (id-9321 val-9322 e1-9323 e2-9324)
+ (if (not (valid-bound-ids?-4373 id-9321))
(syntax-violation
'letrec*
"duplicate bound variable"
- e-7941)
- (let ((labels-8063 (gen-labels-4298 id-7970))
- (new-vars-8064 (map gen-var-4345 id-7970)))
- (let ((w-8065
- (make-binding-wrap-4309
- id-7970
- labels-8063
- w-7943))
- (r-8066
- (extend-var-env-4290
- labels-8063
- new-vars-8064
- r-7942)))
- (build-letrec-4279
- s-7944
+ e-9292)
+ (let ((labels-9421 (gen-labels-4350 id-9321))
+ (new-vars-9422 (map gen-var-4397 id-9321)))
+ (let ((w-9423
+ (make-binding-wrap-4361
+ id-9321
+ labels-9421
+ w-9294))
+ (r-9424
+ (extend-var-env-4343
+ labels-9421
+ new-vars-9422
+ r-9293)))
+ (build-letrec-4332
+ s-9295
#t
- (map syntax->datum id-7970)
- new-vars-8064
- (map (lambda (x-8151)
- (expand-4331 x-8151 r-8066 w-8065 mod-7945))
- val-7971)
- (expand-body-4335
- (cons e1-7972 e2-7973)
- (wrap-4324
- (begin
- (if (if s-7944
- (supports-source-properties? e-7941)
+ (map syntax->datum id-9321)
+ new-vars-9422
+ (map (lambda (x-9501)
+ (expand-4383 x-9501 r-9424 w-9423 mod-9296))
+ val-9322)
+ (expand-body-4387
+ (cons e1-9323 e2-9324)
+ (let ((x-9563
+ (begin
+ (if (if s-9295
+ (supports-source-properties?
+ e-9292)
+ #f)
+ (set-source-properties! e-9292 s-9295))
+ e-9292)))
+ (if (if (null? (car w-9423))
+ (null? (cdr w-9423))
+ #f)
+ x-9563
+ (if (if (vector? x-9563)
+ (if (= (vector-length x-9563) 4)
+ (eq? (vector-ref x-9563 0)
+ 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-7941 s-7944))
- e-7941)
- w-8065
- mod-7945)
- r-8066
- w-8065
- mod-7945))))))
- tmp-7947)
+ (let ((expression-9595 (vector-ref x-9563 1))
+ (wrap-9596
+ (let ((w2-9604
+ (vector-ref x-9563 2)))
+ (let ((m1-9605 (car w-9423))
+ (s1-9606 (cdr w-9423)))
+ (if (null? m1-9605)
+ (if (null? s1-9606)
+ w2-9604
+ (cons (car w2-9604)
+ (let ((m2-9621
+ (cdr w2-9604)))
+ (if (null? m2-9621)
+ s1-9606
+ (append
+ s1-9606
+ m2-9621)))))
+ (cons (let ((m2-9629
+ (car w2-9604)))
+ (if (null? m2-9629)
+ m1-9605
+ (append
+ m1-9605
+ m2-9629)))
+ (let ((m2-9637
+ (cdr w2-9604)))
+ (if (null? m2-9637)
+ s1-9606
+ (append
+ s1-9606
+ m2-9637))))))))
+ (module-9597 (vector-ref x-9563 3)))
+ (vector
+ 'syntax-object
+ expression-9595
+ wrap-9596
+ module-9597))
+ (if (null? x-9563)
+ x-9563
+ (vector
+ 'syntax-object
+ x-9563
+ w-9423
+ mod-9296)))))
+ r-9424
+ w-9423
+ mod-9296))))))
+ tmp-9298)
(syntax-violation
'letrec*
"bad letrec*"
- (wrap-4324
- (begin
- (if (if s-7944
- (supports-source-properties? e-7941)
+ (let ((x-9848
+ (begin
+ (if (if s-9295
+ (supports-source-properties? e-9292)
+ #f)
+ (set-source-properties! e-9292 s-9295))
+ e-9292)))
+ (if (if (null? (car w-9294)) (null? (cdr w-9294)) #f)
+ x-9848
+ (if (if (vector? x-9848)
+ (if (= (vector-length x-9848) 4)
+ (eq? (vector-ref x-9848 0) 'syntax-object)
+ #f)
#f)
- (set-source-properties! e-7941 s-7944))
- e-7941)
- w-7943
- mod-7945))))))
- (global-extend-4293
+ (let ((expression-9880 (vector-ref x-9848 1))
+ (wrap-9881
+ (let ((w2-9889 (vector-ref x-9848 2)))
+ (let ((m1-9890 (car w-9294))
+ (s1-9891 (cdr w-9294)))
+ (if (null? m1-9890)
+ (if (null? s1-9891)
+ w2-9889
+ (cons (car w2-9889)
+ (let ((m2-9906 (cdr w2-9889)))
+ (if (null? m2-9906)
+ s1-9891
+ (append s1-9891 m2-9906)))))
+ (cons (let ((m2-9914 (car w2-9889)))
+ (if (null? m2-9914)
+ m1-9890
+ (append m1-9890 m2-9914)))
+ (let ((m2-9922 (cdr w2-9889)))
+ (if (null? m2-9922)
+ s1-9891
+ (append s1-9891 m2-9922))))))))
+ (module-9882 (vector-ref x-9848 3)))
+ (vector
+ 'syntax-object
+ expression-9880
+ wrap-9881
+ module-9882))
+ (if (null? x-9848)
+ x-9848
+ (vector 'syntax-object x-9848 w-9294 mod-9296))))))))))
+ (global-extend-4345
'core
'set!
- (lambda (e-8585 r-8586 w-8587 s-8588 mod-8589)
- (let ((tmp-8591 ($sc-dispatch e-8585 '(_ any any))))
- (if (if tmp-8591
+ (lambda (e-10179 r-10180 w-10181 s-10182 mod-10183)
+ (let ((tmp-10185 ($sc-dispatch e-10179 '(_ any any))))
+ (if (if tmp-10185
(@apply
- (lambda (id-8595 val-8596)
- (if (symbol? id-8595)
+ (lambda (id-10189 val-10190)
+ (if (symbol? id-10189)
#t
- (if (if (vector? id-8595)
- (if (= (vector-length id-8595) 4)
- (eq? (vector-ref id-8595 0) 'syntax-object)
+ (if (if (vector? id-10189)
+ (if (= (vector-length id-10189) 4)
+ (eq? (vector-ref id-10189 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref id-8595 1))
+ (symbol? (vector-ref id-10189 1))
#f)))
- tmp-8591)
+ tmp-10185)
#f)
(@apply
- (lambda (id-8623 val-8624)
- (let ((n-8625 (id-var-name-4314 id-8623 w-8587))
- (id-mod-8626
- (if (if (vector? id-8623)
- (if (= (vector-length id-8623) 4)
- (eq? (vector-ref id-8623 0) 'syntax-object)
+ (lambda (id-10217 val-10218)
+ (call-with-values
+ (lambda ()
+ (resolve-identifier-4368
+ id-10217
+ w-10181
+ r-10180
+ mod-10183
+ #t))
+ (lambda (type-10221 value-10222 id-mod-10223)
+ (if (eqv? type-10221 'lexical)
+ (let ((name-10234 (syntax->datum id-10217))
+ (exp-10236
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ val-10218
+ r-10180
+ w-10181
+ (let ((props-10257
+ (source-properties
+ (if (if (vector? val-10218)
+ (if (= (vector-length
+ val-10218)
+ 4)
+ (eq? (vector-ref
+ val-10218
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref val-10218 1)
+ val-10218))))
+ (if (pair? props-10257)
+ props-10257
+ #f))
+ #f
+ mod-10183
+ #f))
+ (lambda (type-10290
+ value-10291
+ form-10292
+ e-10293
+ w-10294
+ s-10295
+ mod-10296)
+ (expand-expr-4384
+ type-10290
+ value-10291
+ form-10292
+ e-10293
+ r-10180
+ w-10294
+ s-10295
+ mod-10296)))))
+ (begin
+ (if (if (struct? exp-10236)
+ (eq? (struct-vtable exp-10236)
+ (vector-ref %expanded-vtables 14))
#f)
- #f)
- (vector-ref id-8623 3)
- mod-8589)))
- (let ((b-8627
- (let ((t-8668 (assq n-8625 r-8586)))
- (if t-8668
- (cdr t-8668)
- (if (symbol? n-8625)
- (let ((t-8673
- (get-global-definition-hook-4258
- n-8625
- id-mod-8626)))
- (if t-8673 t-8673 '(global)))
- '(displaced-lexical))))))
- (let ((key-8628 (car b-8627)))
- (if (eqv? key-8628 'lexical)
- (build-lexical-assignment-4266
- s-8588
- (syntax->datum id-8623)
- (cdr b-8627)
- (expand-4331 val-8624 r-8586 w-8587 mod-8589))
- (if (eqv? key-8628 'global)
- (build-global-assignment-4269
- s-8588
- n-8625
- (expand-4331 val-8624 r-8586 w-8587 mod-8589)
- id-mod-8626)
- (if (eqv? key-8628 'macro)
- (let ((p-8987 (cdr b-8627)))
- (if (procedure-property
- p-8987
- 'variable-transformer)
- (expand-4331
- (expand-macro-4334
- p-8987
- e-8585
- r-8586
- w-8587
- s-8588
+ (let ((meta-10308 (struct-ref exp-10236 1)))
+ (if (not (assq 'name meta-10308))
+ (let ((v-10315
+ (cons (cons 'name name-10234)
+ meta-10308)))
+ (struct-set! exp-10236 1 v-10315)))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 4)
+ s-10182
+ name-10234
+ value-10222
+ exp-10236)))
+ (if (eqv? type-10221 'global)
+ (let ((exp-10334
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ val-10218
+ r-10180
+ w-10181
+ (let ((props-10356
+ (source-properties
+ (if (if (vector? val-10218)
+ (if (= (vector-length
+ val-10218)
+ 4)
+ (eq? (vector-ref
+ val-10218
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref val-10218 1)
+ val-10218))))
+ (if (pair? props-10356)
+ props-10356
+ #f))
+ #f
+ mod-10183
+ #f))
+ (lambda (type-10389
+ value-10390
+ form-10391
+ e-10392
+ w-10393
+ s-10394
+ mod-10395)
+ (expand-expr-4384
+ type-10389
+ value-10390
+ form-10391
+ e-10392
+ r-10180
+ w-10393
+ s-10394
+ mod-10395)))))
+ (begin
+ (if (if (struct? exp-10334)
+ (eq? (struct-vtable exp-10334)
+ (vector-ref %expanded-vtables 14))
+ #f)
+ (let ((meta-10407 (struct-ref exp-10334 1)))
+ (if (not (assq 'name meta-10407))
+ (let ((v-10414
+ (cons (cons 'name value-10222)
+ meta-10407)))
+ (struct-set! exp-10334 1 v-10414)))))
+ (analyze-variable-4319
+ id-mod-10223
+ value-10222
+ (lambda (mod-10422 var-10423 public?-10424)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 6)
+ s-10182
+ mod-10422
+ var-10423
+ public?-10424
+ exp-10334))
+ (lambda (var-10433)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 8)
+ s-10182
+ var-10433
+ exp-10334)))))
+ (if (eqv? type-10221 'macro)
+ (if (procedure-property
+ value-10222
+ 'variable-transformer)
+ (let ((e-10449
+ (expand-macro-4386
+ value-10222
+ e-10179
+ r-10180
+ w-10181
+ s-10182
+ #f
+ mod-10183)))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-10449
+ r-10180
+ '(())
+ (let ((props-10460
+ (source-properties
+ (if (if (vector? e-10449)
+ (if (= (vector-length
+ e-10449)
+ 4)
+ (eq? (vector-ref
+ e-10449
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-10449 1)
+ e-10449))))
+ (if (pair? props-10460)
+ props-10460
+ #f))
#f
- mod-8589)
- r-8586
- '(())
- mod-8589)
- (syntax-violation
- 'set!
- "not a variable transformer"
- (wrap-4324 e-8585 w-8587 mod-8589)
- (wrap-4324 id-8623 w-8587 id-mod-8626))))
- (if (eqv? key-8628 'displaced-lexical)
- (syntax-violation
- 'set!
- "identifier out of context"
- (wrap-4324 id-8623 w-8587 mod-8589))
- (syntax-violation
- 'set!
- "bad set!"
- (wrap-4324
- (begin
- (if (if s-8588
- (supports-source-properties?
- e-8585)
+ mod-10183
+ #f))
+ (lambda (type-10483
+ value-10484
+ form-10485
+ e-10486
+ w-10487
+ s-10488
+ mod-10489)
+ (expand-expr-4384
+ type-10483
+ value-10484
+ form-10485
+ e-10486
+ r-10180
+ w-10487
+ s-10488
+ mod-10489))))
+ (syntax-violation
+ 'set!
+ "not a variable transformer"
+ (if (if (null? (car w-10181))
+ (null? (cdr w-10181))
+ #f)
+ e-10179
+ (if (if (vector? e-10179)
+ (if (= (vector-length e-10179) 4)
+ (eq? (vector-ref e-10179 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-10522
+ (vector-ref e-10179 1))
+ (wrap-10523
+ (let ((w2-10533
+ (vector-ref e-10179 2)))
+ (let ((m1-10534 (car w-10181))
+ (s1-10535 (cdr w-10181)))
+ (if (null? m1-10534)
+ (if (null? s1-10535)
+ w2-10533
+ (cons (car w2-10533)
+ (let ((m2-10552
+ (cdr w2-10533)))
+ (if (null? m2-10552)
+ s1-10535
+ (append
+ s1-10535
+ m2-10552)))))
+ (cons (let ((m2-10560
+ (car w2-10533)))
+ (if (null? m2-10560)
+ m1-10534
+ (append
+ m1-10534
+ m2-10560)))
+ (let ((m2-10568
+ (cdr w2-10533)))
+ (if (null? m2-10568)
+ s1-10535
+ (append
+ s1-10535
+ m2-10568))))))))
+ (module-10524
+ (vector-ref e-10179 3)))
+ (vector
+ 'syntax-object
+ expression-10522
+ wrap-10523
+ module-10524))
+ (if (null? e-10179)
+ e-10179
+ (vector
+ 'syntax-object
+ e-10179
+ w-10181
+ mod-10183))))
+ (if (if (null? (car w-10181))
+ (null? (cdr w-10181))
+ #f)
+ id-10217
+ (if (if (vector? id-10217)
+ (if (= (vector-length id-10217) 4)
+ (eq? (vector-ref id-10217 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-10620
+ (vector-ref id-10217 1))
+ (wrap-10621
+ (let ((w2-10631
+ (vector-ref id-10217 2)))
+ (let ((m1-10632 (car w-10181))
+ (s1-10633 (cdr w-10181)))
+ (if (null? m1-10632)
+ (if (null? s1-10633)
+ w2-10631
+ (cons (car w2-10631)
+ (let ((m2-10650
+ (cdr w2-10631)))
+ (if (null? m2-10650)
+ s1-10633
+ (append
+ s1-10633
+ m2-10650)))))
+ (cons (let ((m2-10658
+ (car w2-10631)))
+ (if (null? m2-10658)
+ m1-10632
+ (append
+ m1-10632
+ m2-10658)))
+ (let ((m2-10666
+ (cdr w2-10631)))
+ (if (null? m2-10666)
+ s1-10633
+ (append
+ s1-10633
+ m2-10666))))))))
+ (module-10622
+ (vector-ref id-10217 3)))
+ (vector
+ 'syntax-object
+ expression-10620
+ wrap-10621
+ module-10622))
+ (if (null? id-10217)
+ id-10217
+ (vector
+ 'syntax-object
+ id-10217
+ w-10181
+ id-mod-10223))))))
+ (if (eqv? type-10221 'displaced-lexical)
+ (syntax-violation
+ 'set!
+ "identifier out of context"
+ (if (if (null? (car w-10181))
+ (null? (cdr w-10181))
+ #f)
+ id-10217
+ (if (if (vector? id-10217)
+ (if (= (vector-length id-10217) 4)
+ (eq? (vector-ref id-10217 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-10724
+ (vector-ref id-10217 1))
+ (wrap-10725
+ (let ((w2-10735
+ (vector-ref id-10217 2)))
+ (let ((m1-10736 (car w-10181))
+ (s1-10737 (cdr w-10181)))
+ (if (null? m1-10736)
+ (if (null? s1-10737)
+ w2-10735
+ (cons (car w2-10735)
+ (let ((m2-10754
+ (cdr w2-10735)))
+ (if (null? m2-10754)
+ s1-10737
+ (append
+ s1-10737
+ m2-10754)))))
+ (cons (let ((m2-10762
+ (car w2-10735)))
+ (if (null? m2-10762)
+ m1-10736
+ (append
+ m1-10736
+ m2-10762)))
+ (let ((m2-10770
+ (cdr w2-10735)))
+ (if (null? m2-10770)
+ s1-10737
+ (append
+ s1-10737
+ m2-10770))))))))
+ (module-10726
+ (vector-ref id-10217 3)))
+ (vector
+ 'syntax-object
+ expression-10724
+ wrap-10725
+ module-10726))
+ (if (null? id-10217)
+ id-10217
+ (vector
+ 'syntax-object
+ id-10217
+ w-10181
+ mod-10183)))))
+ (syntax-violation
+ 'set!
+ "bad set!"
+ (let ((x-10802
+ (begin
+ (if (if s-10182
+ (supports-source-properties?
+ e-10179)
+ #f)
+ (set-source-properties!
+ e-10179
+ s-10182))
+ e-10179)))
+ (if (if (null? (car w-10181))
+ (null? (cdr w-10181))
+ #f)
+ x-10802
+ (if (if (vector? x-10802)
+ (if (= (vector-length x-10802) 4)
+ (eq? (vector-ref x-10802 0)
+ 'syntax-object)
#f)
- (set-source-properties! e-8585 s-8588))
- e-8585)
- w-8587
- mod-8589))))))))))
- tmp-8591)
- (let ((tmp-9082
- ($sc-dispatch e-8585 '(_ (any . each-any) any))))
- (if tmp-9082
+ #f)
+ (let ((expression-10834
+ (vector-ref x-10802 1))
+ (wrap-10835
+ (let ((w2-10843
+ (vector-ref x-10802 2)))
+ (let ((m1-10844 (car w-10181))
+ (s1-10845 (cdr w-10181)))
+ (if (null? m1-10844)
+ (if (null? s1-10845)
+ w2-10843
+ (cons (car w2-10843)
+ (let ((m2-10860
+ (cdr w2-10843)))
+ (if (null? m2-10860)
+ s1-10845
+ (append
+ s1-10845
+ m2-10860)))))
+ (cons (let ((m2-10868
+ (car w2-10843)))
+ (if (null? m2-10868)
+ m1-10844
+ (append
+ m1-10844
+ m2-10868)))
+ (let ((m2-10876
+ (cdr w2-10843)))
+ (if (null? m2-10876)
+ s1-10845
+ (append
+ s1-10845
+ m2-10876))))))))
+ (module-10836
+ (vector-ref x-10802 3)))
+ (vector
+ 'syntax-object
+ expression-10834
+ wrap-10835
+ module-10836))
+ (if (null? x-10802)
+ x-10802
+ (vector
+ 'syntax-object
+ x-10802
+ w-10181
+ mod-10183)))))))))))))
+ tmp-10185)
+ (let ((tmp-10891
+ ($sc-dispatch e-10179 '(_ (any . each-any) any))))
+ (if tmp-10891
(@apply
- (lambda (head-9086 tail-9087 val-9088)
+ (lambda (head-10895 tail-10896 val-10897)
(call-with-values
(lambda ()
- (syntax-type-4330
- head-9086
- r-8586
+ (syntax-type-4382
+ head-10895
+ r-10180
'(())
#f
#f
- mod-8589
+ mod-10183
#t))
- (lambda (type-9091
- value-9092
- formform-9093
- ee-9094
- ww-9095
- ss-9096
- modmod-9097)
- (if (eqv? type-9091 'module-ref)
- (let ((val-9103
- (expand-4331
- val-9088
- r-8586
- w-8587
- mod-8589)))
+ (lambda (type-10900
+ value-10901
+ ee*-10902
+ ee-10903
+ ww-10904
+ ss-10905
+ modmod-10906)
+ (if (eqv? type-10900 'module-ref)
+ (let ((val-10912
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ val-10897
+ r-10180
+ w-10181
+ (let ((props-10979
+ (source-properties
+ (if (if (vector? val-10897)
+ (if (= (vector-length
+ val-10897)
+ 4)
+ (eq? (vector-ref
+ val-10897
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref val-10897 1)
+ val-10897))))
+ (if (pair? props-10979)
+ props-10979
+ #f))
+ #f
+ mod-10183
+ #f))
+ (lambda (type-11012
+ value-11013
+ form-11014
+ e-11015
+ w-11016
+ s-11017
+ mod-11018)
+ (expand-expr-4384
+ type-11012
+ value-11013
+ form-11014
+ e-11015
+ r-10180
+ w-11016
+ s-11017
+ mod-11018)))))
(call-with-values
(lambda ()
- (value-9092
- (cons head-9086 tail-9087)
- r-8586
- w-8587))
- (lambda (e-9104 r-9105 w-9106 s*-9107 mod-9108)
- (let ((tmp-9110 (list e-9104)))
+ (value-10901
+ (cons head-10895 tail-10896)
+ r-10180
+ w-10181))
+ (lambda (e-10913
+ r-10914
+ w-10915
+ s*-10916
+ mod-10917)
+ (let ((tmp-10919 (list e-10913)))
(if (@apply
- (lambda (e-9112)
- (if (symbol? e-9112)
+ (lambda (e-10921)
+ (if (symbol? e-10921)
#t
- (if (if (vector? e-9112)
+ (if (if (vector? e-10921)
(if (= (vector-length
- e-9112)
+ e-10921)
4)
(eq? (vector-ref
- e-9112
+ e-10921
0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref e-9112 1))
+ (symbol?
+ (vector-ref e-10921 1))
#f)))
- tmp-9110)
+ tmp-10919)
(@apply
- (lambda (e-9142)
- (build-global-assignment-4269
- s-8588
- (syntax->datum e-9142)
- val-9103
- mod-9108))
- tmp-9110)
+ (lambda (e-10951)
+ (let ((var-10956
+ (syntax->datum e-10951)))
+ (begin
+ (if (if (struct? val-10912)
+ (eq? (struct-vtable
+ val-10912)
+ (vector-ref
+ %expanded-vtables
+ 14))
+ #f)
+ (let ((meta-11034
+ (struct-ref
+ val-10912
+ 1)))
+ (if (not (assq 'name
+ meta-11034))
+ (let ((v-11043
+ (cons (cons 'name
+ var-10956)
+ meta-11034)))
+ (struct-set!
+ val-10912
+ 1
+ v-11043)))))
+ (analyze-variable-4319
+ mod-10917
+ var-10956
+ (lambda (mod-11049
+ var-11050
+ public?-11051)
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 6)
+ s-10182
+ mod-11049
+ var-11050
+ public?-11051
+ val-10912))
+ (lambda (var-11062)
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 8)
+ s-10182
+ var-11062
+ val-10912))))))
+ tmp-10919)
(syntax-violation
#f
"source expression failed to match any pattern"
- e-9104))))))
- (build-application-4262
- s-8588
- (let ((e-9367
- (list '#(syntax-object
- setter
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(key)
- #((m-*-3554 top))
- #("l-*-3555"))
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(type
- value
- formform
- ee
- ww
- ss
- modmod)
- #((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3547"
- "l-*-3548"
- "l-*-3549"
- "l-*-3550"
- "l-*-3551"
- "l-*-3552"
- "l-*-3553"))
- #(ribcage
- #(head tail val)
- #((top) (top) (top))
- #("l-*-3532"
- "l-*-3533"
- "l-*-3534"))
- #(ribcage () () ())
- #(ribcage
- #(e r w s mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3501"
- "l-*-3502"
- "l-*-3503"
- "l-*-3504"
- "l-*-3505"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- head-9086)))
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-9367
- r-8586
- w-8587
- (source-annotation-4288 e-9367)
- #f
- mod-8589
- #f))
- (lambda (type-9374
- value-9375
- form-9376
- e-9377
- w-9378
- s-9379
- mod-9380)
- (expand-expr-4332
- type-9374
- value-9375
- form-9376
- e-9377
- r-8586
- w-9378
- s-9379
- mod-9380))))
- (map (lambda (e-9384)
- (call-with-values
- (lambda ()
- (syntax-type-4330
- e-9384
- r-8586
- w-8587
- (source-annotation-4288 e-9384)
- #f
- mod-8589
- #f))
- (lambda (type-9399
- value-9400
- form-9401
- e-9402
- w-9403
- s-9404
- mod-9405)
- (expand-expr-4332
- type-9399
- value-9400
- form-9401
- e-9402
- r-8586
- w-9403
- s-9404
- mod-9405))))
- (append tail-9087 (list val-9088))))))))
- tmp-9082)
- (syntax-violation
- 'set!
- "bad set!"
- (wrap-4324
- (begin
- (if (if s-8588
- (supports-source-properties? e-8585)
- #f)
- (set-source-properties! e-8585 s-8588))
- e-8585)
- w-8587
- mod-8589))))))))
- (module-define!
- (current-module)
- '@
- (make-syntax-transformer
- '@
- 'module-ref
- (lambda (e-9448 r-9449 w-9450)
- (let ((tmp-9452
- ($sc-dispatch e-9448 '(_ each-any any))))
- (if (if tmp-9452
- (@apply
- (lambda (mod-9455 id-9456)
- (if (and-map id?-4295 mod-9455)
- (if (symbol? id-9456)
- #t
- (if (if (vector? id-9456)
- (if (= (vector-length id-9456) 4)
- (eq? (vector-ref id-9456 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref id-9456 1))
- #f))
- #f))
- tmp-9452)
- #f)
- (@apply
- (lambda (mod-9496 id-9497)
- (values
- (syntax->datum id-9497)
- r-9449
- w-9450
- #f
- (syntax->datum
- (cons '#(syntax-object
- public
- ((top)
- #(ribcage
- #(mod id)
- #((top) (top))
- #("l-*-3596" "l-*-3597"))
- #(ribcage () () ())
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3584" "l-*-3585" "l-*-3586"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- mod-9496))))
- tmp-9452)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-9448))))))
- (global-extend-4293
- 'module-ref
- '@@
- (lambda (e-9589 r-9590 w-9591)
- (letrec*
- ((remodulate-9592
- (lambda (x-9627 mod-9628)
- (if (pair? x-9627)
- (cons (remodulate-9592 (car x-9627) mod-9628)
- (remodulate-9592 (cdr x-9627) mod-9628))
- (if (if (vector? x-9627)
- (if (= (vector-length x-9627) 4)
- (eq? (vector-ref x-9627 0) 'syntax-object)
- #f)
- #f)
- (let ((expression-9642
- (remodulate-9592 (vector-ref x-9627 1) mod-9628))
- (wrap-9643 (vector-ref x-9627 2)))
- (vector
- 'syntax-object
- expression-9642
- wrap-9643
- mod-9628))
- (if (vector? x-9627)
- (let ((n-9651 (vector-length x-9627)))
- (let ((v-9652 (make-vector n-9651)))
- (letrec*
- ((loop-9653
- (lambda (i-9700)
- (if (= i-9700 n-9651)
- v-9652
- (begin
- (vector-set!
- v-9652
- i-9700
- (remodulate-9592
- (vector-ref x-9627 i-9700)
- mod-9628))
- (loop-9653 (#{1+}# i-9700)))))))
- (loop-9653 0))))
- x-9627))))))
- (let ((tmp-9594
- ($sc-dispatch e-9589 '(_ each-any any))))
- (if (if tmp-9594
- (@apply
- (lambda (mod-9598 exp-9599)
- (and-map id?-4295 mod-9598))
- tmp-9594)
- #f)
- (@apply
- (lambda (mod-9615 exp-9616)
- (let ((mod-9617
- (syntax->datum
- (cons '#(syntax-object
- private
- ((top)
- #(ribcage
- #(mod exp)
- #((top) (top))
- #("l-*-3634" "l-*-3635"))
- #(ribcage
- (remodulate)
- ((top))
- ("l-*-3607"))
- #(ribcage
- #(e r w)
- #((top) (top) (top))
- #("l-*-3604" "l-*-3605" "l-*-3606"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- mod-9615))))
- (values
- (remodulate-9592 exp-9616 mod-9617)
- r-9590
- w-9591
- (source-annotation-4288 exp-9616)
- mod-9617)))
- tmp-9594)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-9589))))))
- (global-extend-4293
- 'core
- 'if
- (lambda (e-9801 r-9802 w-9803 s-9804 mod-9805)
- (let ((tmp-9807 ($sc-dispatch e-9801 '(_ any any))))
- (if tmp-9807
- (@apply
- (lambda (test-9811 then-9812)
- (build-conditional-4263
- s-9804
- (expand-4331 test-9811 r-9802 w-9803 mod-9805)
- (expand-4331 then-9812 r-9802 w-9803 mod-9805)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 0)
- #f)))
- tmp-9807)
- (let ((tmp-10037
- ($sc-dispatch e-9801 '(_ any any any))))
- (if tmp-10037
- (@apply
- (lambda (test-10041 then-10042 else-10043)
- (build-conditional-4263
- s-9804
- (expand-4331 test-10041 r-9802 w-9803 mod-9805)
- (expand-4331 then-10042 r-9802 w-9803 mod-9805)
- (expand-4331 else-10043 r-9802 w-9803 mod-9805)))
- tmp-10037)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-9801)))))))
- (global-extend-4293
- 'core
- 'with-fluids
- (lambda (e-10442 r-10443 w-10444 s-10445 mod-10446)
- (let ((tmp-10448
- ($sc-dispatch
- e-10442
- '(_ #(each (any any)) any . each-any))))
- (if tmp-10448
- (@apply
- (lambda (fluid-10452 val-10453 b-10454 b*-10455)
- (build-dynlet-4264
- s-10445
- (map (lambda (x-10536)
- (expand-4331 x-10536 r-10443 w-10444 mod-10446))
- fluid-10452)
- (map (lambda (x-10606)
- (expand-4331 x-10606 r-10443 w-10444 mod-10446))
- val-10453)
- (expand-body-4335
- (cons b-10454 b*-10455)
- (wrap-4324
- (begin
- (if (if s-10445
- (supports-source-properties? e-10442)
- #f)
- (set-source-properties! e-10442 s-10445))
- e-10442)
- w-10444
- mod-10446)
- r-10443
- w-10444
- mod-10446)))
- tmp-10448)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-10442)))))
- (module-define!
- (current-module)
- 'begin
- (make-syntax-transformer 'begin 'begin '()))
- (module-define!
- (current-module)
- 'define
- (make-syntax-transformer 'define 'define '()))
- (module-define!
- (current-module)
- 'define-syntax
- (make-syntax-transformer
- 'define-syntax
- 'define-syntax
- '()))
- (module-define!
- (current-module)
- 'define-syntax-parameter
- (make-syntax-transformer
- 'define-syntax-parameter
- 'define-syntax-parameter
- '()))
- (module-define!
- (current-module)
- 'eval-when
- (make-syntax-transformer
- 'eval-when
- 'eval-when
- '()))
- (global-extend-4293
- 'core
- 'syntax-case
- (letrec*
- ((convert-pattern-10974
- (lambda (pattern-12571 keys-12572)
- (letrec*
- ((cvt*-12573
- (lambda (p*-13197 n-13198 ids-13199)
- (if (not (pair? p*-13197))
- (cvt-12575 p*-13197 n-13198 ids-13199)
- (call-with-values
- (lambda ()
- (cvt*-12573 (cdr p*-13197) n-13198 ids-13199))
- (lambda (y-13202 ids-13203)
- (call-with-values
- (lambda ()
- (cvt-12575 (car p*-13197) n-13198 ids-13203))
- (lambda (x-13206 ids-13207)
- (values
- (cons x-13206 y-13202)
- ids-13207))))))))
- (v-reverse-12574
- (lambda (x-13208)
- (letrec*
- ((loop-13209
- (lambda (r-13289 x-13290)
- (if (not (pair? x-13290))
- (values r-13289 x-13290)
- (loop-13209
- (cons (car x-13290) r-13289)
- (cdr x-13290))))))
- (loop-13209 '() x-13208))))
- (cvt-12575
- (lambda (p-12578 n-12579 ids-12580)
- (if (if (symbol? p-12578)
- #t
- (if (if (vector? p-12578)
- (if (= (vector-length p-12578) 4)
- (eq? (vector-ref p-12578 0) 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref p-12578 1))
- #f))
- (if (bound-id-member?-4323 p-12578 keys-12572)
- (values (vector 'free-id p-12578) ids-12580)
- (if (if (eq? (if (if (vector? p-12578)
- (if (= (vector-length p-12578) 4)
- (eq? (vector-ref p-12578 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref p-12578 1)
- p-12578)
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702"
- "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702" "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 p-12578 '(()))
- (id-var-name-4314
- '#(syntax-object
- _
- ((top)
- #(ribcage () () ())
- #(ribcage
- #(p n ids)
- #((top) (top) (top))
- #("l-*-3735"
- "l-*-3736"
- "l-*-3737"))
- #(ribcage
- (cvt v-reverse cvt*)
- ((top) (top) (top))
- ("l-*-3708"
- "l-*-3706"
- "l-*-3704"))
- #(ribcage
- #(pattern keys)
- #((top) (top))
- #("l-*-3702" "l-*-3703"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- (values '_ ids-12580)
- (values
- 'any
- (cons (cons p-12578 n-12579) ids-12580))))
- (let ((tmp-12900 ($sc-dispatch p-12578 '(any any))))
- (if (if tmp-12900
- (@apply
- (lambda (x-12904 dots-12905)
- (if (if (if (vector? dots-12905)
- (if (= (vector-length dots-12905)
- 4)
- (eq? (vector-ref dots-12905 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref dots-12905 1))
- #f)
- (if (eq? (if (if (vector? dots-12905)
- (if (= (vector-length
- dots-12905)
- 4)
- (eq? (vector-ref
- dots-12905
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref dots-12905 1)
- dots-12905)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- dots-12905
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- tmp-12900)
- #f)
- (@apply
- (lambda (x-13005 dots-13006)
- (call-with-values
- (lambda ()
- (cvt-12575
- x-13005
- (#{1+}# n-12579)
- ids-12580))
- (lambda (p-13007 ids-13008)
- (values
- (if (eq? p-13007 'any)
- 'each-any
- (vector 'each p-13007))
- ids-13008))))
- tmp-12900)
- (let ((tmp-13009
- ($sc-dispatch p-12578 '(any any . any))))
- (if (if tmp-13009
- (@apply
- (lambda (x-13013 dots-13014 ys-13015)
- (if (if (if (vector? dots-13014)
- (if (= (vector-length
- dots-13014)
- 4)
- (eq? (vector-ref
- dots-13014
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol?
- (vector-ref dots-13014 1))
- #f)
- (if (eq? (if (if (vector? dots-13014)
- (if (= (vector-length
- dots-13014)
- 4)
- (eq? (vector-ref
- dots-13014
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref dots-13014 1)
- dots-13014)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- dots-13014
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))
- tmp-13009)
- #f)
- (@apply
- (lambda (x-13115 dots-13116 ys-13117)
- (call-with-values
- (lambda ()
- (cvt*-12573
- ys-13117
- n-12579
- ids-12580))
- (lambda (ys-13120 ids-13121)
- (call-with-values
- (lambda ()
- (cvt-12575
- x-13115
- (#{1+}# n-12579)
- ids-13121))
- (lambda (x-13122 ids-13123)
- (call-with-values
- (lambda ()
- (v-reverse-12574 ys-13120))
- (lambda (ys-13156 e-13157)
- (values
- (vector
- 'each+
- x-13122
- ys-13156
- e-13157)
- ids-13123))))))))
- tmp-13009)
- (let ((tmp-13158
- ($sc-dispatch p-12578 '(any . any))))
- (if tmp-13158
- (@apply
- (lambda (x-13162 y-13163)
- (call-with-values
- (lambda ()
- (cvt-12575
- y-13163
- n-12579
- ids-12580))
- (lambda (y-13164 ids-13165)
- (call-with-values
- (lambda ()
- (cvt-12575
- x-13162
- n-12579
- ids-13165))
- (lambda (x-13166 ids-13167)
- (values
- (cons x-13166 y-13164)
- ids-13167))))))
- tmp-13158)
- (let ((tmp-13168
- ($sc-dispatch p-12578 '())))
- (if tmp-13168
- (@apply
- (lambda () (values '() ids-12580))
- tmp-13168)
- (let ((tmp-13172
- ($sc-dispatch
- p-12578
- '#(vector each-any))))
- (if tmp-13172
- (@apply
- (lambda (x-13176)
- (call-with-values
- (lambda ()
- (cvt-12575
- x-13176
- n-12579
- ids-12580))
- (lambda (p-13177 ids-13178)
- (values
- (vector 'vector p-13177)
- ids-13178))))
- tmp-13172)
- (values
- (vector
- 'atom
- (strip-4344 p-12578 '(())))
- ids-12580)))))))))))))))
- (cvt-12575 pattern-12571 0 '()))))
- (build-dispatch-call-10975
- (lambda (pvars-13291 exp-13292 y-13293 r-13294 mod-13295)
- (let ((ids-13296 (map car pvars-13291)))
- (begin
- (map cdr pvars-13291)
- (let ((labels-13298 (gen-labels-4298 ids-13296))
- (new-vars-13299 (map gen-var-4345 ids-13296)))
- (build-application-4262
- #f
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'apply)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'apply
- #f))
- (list (build-simple-lambda-4271
- #f
- (map syntax->datum ids-13296)
- #f
- new-vars-13299
- '()
- (expand-4331
- exp-13292
- (extend-env-4289
- labels-13298
- (map (lambda (var-13622 level-13623)
- (cons 'syntax
- (cons var-13622 level-13623)))
- new-vars-13299
- (map cdr pvars-13291))
- r-13294)
- (make-binding-wrap-4309
- ids-13296
- labels-13298
- '(()))
- mod-13295))
- y-13293)))))))
- (gen-clause-10976
- (lambda (x-11943
- keys-11944
- clauses-11945
- r-11946
- pat-11947
- fender-11948
- exp-11949
- mod-11950)
- (call-with-values
- (lambda ()
- (convert-pattern-10974 pat-11947 keys-11944))
- (lambda (p-12105 pvars-12106)
- (if (not (distinct-bound-ids?-4322 (map car pvars-12106)))
- (syntax-violation
- 'syntax-case
- "duplicate pattern variable"
- pat-11947)
- (if (not (and-map
- (lambda (x-12222)
- (not (let ((x-12226 (car x-12222)))
- (if (if (if (vector? x-12226)
- (if (= (vector-length
- x-12226)
- 4)
- (eq? (vector-ref
- x-12226
- 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-12226 1))
- #f)
- (if (eq? (if (if (vector? x-12226)
- (if (= (vector-length
- x-12226)
- 4)
- (eq? (vector-ref
- x-12226
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-12226 1)
- x-12226)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- x-12226
- '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- #f))))
- pvars-12106))
- (syntax-violation
- 'syntax-case
- "misplaced ellipsis"
- pat-11947)
- (let ((y-12302
- (gensym
- (string-append (symbol->string 'tmp) "-"))))
- (build-application-4262
- #f
- (let ((req-12445 (list 'tmp))
- (vars-12447 (list y-12302))
- (exp-12449
- (let ((y-12466
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- 'tmp
- y-12302)))
- (let ((test-exp-12470
- (let ((tmp-12479
- ($sc-dispatch
- fender-11948
- '#(atom #t))))
- (if tmp-12479
- (@apply
- (lambda () y-12466)
- tmp-12479)
- (let ((then-exp-12497
- (build-dispatch-call-10975
- pvars-12106
- fender-11948
- y-12466
- r-11946
- mod-11950))
- (else-exp-12498
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- #f)))
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 10)
- #f
- y-12466
- then-exp-12497
- else-exp-12498)))))
- (then-exp-12471
- (build-dispatch-call-10975
- pvars-12106
- exp-11949
- y-12466
- r-11946
- mod-11950))
- (else-exp-12472
- (gen-syntax-case-10977
- x-11943
- keys-11944
- clauses-11945
- r-11946
- mod-11950)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 10)
- #f
- test-exp-12470
- then-exp-12471
- else-exp-12472)))))
- (let ((body-12454
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- req-12445
- #f
- #f
- #f
- '()
- vars-12447
- exp-12449
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- body-12454)))
- (list (if (eq? p-12105 'any)
- (let ((fun-exp-12520
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'list)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'list
- #f)))
- (arg-exps-12521 (list x-11943)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-12520
- arg-exps-12521))
- (let ((fun-exp-12544
- (if (equal?
- (module-name (current-module))
- '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- '$sc-dispatch)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- '$sc-dispatch
- #f)))
- (arg-exps-12545
- (list x-11943
- (make-struct/no-tail
- (vector-ref
- %expanded-vtables
- 1)
- #f
- p-12105))))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-12544
- arg-exps-12545))))))))))))
- (gen-syntax-case-10977
- (lambda (x-11376
- keys-11377
- clauses-11378
- r-11379
- mod-11380)
- (if (null? clauses-11378)
- (let ((fun-exp-11385
- (if (equal? (module-name (current-module)) '(guile))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 7)
- #f
- 'syntax-violation)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 5)
- #f
- '(guile)
- 'syntax-violation
- #f)))
- (arg-exps-11386
- (list (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- #f)
- (make-struct/no-tail
- (vector-ref %expanded-vtables 1)
- #f
- "source expression failed to match any pattern")
- x-11376)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 11)
- #f
- fun-exp-11385
- arg-exps-11386))
- (let ((tmp-11419 (car clauses-11378)))
- (let ((tmp-11420 ($sc-dispatch tmp-11419 '(any any))))
- (if tmp-11420
- (@apply
- (lambda (pat-11422 exp-11423)
- (if (if (if (symbol? pat-11422)
- #t
- (if (if (vector? pat-11422)
- (if (= (vector-length pat-11422) 4)
- (eq? (vector-ref pat-11422 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref pat-11422 1))
- #f))
- (and-map
- (lambda (x-11450)
- (not (if (eq? (if (if (vector? pat-11422)
- (if (= (vector-length
- pat-11422)
- 4)
- (eq? (vector-ref
- pat-11422
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref pat-11422 1)
- pat-11422)
- (if (if (vector? x-11450)
- (if (= (vector-length
- x-11450)
- 4)
- (eq? (vector-ref
- x-11450
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-11450 1)
- x-11450))
- (eq? (id-var-name-4314
- pat-11422
- '(()))
- (id-var-name-4314
- x-11450
- '(())))
- #f)))
- (cons '#(syntax-object
- ...
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top) (top) (top) (top) (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- keys-11377))
- #f)
- (if (if (eq? (if (if (= (vector-length
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891"
- "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- 'pad
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- (if (if (= (vector-length
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891"
- "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x
- keys
- clauses
- r
- mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top)
- (top)
- (top)
- (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile)))
- 4)
- #t
- #f)
- '_
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314
- '#(syntax-object
- pad
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(()))
- (id-var-name-4314
- '#(syntax-object
- _
- ((top)
- #(ribcage
- #(pat exp)
- #((top) (top))
- #("l-*-3891" "l-*-3892"))
- #(ribcage () () ())
- #(ribcage
- #(x keys clauses r mod)
- #((top)
- (top)
- (top)
- (top)
- (top))
- #("l-*-3880"
- "l-*-3881"
- "l-*-3882"
- "l-*-3883"
- "l-*-3884"))
- #(ribcage
- (gen-syntax-case
- gen-clause
- build-dispatch-call
- convert-pattern)
- ((top) (top) (top) (top))
- ("l-*-3698"
- "l-*-3696"
- "l-*-3694"
- "l-*-3692"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47" "l-*-46" "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
- (expand-4331 exp-11423 r-11379 '(()) mod-11380)
- (let ((labels-11626
- (list (string-append
- "l-"
- (session-id-4256)
- (symbol->string (gensym "-")))))
- (var-11627
- (let ((id-11665
- (if (if (vector? pat-11422)
- (if (= (vector-length
- pat-11422)
- 4)
- (eq? (vector-ref
- pat-11422
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref pat-11422 1)
- pat-11422)))
- (gensym
- (string-append
- (symbol->string id-11665)
- "-")))))
- (build-application-4262
- #f
- (build-simple-lambda-4271
- #f
- (list (syntax->datum pat-11422))
- #f
- (list var-11627)
- '()
- (expand-4331
- exp-11423
- (extend-env-4289
- labels-11626
- (list (cons 'syntax
- (cons var-11627 0)))
- r-11379)
- (make-binding-wrap-4309
- (list pat-11422)
- labels-11626
- '(()))
- mod-11380))
- (list x-11376))))
- (gen-clause-10976
- x-11376
- keys-11377
- (cdr clauses-11378)
- r-11379
- pat-11422
- #t
- exp-11423
- mod-11380)))
- tmp-11420)
- (let ((tmp-11935
- ($sc-dispatch tmp-11419 '(any any any))))
- (if tmp-11935
- (@apply
- (lambda (pat-11937 fender-11938 exp-11939)
- (gen-clause-10976
- x-11376
- keys-11377
- (cdr clauses-11378)
- r-11379
- pat-11937
- fender-11938
- exp-11939
- mod-11380))
- tmp-11935)
- (syntax-violation
- 'syntax-case
- "invalid clause"
- (car clauses-11378)))))))))))
- (lambda (e-10978 r-10979 w-10980 s-10981 mod-10982)
- (let ((e-10983
- (wrap-4324
- (begin
- (if (if s-10981
- (supports-source-properties? e-10978)
- #f)
- (set-source-properties! e-10978 s-10981))
- e-10978)
- w-10980
- mod-10982)))
- (let ((tmp-10985
- ($sc-dispatch
- e-10983
- '(_ any each-any . each-any))))
- (if tmp-10985
- (@apply
- (lambda (val-11010 key-11011 m-11012)
- (if (and-map
- (lambda (x-11013)
- (if (if (symbol? x-11013)
- #t
- (if (if (vector? x-11013)
- (if (= (vector-length x-11013) 4)
- (eq? (vector-ref x-11013 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-11013 1))
- #f))
- (not (if (if (if (vector? x-11013)
- (if (= (vector-length x-11013)
- 4)
- (eq? (vector-ref x-11013 0)
- 'syntax-object)
- #f)
- #f)
- (symbol? (vector-ref x-11013 1))
- #f)
- (if (eq? (if (if (vector? x-11013)
- (if (= (vector-length
- x-11013)
- 4)
- (eq? (vector-ref
- x-11013
- 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref x-11013 1)
- x-11013)
- (if (if (= (vector-length
- '#(syntax-object
- ...
- ((top)
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- ()
- ()
- ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top)
- (top)
- (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene
- guile)))
- 4)
- #t
- #f)
- '...
- '#(syntax-object
- ...
+ e-10913))))))
+ (let ((fun-exp-11078
+ (let ((e-11086
+ (list '#(syntax-object
+ setter
((top)
#(ribcage () () ())
+ #(ribcage
+ #(key)
+ #((m-*-3609 top))
+ #("l-*-3610"))
+ #(ribcage () () ())
#(ribcage () () ())
#(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
+ #(type
+ value
+ ee*
+ ee
+ ww
+ ss
+ modmod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("l-*-3602"
+ "l-*-3603"
+ "l-*-3604"
+ "l-*-3605"
+ "l-*-3606"
+ "l-*-3607"
+ "l-*-3608"))
+ #(ribcage
+ #(head tail val)
+ #((top) (top) (top))
+ #("l-*-3587"
+ "l-*-3588"
+ "l-*-3589"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e r w s mod)
+ #((top)
+ (top)
+ (top)
+ (top)
+ (top))
+ #("l-*-3561"
+ "l-*-3562"
+ "l-*-3563"
+ "l-*-3564"
+ "l-*-3565"))
#(ribcage
(lambda-var-list
gen-var
expand-local-syntax
expand-body
expand-macro
- expand-application
+ expand-call
expand-expr
expand
syntax-type
id?
nonsymbol-id?
global-extend
- lookup
macros-only-env
extend-var-env
extend-env
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-let
make-lambda-case
make-lambda
- make-sequence
- make-application
+ make-seq
+ make-primcall
+ make-call
make-conditional
make-toplevel-define
make-toplevel-set
(top)
(top)
(top)
+ (top)
(top))
- ("l-*-476"
+ ("l-*-478"
+ "l-*-476"
"l-*-474"
"l-*-472"
"l-*-470"
"l-*-406"
"l-*-404"
"l-*-402"
- "l-*-400"
+ "l-*-401"
"l-*-399"
- "l-*-397"
+ "l-*-396"
+ "l-*-395"
"l-*-394"
- "l-*-393"
"l-*-392"
- "l-*-390"
+ "l-*-391"
"l-*-389"
"l-*-387"
"l-*-385"
"l-*-379"
"l-*-377"
"l-*-375"
- "l-*-373"
+ "l-*-372"
"l-*-370"
- "l-*-368"
+ "l-*-369"
"l-*-367"
"l-*-365"
"l-*-363"
"l-*-361"
+ "l-*-360"
"l-*-359"
"l-*-358"
- "l-*-357"
"l-*-356"
- "l-*-354"
- "l-*-353"
+ "l-*-355"
+ "l-*-352"
"l-*-350"
"l-*-348"
"l-*-346"
"l-*-344"
"l-*-342"
+ "l-*-341"
"l-*-340"
"l-*-338"
- "l-*-337"
"l-*-336"
- "l-*-334"
+ "l-*-335"
"l-*-332"
"l-*-331"
- "l-*-328"
+ "l-*-329"
"l-*-327"
"l-*-325"
"l-*-323"
"l-*-319"
"l-*-317"
"l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))))
- (eq? (id-var-name-4314 x-11013 '(()))
- (id-var-name-4314
- '#(syntax-object
- ...
- ((top)
- #(ribcage () () ())
- #(ribcage () () ())
- #(ribcage
- #(x)
- #((top))
- #("l-*-2267"))
- #(ribcage
- (lambda-var-list
- gen-var
- strip
- expand-lambda-case
- lambda*-formals
- expand-simple-lambda
- lambda-formals
- ellipsis?
- expand-void
- eval-local-transformer
- expand-local-syntax
- expand-body
- expand-macro
- expand-application
- expand-expr
- expand
- syntax-type
- parse-when-list
- expand-install-global
- expand-top-sequence
- expand-sequence
- source-wrap
- wrap
- bound-id-member?
- distinct-bound-ids?
- valid-bound-ids?
- bound-id=?
- free-id=?
- with-transformer-environment
- transformer-environment
- resolve-identifier
- locally-bound-identifiers
- id-var-name
- same-marks?
- join-marks
- join-wraps
- smart-append
- make-binding-wrap
- extend-ribcage!
- make-empty-ribcage
- new-mark
- anti-mark
- the-anti-mark
- top-marked?
- top-wrap
- empty-wrap
- set-ribcage-labels!
- set-ribcage-marks!
- set-ribcage-symnames!
- ribcage-labels
- ribcage-marks
- ribcage-symnames
- ribcage?
- make-ribcage
- gen-labels
- gen-label
- make-rename
- rename-marks
- rename-new
- rename-old
- subst-rename?
- wrap-subst
- wrap-marks
- make-wrap
- id-sym-name&marks
- id-sym-name
- id?
- nonsymbol-id?
- global-extend
- lookup
- macros-only-env
- extend-var-env
- extend-env
- null-env
- binding-value
- binding-type
- make-binding
- arg-check
- source-annotation
- no-source
- set-syntax-object-module!
- set-syntax-object-wrap!
- set-syntax-object-expression!
- syntax-object-module
- syntax-object-wrap
- syntax-object-expression
- syntax-object?
- make-syntax-object
- build-lexical-var
- build-letrec
- build-named-let
- build-let
- build-sequence
- build-data
- build-primref
- build-lambda-case
- build-case-lambda
- build-simple-lambda
- build-global-definition
- build-global-assignment
- build-global-reference
- analyze-variable
- build-lexical-assignment
- build-lexical-reference
- build-dynlet
- build-conditional
- build-application
- build-void
- maybe-name-value!
- decorate-source
- get-global-definition-hook
- put-global-definition-hook
- session-id
- local-eval-hook
- top-level-eval-hook
- fx<
- fx=
- fx-
- fx+
- set-lambda-meta!
- lambda-meta
- lambda?
- make-dynlet
- make-letrec
- make-let
- make-lambda-case
- make-lambda
- make-sequence
- make-application
- make-conditional
- make-toplevel-define
- make-toplevel-set
- make-toplevel-ref
- make-module-set
- make-module-ref
- make-lexical-set
- make-lexical-ref
- make-primitive-ref
- make-const
- make-void)
- ((top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top)
- (top))
- ("l-*-476"
- "l-*-474"
- "l-*-472"
- "l-*-470"
- "l-*-468"
- "l-*-466"
- "l-*-464"
- "l-*-462"
- "l-*-460"
- "l-*-458"
- "l-*-456"
- "l-*-454"
- "l-*-452"
- "l-*-450"
- "l-*-448"
- "l-*-446"
- "l-*-444"
- "l-*-442"
- "l-*-440"
- "l-*-438"
- "l-*-436"
- "l-*-434"
- "l-*-432"
- "l-*-430"
- "l-*-428"
- "l-*-426"
- "l-*-424"
- "l-*-422"
- "l-*-420"
- "l-*-418"
- "l-*-416"
- "l-*-414"
- "l-*-412"
- "l-*-410"
- "l-*-408"
- "l-*-406"
- "l-*-404"
- "l-*-402"
- "l-*-400"
- "l-*-399"
- "l-*-397"
- "l-*-394"
- "l-*-393"
- "l-*-392"
- "l-*-390"
- "l-*-389"
- "l-*-387"
- "l-*-385"
- "l-*-383"
- "l-*-381"
- "l-*-379"
- "l-*-377"
- "l-*-375"
- "l-*-373"
- "l-*-370"
- "l-*-368"
- "l-*-367"
- "l-*-365"
- "l-*-363"
- "l-*-361"
- "l-*-359"
- "l-*-358"
- "l-*-357"
- "l-*-356"
- "l-*-354"
- "l-*-353"
- "l-*-350"
- "l-*-348"
- "l-*-346"
- "l-*-344"
- "l-*-342"
- "l-*-340"
- "l-*-338"
- "l-*-337"
- "l-*-336"
- "l-*-334"
- "l-*-332"
- "l-*-331"
- "l-*-328"
- "l-*-327"
- "l-*-325"
- "l-*-323"
- "l-*-321"
- "l-*-319"
- "l-*-317"
- "l-*-315"
- "l-*-313"
- "l-*-311"
- "l-*-309"
- "l-*-306"
- "l-*-304"
- "l-*-302"
- "l-*-300"
- "l-*-298"
- "l-*-296"
- "l-*-294"
- "l-*-292"
- "l-*-290"
- "l-*-288"
- "l-*-286"
- "l-*-284"
- "l-*-282"
- "l-*-280"
- "l-*-278"
- "l-*-276"
- "l-*-274"
- "l-*-272"
- "l-*-270"
- "l-*-268"
- "l-*-266"
- "l-*-264"
- "l-*-262"
- "l-*-260"
- "l-*-258"
- "l-*-256"
- "l-*-255"
- "l-*-254"
- "l-*-253"
- "l-*-252"
- "l-*-250"
- "l-*-248"
- "l-*-246"
- "l-*-243"
- "l-*-241"
- "l-*-239"
- "l-*-237"
- "l-*-235"
- "l-*-233"
- "l-*-231"
- "l-*-229"
- "l-*-227"
- "l-*-225"
- "l-*-223"
- "l-*-221"
- "l-*-219"
- "l-*-217"
- "l-*-215"
- "l-*-213"
- "l-*-211"
- "l-*-209"))
- #(ribcage
- (define-structure
- define-expansion-accessors
- define-expansion-constructors)
- ((top) (top) (top))
- ("l-*-47"
- "l-*-46"
- "l-*-45")))
- (hygiene guile))
- '(())))
- #f)
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47"
+ "l-*-46"
+ "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ head-10895)))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-11086
+ r-10180
+ w-10181
+ (let ((props-11096
+ (source-properties
+ (if (if (vector? e-11086)
+ (if (= (vector-length
+ e-11086)
+ 4)
+ (eq? (vector-ref
+ e-11086
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref e-11086 1)
+ e-11086))))
+ (if (pair? props-11096)
+ props-11096
+ #f))
+ #f
+ mod-10183
+ #f))
+ (lambda (type-11119
+ value-11120
+ form-11121
+ e-11122
+ w-11123
+ s-11124
+ mod-11125)
+ (expand-expr-4384
+ type-11119
+ value-11120
+ form-11121
+ e-11122
+ r-10180
+ w-11123
+ s-11124
+ mod-11125)))))
+ (arg-exps-11079
+ (map (lambda (e-11129)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ e-11129
+ r-10180
+ w-10181
+ (let ((props-11144
+ (source-properties
+ (if (if (vector?
+ e-11129)
+ (if (= (vector-length
+ e-11129)
+ 4)
+ (eq? (vector-ref
+ e-11129
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ e-11129
+ 1)
+ e-11129))))
+ (if (pair? props-11144)
+ props-11144
+ #f))
+ #f
+ mod-10183
+ #f))
+ (lambda (type-11177
+ value-11178
+ form-11179
+ e-11180
+ w-11181
+ s-11182
+ mod-11183)
+ (expand-expr-4384
+ type-11177
+ value-11178
+ form-11179
+ e-11180
+ r-10180
+ w-11181
+ s-11182
+ mod-11183))))
+ (append
+ tail-10896
+ (list val-10897)))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ s-10182
+ fun-exp-11078
+ arg-exps-11079))))))
+ tmp-10891)
+ (syntax-violation
+ 'set!
+ "bad set!"
+ (let ((x-11197
+ (begin
+ (if (if s-10182
+ (supports-source-properties? e-10179)
+ #f)
+ (set-source-properties! e-10179 s-10182))
+ e-10179)))
+ (if (if (null? (car w-10181))
+ (null? (cdr w-10181))
+ #f)
+ x-11197
+ (if (if (vector? x-11197)
+ (if (= (vector-length x-11197) 4)
+ (eq? (vector-ref x-11197 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-11229 (vector-ref x-11197 1))
+ (wrap-11230
+ (let ((w2-11238 (vector-ref x-11197 2)))
+ (let ((m1-11239 (car w-10181))
+ (s1-11240 (cdr w-10181)))
+ (if (null? m1-11239)
+ (if (null? s1-11240)
+ w2-11238
+ (cons (car w2-11238)
+ (let ((m2-11255
+ (cdr w2-11238)))
+ (if (null? m2-11255)
+ s1-11240
+ (append
+ s1-11240
+ m2-11255)))))
+ (cons (let ((m2-11263 (car w2-11238)))
+ (if (null? m2-11263)
+ m1-11239
+ (append m1-11239 m2-11263)))
+ (let ((m2-11271 (cdr w2-11238)))
+ (if (null? m2-11271)
+ s1-11240
+ (append
+ s1-11240
+ m2-11271))))))))
+ (module-11231 (vector-ref x-11197 3)))
+ (vector
+ 'syntax-object
+ expression-11229
+ wrap-11230
+ module-11231))
+ (if (null? x-11197)
+ x-11197
+ (vector
+ 'syntax-object
+ x-11197
+ w-10181
+ mod-10183))))))))))))
+ (module-define!
+ (current-module)
+ '@
+ (make-syntax-transformer
+ '@
+ 'module-ref
+ (lambda (e-11302 r-11303 w-11304)
+ (let ((tmp-11306
+ ($sc-dispatch e-11302 '(_ each-any any))))
+ (if (if tmp-11306
+ (@apply
+ (lambda (mod-11309 id-11310)
+ (if (and-map id?-4347 mod-11309)
+ (if (symbol? id-11310)
+ #t
+ (if (if (vector? id-11310)
+ (if (= (vector-length id-11310) 4)
+ (eq? (vector-ref id-11310 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref id-11310 1))
+ #f))
+ #f))
+ tmp-11306)
+ #f)
+ (@apply
+ (lambda (mod-11350 id-11351)
+ (values
+ (syntax->datum id-11351)
+ r-11303
+ w-11304
+ #f
+ (syntax->datum
+ (cons '#(syntax-object
+ public
+ ((top)
+ #(ribcage
+ #(mod id)
+ #((top) (top))
+ #("l-*-3651" "l-*-3652"))
+ #(ribcage () () ())
+ #(ribcage
+ #(e r w)
+ #((top) (top) (top))
+ #("l-*-3639" "l-*-3640" "l-*-3641"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ mod-11350))))
+ tmp-11306)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-11302))))))
+ (global-extend-4345
+ 'module-ref
+ '@@
+ (lambda (e-11465 r-11466 w-11467)
+ (letrec*
+ ((remodulate-11468
+ (lambda (x-11530 mod-11531)
+ (if (pair? x-11530)
+ (cons (remodulate-11468 (car x-11530) mod-11531)
+ (remodulate-11468 (cdr x-11530) mod-11531))
+ (if (if (vector? x-11530)
+ (if (= (vector-length x-11530) 4)
+ (eq? (vector-ref x-11530 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-11545
+ (remodulate-11468
+ (vector-ref x-11530 1)
+ mod-11531))
+ (wrap-11546 (vector-ref x-11530 2)))
+ (vector
+ 'syntax-object
+ expression-11545
+ wrap-11546
+ mod-11531))
+ (if (vector? x-11530)
+ (let ((n-11554 (vector-length x-11530)))
+ (let ((v-11555 (make-vector n-11554)))
+ (letrec*
+ ((loop-11556
+ (lambda (i-11611)
+ (if (= i-11611 n-11554)
+ v-11555
+ (begin
+ (vector-set!
+ v-11555
+ i-11611
+ (remodulate-11468
+ (vector-ref x-11530 i-11611)
+ mod-11531))
+ (loop-11556 (#{1+}# i-11611)))))))
+ (loop-11556 0))))
+ x-11530))))))
+ (let ((tmp-11470
+ ($sc-dispatch e-11465 '(_ each-any any))))
+ (if (if tmp-11470
+ (@apply
+ (lambda (mod-11474 exp-11475)
+ (and-map id?-4347 mod-11474))
+ tmp-11470)
+ #f)
+ (@apply
+ (lambda (mod-11491 exp-11492)
+ (let ((mod-11493
+ (syntax->datum
+ (cons '#(syntax-object
+ private
+ ((top)
+ #(ribcage
+ #(mod exp)
+ #((top) (top))
+ #("l-*-3689" "l-*-3690"))
+ #(ribcage
+ (remodulate)
+ ((top))
+ ("l-*-3662"))
+ #(ribcage
+ #(e r w)
+ #((top) (top) (top))
+ #("l-*-3659" "l-*-3660" "l-*-3661"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ mod-11491))))
+ (values
+ (remodulate-11468 exp-11492 mod-11493)
+ r-11466
+ w-11467
+ (let ((props-11501
+ (source-properties
+ (if (if (vector? exp-11492)
+ (if (= (vector-length exp-11492) 4)
+ (eq? (vector-ref exp-11492 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref exp-11492 1)
+ exp-11492))))
+ (if (pair? props-11501) props-11501 #f))
+ mod-11493)))
+ tmp-11470)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-11465))))))
+ (global-extend-4345
+ 'core
+ 'if
+ (lambda (e-11884 r-11885 w-11886 s-11887 mod-11888)
+ (let ((tmp-11890 ($sc-dispatch e-11884 '(_ any any))))
+ (if tmp-11890
+ (@apply
+ (lambda (test-11894 then-11895)
+ (let ((test-exp-11900
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ test-11894
+ r-11885
+ w-11886
+ (let ((props-11922
+ (source-properties
+ (if (if (vector? test-11894)
+ (if (= (vector-length
+ test-11894)
+ 4)
+ (eq? (vector-ref
+ test-11894
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref test-11894 1)
+ test-11894))))
+ (if (pair? props-11922) props-11922 #f))
+ #f
+ mod-11888
+ #f))
+ (lambda (type-11955
+ value-11956
+ form-11957
+ e-11958
+ w-11959
+ s-11960
+ mod-11961)
+ (expand-expr-4384
+ type-11955
+ value-11956
+ form-11957
+ e-11958
+ r-11885
+ w-11959
+ s-11960
+ mod-11961))))
+ (then-exp-11901
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ then-11895
+ r-11885
+ w-11886
+ (let ((props-11979
+ (source-properties
+ (if (if (vector? then-11895)
+ (if (= (vector-length
+ then-11895)
+ 4)
+ (eq? (vector-ref
+ then-11895
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref then-11895 1)
+ then-11895))))
+ (if (pair? props-11979) props-11979 #f))
+ #f
+ mod-11888
+ #f))
+ (lambda (type-12012
+ value-12013
+ form-12014
+ e-12015
+ w-12016
+ s-12017
+ mod-12018)
+ (expand-expr-4384
+ type-12012
+ value-12013
+ form-12014
+ e-12015
+ r-11885
+ w-12016
+ s-12017
+ mod-12018))))
+ (else-exp-11902
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 0)
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 10)
+ s-11887
+ test-exp-11900
+ then-exp-11901
+ else-exp-11902)))
+ tmp-11890)
+ (let ((tmp-12027
+ ($sc-dispatch e-11884 '(_ any any any))))
+ (if tmp-12027
+ (@apply
+ (lambda (test-12031 then-12032 else-12033)
+ (let ((test-exp-12038
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ test-12031
+ r-11885
+ w-11886
+ (let ((props-12060
+ (source-properties
+ (if (if (vector? test-12031)
+ (if (= (vector-length
+ test-12031)
+ 4)
+ (eq? (vector-ref
+ test-12031
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref test-12031 1)
+ test-12031))))
+ (if (pair? props-12060) props-12060 #f))
+ #f
+ mod-11888
+ #f))
+ (lambda (type-12093
+ value-12094
+ form-12095
+ e-12096
+ w-12097
+ s-12098
+ mod-12099)
+ (expand-expr-4384
+ type-12093
+ value-12094
+ form-12095
+ e-12096
+ r-11885
+ w-12097
+ s-12098
+ mod-12099))))
+ (then-exp-12039
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ then-12032
+ r-11885
+ w-11886
+ (let ((props-12117
+ (source-properties
+ (if (if (vector? then-12032)
+ (if (= (vector-length
+ then-12032)
+ 4)
+ (eq? (vector-ref
+ then-12032
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref then-12032 1)
+ then-12032))))
+ (if (pair? props-12117) props-12117 #f))
+ #f
+ mod-11888
+ #f))
+ (lambda (type-12150
+ value-12151
+ form-12152
+ e-12153
+ w-12154
+ s-12155
+ mod-12156)
+ (expand-expr-4384
+ type-12150
+ value-12151
+ form-12152
+ e-12153
+ r-11885
+ w-12154
+ s-12155
+ mod-12156))))
+ (else-exp-12040
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ else-12033
+ r-11885
+ w-11886
+ (let ((props-12174
+ (source-properties
+ (if (if (vector? else-12033)
+ (if (= (vector-length
+ else-12033)
+ 4)
+ (eq? (vector-ref
+ else-12033
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref else-12033 1)
+ else-12033))))
+ (if (pair? props-12174) props-12174 #f))
+ #f
+ mod-11888
+ #f))
+ (lambda (type-12207
+ value-12208
+ form-12209
+ e-12210
+ w-12211
+ s-12212
+ mod-12213)
+ (expand-expr-4384
+ type-12207
+ value-12208
+ form-12209
+ e-12210
+ r-11885
+ w-12211
+ s-12212
+ mod-12213)))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 10)
+ s-11887
+ test-exp-12038
+ then-exp-12039
+ else-exp-12040)))
+ tmp-12027)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-11884)))))))
+ (global-extend-4345
+ 'core
+ 'with-fluids
+ (lambda (e-12466 r-12467 w-12468 s-12469 mod-12470)
+ (let ((tmp-12472
+ ($sc-dispatch
+ e-12466
+ '(_ #(each (any any)) any . each-any))))
+ (if tmp-12472
+ (@apply
+ (lambda (fluid-12476 val-12477 b-12478 b*-12479)
+ (let ((fluids-12483
+ (map (lambda (x-12491)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ x-12491
+ r-12467
+ w-12468
+ (let ((props-12506
+ (source-properties
+ (if (if (vector? x-12491)
+ (if (= (vector-length
+ x-12491)
+ 4)
+ (eq? (vector-ref
+ x-12491
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-12491 1)
+ x-12491))))
+ (if (pair? props-12506)
+ props-12506
+ #f))
+ #f
+ mod-12470
+ #f))
+ (lambda (type-12539
+ value-12540
+ form-12541
+ e-12542
+ w-12543
+ s-12544
+ mod-12545)
+ (expand-expr-4384
+ type-12539
+ value-12540
+ form-12541
+ e-12542
+ r-12467
+ w-12543
+ s-12544
+ mod-12545))))
+ fluid-12476))
+ (vals-12484
+ (map (lambda (x-12549)
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ x-12549
+ r-12467
+ w-12468
+ (let ((props-12564
+ (source-properties
+ (if (if (vector? x-12549)
+ (if (= (vector-length
+ x-12549)
+ 4)
+ (eq? (vector-ref
+ x-12549
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-12549 1)
+ x-12549))))
+ (if (pair? props-12564)
+ props-12564
+ #f))
+ #f
+ mod-12470
+ #f))
+ (lambda (type-12597
+ value-12598
+ form-12599
+ e-12600
+ w-12601
+ s-12602
+ mod-12603)
+ (expand-expr-4384
+ type-12597
+ value-12598
+ form-12599
+ e-12600
+ r-12467
+ w-12601
+ s-12602
+ mod-12603))))
+ val-12477))
+ (body-12485
+ (expand-body-4387
+ (cons b-12478 b*-12479)
+ (let ((x-12616
+ (begin
+ (if (if s-12469
+ (supports-source-properties?
+ e-12466)
+ #f)
+ (set-source-properties!
+ e-12466
+ s-12469))
+ e-12466)))
+ (if (if (null? (car w-12468))
+ (null? (cdr w-12468))
+ #f)
+ x-12616
+ (if (if (vector? x-12616)
+ (if (= (vector-length x-12616) 4)
+ (eq? (vector-ref x-12616 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (make-syntax-object-4333
+ (vector-ref x-12616 1)
+ (let ((w2-12652 (vector-ref x-12616 2)))
+ (let ((m1-12653 (car w-12468))
+ (s1-12654 (cdr w-12468)))
+ (if (null? m1-12653)
+ (if (null? s1-12654)
+ w2-12652
+ (cons (car w2-12652)
+ (let ((m2-12669
+ (cdr w2-12652)))
+ (if (null? m2-12669)
+ s1-12654
+ (append
+ s1-12654
+ m2-12669)))))
+ (cons (let ((m2-12677
+ (car w2-12652)))
+ (if (null? m2-12677)
+ m1-12653
+ (append
+ m1-12653
+ m2-12677)))
+ (let ((m2-12685
+ (cdr w2-12652)))
+ (if (null? m2-12685)
+ s1-12654
+ (append
+ s1-12654
+ m2-12685)))))))
+ (vector-ref x-12616 3))
+ (if (null? x-12616)
+ x-12616
+ (make-syntax-object-4333
+ x-12616
+ w-12468
+ mod-12470)))))
+ r-12467
+ w-12468
+ mod-12470)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 18)
+ s-12469
+ fluids-12483
+ vals-12484
+ body-12485)))
+ tmp-12472)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ e-12466)))))
+ (module-define!
+ (current-module)
+ 'begin
+ (make-syntax-transformer 'begin 'begin '()))
+ (module-define!
+ (current-module)
+ 'define
+ (make-syntax-transformer 'define 'define '()))
+ (module-define!
+ (current-module)
+ 'define-syntax
+ (make-syntax-transformer
+ 'define-syntax
+ 'define-syntax
+ '()))
+ (module-define!
+ (current-module)
+ 'define-syntax-parameter
+ (make-syntax-transformer
+ 'define-syntax-parameter
+ 'define-syntax-parameter
+ '()))
+ (module-define!
+ (current-module)
+ 'eval-when
+ (make-syntax-transformer
+ 'eval-when
+ 'eval-when
+ '()))
+ (global-extend-4345
+ 'core
+ 'syntax-case
+ (letrec*
+ ((convert-pattern-12980
+ (lambda (pattern-14451 keys-14452)
+ (letrec*
+ ((cvt*-14453
+ (lambda (p*-15252 n-15253 ids-15254)
+ (if (not (pair? p*-15252))
+ (cvt-14455 p*-15252 n-15253 ids-15254)
+ (call-with-values
+ (lambda ()
+ (cvt*-14453 (cdr p*-15252) n-15253 ids-15254))
+ (lambda (y-15257 ids-15258)
+ (call-with-values
+ (lambda ()
+ (cvt-14455 (car p*-15252) n-15253 ids-15258))
+ (lambda (x-15261 ids-15262)
+ (values
+ (cons x-15261 y-15257)
+ ids-15262))))))))
+ (v-reverse-14454
+ (lambda (x-15263)
+ (letrec*
+ ((loop-15264
+ (lambda (r-15365 x-15366)
+ (if (not (pair? x-15366))
+ (values r-15365 x-15366)
+ (loop-15264
+ (cons (car x-15366) r-15365)
+ (cdr x-15366))))))
+ (loop-15264 '() x-15263))))
+ (cvt-14455
+ (lambda (p-14458 n-14459 ids-14460)
+ (if (if (symbol? p-14458)
+ #t
+ (if (if (vector? p-14458)
+ (if (= (vector-length p-14458) 4)
+ (eq? (vector-ref p-14458 0) 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref p-14458 1))
+ #f))
+ (if (bound-id-member?-4375 p-14458 keys-14452)
+ (values (vector 'free-id p-14458) ids-14460)
+ (if (free-id=?-4371
+ p-14458
+ '#(syntax-object
+ _
+ ((top)
+ #(ribcage () () ())
+ #(ribcage
+ #(p n ids)
+ #((top) (top) (top))
+ #("l-*-3790" "l-*-3791" "l-*-3792"))
+ #(ribcage
+ (cvt v-reverse cvt*)
+ ((top) (top) (top))
+ ("l-*-3763" "l-*-3761" "l-*-3759"))
+ #(ribcage
+ #(pattern keys)
+ #((top) (top))
+ #("l-*-3757" "l-*-3758"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("l-*-3753"
+ "l-*-3751"
+ "l-*-3749"
+ "l-*-3747"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ (values '_ ids-14460)
+ (values
+ 'any
+ (cons (cons p-14458 n-14459) ids-14460))))
+ (let ((tmp-14592 ($sc-dispatch p-14458 '(any any))))
+ (if (if tmp-14592
+ (@apply
+ (lambda (x-14596 dots-14597)
+ (if (if (if (vector? dots-14597)
+ (if (= (vector-length dots-14597)
+ 4)
+ (eq? (vector-ref dots-14597 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref dots-14597 1))
+ #f)
+ (free-id=?-4371
+ dots-14597
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("l-*-2325"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))
+ tmp-14592)
+ #f)
+ (@apply
+ (lambda (x-14636 dots-14637)
+ (call-with-values
+ (lambda ()
+ (cvt-14455
+ x-14636
+ (#{1+}# n-14459)
+ ids-14460))
+ (lambda (p-14638 ids-14639)
+ (values
+ (if (eq? p-14638 'any)
+ 'each-any
+ (vector 'each p-14638))
+ ids-14639))))
+ tmp-14592)
+ (let ((tmp-14640
+ ($sc-dispatch p-14458 '(any any . any))))
+ (if (if tmp-14640
+ (@apply
+ (lambda (x-14644 dots-14645 ys-14646)
+ (if (if (if (vector? dots-14645)
+ (if (= (vector-length
+ dots-14645)
+ 4)
+ (eq? (vector-ref
+ dots-14645
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol?
+ (vector-ref dots-14645 1))
+ #f)
+ (free-id=?-4371
+ dots-14645
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("l-*-2325"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))
+ tmp-14640)
+ #f)
+ (@apply
+ (lambda (x-14685 dots-14686 ys-14687)
+ (call-with-values
+ (lambda ()
+ (cvt*-14453
+ ys-14687
+ n-14459
+ ids-14460))
+ (lambda (ys-15172 ids-15173)
+ (call-with-values
+ (lambda ()
+ (cvt-14455
+ x-14685
+ (#{1+}# n-14459)
+ ids-15173))
+ (lambda (x-15174 ids-15175)
+ (call-with-values
+ (lambda ()
+ (v-reverse-14454 ys-15172))
+ (lambda (ys-15211 e-15212)
+ (values
+ (vector
+ 'each+
+ x-15174
+ ys-15211
+ e-15212)
+ ids-15175))))))))
+ tmp-14640)
+ (let ((tmp-15213
+ ($sc-dispatch p-14458 '(any . any))))
+ (if tmp-15213
+ (@apply
+ (lambda (x-15217 y-15218)
+ (call-with-values
+ (lambda ()
+ (cvt-14455
+ y-15218
+ n-14459
+ ids-14460))
+ (lambda (y-15219 ids-15220)
+ (call-with-values
+ (lambda ()
+ (cvt-14455
+ x-15217
+ n-14459
+ ids-15220))
+ (lambda (x-15221 ids-15222)
+ (values
+ (cons x-15221 y-15219)
+ ids-15222))))))
+ tmp-15213)
+ (let ((tmp-15223
+ ($sc-dispatch p-14458 '())))
+ (if tmp-15223
+ (@apply
+ (lambda () (values '() ids-14460))
+ tmp-15223)
+ (let ((tmp-15227
+ ($sc-dispatch
+ p-14458
+ '#(vector each-any))))
+ (if tmp-15227
+ (@apply
+ (lambda (x-15231)
+ (call-with-values
+ (lambda ()
+ (cvt-14455
+ x-15231
+ n-14459
+ ids-14460))
+ (lambda (p-15232 ids-15233)
+ (values
+ (vector 'vector p-15232)
+ ids-15233))))
+ tmp-15227)
+ (values
+ (vector
+ 'atom
+ (strip-4396 p-14458 '(())))
+ ids-14460)))))))))))))))
+ (cvt-14455 pattern-14451 0 '()))))
+ (build-dispatch-call-12981
+ (lambda (pvars-15367 exp-15368 y-15369 r-15370 mod-15371)
+ (let ((ids-15372 (map car pvars-15367)))
+ (begin
+ (map cdr pvars-15367)
+ (let ((labels-15374 (gen-labels-4350 ids-15372))
+ (new-vars-15375 (map gen-var-4397 ids-15372)))
+ (build-primcall-4326
+ #f
+ 'apply
+ (list (build-simple-lambda-4323
+ #f
+ (map syntax->datum ids-15372)
+ #f
+ new-vars-15375
+ '()
+ (expand-4383
+ exp-15368
+ (extend-env-4342
+ labels-15374
+ (map (lambda (var-15703 level-15704)
+ (cons 'syntax
+ (cons var-15703 level-15704)))
+ new-vars-15375
+ (map cdr pvars-15367))
+ r-15370)
+ (make-binding-wrap-4361
+ ids-15372
+ labels-15374
+ '(()))
+ mod-15371))
+ y-15369)))))))
+ (gen-clause-12982
+ (lambda (x-14035
+ keys-14036
+ clauses-14037
+ r-14038
+ pat-14039
+ fender-14040
+ exp-14041
+ mod-14042)
+ (call-with-values
+ (lambda ()
+ (convert-pattern-12980 pat-14039 keys-14036))
+ (lambda (p-14180 pvars-14181)
+ (if (not (distinct-bound-ids?-4374 (map car pvars-14181)))
+ (syntax-violation
+ 'syntax-case
+ "duplicate pattern variable"
+ pat-14039)
+ (if (not (and-map
+ (lambda (x-14290)
+ (not (let ((x-14294 (car x-14290)))
+ (if (if (if (vector? x-14294)
+ (if (= (vector-length
+ x-14294)
+ 4)
+ (eq? (vector-ref
+ x-14294
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref x-14294 1))
+ #f)
+ (free-id=?-4371
+ x-14294
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("l-*-2325"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47"
+ "l-*-46"
+ "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))))
+ pvars-14181))
+ (syntax-violation
+ 'syntax-case
+ "misplaced ellipsis"
+ pat-14039)
+ (let ((y-14319
+ (gensym
+ (string-append (symbol->string 'tmp) "-"))))
+ (let ((fun-exp-14324
+ (let ((req-14333 (list 'tmp))
+ (vars-14335 (list y-14319))
+ (exp-14337
+ (let ((y-14366
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 3)
+ #f
+ 'tmp
+ y-14319)))
+ (let ((test-exp-14370
+ (let ((tmp-14379
+ ($sc-dispatch
+ fender-14040
+ '#(atom #t))))
+ (if tmp-14379
+ (@apply
+ (lambda () y-14366)
+ tmp-14379)
+ (let ((then-exp-14397
+ (build-dispatch-call-12981
+ pvars-14181
+ fender-14040
+ y-14366
+ r-14038
+ mod-14042))
+ (else-exp-14398
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 1)
+ #f
+ #f)))
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 10)
+ #f
+ y-14366
+ then-exp-14397
+ else-exp-14398)))))
+ (then-exp-14371
+ (build-dispatch-call-12981
+ pvars-14181
+ exp-14041
+ y-14366
+ r-14038
+ mod-14042))
+ (else-exp-14372
+ (gen-syntax-case-12983
+ x-14035
+ keys-14036
+ clauses-14037
+ r-14038
+ mod-14042)))
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 10)
+ #f
+ test-exp-14370
+ then-exp-14371
+ else-exp-14372)))))
+ (let ((body-14342
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 15)
+ #f
+ req-14333
+ #f
+ #f
+ #f
+ '()
+ vars-14335
+ exp-14337
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #f
+ '()
+ body-14342))))
+ (arg-exps-14325
+ (list (if (eq? p-14180 'any)
+ (let ((args-14430 (list x-14035)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'list
+ args-14430))
+ (let ((args-14439
+ (list x-14035
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 1)
+ #f
+ p-14180))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ '$sc-dispatch
+ args-14439))))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ #f
+ fun-exp-14324
+ arg-exps-14325)))))))))
+ (gen-syntax-case-12983
+ (lambda (x-13555
+ keys-13556
+ clauses-13557
+ r-13558
+ mod-13559)
+ (if (null? clauses-13557)
+ (let ((args-13565
+ (list (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ #f)
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 1)
+ #f
+ "source expression failed to match any pattern")
+ x-13555)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 12)
+ #f
+ 'syntax-violation
+ args-13565))
+ (let ((tmp-13584 (car clauses-13557)))
+ (let ((tmp-13585 ($sc-dispatch tmp-13584 '(any any))))
+ (if tmp-13585
+ (@apply
+ (lambda (pat-13587 exp-13588)
+ (if (if (if (symbol? pat-13587)
+ #t
+ (if (if (vector? pat-13587)
+ (if (= (vector-length pat-13587) 4)
+ (eq? (vector-ref pat-13587 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref pat-13587 1))
#f))
- #f))
- key-11011)
- (let ((x-11139
- (gensym
- (string-append (symbol->string 'tmp) "-"))))
- (build-application-4262
- s-10981
- (let ((req-11269 (list 'tmp))
- (vars-11271 (list x-11139))
- (exp-11273
- (gen-syntax-case-10977
- (make-struct/no-tail
- (vector-ref %expanded-vtables 3)
- #f
- 'tmp
- x-11139)
- key-11011
- m-11012
- r-10979
- mod-10982)))
- (let ((body-11278
- (make-struct/no-tail
- (vector-ref %expanded-vtables 14)
- #f
- req-11269
- #f
- #f
- #f
- '()
- vars-11271
- exp-11273
- #f)))
- (make-struct/no-tail
- (vector-ref %expanded-vtables 13)
- #f
- '()
- body-11278)))
- (list (expand-4331
- val-11010
- r-10979
- '(())
- mod-10982))))
- (syntax-violation
- 'syntax-case
- "invalid literals list"
- e-10983)))
- tmp-10985)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- e-10983)))))))
+ (and-map
+ (lambda (x-13615)
+ (not (free-id=?-4371 pat-13587 x-13615)))
+ (cons '#(syntax-object
+ ...
+ ((top)
+ #(ribcage
+ #(pat exp)
+ #((top) (top))
+ #("l-*-3942" "l-*-3943"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("l-*-3932"
+ "l-*-3933"
+ "l-*-3934"
+ "l-*-3935"
+ "l-*-3936"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("l-*-3753"
+ "l-*-3751"
+ "l-*-3749"
+ "l-*-3747"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ keys-13556))
+ #f)
+ (if (free-id=?-4371
+ '#(syntax-object
+ pad
+ ((top)
+ #(ribcage
+ #(pat exp)
+ #((top) (top))
+ #("l-*-3942" "l-*-3943"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("l-*-3932"
+ "l-*-3933"
+ "l-*-3934"
+ "l-*-3935"
+ "l-*-3936"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("l-*-3753"
+ "l-*-3751"
+ "l-*-3749"
+ "l-*-3747"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile))
+ '#(syntax-object
+ _
+ ((top)
+ #(ribcage
+ #(pat exp)
+ #((top) (top))
+ #("l-*-3942" "l-*-3943"))
+ #(ribcage () () ())
+ #(ribcage
+ #(x keys clauses r mod)
+ #((top) (top) (top) (top) (top))
+ #("l-*-3932"
+ "l-*-3933"
+ "l-*-3934"
+ "l-*-3935"
+ "l-*-3936"))
+ #(ribcage
+ (gen-syntax-case
+ gen-clause
+ build-dispatch-call
+ convert-pattern)
+ ((top) (top) (top) (top))
+ ("l-*-3753"
+ "l-*-3751"
+ "l-*-3749"
+ "l-*-3747"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ exp-13588
+ r-13558
+ '(())
+ (let ((props-13635
+ (source-properties
+ (if (if (vector? exp-13588)
+ (if (= (vector-length
+ exp-13588)
+ 4)
+ (eq? (vector-ref
+ exp-13588
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref exp-13588 1)
+ exp-13588))))
+ (if (pair? props-13635) props-13635 #f))
+ #f
+ mod-13559
+ #f))
+ (lambda (type-13668
+ value-13669
+ form-13670
+ e-13671
+ w-13672
+ s-13673
+ mod-13674)
+ (expand-expr-4384
+ type-13668
+ value-13669
+ form-13670
+ e-13671
+ r-13558
+ w-13672
+ s-13673
+ mod-13674)))
+ (let ((labels-13678
+ (list (string-append
+ "l-"
+ (session-id-4308)
+ (symbol->string (gensym "-")))))
+ (var-13679
+ (let ((id-13717
+ (if (if (vector? pat-13587)
+ (if (= (vector-length
+ pat-13587)
+ 4)
+ (eq? (vector-ref
+ pat-13587
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref pat-13587 1)
+ pat-13587)))
+ (gensym
+ (string-append
+ (symbol->string id-13717)
+ "-")))))
+ (build-call-4314
+ #f
+ (build-simple-lambda-4323
+ #f
+ (list (syntax->datum pat-13587))
+ #f
+ (list var-13679)
+ '()
+ (expand-4383
+ exp-13588
+ (extend-env-4342
+ labels-13678
+ (list (cons 'syntax
+ (cons var-13679 0)))
+ r-13558)
+ (make-binding-wrap-4361
+ (list pat-13587)
+ labels-13678
+ '(()))
+ mod-13559))
+ (list x-13555))))
+ (gen-clause-12982
+ x-13555
+ keys-13556
+ (cdr clauses-13557)
+ r-13558
+ pat-13587
+ #t
+ exp-13588
+ mod-13559)))
+ tmp-13585)
+ (let ((tmp-14027
+ ($sc-dispatch tmp-13584 '(any any any))))
+ (if tmp-14027
+ (@apply
+ (lambda (pat-14029 fender-14030 exp-14031)
+ (gen-clause-12982
+ x-13555
+ keys-13556
+ (cdr clauses-13557)
+ r-13558
+ pat-14029
+ fender-14030
+ exp-14031
+ mod-13559))
+ tmp-14027)
+ (syntax-violation
+ 'syntax-case
+ "invalid clause"
+ (car clauses-13557)))))))))))
+ (lambda (e-12984 r-12985 w-12986 s-12987 mod-12988)
+ (let ((e-12989
+ (let ((x-13466
+ (begin
+ (if (if s-12987
+ (supports-source-properties? e-12984)
+ #f)
+ (set-source-properties! e-12984 s-12987))
+ e-12984)))
+ (if (if (null? (car w-12986))
+ (null? (cdr w-12986))
+ #f)
+ x-13466
+ (if (if (vector? x-13466)
+ (if (= (vector-length x-13466) 4)
+ (eq? (vector-ref x-13466 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-13498 (vector-ref x-13466 1))
+ (wrap-13499
+ (let ((w2-13507 (vector-ref x-13466 2)))
+ (let ((m1-13508 (car w-12986))
+ (s1-13509 (cdr w-12986)))
+ (if (null? m1-13508)
+ (if (null? s1-13509)
+ w2-13507
+ (cons (car w2-13507)
+ (let ((m2-13524
+ (cdr w2-13507)))
+ (if (null? m2-13524)
+ s1-13509
+ (append
+ s1-13509
+ m2-13524)))))
+ (cons (let ((m2-13532 (car w2-13507)))
+ (if (null? m2-13532)
+ m1-13508
+ (append m1-13508 m2-13532)))
+ (let ((m2-13540 (cdr w2-13507)))
+ (if (null? m2-13540)
+ s1-13509
+ (append
+ s1-13509
+ m2-13540))))))))
+ (module-13500 (vector-ref x-13466 3)))
+ (vector
+ 'syntax-object
+ expression-13498
+ wrap-13499
+ module-13500))
+ (if (null? x-13466)
+ x-13466
+ (vector
+ 'syntax-object
+ x-13466
+ w-12986
+ mod-12988)))))))
+ (let ((tmp-12990 e-12989))
+ (let ((tmp-12991
+ ($sc-dispatch
+ tmp-12990
+ '(_ any each-any . each-any))))
+ (if tmp-12991
+ (@apply
+ (lambda (val-13039 key-13040 m-13041)
+ (if (and-map
+ (lambda (x-13042)
+ (if (if (symbol? x-13042)
+ #t
+ (if (if (vector? x-13042)
+ (if (= (vector-length x-13042) 4)
+ (eq? (vector-ref x-13042 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref x-13042 1))
+ #f))
+ (not (if (if (if (vector? x-13042)
+ (if (= (vector-length x-13042)
+ 4)
+ (eq? (vector-ref x-13042 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (symbol? (vector-ref x-13042 1))
+ #f)
+ (free-id=?-4371
+ x-13042
+ '#(syntax-object
+ ...
+ ((top)
+ #(ribcage () () ())
+ #(ribcage () () ())
+ #(ribcage
+ #(x)
+ #((top))
+ #("l-*-2325"))
+ #(ribcage
+ (lambda-var-list
+ gen-var
+ strip
+ expand-lambda-case
+ lambda*-formals
+ expand-simple-lambda
+ lambda-formals
+ ellipsis?
+ expand-void
+ eval-local-transformer
+ expand-local-syntax
+ expand-body
+ expand-macro
+ expand-call
+ expand-expr
+ expand
+ syntax-type
+ parse-when-list
+ expand-install-global
+ expand-top-sequence
+ expand-sequence
+ source-wrap
+ wrap
+ bound-id-member?
+ distinct-bound-ids?
+ valid-bound-ids?
+ bound-id=?
+ free-id=?
+ with-transformer-environment
+ transformer-environment
+ resolve-identifier
+ locally-bound-identifiers
+ id-var-name
+ same-marks?
+ join-marks
+ join-wraps
+ smart-append
+ make-binding-wrap
+ extend-ribcage!
+ make-empty-ribcage
+ new-mark
+ anti-mark
+ the-anti-mark
+ top-marked?
+ top-wrap
+ empty-wrap
+ set-ribcage-labels!
+ set-ribcage-marks!
+ set-ribcage-symnames!
+ ribcage-labels
+ ribcage-marks
+ ribcage-symnames
+ ribcage?
+ make-ribcage
+ gen-labels
+ gen-label
+ make-rename
+ rename-marks
+ rename-new
+ rename-old
+ subst-rename?
+ wrap-subst
+ wrap-marks
+ make-wrap
+ id-sym-name&marks
+ id-sym-name
+ id?
+ nonsymbol-id?
+ global-extend
+ macros-only-env
+ extend-var-env
+ extend-env
+ null-env
+ binding-value
+ binding-type
+ make-binding
+ arg-check
+ source-annotation
+ no-source
+ set-syntax-object-module!
+ set-syntax-object-wrap!
+ set-syntax-object-expression!
+ syntax-object-module
+ syntax-object-wrap
+ syntax-object-expression
+ syntax-object?
+ make-syntax-object
+ build-lexical-var
+ build-letrec
+ build-named-let
+ build-let
+ build-sequence
+ build-data
+ build-primref
+ build-primcall
+ build-lambda-case
+ build-case-lambda
+ build-simple-lambda
+ build-global-definition
+ build-global-assignment
+ build-global-reference
+ analyze-variable
+ build-lexical-assignment
+ build-lexical-reference
+ build-dynlet
+ build-conditional
+ build-call
+ build-void
+ maybe-name-value!
+ decorate-source
+ get-global-definition-hook
+ put-global-definition-hook
+ session-id
+ local-eval-hook
+ top-level-eval-hook
+ fx<
+ fx=
+ fx-
+ fx+
+ set-lambda-meta!
+ lambda-meta
+ lambda?
+ make-dynlet
+ make-letrec
+ make-let
+ make-lambda-case
+ make-lambda
+ make-seq
+ make-primcall
+ make-call
+ make-conditional
+ make-toplevel-define
+ make-toplevel-set
+ make-toplevel-ref
+ make-module-set
+ make-module-ref
+ make-lexical-set
+ make-lexical-ref
+ make-primitive-ref
+ make-const
+ make-void)
+ ((top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top)
+ (top))
+ ("l-*-478"
+ "l-*-476"
+ "l-*-474"
+ "l-*-472"
+ "l-*-470"
+ "l-*-468"
+ "l-*-466"
+ "l-*-464"
+ "l-*-462"
+ "l-*-460"
+ "l-*-458"
+ "l-*-456"
+ "l-*-454"
+ "l-*-452"
+ "l-*-450"
+ "l-*-448"
+ "l-*-446"
+ "l-*-444"
+ "l-*-442"
+ "l-*-440"
+ "l-*-438"
+ "l-*-436"
+ "l-*-434"
+ "l-*-432"
+ "l-*-430"
+ "l-*-428"
+ "l-*-426"
+ "l-*-424"
+ "l-*-422"
+ "l-*-420"
+ "l-*-418"
+ "l-*-416"
+ "l-*-414"
+ "l-*-412"
+ "l-*-410"
+ "l-*-408"
+ "l-*-406"
+ "l-*-404"
+ "l-*-402"
+ "l-*-401"
+ "l-*-399"
+ "l-*-396"
+ "l-*-395"
+ "l-*-394"
+ "l-*-392"
+ "l-*-391"
+ "l-*-389"
+ "l-*-387"
+ "l-*-385"
+ "l-*-383"
+ "l-*-381"
+ "l-*-379"
+ "l-*-377"
+ "l-*-375"
+ "l-*-372"
+ "l-*-370"
+ "l-*-369"
+ "l-*-367"
+ "l-*-365"
+ "l-*-363"
+ "l-*-361"
+ "l-*-360"
+ "l-*-359"
+ "l-*-358"
+ "l-*-356"
+ "l-*-355"
+ "l-*-352"
+ "l-*-350"
+ "l-*-348"
+ "l-*-346"
+ "l-*-344"
+ "l-*-342"
+ "l-*-341"
+ "l-*-340"
+ "l-*-338"
+ "l-*-336"
+ "l-*-335"
+ "l-*-332"
+ "l-*-331"
+ "l-*-329"
+ "l-*-327"
+ "l-*-325"
+ "l-*-323"
+ "l-*-321"
+ "l-*-319"
+ "l-*-317"
+ "l-*-315"
+ "l-*-313"
+ "l-*-310"
+ "l-*-308"
+ "l-*-306"
+ "l-*-304"
+ "l-*-302"
+ "l-*-300"
+ "l-*-298"
+ "l-*-296"
+ "l-*-294"
+ "l-*-292"
+ "l-*-290"
+ "l-*-288"
+ "l-*-286"
+ "l-*-284"
+ "l-*-282"
+ "l-*-280"
+ "l-*-278"
+ "l-*-276"
+ "l-*-274"
+ "l-*-272"
+ "l-*-270"
+ "l-*-268"
+ "l-*-266"
+ "l-*-264"
+ "l-*-262"
+ "l-*-260"
+ "l-*-258"
+ "l-*-257"
+ "l-*-256"
+ "l-*-255"
+ "l-*-254"
+ "l-*-252"
+ "l-*-250"
+ "l-*-248"
+ "l-*-245"
+ "l-*-243"
+ "l-*-241"
+ "l-*-239"
+ "l-*-237"
+ "l-*-235"
+ "l-*-233"
+ "l-*-231"
+ "l-*-229"
+ "l-*-227"
+ "l-*-225"
+ "l-*-223"
+ "l-*-221"
+ "l-*-219"
+ "l-*-217"
+ "l-*-215"
+ "l-*-213"
+ "l-*-211"
+ "l-*-209"))
+ #(ribcage
+ (define-structure
+ define-expansion-accessors
+ define-expansion-constructors)
+ ((top) (top) (top))
+ ("l-*-47" "l-*-46" "l-*-45"))
+ #(ribcage () () ()))
+ (hygiene guile)))
+ #f))
+ #f))
+ key-13040)
+ (let ((x-13107
+ (gensym
+ (string-append
+ (symbol->string 'tmp)
+ "-"))))
+ (let ((fun-exp-13112
+ (let ((req-13121 (list 'tmp))
+ (vars-13123 (list x-13107))
+ (exp-13125
+ (gen-syntax-case-12983
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 3)
+ #f
+ 'tmp
+ x-13107)
+ key-13040
+ m-13041
+ r-12985
+ mod-12988)))
+ (let ((body-13130
+ (make-struct/no-tail
+ (vector-ref
+ %expanded-vtables
+ 15)
+ #f
+ req-13121
+ #f
+ #f
+ #f
+ '()
+ vars-13123
+ exp-13125
+ #f)))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 14)
+ #f
+ '()
+ body-13130))))
+ (arg-exps-13113
+ (list (call-with-values
+ (lambda ()
+ (syntax-type-4382
+ val-13039
+ r-12985
+ '(())
+ (let ((props-13179
+ (source-properties
+ (if (if (vector?
+ val-13039)
+ (if (= (vector-length
+ val-13039)
+ 4)
+ (eq? (vector-ref
+ val-13039
+ 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref
+ val-13039
+ 1)
+ val-13039))))
+ (if (pair? props-13179)
+ props-13179
+ #f))
+ #f
+ mod-12988
+ #f))
+ (lambda (type-13212
+ value-13213
+ form-13214
+ e-13215
+ w-13216
+ s-13217
+ mod-13218)
+ (expand-expr-4384
+ type-13212
+ value-13213
+ form-13214
+ e-13215
+ r-12985
+ w-13216
+ s-13217
+ mod-13218))))))
+ (make-struct/no-tail
+ (vector-ref %expanded-vtables 11)
+ s-12987
+ fun-exp-13112
+ arg-exps-13113)))
+ (syntax-violation
+ 'syntax-case
+ "invalid literals list"
+ e-12989)))
+ tmp-12991)
+ (syntax-violation
+ #f
+ "source expression failed to match any pattern"
+ tmp-12990))))))))
(set! macroexpand
(lambda*
- (x-13696
+ (x-15783
#:optional
- (m-13697 'e)
- (esew-13698 '(eval)))
- (expand-top-sequence-4327
- (list x-13696)
+ (m-15784 'e)
+ (esew-15785 '(eval)))
+ (expand-top-sequence-4379
+ (list x-15783)
'()
'((top))
#f
- m-13697
- esew-13698
+ m-15784
+ esew-15785
(cons 'hygiene (module-name (current-module))))))
(set! identifier?
- (lambda (x-13701)
- (if (if (vector? x-13701)
- (if (= (vector-length x-13701) 4)
- (eq? (vector-ref x-13701 0) 'syntax-object)
+ (lambda (x-15788)
+ (if (if (vector? x-15788)
+ (if (= (vector-length x-15788) 4)
+ (eq? (vector-ref x-15788 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-13701 1))
+ (symbol? (vector-ref x-15788 1))
#f)))
(set! datum->syntax
- (lambda (id-13726 datum-13727)
- (let ((wrap-13732 (vector-ref id-13726 2))
- (module-13733 (vector-ref id-13726 3)))
+ (lambda (id-15813 datum-15814)
+ (let ((wrap-15819 (vector-ref id-15813 2))
+ (module-15820 (vector-ref id-15813 3)))
(vector
'syntax-object
- datum-13727
- wrap-13732
- module-13733))))
+ datum-15814
+ wrap-15819
+ module-15820))))
(set! syntax->datum
- (lambda (x-13740) (strip-4344 x-13740 '(()))))
+ (lambda (x-15827) (strip-4396 x-15827 '(()))))
(set! syntax-source
- (lambda (x-13743)
- (source-annotation-4288 x-13743)))
+ (lambda (x-15830)
+ (let ((props-15835
+ (source-properties
+ (if (if (vector? x-15830)
+ (if (= (vector-length x-15830) 4)
+ (eq? (vector-ref x-15830 0) 'syntax-object)
+ #f)
+ #f)
+ (vector-ref x-15830 1)
+ x-15830))))
+ (if (pair? props-15835) props-15835 #f))))
(set! generate-temporaries
- (lambda (ls-13896)
+ (lambda (ls-15858)
(begin
- (if (not (list? ls-13896))
+ (if (not (list? ls-15858))
(syntax-violation
'generate-temporaries
"invalid argument"
- ls-13896))
- (let ((mod-13904
+ ls-15858))
+ (let ((mod-15866
(cons 'hygiene (module-name (current-module)))))
- (map (lambda (x-13905)
- (wrap-4324 (gensym "t-") '((top)) mod-13904))
- ls-13896)))))
+ (map (lambda (x-15867)
+ (let ((x-15871 (gensym "t-")))
+ (if (if (vector? x-15871)
+ (if (= (vector-length x-15871) 4)
+ (eq? (vector-ref x-15871 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-15886 (vector-ref x-15871 1))
+ (wrap-15887
+ (let ((w2-15895 (vector-ref x-15871 2)))
+ (cons (let ((m2-15902 (car w2-15895)))
+ (if (null? m2-15902)
+ '(top)
+ (append '(top) m2-15902)))
+ (let ((m2-15909 (cdr w2-15895)))
+ (if (null? m2-15909)
+ '()
+ (append '() m2-15909))))))
+ (module-15888 (vector-ref x-15871 3)))
+ (vector
+ 'syntax-object
+ expression-15886
+ wrap-15887
+ module-15888))
+ (if (null? x-15871)
+ x-15871
+ (vector
+ 'syntax-object
+ x-15871
+ '((top))
+ mod-15866)))))
+ ls-15858)))))
(set! free-identifier=?
- (lambda (x-13909 y-13910)
+ (lambda (x-15918 y-15919)
(begin
- (if (not (if (if (vector? x-13909)
- (if (= (vector-length x-13909) 4)
- (eq? (vector-ref x-13909 0) 'syntax-object)
+ (if (not (if (if (vector? x-15918)
+ (if (= (vector-length x-15918) 4)
+ (eq? (vector-ref x-15918 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-13909 1))
+ (symbol? (vector-ref x-15918 1))
#f))
(syntax-violation
'free-identifier=?
"invalid argument"
- x-13909))
- (if (not (if (if (vector? y-13910)
- (if (= (vector-length y-13910) 4)
- (eq? (vector-ref y-13910 0) 'syntax-object)
+ x-15918))
+ (if (not (if (if (vector? y-15919)
+ (if (= (vector-length y-15919) 4)
+ (eq? (vector-ref y-15919 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref y-13910 1))
+ (symbol? (vector-ref y-15919 1))
#f))
(syntax-violation
'free-identifier=?
"invalid argument"
- y-13910))
- (if (eq? (if (if (vector? x-13909)
- (if (= (vector-length x-13909) 4)
- (eq? (vector-ref x-13909 0) 'syntax-object)
- #f)
- #f)
- (vector-ref x-13909 1)
- x-13909)
- (if (if (vector? y-13910)
- (if (= (vector-length y-13910) 4)
- (eq? (vector-ref y-13910 0) 'syntax-object)
- #f)
- #f)
- (vector-ref y-13910 1)
- y-13910))
- (eq? (id-var-name-4314 x-13909 '(()))
- (id-var-name-4314 y-13910 '(())))
- #f))))
+ y-15919))
+ (free-id=?-4371 x-15918 y-15919))))
(set! bound-identifier=?
- (lambda (x-14060 y-14061)
+ (lambda (x-15994 y-15995)
(begin
- (if (not (if (if (vector? x-14060)
- (if (= (vector-length x-14060) 4)
- (eq? (vector-ref x-14060 0) 'syntax-object)
+ (if (not (if (if (vector? x-15994)
+ (if (= (vector-length x-15994) 4)
+ (eq? (vector-ref x-15994 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref x-14060 1))
+ (symbol? (vector-ref x-15994 1))
#f))
(syntax-violation
'bound-identifier=?
"invalid argument"
- x-14060))
- (if (not (if (if (vector? y-14061)
- (if (= (vector-length y-14061) 4)
- (eq? (vector-ref y-14061 0) 'syntax-object)
+ x-15994))
+ (if (not (if (if (vector? y-15995)
+ (if (= (vector-length y-15995) 4)
+ (eq? (vector-ref y-15995 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref y-14061 1))
+ (symbol? (vector-ref y-15995 1))
#f))
(syntax-violation
'bound-identifier=?
"invalid argument"
- y-14061))
- (if (if (if (vector? x-14060)
- (if (= (vector-length x-14060) 4)
- (eq? (vector-ref x-14060 0) 'syntax-object)
- #f)
- #f)
- (if (vector? y-14061)
- (if (= (vector-length y-14061) 4)
- (eq? (vector-ref y-14061 0) 'syntax-object)
- #f)
- #f)
- #f)
- (if (eq? (vector-ref x-14060 1)
- (vector-ref y-14061 1))
- (same-marks?-4313
- (car (vector-ref x-14060 2))
- (car (vector-ref y-14061 2)))
- #f)
- (eq? x-14060 y-14061)))))
+ y-15995))
+ (bound-id=?-4372 x-15994 y-15995))))
(set! syntax-violation
(lambda*
- (who-14194
- message-14195
- form-14196
+ (who-16161
+ message-16162
+ form-16163
#:optional
- (subform-14197 #f))
+ (subform-16164 #f))
(begin
- (if (not (if (not who-14194)
- (not who-14194)
- (let ((t-14215 (string? who-14194)))
- (if t-14215 t-14215 (symbol? who-14194)))))
+ (if (not (if (not who-16161)
+ (not who-16161)
+ (let ((t-16182 (string? who-16161)))
+ (if t-16182 t-16182 (symbol? who-16161)))))
(syntax-violation
'syntax-violation
"invalid argument"
- who-14194))
- (if (not (string? message-14195))
+ who-16161))
+ (if (not (string? message-16162))
(syntax-violation
'syntax-violation
"invalid argument"
- message-14195))
+ message-16162))
(throw 'syntax-error
- who-14194
- message-14195
- (let ((t-14246 (source-annotation-4288 subform-14197)))
- (if t-14246
- t-14246
- (source-annotation-4288 form-14196)))
- (strip-4344 form-14196 '(()))
- (if subform-14197
- (strip-4344 subform-14197 '(()))
+ who-16161
+ message-16162
+ (let ((t-16213
+ (let ((props-16272
+ (source-properties
+ (if (if (vector? subform-16164)
+ (if (= (vector-length subform-16164)
+ 4)
+ (eq? (vector-ref subform-16164 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref subform-16164 1)
+ subform-16164))))
+ (if (pair? props-16272) props-16272 #f))))
+ (if t-16213
+ t-16213
+ (let ((props-16245
+ (source-properties
+ (if (if (vector? form-16163)
+ (if (= (vector-length form-16163) 4)
+ (eq? (vector-ref form-16163 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (vector-ref form-16163 1)
+ form-16163))))
+ (if (pair? props-16245) props-16245 #f))))
+ (strip-4396 form-16163 '(()))
+ (if subform-16164
+ (strip-4396 subform-16164 '(()))
#f)))))
(letrec*
- ((syntax-local-binding-14638
- (lambda (id-14771)
+ ((syntax-local-binding-16300
+ (lambda (id-16440)
(begin
- (if (not (if (if (vector? id-14771)
- (if (= (vector-length id-14771) 4)
- (eq? (vector-ref id-14771 0) 'syntax-object)
+ (if (not (if (if (vector? id-16440)
+ (if (= (vector-length id-16440) 4)
+ (eq? (vector-ref id-16440 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref id-14771 1))
+ (symbol? (vector-ref id-16440 1))
#f))
(syntax-violation
'syntax-local-binding
"invalid argument"
- id-14771))
- ((fluid-ref transformer-environment-4317)
- (lambda (e-14811
- r-14812
- w-14813
- s-14814
- rib-14815
- mod-14816)
+ id-16440))
+ ((fluid-ref transformer-environment-4369)
+ (lambda (e-16480
+ r-16481
+ w-16482
+ s-16483
+ rib-16484
+ mod-16485)
(call-with-values
(lambda ()
- (let ((id-14819 (vector-ref id-14771 1))
- (w-14820
- (let ((w-14831 (vector-ref id-14771 2)))
- (let ((ms-14832 (car w-14831))
- (s-14833 (cdr w-14831)))
- (if (if (pair? ms-14832)
- (eq? (car ms-14832) #f)
- #f)
- (cons (cdr ms-14832)
- (if rib-14815
- (cons rib-14815 (cdr s-14833))
- (cdr s-14833)))
- (cons ms-14832
- (if rib-14815
- (cons rib-14815 s-14833)
- s-14833))))))
- (mod-14822 (vector-ref id-14771 3)))
- (let ((n-14825 (id-var-name-4314 id-14819 w-14820)))
- (if (symbol? n-14825)
- (let ((mod-14839
- (if (if (vector? id-14819)
- (if (= (vector-length id-14819) 4)
- (eq? (vector-ref id-14819 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-14819 3)
- mod-14822)))
- (let ((b-14840
- (let ((t-14841
- (get-global-definition-hook-4258
- n-14825
- mod-14839)))
- (if t-14841 t-14841 '(global)))))
- (if (eq? (car b-14840) 'global)
- (values 'global n-14825 mod-14839)
- (values
- (car b-14840)
- (cdr b-14840)
- mod-14839))))
- (if (string? n-14825)
- (let ((mod-14867
- (if (if (vector? id-14819)
- (if (= (vector-length id-14819) 4)
- (eq? (vector-ref id-14819 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref id-14819 3)
- mod-14822)))
- (let ((b-14868
- (let ((t-14869
- (assq-ref r-14812 n-14825)))
- (if t-14869
- t-14869
- '(displaced-lexical)))))
- (values
- (car b-14868)
- (cdr b-14868)
- mod-14867)))
- (error "unexpected id-var-name"
- id-14819
- w-14820
- n-14825))))))
- (lambda (type-14882 value-14883 mod-14884)
- (if (eqv? type-14882 'lexical)
- (values 'lexical value-14883)
- (if (eqv? type-14882 'macro)
- (values 'macro value-14883)
- (if (eqv? type-14882 'syntax)
- (values 'pattern-variable value-14883)
- (if (eqv? type-14882 'displaced-lexical)
+ (resolve-identifier-4368
+ (vector-ref id-16440 1)
+ (let ((w-16492 (vector-ref id-16440 2)))
+ (let ((ms-16493 (car w-16492))
+ (s-16494 (cdr w-16492)))
+ (if (if (pair? ms-16493)
+ (eq? (car ms-16493) #f)
+ #f)
+ (cons (cdr ms-16493)
+ (if rib-16484
+ (cons rib-16484 (cdr s-16494))
+ (cdr s-16494)))
+ (cons ms-16493
+ (if rib-16484
+ (cons rib-16484 s-16494)
+ s-16494)))))
+ r-16481
+ (vector-ref id-16440 3)
+ #t))
+ (lambda (type-16501 value-16502 mod-16503)
+ (if (eqv? type-16501 'lexical)
+ (values 'lexical value-16502)
+ (if (eqv? type-16501 'macro)
+ (values 'macro value-16502)
+ (if (eqv? type-16501 'syntax)
+ (values 'pattern-variable value-16502)
+ (if (eqv? type-16501 'displaced-lexical)
(values 'displaced-lexical #f)
- (if (eqv? type-14882 'global)
+ (if (eqv? type-16501 'global)
(values
'global
- (cons value-14883 (cdr mod-14884)))
+ (cons value-16502 (cdr mod-16503)))
(values 'other #f)))))))))))))
- (syntax-locally-bound-identifiers-14639
- (lambda (id-14906)
+ (syntax-locally-bound-identifiers-16301
+ (lambda (id-16525)
(begin
- (if (not (if (if (vector? id-14906)
- (if (= (vector-length id-14906) 4)
- (eq? (vector-ref id-14906 0) 'syntax-object)
+ (if (not (if (if (vector? id-16525)
+ (if (= (vector-length id-16525) 4)
+ (eq? (vector-ref id-16525 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref id-14906 1))
+ (symbol? (vector-ref id-16525 1))
#f))
(syntax-violation
'syntax-locally-bound-identifiers
"invalid argument"
- id-14906))
- (locally-bound-identifiers-4315
- (vector-ref id-14906 2)
- (vector-ref id-14906 3))))))
+ id-16525))
+ (locally-bound-identifiers-4367
+ (vector-ref id-16525 2)
+ (vector-ref id-16525 3))))))
(begin
(define!
'syntax-module
- (lambda (id-14641)
+ (lambda (id-16303)
(begin
- (if (not (if (if (vector? id-14641)
- (if (= (vector-length id-14641) 4)
- (eq? (vector-ref id-14641 0) 'syntax-object)
+ (if (not (if (if (vector? id-16303)
+ (if (= (vector-length id-16303) 4)
+ (eq? (vector-ref id-16303 0) 'syntax-object)
#f)
#f)
- (symbol? (vector-ref id-14641 1))
+ (symbol? (vector-ref id-16303 1))
#f))
(syntax-violation
'syntax-module
"invalid argument"
- id-14641))
- (cdr (vector-ref id-14641 3)))))
+ id-16303))
+ (cdr (vector-ref id-16303 3)))))
(define!
'syntax-local-binding
- syntax-local-binding-14638)
+ syntax-local-binding-16300)
(define!
'syntax-locally-bound-identifiers
- syntax-locally-bound-identifiers-14639)))
+ syntax-locally-bound-identifiers-16301)))
(letrec*
- ((match-each-15013
- (lambda (e-15600 p-15601 w-15602 mod-15603)
- (if (pair? e-15600)
- (let ((first-15604
- (match-15019
- (car e-15600)
- p-15601
- w-15602
+ ((match-each-16642
+ (lambda (e-17521 p-17522 w-17523 mod-17524)
+ (if (pair? e-17521)
+ (let ((first-17525
+ (match-16648
+ (car e-17521)
+ p-17522
+ w-17523
'()
- mod-15603)))
- (if first-15604
- (let ((rest-15607
- (match-each-15013
- (cdr e-15600)
- p-15601
- w-15602
- mod-15603)))
- (if rest-15607 (cons first-15604 rest-15607) #f))
+ mod-17524)))
+ (if first-17525
+ (let ((rest-17528
+ (match-each-16642
+ (cdr e-17521)
+ p-17522
+ w-17523
+ mod-17524)))
+ (if rest-17528 (cons first-17525 rest-17528) #f))
#f))
- (if (null? e-15600)
+ (if (null? e-17521)
'()
- (if (if (vector? e-15600)
- (if (= (vector-length e-15600) 4)
- (eq? (vector-ref e-15600 0) 'syntax-object)
+ (if (if (vector? e-17521)
+ (if (= (vector-length e-17521) 4)
+ (eq? (vector-ref e-17521 0) 'syntax-object)
#f)
#f)
- (match-each-15013
- (vector-ref e-15600 1)
- p-15601
- (join-wraps-4311 w-15602 (vector-ref e-15600 2))
- (vector-ref e-15600 3))
+ (match-each-16642
+ (vector-ref e-17521 1)
+ p-17522
+ (let ((w2-17550 (vector-ref e-17521 2)))
+ (let ((m1-17551 (car w-17523))
+ (s1-17552 (cdr w-17523)))
+ (if (null? m1-17551)
+ (if (null? s1-17552)
+ w2-17550
+ (cons (car w2-17550)
+ (let ((m2-17563 (cdr w2-17550)))
+ (if (null? m2-17563)
+ s1-17552
+ (append s1-17552 m2-17563)))))
+ (cons (let ((m2-17571 (car w2-17550)))
+ (if (null? m2-17571)
+ m1-17551
+ (append m1-17551 m2-17571)))
+ (let ((m2-17579 (cdr w2-17550)))
+ (if (null? m2-17579)
+ s1-17552
+ (append s1-17552 m2-17579)))))))
+ (vector-ref e-17521 3))
#f)))))
- (match-each-any-15015
- (lambda (e-15635 w-15636 mod-15637)
- (if (pair? e-15635)
- (let ((l-15638
- (match-each-any-15015
- (cdr e-15635)
- w-15636
- mod-15637)))
- (if l-15638
- (cons (wrap-4324 (car e-15635) w-15636 mod-15637)
- l-15638)
+ (match-each-any-16644
+ (lambda (e-17588 w-17589 mod-17590)
+ (if (pair? e-17588)
+ (let ((l-17591
+ (match-each-any-16644
+ (cdr e-17588)
+ w-17589
+ mod-17590)))
+ (if l-17591
+ (cons (let ((x-17596 (car e-17588)))
+ (if (if (null? (car w-17589))
+ (null? (cdr w-17589))
+ #f)
+ x-17596
+ (if (if (vector? x-17596)
+ (if (= (vector-length x-17596) 4)
+ (eq? (vector-ref x-17596 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-17614 (vector-ref x-17596 1))
+ (wrap-17615
+ (let ((w2-17623 (vector-ref x-17596 2)))
+ (let ((m1-17624 (car w-17589))
+ (s1-17625 (cdr w-17589)))
+ (if (null? m1-17624)
+ (if (null? s1-17625)
+ w2-17623
+ (cons (car w2-17623)
+ (let ((m2-17640
+ (cdr w2-17623)))
+ (if (null? m2-17640)
+ s1-17625
+ (append
+ s1-17625
+ m2-17640)))))
+ (cons (let ((m2-17648
+ (car w2-17623)))
+ (if (null? m2-17648)
+ m1-17624
+ (append
+ m1-17624
+ m2-17648)))
+ (let ((m2-17656
+ (cdr w2-17623)))
+ (if (null? m2-17656)
+ s1-17625
+ (append
+ s1-17625
+ m2-17656))))))))
+ (module-17616 (vector-ref x-17596 3)))
+ (vector
+ 'syntax-object
+ expression-17614
+ wrap-17615
+ module-17616))
+ (if (null? x-17596)
+ x-17596
+ (vector
+ 'syntax-object
+ x-17596
+ w-17589
+ mod-17590)))))
+ l-17591)
#f))
- (if (null? e-15635)
+ (if (null? e-17588)
'()
- (if (if (vector? e-15635)
- (if (= (vector-length e-15635) 4)
- (eq? (vector-ref e-15635 0) 'syntax-object)
+ (if (if (vector? e-17588)
+ (if (= (vector-length e-17588) 4)
+ (eq? (vector-ref e-17588 0) 'syntax-object)
#f)
#f)
- (match-each-any-15015
- (vector-ref e-15635 1)
- (join-wraps-4311 w-15636 (vector-ref e-15635 2))
- mod-15637)
+ (match-each-any-16644
+ (vector-ref e-17588 1)
+ (let ((w2-17689 (vector-ref e-17588 2)))
+ (let ((m1-17690 (car w-17589))
+ (s1-17691 (cdr w-17589)))
+ (if (null? m1-17690)
+ (if (null? s1-17691)
+ w2-17689
+ (cons (car w2-17689)
+ (let ((m2-17702 (cdr w2-17689)))
+ (if (null? m2-17702)
+ s1-17691
+ (append s1-17691 m2-17702)))))
+ (cons (let ((m2-17710 (car w2-17689)))
+ (if (null? m2-17710)
+ m1-17690
+ (append m1-17690 m2-17710)))
+ (let ((m2-17718 (cdr w2-17689)))
+ (if (null? m2-17718)
+ s1-17691
+ (append s1-17691 m2-17718)))))))
+ mod-17590)
#f)))))
- (match-empty-15016
- (lambda (p-15662 r-15663)
- (if (null? p-15662)
- r-15663
- (if (eq? p-15662 '_)
- r-15663
- (if (eq? p-15662 'any)
- (cons '() r-15663)
- (if (pair? p-15662)
- (match-empty-15016
- (car p-15662)
- (match-empty-15016 (cdr p-15662) r-15663))
- (if (eq? p-15662 'each-any)
- (cons '() r-15663)
- (let ((key-15664 (vector-ref p-15662 0)))
- (if (eqv? key-15664 'each)
- (match-empty-15016
- (vector-ref p-15662 1)
- r-15663)
- (if (eqv? key-15664 'each+)
- (match-empty-15016
- (vector-ref p-15662 1)
- (match-empty-15016
- (reverse (vector-ref p-15662 2))
- (match-empty-15016
- (vector-ref p-15662 3)
- r-15663)))
- (if (if (eqv? key-15664 'free-id)
+ (match-empty-16645
+ (lambda (p-17723 r-17724)
+ (if (null? p-17723)
+ r-17724
+ (if (eq? p-17723 '_)
+ r-17724
+ (if (eq? p-17723 'any)
+ (cons '() r-17724)
+ (if (pair? p-17723)
+ (match-empty-16645
+ (car p-17723)
+ (match-empty-16645 (cdr p-17723) r-17724))
+ (if (eq? p-17723 'each-any)
+ (cons '() r-17724)
+ (let ((key-17725 (vector-ref p-17723 0)))
+ (if (eqv? key-17725 'each)
+ (match-empty-16645
+ (vector-ref p-17723 1)
+ r-17724)
+ (if (eqv? key-17725 'each+)
+ (match-empty-16645
+ (vector-ref p-17723 1)
+ (match-empty-16645
+ (reverse (vector-ref p-17723 2))
+ (match-empty-16645
+ (vector-ref p-17723 3)
+ r-17724)))
+ (if (if (eqv? key-17725 'free-id)
#t
- (eqv? key-15664 'atom))
- r-15663
- (if (eqv? key-15664 'vector)
- (match-empty-15016
- (vector-ref p-15662 1)
- r-15663)))))))))))))
- (combine-15017
- (lambda (r*-15683 r-15684)
- (if (null? (car r*-15683))
- r-15684
- (cons (map car r*-15683)
- (combine-15017 (map cdr r*-15683) r-15684)))))
- (match*-15018
- (lambda (e-15048 p-15049 w-15050 r-15051 mod-15052)
- (if (null? p-15049)
- (if (null? e-15048) r-15051 #f)
- (if (pair? p-15049)
- (if (pair? e-15048)
- (match-15019
- (car e-15048)
- (car p-15049)
- w-15050
- (match-15019
- (cdr e-15048)
- (cdr p-15049)
- w-15050
- r-15051
- mod-15052)
- mod-15052)
+ (eqv? key-17725 'atom))
+ r-17724
+ (if (eqv? key-17725 'vector)
+ (match-empty-16645
+ (vector-ref p-17723 1)
+ r-17724)))))))))))))
+ (combine-16646
+ (lambda (r*-17744 r-17745)
+ (if (null? (car r*-17744))
+ r-17745
+ (cons (map car r*-17744)
+ (combine-16646 (map cdr r*-17744) r-17745)))))
+ (match*-16647
+ (lambda (e-16677 p-16678 w-16679 r-16680 mod-16681)
+ (if (null? p-16678)
+ (if (null? e-16677) r-16680 #f)
+ (if (pair? p-16678)
+ (if (pair? e-16677)
+ (match-16648
+ (car e-16677)
+ (car p-16678)
+ w-16679
+ (match-16648
+ (cdr e-16677)
+ (cdr p-16678)
+ w-16679
+ r-16680
+ mod-16681)
+ mod-16681)
#f)
- (if (eq? p-15049 'each-any)
- (let ((l-15057
- (match-each-any-15015 e-15048 w-15050 mod-15052)))
- (if l-15057 (cons l-15057 r-15051) #f))
- (let ((key-15062 (vector-ref p-15049 0)))
- (if (eqv? key-15062 'each)
- (if (null? e-15048)
- (match-empty-15016
- (vector-ref p-15049 1)
- r-15051)
- (let ((l-15069
- (match-each-15013
- e-15048
- (vector-ref p-15049 1)
- w-15050
- mod-15052)))
- (if l-15069
+ (if (eq? p-16678 'each-any)
+ (let ((l-16686
+ (match-each-any-16644 e-16677 w-16679 mod-16681)))
+ (if l-16686 (cons l-16686 r-16680) #f))
+ (let ((key-16691 (vector-ref p-16678 0)))
+ (if (eqv? key-16691 'each)
+ (if (null? e-16677)
+ (match-empty-16645
+ (vector-ref p-16678 1)
+ r-16680)
+ (let ((l-16698
+ (match-each-16642
+ e-16677
+ (vector-ref p-16678 1)
+ w-16679
+ mod-16681)))
+ (if l-16698
(letrec*
- ((collect-15072
- (lambda (l-15123)
- (if (null? (car l-15123))
- r-15051
- (cons (map car l-15123)
- (collect-15072
- (map cdr l-15123)))))))
- (collect-15072 l-15069))
+ ((collect-16701
+ (lambda (l-16758)
+ (if (null? (car l-16758))
+ r-16680
+ (cons (map car l-16758)
+ (collect-16701
+ (map cdr l-16758)))))))
+ (collect-16701 l-16698))
#f)))
- (if (eqv? key-15062 'each+)
+ (if (eqv? key-16691 'each+)
(call-with-values
(lambda ()
- (let ((x-pat-15132 (vector-ref p-15049 1))
- (y-pat-15133 (vector-ref p-15049 2))
- (z-pat-15134 (vector-ref p-15049 3)))
+ (let ((x-pat-16767 (vector-ref p-16678 1))
+ (y-pat-16768 (vector-ref p-16678 2))
+ (z-pat-16769 (vector-ref p-16678 3)))
(letrec*
- ((f-15138
- (lambda (e-15140 w-15141)
- (if (pair? e-15140)
+ ((f-16773
+ (lambda (e-16775 w-16776)
+ (if (pair? e-16775)
(call-with-values
(lambda ()
- (f-15138 (cdr e-15140) w-15141))
- (lambda (xr*-15142
- y-pat-15143
- r-15144)
- (if r-15144
- (if (null? y-pat-15143)
- (let ((xr-15145
- (match-15019
- (car e-15140)
- x-pat-15132
- w-15141
+ (f-16773 (cdr e-16775) w-16776))
+ (lambda (xr*-16777
+ y-pat-16778
+ r-16779)
+ (if r-16779
+ (if (null? y-pat-16778)
+ (let ((xr-16780
+ (match-16648
+ (car e-16775)
+ x-pat-16767
+ w-16776
'()
- mod-15052)))
- (if xr-15145
+ mod-16681)))
+ (if xr-16780
(values
- (cons xr-15145 xr*-15142)
- y-pat-15143
- r-15144)
+ (cons xr-16780 xr*-16777)
+ y-pat-16778
+ r-16779)
(values #f #f #f)))
(values
'()
- (cdr y-pat-15143)
- (match-15019
- (car e-15140)
- (car y-pat-15143)
- w-15141
- r-15144
- mod-15052)))
+ (cdr y-pat-16778)
+ (match-16648
+ (car e-16775)
+ (car y-pat-16778)
+ w-16776
+ r-16779
+ mod-16681)))
(values #f #f #f))))
- (if (if (vector? e-15140)
- (if (= (vector-length e-15140) 4)
- (eq? (vector-ref e-15140 0)
+ (if (if (vector? e-16775)
+ (if (= (vector-length e-16775) 4)
+ (eq? (vector-ref e-16775 0)
'syntax-object)
#f)
#f)
- (f-15138
- (vector-ref e-15140 1)
- (join-wraps-4311 w-15141 e-15140))
+ (f-16773
+ (vector-ref e-16775 1)
+ (let ((m1-16806 (car w-16776))
+ (s1-16807 (cdr w-16776)))
+ (if (null? m1-16806)
+ (if (null? s1-16807)
+ e-16775
+ (cons (car e-16775)
+ (let ((m2-16819
+ (cdr e-16775)))
+ (if (null? m2-16819)
+ s1-16807
+ (append
+ s1-16807
+ m2-16819)))))
+ (cons (let ((m2-16829
+ (car e-16775)))
+ (if (null? m2-16829)
+ m1-16806
+ (append
+ m1-16806
+ m2-16829)))
+ (let ((m2-16839
+ (cdr e-16775)))
+ (if (null? m2-16839)
+ s1-16807
+ (append
+ s1-16807
+ m2-16839)))))))
(values
'()
- y-pat-15133
- (match-15019
- e-15140
- z-pat-15134
- w-15141
- r-15051
- mod-15052)))))))
- (f-15138 e-15048 w-15050))))
- (lambda (xr*-15171 y-pat-15172 r-15173)
- (if r-15173
- (if (null? y-pat-15172)
- (if (null? xr*-15171)
- (match-empty-15016
- (vector-ref p-15049 1)
- r-15173)
- (combine-15017 xr*-15171 r-15173))
+ y-pat-16768
+ (match-16648
+ e-16775
+ z-pat-16769
+ w-16776
+ r-16680
+ mod-16681)))))))
+ (f-16773 e-16677 w-16679))))
+ (lambda (xr*-16849 y-pat-16850 r-16851)
+ (if r-16851
+ (if (null? y-pat-16850)
+ (if (null? xr*-16849)
+ (match-empty-16645
+ (vector-ref p-16678 1)
+ r-16851)
+ (combine-16646 xr*-16849 r-16851))
#f)
#f)))
- (if (eqv? key-15062 'free-id)
- (if (if (symbol? e-15048)
+ (if (eqv? key-16691 'free-id)
+ (if (if (symbol? e-16677)
#t
- (if (if (vector? e-15048)
- (if (= (vector-length e-15048) 4)
- (eq? (vector-ref e-15048 0)
+ (if (if (vector? e-16677)
+ (if (= (vector-length e-16677) 4)
+ (eq? (vector-ref e-16677 0)
'syntax-object)
#f)
#f)
- (symbol? (vector-ref e-15048 1))
+ (symbol? (vector-ref e-16677 1))
#f))
- (if (let ((i-15504
- (wrap-4324 e-15048 w-15050 mod-15052))
- (j-15505 (vector-ref p-15049 1)))
- (if (eq? (if (if (vector? i-15504)
- (if (= (vector-length
- i-15504)
- 4)
- (eq? (vector-ref i-15504 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref i-15504 1)
- i-15504)
- (if (if (vector? j-15505)
- (if (= (vector-length
- j-15505)
- 4)
- (eq? (vector-ref j-15505 0)
- 'syntax-object)
- #f)
- #f)
- (vector-ref j-15505 1)
- j-15505))
- (eq? (id-var-name-4314 i-15504 '(()))
- (id-var-name-4314 j-15505 '(())))
- #f))
- r-15051
+ (if (free-id=?-4371
+ (if (if (null? (car w-16679))
+ (null? (cdr w-16679))
+ #f)
+ e-16677
+ (if (if (vector? e-16677)
+ (if (= (vector-length e-16677) 4)
+ (eq? (vector-ref e-16677 0)
+ 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-17279
+ (vector-ref e-16677 1))
+ (wrap-17280
+ (let ((w2-17290
+ (vector-ref e-16677 2)))
+ (let ((m1-17291 (car w-16679))
+ (s1-17292
+ (cdr w-16679)))
+ (if (null? m1-17291)
+ (if (null? s1-17292)
+ w2-17290
+ (cons (car w2-17290)
+ (let ((m2-17309
+ (cdr w2-17290)))
+ (if (null? m2-17309)
+ s1-17292
+ (append
+ s1-17292
+ m2-17309)))))
+ (cons (let ((m2-17317
+ (car w2-17290)))
+ (if (null? m2-17317)
+ m1-17291
+ (append
+ m1-17291
+ m2-17317)))
+ (let ((m2-17325
+ (cdr w2-17290)))
+ (if (null? m2-17325)
+ s1-17292
+ (append
+ s1-17292
+ m2-17325))))))))
+ (module-17281
+ (vector-ref e-16677 3)))
+ (vector
+ 'syntax-object
+ expression-17279
+ wrap-17280
+ module-17281))
+ (if (null? e-16677)
+ e-16677
+ (vector
+ 'syntax-object
+ e-16677
+ w-16679
+ mod-16681))))
+ (vector-ref p-16678 1))
+ r-16680
#f)
#f)
- (if (eqv? key-15062 'atom)
+ (if (eqv? key-16691 'atom)
(if (equal?
- (vector-ref p-15049 1)
- (strip-4344 e-15048 w-15050))
- r-15051
+ (vector-ref p-16678 1)
+ (strip-4396 e-16677 w-16679))
+ r-16680
#f)
- (if (eqv? key-15062 'vector)
- (if (vector? e-15048)
- (match-15019
- (vector->list e-15048)
- (vector-ref p-15049 1)
- w-15050
- r-15051
- mod-15052)
+ (if (eqv? key-16691 'vector)
+ (if (vector? e-16677)
+ (match-16648
+ (vector->list e-16677)
+ (vector-ref p-16678 1)
+ w-16679
+ r-16680
+ mod-16681)
#f))))))))))))
- (match-15019
- (lambda (e-15565 p-15566 w-15567 r-15568 mod-15569)
- (if (not r-15568)
+ (match-16648
+ (lambda (e-17358 p-17359 w-17360 r-17361 mod-17362)
+ (if (not r-17361)
#f
- (if (eq? p-15566 '_)
- r-15568
- (if (eq? p-15566 'any)
- (cons (wrap-4324 e-15565 w-15567 mod-15569)
- r-15568)
- (if (if (vector? e-15565)
- (if (= (vector-length e-15565) 4)
- (eq? (vector-ref e-15565 0) 'syntax-object)
+ (if (eq? p-17359 '_)
+ r-17361
+ (if (eq? p-17359 'any)
+ (cons (if (if (null? (car w-17360))
+ (null? (cdr w-17360))
+ #f)
+ e-17358
+ (if (if (vector? e-17358)
+ (if (= (vector-length e-17358) 4)
+ (eq? (vector-ref e-17358 0) 'syntax-object)
+ #f)
+ #f)
+ (let ((expression-17392 (vector-ref e-17358 1))
+ (wrap-17393
+ (let ((w2-17403 (vector-ref e-17358 2)))
+ (let ((m1-17404 (car w-17360))
+ (s1-17405 (cdr w-17360)))
+ (if (null? m1-17404)
+ (if (null? s1-17405)
+ w2-17403
+ (cons (car w2-17403)
+ (let ((m2-17422
+ (cdr w2-17403)))
+ (if (null? m2-17422)
+ s1-17405
+ (append
+ s1-17405
+ m2-17422)))))
+ (cons (let ((m2-17430
+ (car w2-17403)))
+ (if (null? m2-17430)
+ m1-17404
+ (append
+ m1-17404
+ m2-17430)))
+ (let ((m2-17438
+ (cdr w2-17403)))
+ (if (null? m2-17438)
+ s1-17405
+ (append
+ s1-17405
+ m2-17438))))))))
+ (module-17394 (vector-ref e-17358 3)))
+ (vector
+ 'syntax-object
+ expression-17392
+ wrap-17393
+ module-17394))
+ (if (null? e-17358)
+ e-17358
+ (vector
+ 'syntax-object
+ e-17358
+ w-17360
+ mod-17362))))
+ r-17361)
+ (if (if (vector? e-17358)
+ (if (= (vector-length e-17358) 4)
+ (eq? (vector-ref e-17358 0) 'syntax-object)
#f)
#f)
- (match*-15018
- (vector-ref e-15565 1)
- p-15566
- (join-wraps-4311 w-15567 (vector-ref e-15565 2))
- r-15568
- (vector-ref e-15565 3))
- (match*-15018
- e-15565
- p-15566
- w-15567
- r-15568
- mod-15569))))))))
+ (match*-16647
+ (vector-ref e-17358 1)
+ p-17359
+ (let ((w2-17481 (vector-ref e-17358 2)))
+ (let ((m1-17482 (car w-17360))
+ (s1-17483 (cdr w-17360)))
+ (if (null? m1-17482)
+ (if (null? s1-17483)
+ w2-17481
+ (cons (car w2-17481)
+ (let ((m2-17494 (cdr w2-17481)))
+ (if (null? m2-17494)
+ s1-17483
+ (append s1-17483 m2-17494)))))
+ (cons (let ((m2-17502 (car w2-17481)))
+ (if (null? m2-17502)
+ m1-17482
+ (append m1-17482 m2-17502)))
+ (let ((m2-17510 (cdr w2-17481)))
+ (if (null? m2-17510)
+ s1-17483
+ (append s1-17483 m2-17510)))))))
+ r-17361
+ (vector-ref e-17358 3))
+ (match*-16647
+ e-17358
+ p-17359
+ w-17360
+ r-17361
+ mod-17362))))))))
(set! $sc-dispatch
- (lambda (e-15020 p-15021)
- (if (eq? p-15021 'any)
- (list e-15020)
- (if (eq? p-15021 '_)
+ (lambda (e-16649 p-16650)
+ (if (eq? p-16650 'any)
+ (list e-16649)
+ (if (eq? p-16650 '_)
'()
- (if (if (vector? e-15020)
- (if (= (vector-length e-15020) 4)
- (eq? (vector-ref e-15020 0) 'syntax-object)
+ (if (if (vector? e-16649)
+ (if (= (vector-length e-16649) 4)
+ (eq? (vector-ref e-16649 0) 'syntax-object)
#f)
#f)
- (match*-15018
- (vector-ref e-15020 1)
- p-15021
- (vector-ref e-15020 2)
+ (match*-16647
+ (vector-ref e-16649 1)
+ p-16650
+ (vector-ref e-16649 2)
'()
- (vector-ref e-15020 3))
- (match*-15018 e-15020 p-15021 '(()) '() #f))))))))))
+ (vector-ref e-16649 3))
+ (match*-16647 e-16649 p-16650 '(()) '() #f))))))))))
(define with-syntax
(make-syntax-transformer
'with-syntax
'macro
- (lambda (x-28007)
- (let ((tmp-28009
- ($sc-dispatch x-28007 '(_ () any . each-any))))
- (if tmp-28009
+ (lambda (x-35161)
+ (let ((tmp-35163
+ ($sc-dispatch x-35161 '(_ () any . each-any))))
+ (if tmp-35163
(@apply
- (lambda (e1-28013 e2-28014)
+ (lambda (e1-35167 e2-35168)
(cons '#(syntax-object
let
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-27980" "l-*-27981"))
+ #("l-*-35134" "l-*-35135"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
+ #(ribcage #(x) #((top)) #("l-*-35131"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons e1-28013 e2-28014))))
- tmp-28009)
- (let ((tmp-28015
+ (cons '() (cons e1-35167 e2-35168))))
+ tmp-35163)
+ (let ((tmp-35169
($sc-dispatch
- x-28007
+ x-35161
'(_ ((any any)) any . each-any))))
- (if tmp-28015
+ (if tmp-35169
(@apply
- (lambda (out-28019 in-28020 e1-28021 e2-28022)
+ (lambda (out-35173 in-35174 e1-35175 e2-35176)
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("l-*-27986"
- "l-*-27987"
- "l-*-27988"
- "l-*-27989"))
+ #("l-*-35140"
+ "l-*-35141"
+ "l-*-35142"
+ "l-*-35143"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
+ #(ribcage #(x) #((top)) #("l-*-35131"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- in-28020
+ in-35174
'()
- (list out-28019
+ (list out-35173
(cons '#(syntax-object
let
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("l-*-27986"
- "l-*-27987"
- "l-*-27988"
- "l-*-27989"))
+ #("l-*-35140"
+ "l-*-35141"
+ "l-*-35142"
+ "l-*-35143"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-35131"))
#(ribcage
- #(x)
- #((top))
- #("l-*-27977")))
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons e1-28021 e2-28022))))))
- tmp-28015)
- (let ((tmp-28023
+ (cons '() (cons e1-35175 e2-35176))))))
+ tmp-35169)
+ (let ((tmp-35177
($sc-dispatch
- x-28007
+ x-35161
'(_ #(each (any any)) any . each-any))))
- (if tmp-28023
+ (if tmp-35177
(@apply
- (lambda (out-28027 in-28028 e1-28029 e2-28030)
+ (lambda (out-35181 in-35182 e1-35183 e2-35184)
(list '#(syntax-object
syntax-case
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
+ #("l-*-35150"
+ "l-*-35151"
+ "l-*-35152"
+ "l-*-35153"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
+ #(ribcage #(x) #((top)) #("l-*-35131"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
list
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
+ #("l-*-35150"
+ "l-*-35151"
+ "l-*-35152"
+ "l-*-35153"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-27977")))
+ #(ribcage #(x) #((top)) #("l-*-35131"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- in-28028)
+ in-35182)
'()
- (list out-28027
+ (list out-35181
(cons '#(syntax-object
let
((top)
#(ribcage
#(out in e1 e2)
#((top) (top) (top) (top))
- #("l-*-27996"
- "l-*-27997"
- "l-*-27998"
- "l-*-27999"))
+ #("l-*-35150"
+ "l-*-35151"
+ "l-*-35152"
+ "l-*-35153"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-27977")))
+ #("l-*-35131"))
+ #(ribcage
+ (with-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ with-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons e1-28029 e2-28030))))))
- tmp-28023)
+ (cons '() (cons e1-35183 e2-35184))))))
+ tmp-35177)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28007))))))))))
+ x-35161))))))))))
(define syntax-rules
(make-syntax-transformer
'syntax-rules
'macro
- (lambda (x-28084)
- (let ((tmp-28086
+ (lambda (x-35239)
+ (let ((tmp-35241
($sc-dispatch
- x-28084
+ x-35239
'(_ each-any . #(each ((any . any) any))))))
- (if tmp-28086
+ (if tmp-35241
(@apply
- (lambda (k-28090
- keyword-28091
- pattern-28092
- template-28093)
+ (lambda (k-35245
+ keyword-35246
+ pattern-35247
+ template-35248)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(vector
'(#(syntax-object
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(cons '#(syntax-object
patterns
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- pattern-28092))
+ pattern-35247))
(cons '#(syntax-object
syntax-case
((top)
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
x
#(ribcage
#(k keyword pattern template)
#((top) (top) (top) (top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons k-28090
- (map (lambda (tmp-28058-28094
- tmp-28057-28095)
+ (cons k-35245
+ (map (lambda (tmp-35213-35249
+ tmp-35212-35250)
(list (cons '#(syntax-object
- dummy
+ _
((top)
#(ribcage
#(k
(top)
(top)
(top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28044")))
+ #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- tmp-28057-28095)
+ tmp-35212-35250)
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("l-*-28047"
- "l-*-28048"
- "l-*-28049"
- "l-*-28050"))
+ #("l-*-35202"
+ "l-*-35203"
+ "l-*-35204"
+ "l-*-35205"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28044")))
+ #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- tmp-28058-28094)))
- template-28093
- pattern-28092))))))
- tmp-28086)
- (let ((tmp-28096
+ tmp-35213-35249)))
+ template-35248
+ pattern-35247))))))
+ tmp-35241)
+ (let ((tmp-35251
($sc-dispatch
- x-28084
+ x-35239
'(_ each-any any . #(each ((any . any) any))))))
- (if (if tmp-28096
+ (if (if tmp-35251
(@apply
- (lambda (k-28100
- docstring-28101
- keyword-28102
- pattern-28103
- template-28104)
- (string? (syntax->datum docstring-28101)))
- tmp-28096)
+ (lambda (k-35255
+ docstring-35256
+ keyword-35257
+ pattern-35258
+ template-35259)
+ (string? (syntax->datum docstring-35256)))
+ tmp-35251)
#f)
(@apply
- (lambda (k-28105
- docstring-28106
- keyword-28107
- pattern-28108
- template-28109)
+ (lambda (k-35260
+ docstring-35261
+ keyword-35262
+ pattern-35263
+ template-35264)
(list '#(syntax-object
lambda
((top)
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- docstring-28106
+ docstring-35261
(vector
'(#(syntax-object
macro-type
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(cons '#(syntax-object
patterns
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- pattern-28108))
+ pattern-35263))
(cons '#(syntax-object
syntax-case
((top)
#(ribcage
#(k docstring keyword pattern template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28044")))
+ #(ribcage #(x) #((top)) #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(cons '#(syntax-object
x
pattern
template)
#((top) (top) (top) (top) (top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-35199"))
#(ribcage
- #(x)
- #((top))
- #("l-*-28044")))
+ (syntax-rules)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons k-28105
- (map (lambda (tmp-28083-28110
- tmp-28082-28111)
+ (cons k-35260
+ (map (lambda (tmp-35238-35265
+ tmp-35237-35266)
(list (cons '#(syntax-object
- dummy
+ _
((top)
#(ribcage
#(k
(top)
(top)
(top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28044")))
+ #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- tmp-28082-28111)
+ tmp-35237-35266)
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("l-*-28070"
- "l-*-28071"
- "l-*-28072"
- "l-*-28073"
- "l-*-28074"))
+ #("l-*-35225"
+ "l-*-35226"
+ "l-*-35227"
+ "l-*-35228"
+ "l-*-35229"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28044")))
+ #("l-*-35199"))
+ #(ribcage
+ (syntax-rules)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ syntax-rules
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- tmp-28083-28110)))
- template-28109
- pattern-28108))))))
- tmp-28096)
+ tmp-35238-35265)))
+ template-35264
+ pattern-35263))))))
+ tmp-35251)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28084))))))))
+ x-35239))))))))
(define define-syntax-rule
(make-syntax-transformer
'define-syntax-rule
'macro
- (lambda (x-28148)
- (let ((tmp-28150
- ($sc-dispatch x-28148 '(_ (any . any) any))))
- (if tmp-28150
+ (lambda (x-35304)
+ (let ((tmp-35306
+ ($sc-dispatch x-35304 '(_ (any . any) any))))
+ (if tmp-35306
(@apply
- (lambda (name-28154 pattern-28155 template-28156)
+ (lambda (name-35310 pattern-35311 template-35312)
(list '#(syntax-object
define-syntax
((top)
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("l-*-28125" "l-*-28126" "l-*-28127"))
+ #("l-*-35281" "l-*-35282" "l-*-35283"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
+ #(ribcage #(x) #((top)) #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- name-28154
+ name-35310
(list '#(syntax-object
syntax-rules
((top)
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("l-*-28125" "l-*-28126" "l-*-28127"))
+ #("l-*-35281" "l-*-35282" "l-*-35283"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
+ #(ribcage #(x) #((top)) #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
(list (cons '#(syntax-object
#(ribcage
#(name pattern template)
#((top) (top) (top))
- #("l-*-28125"
- "l-*-28126"
- "l-*-28127"))
+ #("l-*-35281"
+ "l-*-35282"
+ "l-*-35283"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28122")))
+ #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- pattern-28155)
- template-28156))))
- tmp-28150)
- (let ((tmp-28157
- ($sc-dispatch x-28148 '(_ (any . any) any any))))
- (if (if tmp-28157
+ pattern-35311)
+ template-35312))))
+ tmp-35306)
+ (let ((tmp-35313
+ ($sc-dispatch x-35304 '(_ (any . any) any any))))
+ (if (if tmp-35313
(@apply
- (lambda (name-28161
- pattern-28162
- docstring-28163
- template-28164)
- (string? (syntax->datum docstring-28163)))
- tmp-28157)
+ (lambda (name-35317
+ pattern-35318
+ docstring-35319
+ template-35320)
+ (string? (syntax->datum docstring-35319)))
+ tmp-35313)
#f)
(@apply
- (lambda (name-28165
- pattern-28166
- docstring-28167
- template-28168)
+ (lambda (name-35321
+ pattern-35322
+ docstring-35323
+ template-35324)
(list '#(syntax-object
define-syntax
((top)
#(ribcage
#(name pattern docstring template)
#((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
+ #("l-*-35296"
+ "l-*-35297"
+ "l-*-35298"
+ "l-*-35299"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
+ #(ribcage #(x) #((top)) #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- name-28165
+ name-35321
(list '#(syntax-object
syntax-rules
((top)
#(ribcage
#(name pattern docstring template)
#((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
+ #("l-*-35296"
+ "l-*-35297"
+ "l-*-35298"
+ "l-*-35299"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28122")))
+ #(ribcage #(x) #((top)) #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
- docstring-28167
+ docstring-35323
(list (cons '#(syntax-object
_
((top)
docstring
template)
#((top) (top) (top) (top))
- #("l-*-28140"
- "l-*-28141"
- "l-*-28142"
- "l-*-28143"))
+ #("l-*-35296"
+ "l-*-35297"
+ "l-*-35298"
+ "l-*-35299"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28122")))
+ #("l-*-35278"))
+ #(ribcage
+ (define-syntax-rule)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define-syntax-rule
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- pattern-28166)
- template-28168))))
- tmp-28157)
+ pattern-35322)
+ template-35324))))
+ tmp-35313)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28148))))))))
+ x-35304))))))))
(define let*
(make-syntax-transformer
'let*
'macro
- (lambda (x-28217)
- (let ((tmp-28219
+ (lambda (x-35374)
+ (let ((tmp-35376
($sc-dispatch
- x-28217
+ x-35374
'(any #(each (any any)) any . each-any))))
- (if (if tmp-28219
+ (if (if tmp-35376
(@apply
- (lambda (let*-28223 x-28224 v-28225 e1-28226 e2-28227)
- (and-map identifier? x-28224))
- tmp-28219)
+ (lambda (let*-35380 x-35381 v-35382 e1-35383 e2-35384)
+ (and-map identifier? x-35381))
+ tmp-35376)
#f)
(@apply
- (lambda (let*-28228 x-28229 v-28230 e1-28231 e2-28232)
+ (lambda (let*-35385 x-35386 v-35387 e1-35388 e2-35389)
(letrec*
- ((f-28233
- (lambda (bindings-28236)
- (if (null? bindings-28236)
+ ((f-35390
+ (lambda (bindings-35393)
+ (if (null? bindings-35393)
(cons '#(syntax-object
let
((top)
#(ribcage
#(f bindings)
#((top) (top))
- #("l-*-28203" "l-*-28204"))
+ #("l-*-35360" "l-*-35361"))
#(ribcage
#(let* x v e1 e2)
#((top) (top) (top) (top) (top))
- #("l-*-28193"
- "l-*-28194"
- "l-*-28195"
- "l-*-28196"
- "l-*-28197"))
+ #("l-*-35350"
+ "l-*-35351"
+ "l-*-35352"
+ "l-*-35353"
+ "l-*-35354"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28179")))
+ #(ribcage #(x) #((top)) #("l-*-35336"))
+ #(ribcage
+ (let*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ let*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons '() (cons e1-28231 e2-28232)))
- (let ((tmp-28237
- (list (f-28233 (cdr bindings-28236))
- (car bindings-28236))))
- (let ((tmp-28238 ($sc-dispatch tmp-28237 '(any any))))
- (if tmp-28238
+ (cons '() (cons e1-35388 e2-35389)))
+ (let ((tmp-35394
+ (list (f-35390 (cdr bindings-35393))
+ (car bindings-35393))))
+ (let ((tmp-35395 ($sc-dispatch tmp-35394 '(any any))))
+ (if tmp-35395
(@apply
- (lambda (body-28240 binding-28241)
+ (lambda (body-35397 binding-35398)
(list '#(syntax-object
let
((top)
#(ribcage
#(body binding)
#((top) (top))
- #("l-*-28213" "l-*-28214"))
+ #("l-*-35370" "l-*-35371"))
#(ribcage () () ())
#(ribcage
#(f bindings)
#((top) (top))
- #("l-*-28203" "l-*-28204"))
+ #("l-*-35360" "l-*-35361"))
#(ribcage
#(let* x v e1 e2)
#((top) (top) (top) (top) (top))
- #("l-*-28193"
- "l-*-28194"
- "l-*-28195"
- "l-*-28196"
- "l-*-28197"))
+ #("l-*-35350"
+ "l-*-35351"
+ "l-*-35352"
+ "l-*-35353"
+ "l-*-35354"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28179")))
+ #("l-*-35336"))
+ #(ribcage
+ (let*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ let*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (list binding-28241)
- body-28240))
- tmp-28238)
+ (list binding-35398)
+ body-35397))
+ tmp-35395)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-28237))))))))
- (f-28233 (map list x-28229 v-28230))))
- tmp-28219)
+ tmp-35394))))))))
+ (f-35390 (map list x-35386 v-35387))))
+ tmp-35376)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28217))))))
+ x-35374))))))
(define do
(make-syntax-transformer
'do
'macro
- (lambda (orig-x-28299)
- (let ((tmp-28301
+ (lambda (orig-x-35457)
+ (let ((tmp-35459
($sc-dispatch
- orig-x-28299
+ orig-x-35457
'(_ #(each (any any . any))
(any . each-any)
.
each-any))))
- (if tmp-28301
+ (if tmp-35459
(@apply
- (lambda (var-28305
- init-28306
- step-28307
- e0-28308
- e1-28309
- c-28310)
- (let ((tmp-28311
- (map (lambda (v-28314 s-28315)
- (let ((tmp-28317 ($sc-dispatch s-28315 '())))
- (if tmp-28317
- (@apply (lambda () v-28314) tmp-28317)
- (let ((tmp-28320
- ($sc-dispatch s-28315 '(any))))
- (if tmp-28320
+ (lambda (var-35463
+ init-35464
+ step-35465
+ e0-35466
+ e1-35467
+ c-35468)
+ (let ((tmp-35469
+ (map (lambda (v-35472 s-35473)
+ (let ((tmp-35475 ($sc-dispatch s-35473 '())))
+ (if tmp-35475
+ (@apply (lambda () v-35472) tmp-35475)
+ (let ((tmp-35478
+ ($sc-dispatch s-35473 '(any))))
+ (if tmp-35478
(@apply
- (lambda (e-28323) e-28323)
- tmp-28320)
+ (lambda (e-35481) e-35481)
+ tmp-35478)
(syntax-violation
'do
"bad step expression"
- orig-x-28299
- s-28315))))))
- var-28305
- step-28307)))
- (let ((tmp-28312 ($sc-dispatch tmp-28311 'each-any)))
- (if tmp-28312
+ orig-x-35457
+ s-35473))))))
+ var-35463
+ step-35465)))
+ (let ((tmp-35470 ($sc-dispatch tmp-35469 'each-any)))
+ (if tmp-35470
(@apply
- (lambda (step-28329)
- (let ((tmp-28331 ($sc-dispatch e1-28309 '())))
- (if tmp-28331
+ (lambda (step-35487)
+ (let ((tmp-35489 ($sc-dispatch e1-35467 '())))
+ (if tmp-35489
(@apply
(lambda ()
(list '#(syntax-object
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
doloop
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (map list var-28305 init-28306)
+ (map list var-35463 init-35464)
(list '#(syntax-object
if
((top)
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
not
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- e0-28308)
+ e0-35466)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(append
- c-28310
+ c-35468
(list (cons '#(syntax-object
doloop
((top)
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage
()
()
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- step-28329)))))))
- tmp-28331)
- (let ((tmp-28335
- ($sc-dispatch e1-28309 '(any . each-any))))
- (if tmp-28335
+ step-35487)))))))
+ tmp-35489)
+ (let ((tmp-35493
+ ($sc-dispatch e1-35467 '(any . each-any))))
+ (if tmp-35493
(@apply
- (lambda (e1-28339 e2-28340)
+ (lambda (e1-35497 e2-35498)
(list '#(syntax-object
let
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-28276" "l-*-28277"))
+ #("l-*-35434" "l-*-35435"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
doloop
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-28276" "l-*-28277"))
+ #("l-*-35434" "l-*-35435"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (map list var-28305 init-28306)
+ (map list var-35463 init-35464)
(list '#(syntax-object
if
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-28276"
- "l-*-28277"))
+ #("l-*-35434"
+ "l-*-35435"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var init step e0 e1 c)
#((top)
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- e0-28308
+ e0-35466
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-28276"
- "l-*-28277"))
+ #("l-*-35434"
+ "l-*-35435"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons e1-28339 e2-28340))
+ (cons e1-35497 e2-35498))
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-28276"
- "l-*-28277"))
+ #("l-*-35434"
+ "l-*-35435"))
#(ribcage () () ())
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage () () ())
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(append
- c-28310
+ c-35468
(list (cons '#(syntax-object
doloop
((top)
e2)
#((top)
(top))
- #("l-*-28276"
- "l-*-28277"))
+ #("l-*-35434"
+ "l-*-35435"))
#(ribcage
()
()
#(ribcage
#(step)
#((top))
- #("l-*-28267"))
+ #("l-*-35425"))
#(ribcage
#(var
init
(top)
(top)
(top))
- #("l-*-28252"
- "l-*-28253"
- "l-*-28254"
- "l-*-28255"
- "l-*-28256"
- "l-*-28257"))
+ #("l-*-35410"
+ "l-*-35411"
+ "l-*-35412"
+ "l-*-35413"
+ "l-*-35414"
+ "l-*-35415"))
#(ribcage
()
()
#(ribcage
#(orig-x)
#((top))
- #("l-*-28249")))
+ #("l-*-35407"))
+ #(ribcage
+ (do)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ do
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- step-28329)))))))
- tmp-28335)
+ step-35487)))))))
+ tmp-35493)
(syntax-violation
#f
"source expression failed to match any pattern"
- e1-28309))))))
- tmp-28312)
+ e1-35467))))))
+ tmp-35470)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-28311)))))
- tmp-28301)
+ tmp-35469)))))
+ tmp-35459)
(syntax-violation
#f
"source expression failed to match any pattern"
- orig-x-28299))))))
+ orig-x-35457))))))
(define quasiquote
(make-syntax-transformer
'quasiquote
'macro
(letrec*
- ((quasi-28620
- (lambda (p-28644 lev-28645)
- (let ((tmp-28647
+ ((quasi-35779
+ (lambda (p-35803 lev-35804)
+ (let ((tmp-35806
($sc-dispatch
- p-28644
+ p-35803
'(#(free-id
#(syntax-object
unquote
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any))))
- (if tmp-28647
+ (if tmp-35806
(@apply
- (lambda (p-28651)
- (if (= lev-28645 0)
+ (lambda (p-35810)
+ (if (= lev-35804 0)
(list '#(syntax-object
"value"
((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
+ #(ribcage #(p) #((top)) #("l-*-35535"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- p-28651)
- (quasicons-28622
+ p-35810)
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
+ #(ribcage #(p) #((top)) #("l-*-35535"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
((top)
- #(ribcage #(p) #((top)) #("l-*-28376"))
+ #(ribcage #(p) #((top)) #("l-*-35535"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620 (list p-28651) (#{1-}# lev-28645)))))
- tmp-28647)
- (let ((tmp-28654
+ (quasi-35779 (list p-35810) (#{1-}# lev-35804)))))
+ tmp-35806)
+ (let ((tmp-35813
($sc-dispatch
- p-28644
+ p-35803
'(#(free-id
#(syntax-object
quasiquote
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any))))
- (if tmp-28654
+ (if tmp-35813
(@apply
- (lambda (p-28658)
- (quasicons-28622
+ (lambda (p-35817)
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("l-*-28379"))
+ #(ribcage #(p) #((top)) #("l-*-35538"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
quasiquote
((top)
- #(ribcage #(p) #((top)) #("l-*-28379"))
+ #(ribcage #(p) #((top)) #("l-*-35538"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620 (list p-28658) (#{1+}# lev-28645))))
- tmp-28654)
- (let ((tmp-28661 ($sc-dispatch p-28644 '(any . any))))
- (if tmp-28661
+ (quasi-35779 (list p-35817) (#{1+}# lev-35804))))
+ tmp-35813)
+ (let ((tmp-35820 ($sc-dispatch p-35803 '(any . any))))
+ (if tmp-35820
(@apply
- (lambda (p-28665 q-28666)
- (let ((tmp-28668
+ (lambda (p-35824 q-35825)
+ (let ((tmp-35827
($sc-dispatch
- p-28665
+ p-35824
'(#(free-id
#(syntax-object
unquote
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if tmp-28668
+ (if tmp-35827
(@apply
- (lambda (p-28672)
- (if (= lev-28645 0)
- (quasilist*-28624
- (map (lambda (tmp-28390-28708)
+ (lambda (p-35831)
+ (if (= lev-35804 0)
+ (quasilist*-35783
+ (map (lambda (tmp-35549-35870)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28388"))
+ #("l-*-35547"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382"
- "l-*-28383"))
+ #("l-*-35541"
+ "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372"
- "l-*-28373"))
+ #("l-*-35531"
+ "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- tmp-28390-28708))
- p-28672)
- (quasi-28620 q-28666 lev-28645))
- (quasicons-28622
- (quasicons-28622
+ tmp-35549-35870))
+ p-35831)
+ (quasi-35779 q-35825 lev-35804))
+ (quasicons-35781
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28388"))
+ #("l-*-35547"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
#(ribcage
#(p)
#((top))
- #("l-*-28388"))
+ #("l-*-35547"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620
- p-28672
- (#{1-}# lev-28645)))
- (quasi-28620 q-28666 lev-28645))))
- tmp-28668)
- (let ((tmp-28713
+ (quasi-35779
+ p-35831
+ (#{1-}# lev-35804)))
+ (quasi-35779 q-35825 lev-35804))))
+ tmp-35827)
+ (let ((tmp-35875
($sc-dispatch
- p-28665
+ p-35824
'(#(free-id
#(syntax-object
unquote-splicing
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if tmp-28713
+ (if tmp-35875
(@apply
- (lambda (p-28717)
- (if (= lev-28645 0)
- (quasiappend-28623
- (map (lambda (tmp-28395-28720)
+ (lambda (p-35879)
+ (if (= lev-35804 0)
+ (quasiappend-35782
+ (map (lambda (tmp-35554-35882)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28393"))
+ #("l-*-35552"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382"
- "l-*-28383"))
+ #("l-*-35541"
+ "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372"
- "l-*-28373"))
+ #("l-*-35531"
+ "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- tmp-28395-28720))
- p-28717)
- (quasi-28620 q-28666 lev-28645))
- (quasicons-28622
- (quasicons-28622
+ tmp-35554-35882))
+ p-35879)
+ (quasi-35779 q-35825 lev-35804))
+ (quasicons-35781
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28393"))
+ #("l-*-35552"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote-splicing
#(ribcage
#(p)
#((top))
- #("l-*-28393"))
+ #("l-*-35552"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28382" "l-*-28383"))
+ #("l-*-35541" "l-*-35542"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620
- p-28717
- (#{1-}# lev-28645)))
- (quasi-28620 q-28666 lev-28645))))
- tmp-28713)
- (quasicons-28622
- (quasi-28620 p-28665 lev-28645)
- (quasi-28620 q-28666 lev-28645)))))))
- tmp-28661)
- (let ((tmp-28734
- ($sc-dispatch p-28644 '#(vector each-any))))
- (if tmp-28734
+ (quasi-35779
+ p-35879
+ (#{1-}# lev-35804)))
+ (quasi-35779 q-35825 lev-35804))))
+ tmp-35875)
+ (quasicons-35781
+ (quasi-35779 p-35824 lev-35804)
+ (quasi-35779 q-35825 lev-35804)))))))
+ tmp-35820)
+ (let ((tmp-35896
+ ($sc-dispatch p-35803 '#(vector each-any))))
+ (if tmp-35896
(@apply
- (lambda (x-28738)
- (let ((x-28741
- (vquasi-28621 x-28738 lev-28645)))
- (let ((tmp-28743
+ (lambda (x-35900)
+ (let ((x-35903
+ (vquasi-35780 x-35900 lev-35804)))
+ (let ((tmp-35905
($sc-dispatch
- x-28741
+ x-35903
'(#(atom "quote") each-any))))
- (if tmp-28743
+ (if tmp-35905
(@apply
- (lambda (x-28747)
+ (lambda (x-35909)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(x)
#((top))
- #("l-*-28494"))
+ #("l-*-35653"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28491"))
+ #("l-*-35650"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (list->vector x-28747)))
- tmp-28743)
+ (list->vector x-35909)))
+ tmp-35905)
(letrec*
- ((f-28749
- (lambda (y-28761 k-28762)
- (let ((tmp-28764
+ ((f-35911
+ (lambda (y-35923 k-35924)
+ (let ((tmp-35926
($sc-dispatch
- y-28761
+ y-35923
'(#(atom "quote")
each-any))))
- (if tmp-28764
+ (if tmp-35926
(@apply
- (lambda (y-28767)
- (k-28762
- (map (lambda (tmp-28519-28768)
+ (lambda (y-35929)
+ (k-35924
+ (map (lambda (tmp-35678-35930)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(y)
#((top))
- #("l-*-28517"))
+ #("l-*-35676"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("l-*-28499"
- "l-*-28500"
- "l-*-28501"))
+ #("l-*-35658"
+ "l-*-35659"
+ "l-*-35660"))
#(ribcage
#(_)
#((top))
- #("l-*-28497"))
+ #("l-*-35656"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28491"))
+ #("l-*-35650"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- tmp-28519-28768))
- y-28767)))
- tmp-28764)
- (let ((tmp-28769
+ tmp-35678-35930))
+ y-35929)))
+ tmp-35926)
+ (let ((tmp-35931
($sc-dispatch
- y-28761
+ y-35923
'(#(atom "list")
.
each-any))))
- (if tmp-28769
+ (if tmp-35931
(@apply
- (lambda (y-28772)
- (k-28762 y-28772))
- tmp-28769)
- (let ((tmp-28773
+ (lambda (y-35934)
+ (k-35924 y-35934))
+ tmp-35931)
+ (let ((tmp-35935
($sc-dispatch
- y-28761
+ y-35923
'(#(atom "list*")
.
#(each+
any
(any)
())))))
- (if tmp-28773
+ (if tmp-35935
(@apply
- (lambda (y-28776
- z-28777)
- (f-28749
- z-28777
- (lambda (ls-28778)
- (k-28762
+ (lambda (y-35938
+ z-35939)
+ (f-35911
+ z-35939
+ (lambda (ls-35940)
+ (k-35924
(append
- y-28776
- ls-28778)))))
- tmp-28773)
+ y-35938
+ ls-35940)))))
+ tmp-35935)
(list '#(syntax-object
"list->vector"
((top)
()
())
#(ribcage
- #(t-28534)
- #((m-*-28535
+ #(t-35693)
+ #((m-*-35694
top))
- #("l-*-28538"))
+ #("l-*-35697"))
#(ribcage
#(else)
#((top))
- #("l-*-28532"))
+ #("l-*-35691"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("l-*-28499"
- "l-*-28500"
- "l-*-28501"))
+ #("l-*-35658"
+ "l-*-35659"
+ "l-*-35660"))
#(ribcage
#(_)
#((top))
- #("l-*-28497"))
+ #("l-*-35656"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28491"))
+ #("l-*-35650"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- x-28741))))))))))
- (f-28749
- x-28741
- (lambda (ls-28751)
- (let ((tmp-28753
+ x-35903))))))))))
+ (f-35911
+ x-35903
+ (lambda (ls-35913)
+ (let ((tmp-35915
($sc-dispatch
- ls-28751
+ ls-35913
'each-any)))
- (if tmp-28753
+ (if tmp-35915
(@apply
- (lambda (t-28507-28756)
+ (lambda (t-35666-35918)
(cons '#(syntax-object
"vector"
((top)
()
())
#(ribcage
- #(t-28507)
- #((m-*-28508
+ #(t-35666)
+ #((m-*-35667
top))
- #("l-*-28512"))
+ #("l-*-35671"))
#(ribcage
()
()
#(ribcage
#(ls)
#((top))
- #("l-*-28506"))
+ #("l-*-35665"))
#(ribcage
#(_)
#((top))
- #("l-*-28497"))
+ #("l-*-35656"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-28491"))
+ #("l-*-35650"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- t-28507-28756))
- tmp-28753)
+ t-35666-35918))
+ tmp-35915)
(syntax-violation
#f
"source expression failed to match any pattern"
- ls-28751))))))))))
- tmp-28734)
+ ls-35913))))))))))
+ tmp-35896)
(list '#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("l-*-28403"))
+ #(ribcage #(p) #((top)) #("l-*-35562"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28372" "l-*-28373"))
+ #("l-*-35531" "l-*-35532"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- p-28644)))))))))))
- (vquasi-28621
- (lambda (p-28806 lev-28807)
- (let ((tmp-28809 ($sc-dispatch p-28806 '(any . any))))
- (if tmp-28809
+ p-35803)))))))))))
+ (vquasi-35780
+ (lambda (p-35968 lev-35969)
+ (let ((tmp-35971 ($sc-dispatch p-35968 '(any . any))))
+ (if tmp-35971
(@apply
- (lambda (p-28813 q-28814)
- (let ((tmp-28816
+ (lambda (p-35975 q-35976)
+ (let ((tmp-35978
($sc-dispatch
- p-28813
+ p-35975
'(#(free-id
#(syntax-object
unquote
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if tmp-28816
+ (if tmp-35978
(@apply
- (lambda (p-28820)
- (if (= lev-28807 0)
- (quasilist*-28624
- (map (lambda (tmp-28419-28856)
+ (lambda (p-35982)
+ (if (= lev-35969 0)
+ (quasilist*-35783
+ (map (lambda (tmp-35578-36021)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28417"))
+ #("l-*-35576"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- tmp-28419-28856))
- p-28820)
- (vquasi-28621 q-28814 lev-28807))
- (quasicons-28622
- (quasicons-28622
+ tmp-35578-36021))
+ p-35982)
+ (vquasi-35780 q-35976 lev-35969))
+ (quasicons-35781
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
- #(ribcage #(p) #((top)) #("l-*-28417"))
+ #(ribcage #(p) #((top)) #("l-*-35576"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote
((top)
- #(ribcage #(p) #((top)) #("l-*-28417"))
+ #(ribcage #(p) #((top)) #("l-*-35576"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620 p-28820 (#{1-}# lev-28807)))
- (vquasi-28621 q-28814 lev-28807))))
- tmp-28816)
- (let ((tmp-28863
+ (quasi-35779 p-35982 (#{1-}# lev-35969)))
+ (vquasi-35780 q-35976 lev-35969))))
+ tmp-35978)
+ (let ((tmp-36028
($sc-dispatch
- p-28813
+ p-35975
'(#(free-id
#(syntax-object
unquote-splicing
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
.
each-any))))
- (if tmp-28863
+ (if tmp-36028
(@apply
- (lambda (p-28867)
- (if (= lev-28807 0)
- (quasiappend-28623
- (map (lambda (tmp-28424-28870)
+ (lambda (p-36032)
+ (if (= lev-35969 0)
+ (quasiappend-35782
+ (map (lambda (tmp-35583-36035)
(list '#(syntax-object
"value"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28422"))
+ #("l-*-35581"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411"
- "l-*-28412"))
+ #("l-*-35570"
+ "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407"
- "l-*-28408"))
+ #("l-*-35566"
+ "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- tmp-28424-28870))
- p-28867)
- (vquasi-28621 q-28814 lev-28807))
- (quasicons-28622
- (quasicons-28622
+ tmp-35583-36035))
+ p-36032)
+ (vquasi-35780 q-35976 lev-35969))
+ (quasicons-35781
+ (quasicons-35781
'(#(syntax-object
"quote"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28422"))
+ #("l-*-35581"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
unquote-splicing
#(ribcage
#(p)
#((top))
- #("l-*-28422"))
+ #("l-*-35581"))
#(ribcage
#(p q)
#((top) (top))
- #("l-*-28411" "l-*-28412"))
+ #("l-*-35570" "l-*-35571"))
#(ribcage () () ())
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
- (quasi-28620 p-28867 (#{1-}# lev-28807)))
- (vquasi-28621 q-28814 lev-28807))))
- tmp-28863)
- (quasicons-28622
- (quasi-28620 p-28813 lev-28807)
- (vquasi-28621 q-28814 lev-28807)))))))
- tmp-28809)
- (let ((tmp-28888 ($sc-dispatch p-28806 '())))
- (if tmp-28888
+ (quasi-35779 p-36032 (#{1-}# lev-35969)))
+ (vquasi-35780 q-35976 lev-35969))))
+ tmp-36028)
+ (quasicons-35781
+ (quasi-35779 p-35975 lev-35969)
+ (vquasi-35780 q-35976 lev-35969)))))))
+ tmp-35971)
+ (let ((tmp-36053 ($sc-dispatch p-35968 '())))
+ (if tmp-36053
(@apply
(lambda ()
'(#(syntax-object
#(ribcage
#(p lev)
#((top) (top))
- #("l-*-28407" "l-*-28408"))
+ #("l-*-35566" "l-*-35567"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
()))
- tmp-28888)
+ tmp-36053)
(syntax-violation
#f
"source expression failed to match any pattern"
- p-28806)))))))
- (quasicons-28622
- (lambda (x-28901 y-28902)
- (let ((tmp-28903 (list x-28901 y-28902)))
- (let ((tmp-28904 ($sc-dispatch tmp-28903 '(any any))))
- (if tmp-28904
+ p-35968)))))))
+ (quasicons-35781
+ (lambda (x-36066 y-36067)
+ (let ((tmp-36068 (list x-36066 y-36067)))
+ (let ((tmp-36069 ($sc-dispatch tmp-36068 '(any any))))
+ (if tmp-36069
(@apply
- (lambda (x-28906 y-28907)
- (let ((tmp-28909
- ($sc-dispatch y-28907 '(#(atom "quote") any))))
- (if tmp-28909
+ (lambda (x-36071 y-36072)
+ (let ((tmp-36074
+ ($sc-dispatch y-36072 '(#(atom "quote") any))))
+ (if tmp-36074
(@apply
- (lambda (dy-28913)
- (let ((tmp-28915
+ (lambda (dy-36078)
+ (let ((tmp-36080
($sc-dispatch
- x-28906
+ x-36071
'(#(atom "quote") any))))
- (if tmp-28915
+ (if tmp-36080
(@apply
- (lambda (dx-28919)
+ (lambda (dx-36084)
(list '#(syntax-object
"quote"
((top)
#(ribcage
#(dx)
#((top))
- #("l-*-28446"))
+ #("l-*-35605"))
#(ribcage
#(dy)
#((top))
- #("l-*-28442"))
+ #("l-*-35601"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons dx-28919 dy-28913)))
- tmp-28915)
- (if (null? dy-28913)
+ (cons dx-36084 dy-36078)))
+ tmp-36080)
+ (if (null? dy-36078)
(list '#(syntax-object
"list"
((top)
#(ribcage
#(_)
#((top))
- #("l-*-28448"))
+ #("l-*-35607"))
#(ribcage
#(dy)
#((top))
- #("l-*-28442"))
+ #("l-*-35601"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- x-28906)
+ x-36071)
(list '#(syntax-object
"list*"
((top)
#(ribcage
#(_)
#((top))
- #("l-*-28448"))
+ #("l-*-35607"))
#(ribcage
#(dy)
#((top))
- #("l-*-28442"))
+ #("l-*-35601"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- x-28906
- y-28907)))))
- tmp-28909)
- (let ((tmp-28924
+ x-36071
+ y-36072)))))
+ tmp-36074)
+ (let ((tmp-36089
($sc-dispatch
- y-28907
+ y-36072
'(#(atom "list") . any))))
- (if tmp-28924
+ (if tmp-36089
(@apply
- (lambda (stuff-28928)
+ (lambda (stuff-36093)
(cons '#(syntax-object
"list"
((top)
#(ribcage
#(stuff)
#((top))
- #("l-*-28451"))
+ #("l-*-35610"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons x-28906 stuff-28928)))
- tmp-28924)
- (let ((tmp-28929
+ (cons x-36071 stuff-36093)))
+ tmp-36089)
+ (let ((tmp-36094
($sc-dispatch
- y-28907
+ y-36072
'(#(atom "list*") . any))))
- (if tmp-28929
+ (if tmp-36094
(@apply
- (lambda (stuff-28933)
+ (lambda (stuff-36098)
(cons '#(syntax-object
"list*"
((top)
#(ribcage
#(stuff)
#((top))
- #("l-*-28454"))
+ #("l-*-35613"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons x-28906 stuff-28933)))
- tmp-28929)
+ (cons x-36071 stuff-36098)))
+ tmp-36094)
(list '#(syntax-object
"list*"
((top)
#(ribcage
#(_)
#((top))
- #("l-*-28456"))
+ #("l-*-35615"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28436" "l-*-28437"))
+ #("l-*-35595" "l-*-35596"))
#(ribcage () () ())
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28431" "l-*-28432"))
+ #("l-*-35590" "l-*-35591"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- x-28906
- y-28907))))))))
- tmp-28904)
+ x-36071
+ y-36072))))))))
+ tmp-36069)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-28903))))))
- (quasiappend-28623
- (lambda (x-28944 y-28945)
- (let ((tmp-28947
- ($sc-dispatch y-28945 '(#(atom "quote") ()))))
- (if tmp-28947
+ tmp-36068))))))
+ (quasiappend-35782
+ (lambda (x-36109 y-36110)
+ (let ((tmp-36112
+ ($sc-dispatch y-36110 '(#(atom "quote") ()))))
+ (if tmp-36112
(@apply
(lambda ()
- (if (null? x-28944)
+ (if (null? x-36109)
'(#(syntax-object
"quote"
((top)
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28460" "l-*-28461"))
+ #("l-*-35619" "l-*-35620"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
())
- (if (null? (cdr x-28944))
- (car x-28944)
- (let ((tmp-28952 ($sc-dispatch x-28944 'each-any)))
- (if tmp-28952
+ (if (null? (cdr x-36109))
+ (car x-36109)
+ (let ((tmp-36117 ($sc-dispatch x-36109 'each-any)))
+ (if tmp-36117
(@apply
- (lambda (p-28956)
+ (lambda (p-36121)
(cons '#(syntax-object
"append"
((top)
#(ribcage
#(p)
#((top))
- #("l-*-28468"))
+ #("l-*-35627"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28460" "l-*-28461"))
+ #("l-*-35619" "l-*-35620"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- p-28956))
- tmp-28952)
+ p-36121))
+ tmp-36117)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28944))))))
- tmp-28947)
- (if (null? x-28944)
- y-28945
- (let ((tmp-28964 (list x-28944 y-28945)))
- (let ((tmp-28965
- ($sc-dispatch tmp-28964 '(each-any any))))
- (if tmp-28965
+ x-36109))))))
+ tmp-36112)
+ (if (null? x-36109)
+ y-36110
+ (let ((tmp-36129 (list x-36109 y-36110)))
+ (let ((tmp-36130
+ ($sc-dispatch tmp-36129 '(each-any any))))
+ (if tmp-36130
(@apply
- (lambda (p-28967 y-28968)
+ (lambda (p-36132 y-36133)
(cons '#(syntax-object
"append"
((top)
#(ribcage
#(p y)
#((top) (top))
- #("l-*-28477" "l-*-28478"))
- #(ribcage #(_) #((top)) #("l-*-28471"))
+ #("l-*-35636" "l-*-35637"))
+ #(ribcage #(_) #((top)) #("l-*-35630"))
#(ribcage () () ())
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28460" "l-*-28461"))
+ #("l-*-35619" "l-*-35620"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (append p-28967 (list y-28968))))
- tmp-28965)
+ (append p-36132 (list y-36133))))
+ tmp-36130)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-28964)))))))))
- (quasilist*-28624
- (lambda (x-28972 y-28973)
+ tmp-36129)))))))))
+ (quasilist*-35783
+ (lambda (x-36137 y-36138)
(letrec*
- ((f-28974
- (lambda (x-29063)
- (if (null? x-29063)
- y-28973
- (quasicons-28622
- (car x-29063)
- (f-28974 (cdr x-29063)))))))
- (f-28974 x-28972))))
- (emit-28626
- (lambda (x-29066)
- (let ((tmp-29068
- ($sc-dispatch x-29066 '(#(atom "quote") any))))
- (if tmp-29068
+ ((f-36139
+ (lambda (x-36243)
+ (if (null? x-36243)
+ y-36138
+ (quasicons-35781
+ (car x-36243)
+ (f-36139 (cdr x-36243)))))))
+ (f-36139 x-36137))))
+ (emit-35785
+ (lambda (x-36246)
+ (let ((tmp-36248
+ ($sc-dispatch x-36246 '(#(atom "quote") any))))
+ (if tmp-36248
(@apply
- (lambda (x-29072)
+ (lambda (x-36252)
(list '#(syntax-object
quote
((top)
- #(ribcage #(x) #((top)) #("l-*-28544"))
+ #(ribcage #(x) #((top)) #("l-*-35703"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-28541"))
+ #(ribcage #(x) #((top)) #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
vquasi
quasi)
((top) (top) (top) (top) (top) (top) (top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- x-29072))
- tmp-29068)
- (let ((tmp-29073
+ x-36252))
+ tmp-36248)
+ (let ((tmp-36253
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "list") . each-any))))
- (if tmp-29073
+ (if tmp-36253
(@apply
- (lambda (x-29077)
- (let ((tmp-29078 (map emit-28626 x-29077)))
- (let ((tmp-29079 ($sc-dispatch tmp-29078 'each-any)))
- (if tmp-29079
+ (lambda (x-36257)
+ (let ((tmp-36258 (map emit-35785 x-36257)))
+ (let ((tmp-36259 ($sc-dispatch tmp-36258 'each-any)))
+ (if tmp-36259
(@apply
- (lambda (t-28549-29081)
+ (lambda (t-35708-36261)
(cons '#(syntax-object
list
((top)
#(ribcage () () ())
#(ribcage
- #(t-28549)
- #((m-*-28550 top))
- #("l-*-28554"))
+ #(t-35708)
+ #((m-*-35709 top))
+ #("l-*-35713"))
#(ribcage
#(x)
#((top))
- #("l-*-28547"))
+ #("l-*-35706"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28541"))
+ #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- t-28549-29081))
- tmp-29079)
+ t-35708-36261))
+ tmp-36259)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-29078)))))
- tmp-29073)
- (let ((tmp-29082
+ tmp-36258)))))
+ tmp-36253)
+ (let ((tmp-36262
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "list*") . #(each+ any (any) ())))))
- (if tmp-29082
+ (if tmp-36262
(@apply
- (lambda (x-29086 y-29087)
+ (lambda (x-36266 y-36267)
(letrec*
- ((f-29088
- (lambda (x*-29091)
- (if (null? x*-29091)
- (emit-28626 y-29087)
- (let ((tmp-29092
- (list (emit-28626 (car x*-29091))
- (f-29088 (cdr x*-29091)))))
- (let ((tmp-29093
+ ((f-36268
+ (lambda (x*-36271)
+ (if (null? x*-36271)
+ (emit-35785 y-36267)
+ (let ((tmp-36272
+ (list (emit-35785 (car x*-36271))
+ (f-36268 (cdr x*-36271)))))
+ (let ((tmp-36273
($sc-dispatch
- tmp-29092
+ tmp-36272
'(any any))))
- (if tmp-29093
+ (if tmp-36273
(@apply
- (lambda (t-28569-29095
- t-28568-29096)
+ (lambda (t-35728-36275
+ t-35727-36276)
(list '#(syntax-object
cons
((top)
#(ribcage () () ())
#(ribcage
- #(t-28569 t-28568)
- #((m-*-28570 top)
- (m-*-28570 top))
- #("l-*-28574"
- "l-*-28575"))
+ #(t-35728 t-35727)
+ #((m-*-35729 top)
+ (m-*-35729 top))
+ #("l-*-35733"
+ "l-*-35734"))
#(ribcage () () ())
#(ribcage
#(f x*)
#((top) (top))
- #("l-*-28563"
- "l-*-28564"))
+ #("l-*-35722"
+ "l-*-35723"))
#(ribcage
#(x y)
#((top) (top))
- #("l-*-28559"
- "l-*-28560"))
+ #("l-*-35718"
+ "l-*-35719"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28541"))
+ #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- t-28569-29095
- t-28568-29096))
- tmp-29093)
+ t-35728-36275
+ t-35727-36276))
+ tmp-36273)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-29092))))))))
- (f-29088 x-29086)))
- tmp-29082)
- (let ((tmp-29097
+ tmp-36272))))))))
+ (f-36268 x-36266)))
+ tmp-36262)
+ (let ((tmp-36277
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "append") . each-any))))
- (if tmp-29097
+ (if tmp-36277
(@apply
- (lambda (x-29101)
- (let ((tmp-29102 (map emit-28626 x-29101)))
- (let ((tmp-29103
- ($sc-dispatch tmp-29102 'each-any)))
- (if tmp-29103
+ (lambda (x-36281)
+ (let ((tmp-36282 (map emit-35785 x-36281)))
+ (let ((tmp-36283
+ ($sc-dispatch tmp-36282 'each-any)))
+ (if tmp-36283
(@apply
- (lambda (t-28581-29105)
+ (lambda (t-35740-36285)
(cons '#(syntax-object
append
((top)
#(ribcage () () ())
#(ribcage
- #(t-28581)
- #((m-*-28582 top))
- #("l-*-28586"))
+ #(t-35740)
+ #((m-*-35741 top))
+ #("l-*-35745"))
#(ribcage
#(x)
#((top))
- #("l-*-28579"))
+ #("l-*-35738"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28541"))
+ #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- t-28581-29105))
- tmp-29103)
+ t-35740-36285))
+ tmp-36283)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-29102)))))
- tmp-29097)
- (let ((tmp-29106
+ tmp-36282)))))
+ tmp-36277)
+ (let ((tmp-36286
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "vector") . each-any))))
- (if tmp-29106
+ (if tmp-36286
(@apply
- (lambda (x-29110)
- (let ((tmp-29111 (map emit-28626 x-29110)))
- (let ((tmp-29112
+ (lambda (x-36290)
+ (let ((tmp-36291 (map emit-35785 x-36290)))
+ (let ((tmp-36292
($sc-dispatch
- tmp-29111
+ tmp-36291
'each-any)))
- (if tmp-29112
+ (if tmp-36292
(@apply
- (lambda (t-28593-29114)
+ (lambda (t-35752-36294)
(cons '#(syntax-object
vector
((top)
#(ribcage () () ())
#(ribcage
- #(t-28593)
- #((m-*-28594 top))
- #("l-*-28598"))
+ #(t-35752)
+ #((m-*-35753 top))
+ #("l-*-35757"))
#(ribcage
#(x)
#((top))
- #("l-*-28591"))
+ #("l-*-35750"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28541"))
+ #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- t-28593-29114))
- tmp-29112)
+ t-35752-36294))
+ tmp-36292)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-29111)))))
- tmp-29106)
- (let ((tmp-29115
+ tmp-36291)))))
+ tmp-36286)
+ (let ((tmp-36295
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "list->vector") any))))
- (if tmp-29115
+ (if tmp-36295
(@apply
- (lambda (x-29119)
- (let ((tmp-29120 (emit-28626 x-29119)))
+ (lambda (x-36299)
+ (let ((tmp-36300 (emit-35785 x-36299)))
(list '#(syntax-object
list->vector
((top)
#(ribcage () () ())
#(ribcage
- #(t-28605)
- #((m-*-28606 top))
- #("l-*-28609"))
+ #(t-35764)
+ #((m-*-35765 top))
+ #("l-*-35768"))
#(ribcage
#(x)
#((top))
- #("l-*-28603"))
+ #("l-*-35762"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-28541"))
+ #("l-*-35700"))
#(ribcage
(emit quasivector
quasilist*
(top)
(top)
(top))
- ("l-*-28368"
- "l-*-28366"
- "l-*-28364"
- "l-*-28362"
- "l-*-28360"
- "l-*-28358"
- "l-*-28356")))
+ ("l-*-35527"
+ "l-*-35525"
+ "l-*-35523"
+ "l-*-35521"
+ "l-*-35519"
+ "l-*-35517"
+ "l-*-35515"))
+ #(ribcage
+ (quasiquote)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ quasiquote
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- tmp-29120)))
- tmp-29115)
- (let ((tmp-29123
+ tmp-36300)))
+ tmp-36295)
+ (let ((tmp-36303
($sc-dispatch
- x-29066
+ x-36246
'(#(atom "value") any))))
- (if tmp-29123
+ (if tmp-36303
(@apply
- (lambda (x-29127) x-29127)
- tmp-29123)
+ (lambda (x-36307) x-36307)
+ tmp-36303)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29066))))))))))))))))))
- (lambda (x-28627)
- (let ((tmp-28629 ($sc-dispatch x-28627 '(_ any))))
- (if tmp-28629
+ x-36246))))))))))))))))))
+ (lambda (x-35786)
+ (let ((tmp-35788 ($sc-dispatch x-35786 '(_ any))))
+ (if tmp-35788
(@apply
- (lambda (e-28633)
- (emit-28626 (quasi-28620 e-28633 0)))
- tmp-28629)
+ (lambda (e-35792)
+ (emit-35785 (quasi-35779 e-35792 0)))
+ tmp-35788)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-28627)))))))
+ x-35786)))))))
(define include
(make-syntax-transformer
'include
'macro
- (lambda (x-29182)
+ (lambda (x-36363)
(letrec*
- ((read-file-29183
- (lambda (fn-29292 k-29293)
- (let ((p-29294 (open-input-file fn-29292)))
+ ((read-file-36364
+ (lambda (fn-36473 k-36474)
+ (let ((p-36475 (open-input-file fn-36473)))
(letrec*
- ((f-29295
- (lambda (x-29349 result-29350)
- (if (eof-object? x-29349)
+ ((f-36476
+ (lambda (x-36530 result-36531)
+ (if (eof-object? x-36530)
(begin
- (close-input-port p-29294)
- (reverse result-29350))
- (f-29295
- (read p-29294)
- (cons (datum->syntax k-29293 x-29349)
- result-29350))))))
- (f-29295 (read p-29294) '()))))))
- (let ((tmp-29185 ($sc-dispatch x-29182 '(any any))))
- (if tmp-29185
+ (close-input-port p-36475)
+ (reverse result-36531))
+ (f-36476
+ (read p-36475)
+ (cons (datum->syntax k-36474 x-36530)
+ result-36531))))))
+ (f-36476 (read p-36475) '()))))))
+ (let ((tmp-36366 ($sc-dispatch x-36363 '(any any))))
+ (if tmp-36366
(@apply
- (lambda (k-29189 filename-29190)
- (let ((fn-29191 (syntax->datum filename-29190)))
- (let ((tmp-29192
- (read-file-29183 fn-29191 filename-29190)))
- (let ((tmp-29193 ($sc-dispatch tmp-29192 'each-any)))
- (if tmp-29193
+ (lambda (k-36370 filename-36371)
+ (let ((fn-36372 (syntax->datum filename-36371)))
+ (let ((tmp-36373
+ (read-file-36364 fn-36372 filename-36371)))
+ (let ((tmp-36374 ($sc-dispatch tmp-36373 'each-any)))
+ (if tmp-36374
(@apply
- (lambda (exp-29211)
+ (lambda (exp-36392)
(cons '#(syntax-object
begin
((top)
#(ribcage () () ())
- #(ribcage #(exp) #((top)) #("l-*-29179"))
+ #(ribcage #(exp) #((top)) #("l-*-36360"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29174"))
+ #(ribcage #(fn) #((top)) #("l-*-36355"))
#(ribcage
#(k filename)
#((top) (top))
- #("l-*-29170" "l-*-29171"))
+ #("l-*-36351" "l-*-36352"))
#(ribcage
(read-file)
((top))
- ("l-*-29154"))
- #(ribcage #(x) #((top)) #("l-*-29153")))
+ ("l-*-36335"))
+ #(ribcage #(x) #((top)) #("l-*-36334"))
+ #(ribcage
+ (include)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ include
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- exp-29211))
- tmp-29193)
+ exp-36392))
+ tmp-36374)
(syntax-violation
#f
"source expression failed to match any pattern"
- tmp-29192))))))
- tmp-29185)
+ tmp-36373))))))
+ tmp-36366)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29182)))))))
+ x-36363)))))))
(define include-from-path
(make-syntax-transformer
'include-from-path
'macro
- (lambda (x-29369)
- (let ((tmp-29371 ($sc-dispatch x-29369 '(any any))))
- (if tmp-29371
+ (lambda (x-36551)
+ (let ((tmp-36553 ($sc-dispatch x-36551 '(any any))))
+ (if tmp-36553
(@apply
- (lambda (k-29375 filename-29376)
- (let ((fn-29377 (syntax->datum filename-29376)))
- (let ((tmp-29378
+ (lambda (k-36557 filename-36558)
+ (let ((fn-36559 (syntax->datum filename-36558)))
+ (let ((tmp-36560
(datum->syntax
- filename-29376
- (let ((t-29381 (%search-load-path fn-29377)))
- (if t-29381
- t-29381
+ filename-36558
+ (let ((t-36563 (%search-load-path fn-36559)))
+ (if t-36563
+ t-36563
(syntax-violation
'include-from-path
"file not found in path"
- x-29369
- filename-29376))))))
+ x-36551
+ filename-36558))))))
(list '#(syntax-object
include
((top)
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29363"))
+ #(ribcage #(fn) #((top)) #("l-*-36545"))
#(ribcage () () ())
#(ribcage () () ())
- #(ribcage #(fn) #((top)) #("l-*-29359"))
+ #(ribcage #(fn) #((top)) #("l-*-36541"))
#(ribcage
#(k filename)
#((top) (top))
- #("l-*-29355" "l-*-29356"))
+ #("l-*-36537" "l-*-36538"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29352")))
+ #(ribcage #(x) #((top)) #("l-*-36534"))
+ #(ribcage
+ (include-from-path)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ include-from-path
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- tmp-29378))))
- tmp-29371)
+ tmp-36560))))
+ tmp-36553)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29369))))))
+ x-36551))))))
(define unquote
(make-syntax-transformer
'unquote
'macro
- (lambda (x-29390)
+ (lambda (x-36573)
(syntax-violation
'unquote
"expression not valid outside of quasiquote"
- x-29390))))
+ x-36573))))
(define unquote-splicing
(make-syntax-transformer
'unquote-splicing
'macro
- (lambda (x-29393)
+ (lambda (x-36577)
(syntax-violation
'unquote-splicing
"expression not valid outside of quasiquote"
- x-29393))))
+ x-36577))))
(define case
(make-syntax-transformer
'case
'macro
- (lambda (x-29449)
- (let ((tmp-29451
- ($sc-dispatch x-29449 '(_ any any . each-any))))
- (if tmp-29451
+ (lambda (x-36634)
+ (let ((tmp-36636
+ ($sc-dispatch x-36634 '(_ any any . each-any))))
+ (if tmp-36636
(@apply
- (lambda (e-29455 m1-29456 m2-29457)
- (let ((tmp-29458
+ (lambda (e-36640 m1-36641 m2-36642)
+ (let ((tmp-36643
(letrec*
- ((f-29500
- (lambda (clause-29503 clauses-29504)
- (if (null? clauses-29504)
- (let ((tmp-29506
+ ((f-36697
+ (lambda (clause-36700 clauses-36701)
+ (if (null? clauses-36701)
+ (let ((tmp-36703
($sc-dispatch
- clause-29503
+ clause-36700
'(#(free-id
#(syntax-object
else
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any
.
each-any))))
- (if tmp-29506
+ (if tmp-36703
(@apply
- (lambda (e1-29510 e2-29511)
+ (lambda (e1-36707 e2-36708)
(cons '#(syntax-object
begin
((top)
#(ribcage
#(e1 e2)
#((top) (top))
- #("l-*-29417" "l-*-29418"))
+ #("l-*-36602" "l-*-36603"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons e1-29510 e2-29511)))
- tmp-29506)
- (let ((tmp-29512
+ (cons e1-36707 e2-36708)))
+ tmp-36703)
+ (let ((tmp-36709
($sc-dispatch
- clause-29503
+ clause-36700
'(each-any any . each-any))))
- (if tmp-29512
+ (if tmp-36709
(@apply
- (lambda (k-29516 e1-29517 e2-29518)
+ (lambda (k-36713 e1-36714 e2-36715)
(list '#(syntax-object
if
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
+ #("l-*-36608"
+ "l-*-36609"
+ "l-*-36610"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
memv
#((top)
(top)
(top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
+ #("l-*-36608"
+ "l-*-36609"
+ "l-*-36610"))
#(ribcage () () ())
#(ribcage
#(f
#((top)
(top)
(top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
'#(syntax-object
t
#((top)
(top)
(top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
+ #("l-*-36608"
+ "l-*-36609"
+ "l-*-36610"))
#(ribcage () () ())
#(ribcage
#(f
#((top)
(top)
(top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(list '#(syntax-object
quote
#((top)
(top)
(top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
+ #("l-*-36608"
+ "l-*-36609"
+ "l-*-36610"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene
guile))
- k-29516))
+ k-36713))
(cons '#(syntax-object
begin
((top)
#((top)
(top)
(top))
- #("l-*-29423"
- "l-*-29424"
- "l-*-29425"))
+ #("l-*-36608"
+ "l-*-36609"
+ "l-*-36610"))
#(ribcage () () ())
#(ribcage
#(f
#((top)
(top)
(top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons e1-29517
- e2-29518))))
- tmp-29512)
+ (cons e1-36714
+ e2-36715))))
+ tmp-36709)
(syntax-violation
'case
"bad clause"
- x-29449
- clause-29503)))))
- (let ((tmp-29526
- (f-29500
- (car clauses-29504)
- (cdr clauses-29504))))
- (let ((tmp-29529
+ x-36634
+ clause-36700)))))
+ (let ((tmp-36723
+ (f-36697
+ (car clauses-36701)
+ (cdr clauses-36701))))
+ (let ((tmp-36726
($sc-dispatch
- clause-29503
+ clause-36700
'(each-any any . each-any))))
- (if tmp-29529
+ (if tmp-36726
(@apply
- (lambda (k-29533 e1-29534 e2-29535)
+ (lambda (k-36730 e1-36731 e2-36732)
(list '#(syntax-object
if
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
+ #("l-*-36624"
+ "l-*-36625"
+ "l-*-36626"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("l-*-29435"))
+ #("l-*-36620"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
memv
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
+ #("l-*-36624"
+ "l-*-36625"
+ "l-*-36626"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("l-*-29435"))
+ #("l-*-36620"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
'#(syntax-object
t
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
+ #("l-*-36624"
+ "l-*-36625"
+ "l-*-36626"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("l-*-29435"))
+ #("l-*-36620"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
(list '#(syntax-object
quote
#((top)
(top)
(top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
+ #("l-*-36624"
+ "l-*-36625"
+ "l-*-36626"))
#(ribcage
()
()
#(ribcage
#(rest)
#((top))
- #("l-*-29435"))
+ #("l-*-36620"))
#(ribcage
()
()
#((top)
(top)
(top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top)
(top)
(top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage
()
()
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene
+ guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- k-29533))
+ k-36730))
(cons '#(syntax-object
begin
((top)
#(ribcage
#(k e1 e2)
#((top) (top) (top))
- #("l-*-29439"
- "l-*-29440"
- "l-*-29441"))
+ #("l-*-36624"
+ "l-*-36625"
+ "l-*-36626"))
#(ribcage () () ())
#(ribcage
#(rest)
#((top))
- #("l-*-29435"))
+ #("l-*-36620"))
#(ribcage () () ())
#(ribcage
#(f clause clauses)
#((top) (top) (top))
- #("l-*-29408"
- "l-*-29409"
- "l-*-29410"))
+ #("l-*-36593"
+ "l-*-36594"
+ "l-*-36595"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29395")))
+ #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- (cons e1-29534 e2-29535))
- tmp-29526))
- tmp-29529)
+ (cons e1-36731 e2-36732))
+ tmp-36723))
+ tmp-36726)
(syntax-violation
'case
"bad clause"
- x-29449
- clause-29503))))))))
- (f-29500 m1-29456 m2-29457))))
- (let ((body-29459 tmp-29458))
+ x-36634
+ clause-36700))))))))
+ (f-36697 m1-36641 m2-36642))))
+ (let ((body-36644 tmp-36643))
(list '#(syntax-object
let
((top)
#(ribcage () () ())
- #(ribcage #(body) #((top)) #("l-*-29406"))
+ #(ribcage #(body) #((top)) #("l-*-36591"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398" "l-*-29399" "l-*-29400"))
+ #("l-*-36583" "l-*-36584" "l-*-36585"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29395")))
+ #(ribcage #(x) #((top)) #("l-*-36580"))
+ #(ribcage
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list (list '#(syntax-object
t
#(ribcage
#(body)
#((top))
- #("l-*-29406"))
+ #("l-*-36591"))
#(ribcage
#(e m1 m2)
#((top) (top) (top))
- #("l-*-29398"
- "l-*-29399"
- "l-*-29400"))
+ #("l-*-36583"
+ "l-*-36584"
+ "l-*-36585"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-36580"))
#(ribcage
- #(x)
- #((top))
- #("l-*-29395")))
+ (case)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ case
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- e-29455))
- body-29459))))
- tmp-29451)
+ e-36640))
+ body-36644))))
+ tmp-36636)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29449))))))
+ x-36634))))))
(define make-variable-transformer
- (lambda (proc-29553)
- (if (procedure? proc-29553)
+ (lambda (proc-36751)
+ (if (procedure? proc-36751)
(letrec*
- ((trans-29554
- (lambda (x-29560) (proc-29553 x-29560))))
+ ((trans-36752
+ (lambda (x-36754) (proc-36751 x-36754))))
(begin
(set-procedure-property!
- trans-29554
+ trans-36752
'variable-transformer
#t)
- trans-29554))
+ trans-36752))
(error "variable transformer not a procedure"
- proc-29553))))
+ proc-36751))))
(define identifier-syntax
(make-syntax-transformer
'identifier-syntax
'macro
- (lambda (x-29592)
- (let ((tmp-29594 ($sc-dispatch x-29592 '(_ any))))
- (if tmp-29594
+ (lambda (x-36791)
+ (let ((tmp-36793 ($sc-dispatch x-36791 '(_ any))))
+ (if tmp-36793
(@apply
- (lambda (e-29598)
+ (lambda (e-36797)
(list '#(syntax-object
lambda
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
'#((#(syntax-object
macro-type
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
identifier-syntax
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax-case
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'()
(list '#(syntax-object
id
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
identifier?
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(#(syntax-object
syntax
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
id
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax
#(ribcage
#(e)
#((top))
- #("l-*-29567"))
+ #("l-*-36766"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- e-29598))
+ e-36797))
(list '(#(syntax-object
_
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
x
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
((top)
- #(ribcage #(e) #((top)) #("l-*-29567"))
+ #(ribcage #(e) #((top)) #("l-*-36766"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(list '#(syntax-object
syntax
#(ribcage
#(e)
#((top))
- #("l-*-29567"))
+ #("l-*-36766"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons e-29598
+ (cons e-36797
'(#(syntax-object
x
((top)
#(ribcage
#(e)
#((top))
- #("l-*-29567"))
+ #("l-*-36766"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
#(ribcage
#(e)
#((top))
- #("l-*-29567"))
+ #("l-*-36766"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))))))))
- tmp-29594)
- (let ((tmp-29599
+ tmp-36793)
+ (let ((tmp-36798
($sc-dispatch
- x-29592
+ x-36791
'(_ (any any)
((#(free-id
#(syntax-object
set!
((top)
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
any
any)
any)))))
- (if (if tmp-29599
+ (if (if tmp-36798
(@apply
- (lambda (id-29603
- exp1-29604
- var-29605
- val-29606
- exp2-29607)
- (if (identifier? id-29603)
- (identifier? var-29605)
+ (lambda (id-36802
+ exp1-36803
+ var-36804
+ val-36805
+ exp2-36806)
+ (if (identifier? id-36802)
+ (identifier? var-36804)
#f))
- tmp-29599)
+ tmp-36798)
#f)
(@apply
- (lambda (id-29608
- exp1-29609
- var-29610
- val-29611
- exp2-29612)
+ (lambda (id-36807
+ exp1-36808
+ var-36809
+ val-36810
+ exp2-36811)
(list '#(syntax-object
make-variable-transformer
((top)
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
lambda
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
x
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
'#((#(syntax-object
macro-type
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
.
#(syntax-object
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29564")))
+ #(ribcage #(x) #((top)) #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax-case
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-36763"))
#(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'#(syntax-object
x
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
+ #(ribcage #(x) #((top)) #("l-*-36763"))
#(ribcage
- #(x)
- #((top))
- #("l-*-29564")))
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
'(#(syntax-object
set!
#(ribcage
#(id exp1 var val exp2)
#((top) (top) (top) (top) (top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile)))
(list (list '#(syntax-object
set!
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- var-29610
- val-29611)
+ var-36809
+ val-36810)
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- exp2-29612))
- (list (cons id-29608
+ exp2-36811))
+ (list (cons id-36807
'(#(syntax-object
x
((top)
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
#(syntax-object
...
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
(list '#(syntax-object
syntax
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons exp1-29609
+ (cons exp1-36808
'(#(syntax-object
x
((top)
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
#(syntax-object
...
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))))))
- (list id-29608
+ (list id-36807
(list '#(syntax-object
identifier?
((top)
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
(list '#(syntax-object
syntax
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene
+ guile))))))
(hygiene guile))
- id-29608))
+ id-36807))
(list '#(syntax-object
syntax
((top)
(top)
(top)
(top))
- #("l-*-29582"
- "l-*-29583"
- "l-*-29584"
- "l-*-29585"
- "l-*-29586"))
+ #("l-*-36781"
+ "l-*-36782"
+ "l-*-36783"
+ "l-*-36784"
+ "l-*-36785"))
#(ribcage () () ())
#(ribcage
#(x)
#((top))
- #("l-*-29564")))
+ #("l-*-36763"))
+ #(ribcage
+ (identifier-syntax)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ identifier-syntax
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- exp1-29609))))))
- tmp-29599)
+ exp1-36808))))))
+ tmp-36798)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29592))))))))
+ x-36791))))))))
(define define*
(make-syntax-transformer
'define*
'macro
- (lambda (x-29644)
- (let ((tmp-29646
+ (lambda (x-36844)
+ (let ((tmp-36846
($sc-dispatch
- x-29644
+ x-36844
'(_ (any . any) any . each-any))))
- (if tmp-29646
+ (if tmp-36846
(@apply
- (lambda (id-29650 args-29651 b0-29652 b1-29653)
+ (lambda (id-36850 args-36851 b0-36852 b1-36853)
(list '#(syntax-object
define
((top)
#(ribcage
#(id args b0 b1)
#((top) (top) (top) (top))
- #("l-*-29626"
- "l-*-29627"
- "l-*-29628"
- "l-*-29629"))
+ #("l-*-36826"
+ "l-*-36827"
+ "l-*-36828"
+ "l-*-36829"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
+ #(ribcage #(x) #((top)) #("l-*-36823"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- id-29650
+ id-36850
(cons '#(syntax-object
lambda*
((top)
#(ribcage
#(id args b0 b1)
#((top) (top) (top) (top))
- #("l-*-29626"
- "l-*-29627"
- "l-*-29628"
- "l-*-29629"))
+ #("l-*-36826"
+ "l-*-36827"
+ "l-*-36828"
+ "l-*-36829"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
+ #(ribcage #(x) #((top)) #("l-*-36823"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- (cons args-29651 (cons b0-29652 b1-29653)))))
- tmp-29646)
- (let ((tmp-29654 ($sc-dispatch x-29644 '(_ any any))))
- (if (if tmp-29654
+ (cons args-36851 (cons b0-36852 b1-36853)))))
+ tmp-36846)
+ (let ((tmp-36854 ($sc-dispatch x-36844 '(_ any any))))
+ (if (if tmp-36854
(@apply
- (lambda (id-29658 val-29659)
+ (lambda (id-36858 val-36859)
(identifier?
'#(syntax-object
x
#(ribcage
#(id val)
#((top) (top))
- #("l-*-29636" "l-*-29637"))
+ #("l-*-36836" "l-*-36837"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
+ #(ribcage #(x) #((top)) #("l-*-36823"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))))
- tmp-29654)
+ tmp-36854)
#f)
(@apply
- (lambda (id-29660 val-29661)
+ (lambda (id-36860 val-36861)
(list '#(syntax-object
define
((top)
#(ribcage
#(id val)
#((top) (top))
- #("l-*-29640" "l-*-29641"))
+ #("l-*-36840" "l-*-36841"))
#(ribcage () () ())
- #(ribcage #(x) #((top)) #("l-*-29623")))
+ #(ribcage #(x) #((top)) #("l-*-36823"))
+ #(ribcage
+ (define*)
+ ((top))
+ (((hygiene guile)
+ .
+ #(syntax-object
+ define*
+ ((top))
+ (hygiene guile))))))
(hygiene guile))
- id-29660
- val-29661))
- tmp-29654)
+ id-36860
+ val-36861))
+ tmp-36854)
(syntax-violation
#f
"source expression failed to match any pattern"
- x-29644))))))))
+ x-36844))))))))
(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)
;; global (assumed global variable) and displaced-lexical (see below)
;; do not show up in any environment; instead, they are fabricated by
- ;; lookup when it finds no other bindings.
+ ;; resolve-identifier when it finds no other bindings.
;; <environment> ::= ((<label> . <binding>)*)
;; identifier bindings include a type and a value
;; <binding> ::= (macro . <procedure>) macros
+ ;; (syntax-parameter . (<procedure>)) syntax parameters
;; (core . <procedure>) core forms
;; (module-ref . <procedure>) @ or @@
;; (begin) begin
(if (null? r)
'()
(let ((a (car r)))
- (if (eq? (cadr a) 'macro)
+ (if (memq (cadr a) '(macro syntax-parameter))
(cons a (macros-only-env (cdr r)))
(macros-only-env (cdr r)))))))
- (define lookup
- ;; x may be a label or a symbol
- ;; although symbols are usually global, we check the environment first
- ;; anyway because a temporary binding may have been established by
- ;; fluid-let-syntax
- (lambda (x r mod)
- (cond
- ((assq x r) => cdr)
- ((symbol? x)
- (or (get-global-definition-hook x mod) (make-binding 'global)))
- (else (make-binding 'displaced-lexical)))))
-
(define global-extend
(lambda (type sym val)
(put-global-definition-hook sym type val)))
(same-marks? (cdr x) (cdr y))))))
(define id-var-name
- (lambda (id w)
+ ;; Syntax objects use wraps to associate names with marked
+ ;; identifiers. This function returns the name corresponding to
+ ;; the given identifier and wrap, or the original identifier if no
+ ;; corresponding name was found.
+ ;;
+ ;; The name may be a string created by gen-label, indicating a
+ ;; lexical binding, or another syntax object, indicating a
+ ;; reference to a top-level definition created during a previous
+ ;; macroexpansion.
+ ;;
+ ;; For lexical variables, finding a label simply amounts to
+ ;; looking for an entry with the same symbolic name and the same
+ ;; marks. Finding a toplevel definition is the same, except we
+ ;; also have to compare modules, hence the `mod' parameter.
+ ;; Instead of adding a separate entry in the ribcage for modules,
+ ;; which wouldn't be used for lexicals, we arrange for the entry
+ ;; for the name entry to be a pair with the module in its car, and
+ ;; the name itself in the cdr. So if the name that we find is a
+ ;; pair, we have to check modules.
+ ;;
+ ;; The identifer may be passed in wrapped or unwrapped. In any
+ ;; case, this routine returns either a symbol, a syntax object, or
+ ;; a string label.
+ ;;
+ (lambda (id w mod)
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
- (lambda (sym subst marks)
+ (lambda (sym subst marks mod)
(if (null? subst)
(values #f marks)
(let ((fst (car subst)))
(if (eq? fst 'shift)
- (search sym (cdr subst) (cdr marks))
+ (search sym (cdr subst) (cdr marks) mod)
(let ((symnames (ribcage-symnames fst)))
(if (vector? symnames)
- (search-vector-rib sym subst marks symnames fst)
- (search-list-rib sym subst marks symnames fst))))))))
+ (search-vector-rib sym subst marks symnames fst mod)
+ (search-list-rib sym subst marks symnames fst mod))))))))
(define search-list-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let f ((symnames symnames) (i 0))
(cond
- ((null? symnames) (search sym (cdr subst) marks))
+ ((null? symnames) (search sym (cdr subst) marks mod))
((and (eq? (car symnames) sym)
(same-marks? marks (list-ref (ribcage-marks ribcage) i)))
- (values (list-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (list-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (cdr symnames) (fx+ i 1)))
+ (values n marks))))
(else (f (cdr symnames) (fx+ i 1)))))))
(define search-vector-rib
- (lambda (sym subst marks symnames ribcage)
+ (lambda (sym subst marks symnames ribcage mod)
(let ((n (vector-length symnames)))
(let f ((i 0))
(cond
- ((fx= i n) (search sym (cdr subst) marks))
+ ((fx= i n) (search sym (cdr subst) marks mod))
((and (eq? (vector-ref symnames i) sym)
(same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
- (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (let ((n (vector-ref (ribcage-labels ribcage) i)))
+ (if (pair? n)
+ (if (equal? mod (car n))
+ (values (cdr n) marks)
+ (f (fx+ i 1)))
+ (values n marks))))
(else (f (fx+ i 1))))))))
(cond
((symbol? id)
- (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
((syntax-object? id)
(let ((id (syntax-object-expression id))
- (w1 (syntax-object-wrap id)))
+ (w1 (syntax-object-wrap id))
+ (mod (syntax-object-module id)))
(let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
- (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (call-with-values (lambda () (search id (wrap-subst w) marks mod))
(lambda (new-id marks)
(or new-id
- (first (search id (wrap-subst w1) marks))
+ (first (search id (wrap-subst w1) marks mod))
id))))))
(else (syntax-violation 'id-var-name "invalid id" id)))))
;; Returns three values: binding type, binding value, the module (for
;; resolving toplevel vars).
- (define (resolve-identifier id w r mod)
+ (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+ (define (resolve-syntax-parameters b)
+ (if (and resolve-syntax-parameters?
+ (eq? (binding-type b) 'syntax-parameter))
+ (or (assq-ref r (binding-value b))
+ (make-binding 'macro (car (binding-value b))))
+ b))
(define (resolve-global var mod)
- (let ((b (or (get-global-definition-hook var mod)
- (make-binding 'global))))
+ (let ((b (resolve-syntax-parameters
+ (or (get-global-definition-hook var mod)
+ (make-binding 'global)))))
(if (eq? (binding-type b) 'global)
(values 'global var mod)
(values (binding-type b) (binding-value b) mod))))
(define (resolve-lexical label mod)
- (let ((b (or (assq-ref r label)
- (make-binding 'displaced-lexical))))
+ (let ((b (resolve-syntax-parameters
+ (or (assq-ref r label)
+ (make-binding 'displaced-lexical)))))
(values (binding-type b) (binding-value b) mod)))
- (let ((n (id-var-name id w)))
+ (let ((n (id-var-name id w mod)))
(cond
+ ((syntax-object? n)
+ ;; Recursing allows syntax-parameterize to override
+ ;; macro-introduced syntax parameters.
+ (resolve-identifier n w r mod resolve-syntax-parameters?))
((symbol? n)
(resolve-global n (if (syntax-object? id)
(syntax-object-module id)
(define free-id=?
(lambda (i j)
- (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
- (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
-
+ (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
+ (mj (and (syntax-object? j) (syntax-object-module j)))
+ (ni (id-var-name i empty-wrap mi))
+ (nj (id-var-name j empty-wrap mj)))
+ (define (id-module-binding id mod)
+ (module-variable
+ (if mod
+ ;; The normal case.
+ (resolve-module (cdr mod))
+ ;; Either modules have not been booted, or we have a
+ ;; raw symbol coming in, which is possible.
+ (current-module))
+ (id-sym-name id)))
+ (cond
+ ((syntax-object? ni) (free-id=? ni j))
+ ((syntax-object? nj) (free-id=? i nj))
+ ((symbol? ni)
+ ;; `i' is not lexically bound. Assert that `j' is free,
+ ;; and if so, compare their bindings, that they are either
+ ;; bound to the same variable, or both unbound and have
+ ;; the same name.
+ (and (eq? nj (id-sym-name j))
+ (let ((bi (id-module-binding i mi)))
+ (if bi
+ (eq? bi (id-module-binding j mj))
+ (and (not (id-module-binding j mj))
+ (eq? ni nj))))
+ (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (else
+ ;; Otherwise `i' is bound, so check that `j' is bound, and
+ ;; bound to the same thing.
+ (equal? ni nj))))))
+
;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;; long as the missing portion of the wrap is common to both of the ids
;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
;;
(define expand-top-sequence
(lambda (body r w s m esew mod)
- (define (scan body r w s m esew mod exps)
- (cond
- ((null? body)
- ;; in reversed order
- exps)
- (else
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (define (record-definition! id var)
+ (let ((mod (cons 'hygiene (module-name (current-module)))))
+ ;; Ribcages map symbol+marks to names, mostly for
+ ;; resolving lexicals. Here to add a mapping for toplevel
+ ;; definitions we also need to match the module. So, we
+ ;; put it in the name instead, and make id-var-name handle
+ ;; the special case of names that are pairs. See the
+ ;; comments in id-var-name for more.
+ (extend-ribcage! ribcage id
+ (cons (syntax-object-module id)
+ (wrap var top-wrap mod)))))
+ (define (macro-introduced-identifier? id)
+ (not (equal? (wrap-marks (syntax-object-wrap id)) '(top))))
+ (define (fresh-derived-name id orig-form)
+ (symbol-append
+ (syntax-object-expression id)
+ '-
+ (string->symbol
+ ;; FIXME: `hash' currently stops descending into nested
+ ;; data at some point, so it's less unique than we would
+ ;; like. Also this encodes hash values into the ABI of
+ ;; compiled modules; a problem?
+ (number->string
+ (hash (syntax->datum orig-form) most-positive-fixnum)
+ 16))))
+ (define (parse body r w s m esew mod)
+ (let lp ((body body) (exps '()))
+ (if (null? body)
+ exps
+ (lp (cdr body)
+ (append (parse1 (car body) r w s m esew mod)
+ exps)))))
+ (define (parse1 x r w s m esew mod)
(call-with-values
(lambda ()
- (call-with-values
- (lambda ()
- (let ((e (car body)))
- (syntax-type e r w (or (source-annotation e) s) #f mod #f)))
- (lambda (type value form e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) exps)
- ((_ e1 e2 ...)
- (scan #'(e1 e2 ...) r w s m esew mod exps))))
- ((local-syntax-form)
- (expand-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (scan body r w s m esew mod exps))))
- ((eval-when-form)
- (syntax-case e ()
- ((_ (x ...) e1 e2 ...)
- (let ((when-list (parse-when-list e #'(x ...)))
- (body #'(e1 e2 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (scan body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod exps)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod))
- (values exps))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (scan body r w s 'c&e '(compile load) mod exps)
- (if (memq m '(c c&e))
- (scan body r w s 'c '(load) mod exps)
- (values exps))))
- ((or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (top-level-eval-hook
- (expand-top-sequence body r w s 'e '(eval) mod)
- mod)
- (values exps))
- (else
- (values exps)))))))
- ((define-syntax-form define-syntax-parameter-form)
- (let ((n (id-var-name value w)) (r (macros-only-env r)))
- (case m
- ((c)
- (if (memq 'compile esew)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (if (memq 'load esew)
- (values (cons e exps))
- (values exps)))
- (if (memq 'load esew)
- (values (cons (expand-install-global n (expand e r w mod))
- exps))
- (values exps))))
- ((c&e)
- (let ((e (expand-install-global n (expand e r w mod))))
- (top-level-eval-hook e mod)
- (values (cons e exps))))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (expand-install-global n (expand e r w mod))
- mod))
- (values exps)))))
- ((define-form)
- (let* ((n (id-var-name value w))
- ;; Lookup the name in the module of the define form.
- (type (binding-type (lookup n r mod))))
- (case type
- ((global core macro module-ref)
- ;; affect compile-time environment (once we have booted)
- (if (and (memq m '(c c&e))
- (not (module-local-variable (current-module) n))
- (current-module))
- (let ((old (module-variable (current-module) n)))
- ;; use value of the same-named imported variable, if
- ;; any
- (if (and (variable? old) (variable-bound? old))
- (module-define! (current-module) n (variable-ref old))
- (module-add! (current-module) n (make-undefined-variable)))))
- (values
- (cons
- (if (eq? m 'c&e)
- (let ((x (build-global-definition s n (expand e r w mod))))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (build-global-definition s n (expand e r w mod))))
- exps)))
- ((displaced-lexical)
- (syntax-violation #f "identifier out of context"
- (source-wrap form w s mod)
- (wrap value w mod)))
- (else
- (syntax-violation #f "cannot define keyword at top level"
- (source-wrap form w s mod)
- (wrap value w mod))))))
- (else
- (values (cons
- (if (eq? m 'c&e)
- (let ((x (expand-expr type value form e r w s mod)))
- (top-level-eval-hook x mod)
- x)
- (lambda ()
- (expand-expr type value form e r w s mod)))
- exps)))))))
- (lambda (exps)
- (scan (cdr body) r w s m esew mod exps))))))
-
- (call-with-values (lambda ()
- (scan body r w s m esew mod '()))
- (lambda (exps)
+ (syntax-type x r w (source-annotation x) ribcage mod #f))
+ (lambda (type value form e w s mod)
+ (case type
+ ((define-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (build-global-definition s var (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (build-global-definition s var (expand e r w mod)))))))
+ ((define-syntax-form define-syntax-parameter-form)
+ (let* ((id (wrap value w mod))
+ (label (gen-label))
+ (var (if (macro-introduced-identifier? id)
+ (fresh-derived-name id x)
+ (syntax-object-expression id))))
+ (record-definition! id var)
+ (case m
+ ((c)
+ (cond
+ ((memq 'compile esew)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (if (memq 'load esew)
+ (list (lambda () e))
+ '())))
+ ((memq 'load esew)
+ (list (lambda ()
+ (expand-install-global var type (expand e r w mod)))))
+ (else '())))
+ ((c&e)
+ (let ((e (expand-install-global var type (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (list (lambda () e))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global var type (expand e r w mod))
+ mod))
+ '()))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse #'(e1 ...) r w s m esew mod))))
+ ((local-syntax-form)
+ (expand-local-syntax value e r w s mod
+ (lambda (forms r w s mod)
+ (parse forms r w s m esew mod))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (parse-when-list e #'(x ...)))
+ (body #'(e1 e2 ...)))
+ (define (recurse m esew)
+ (parse body r w s m esew mod))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (recurse (if (memq 'expand when-list) 'c&e 'e)
+ '(eval))
+ (begin
+ (if (memq 'expand when-list)
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod))
+ '())))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (recurse 'c&e '(compile load))
+ (if (memq m '(c c&e))
+ (recurse 'c '(load))
+ '())))
+ ((or (memq 'compile when-list)
+ (memq 'expand when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (expand-top-sequence body r w s 'e '(eval) mod)
+ mod)
+ '())
+ (else
+ '()))))))
+ (else
+ (list
+ (if (eq? m 'c&e)
+ (let ((x (expand-expr type value form e r w s mod)))
+ (top-level-eval-hook x mod)
+ (lambda () x))
+ (lambda ()
+ (expand-expr type value form e r w s mod)))))))))
+ (let ((exps (map (lambda (x) (x))
+ (reverse (parse body r w s m esew mod)))))
(if (null? exps)
(build-void s)
- (build-sequence
- s
- (let lp ((in exps) (out '()))
- (if (null? in) out
- (let ((e (car in)))
- (lp (cdr in)
- (cons (if (procedure? e) (e) e) out)))))))))))
+ (build-sequence s exps))))))
(define expand-install-global
- (lambda (name e)
+ (lambda (name type e)
(build-global-definition
no-source
name
- (build-application
+ (build-primcall
no-source
- (build-primref no-source 'make-syntax-transformer)
- (list (build-data no-source name)
- (build-data no-source 'macro)
- e)))))
-
+ 'make-syntax-transformer
+ (if (eq? type 'define-syntax-parameter-form)
+ (list (build-data no-source name)
+ (build-data no-source 'syntax-parameter)
+ (build-primcall no-source 'list (list e)))
+ (list (build-data no-source name)
+ (build-data no-source 'macro)
+ e))))))
+
(define parse-when-list
(lambda (e when-list)
- ;; when-list is syntax'd version of list of situations
+ ;; `when-list' is syntax'd version of list of situations. We
+ ;; could match these keywords lexically, via free-id=?, but then
+ ;; we twingle the definition of eval-when to the bindings of
+ ;; eval, load, expand, and compile, which is totally unintended.
+ ;; So do a symbolic match instead.
(let ((result (strip when-list empty-wrap)))
(let lp ((l result))
(if (null? l)
(lambda (e r w s rib mod for-car?)
(cond
((symbol? e)
- (let* ((n (id-var-name e w))
- (b (lookup n r mod))
- (type (binding-type b)))
- (case type
- ((lexical) (values type (binding-value b) e e w s mod))
- ((global) (values type n e e w s mod))
- ((macro)
- (if for-car?
- (values type (binding-value b) e e w s mod)
- (syntax-type (expand-macro (binding-value b) e r w s rib mod)
- r empty-wrap s rib mod #f)))
- (else (values type (binding-value b) e e w s mod)))))
+ (call-with-values (lambda () (resolve-identifier e w r mod #t))
+ (lambda (type value mod*)
+ (case type
+ ((macro)
+ (if for-car?
+ (values type value e e w s mod)
+ (syntax-type (expand-macro value e r w s rib mod)
+ r empty-wrap s rib mod #f)))
+ ((global)
+ ;; Toplevel definitions may resolve to bindings with
+ ;; different names or in different modules.
+ (values type value e value w s mod*))
+ (else (values type value e e w s mod))))))
((pair? e)
(let ((first (car e)))
(call-with-values
(lambda (e r w s mod)
(expand e r w mod))))
((lexical-call)
- (expand-application
+ (expand-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
value))
e r w s mod))
((global-call)
- (expand-application
+ (expand-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
- ((call) (expand-application (expand (car e) r w mod) e r w s mod))
+ ((call) (expand-call (expand (car e) r w mod) e r w s mod))
((begin-form)
(syntax-case e ()
((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))
((_)
- (if (include-deprecated-features)
- (begin
- (issue-deprecation-warning
- "Sequences of zero expressions are deprecated. Use *unspecified*.")
- (expand-void))
- (syntax-violation #f "sequence of zero expressions"
- (source-wrap e w s mod))))))
+ (syntax-violation #f "sequence of zero expressions"
+ (source-wrap e w s mod)))))
((local-syntax-form)
(expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form)
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
- (define expand-application
+ (define expand-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
- (build-application s x
- (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
+ (build-call s x
+ (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
;;
;;
;; The only wrinkle is when we want a macro to expand to code in another
;; module, as is the case for the r6rs `library' form -- the body expressions
- ;; should be scoped relative the new module, the one defined by the macro.
+ ;; should be scoped relative the the new module, the one defined by the macro.
;; For that, use `(@@ mod-name body)'.
;;
;; Part of the macro output will be from the site of the macro use and part
(parse (cdr body)
(cons id ids) (cons label labels)
var-ids vars vals
- (cons (make-binding 'macro (cons er (wrap e w mod)))
+ (cons (make-binding
+ (if (eq? type 'define-syntax-parameter-form)
+ 'syntax-parameter
+ 'macro)
+ (cons er (wrap e w mod)))
bindings))))
((begin-form)
(syntax-case e ()
(let loop ((bs bindings) (er-cache #f) (r-cache #f))
(if (not (null? bs))
(let* ((b (car bs)))
- (if (eq? (car b) 'macro)
+ (if (memq (car b) '(macro syntax-parameter))
(let* ((er (cadr b))
(r-cache
(if (eq? er er-cache)
(eval-local-transformer
(expand (cddr b) r-cache empty-wrap mod)
mod))
+ (if (eq? (car b) 'syntax-parameter)
+ (set-cdr! b (list (cdr b))))
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f)
- (global-extend 'core 'syntax-parameterize
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((var val) ...) e1 e2 ...)
- (valid-bound-ids? #'(var ...))
- (let ((names (map (lambda (x) (id-var-name x w)) #'(var ...))))
- (for-each
- (lambda (id n)
- (case (binding-type (lookup n r mod))
- ((displaced-lexical)
- (syntax-violation 'syntax-parameterize
- "identifier out of context"
- e
- (source-wrap id w s mod)))))
- #'(var ...)
- names)
- (expand-body
- #'(e1 e2 ...)
- (source-wrap e w s mod)
- (extend-env
- names
- (let ((trans-r (macros-only-env r)))
- (map (lambda (x)
- (make-binding 'macro
- (eval-local-transformer (expand x trans-r w mod)
- mod)))
- #'(val ...)))
- r)
- w
- mod)))
- (_ (syntax-violation 'syntax-parameterize "bad syntax"
- (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'syntax-parameterize
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? #'(var ...))
+ (let ((names
+ (map (lambda (x)
+ (call-with-values
+ (lambda () (resolve-identifier x w r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((displaced-lexical)
+ (syntax-violation 'syntax-parameterize
+ "identifier out of context"
+ e
+ (source-wrap x w s mod)))
+ ((syntax-parameter)
+ value)
+ (else
+ (syntax-violation 'syntax-parameterize
+ "invalid syntax parameter"
+ e
+ (source-wrap x w s mod)))))))
+ #'(var ...)))
+ (bindings
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding
+ 'macro
+ (eval-local-transformer (expand x trans-r w mod) mod)))
+ #'(val ...)))))
+ (expand-body #'(e1 e2 ...)
+ (source-wrap e w s mod)
+ (extend-env names bindings r)
+ w
+ mod)))
+ (_ (syntax-violation 'syntax-parameterize "bad syntax"
+ (source-wrap e w s mod))))))
(global-extend 'core 'quote
(lambda (e r w s mod)
(_ (syntax-violation 'quote "bad syntax"
(source-wrap e w s mod))))))
- (global-extend 'core 'syntax
- (let ()
- (define gen-syntax
- (lambda (src e r maps ellipsis? mod)
- (if (id? e)
- (let ((label (id-var-name e empty-wrap)))
- ;; Mod does not matter, we are looking to see if
- ;; the id is lexical syntax.
- (let ((b (lookup label r mod)))
- (if (eq? (binding-type b) 'syntax)
- (call-with-values
- (lambda ()
- (let ((var.lev (binding-value b)))
- (gen-ref src (car var.lev) (cdr var.lev) maps)))
- (lambda (var maps) (values `(ref ,var) maps)))
- (if (ellipsis? e)
- (syntax-violation 'syntax "misplaced ellipsis" src)
- (values `(quote ,e) maps)))))
- (syntax-case e ()
- ((dots e)
- (ellipsis? #'dots)
- (gen-syntax src #'e r maps (lambda (x) #f) mod))
- ((x dots . y)
- ;; this could be about a dozen lines of code, except that we
- ;; choose to handle #'(x ... ...) forms
- (ellipsis? #'dots)
- (let f ((y #'y)
- (k (lambda (maps)
- (call-with-values
- (lambda ()
- (gen-syntax src #'x r
- (cons '() maps) ellipsis? mod))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis"
- src)
- (values (gen-map x (car maps))
- (cdr maps))))))))
- (syntax-case y ()
- ((dots . y)
- (ellipsis? #'dots)
- (f #'y
- (lambda (maps)
- (call-with-values
- (lambda () (k (cons '() maps)))
- (lambda (x maps)
- (if (null? (car maps))
- (syntax-violation 'syntax "extra ellipsis" src)
- (values (gen-mappend x (car maps))
- (cdr maps))))))))
- (_ (call-with-values
- (lambda () (gen-syntax src y r maps ellipsis? mod))
- (lambda (y maps)
- (call-with-values
- (lambda () (k maps))
- (lambda (x maps)
- (values (gen-append x y) maps)))))))))
- ((x . y)
- (call-with-values
- (lambda () (gen-syntax src #'x r maps ellipsis? mod))
- (lambda (x maps)
- (call-with-values
- (lambda () (gen-syntax src #'y r maps ellipsis? mod))
- (lambda (y maps) (values (gen-cons x y) maps))))))
- (#(e1 e2 ...)
- (call-with-values
- (lambda ()
- (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
- (lambda (e maps) (values (gen-vector e) maps))))
- (_ (values `(quote ,e) maps))))))
-
- (define gen-ref
- (lambda (src var level maps)
- (if (fx= level 0)
- (values var maps)
- (if (null? maps)
- (syntax-violation 'syntax "missing ellipsis" src)
- (call-with-values
- (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
- (lambda (outer-var outer-maps)
- (let ((b (assq outer-var (car maps))))
- (if b
- (values (cdr b) maps)
- (let ((inner-var (gen-var 'tmp)))
- (values inner-var
- (cons (cons (cons outer-var inner-var)
- (car maps))
- outer-maps)))))))))))
-
- (define gen-mappend
- (lambda (e map-env)
- `(apply (primitive append) ,(gen-map e map-env))))
-
- (define gen-map
- (lambda (e map-env)
- (let ((formals (map cdr map-env))
- (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
- (cond
- ((eq? (car e) 'ref)
- ;; identity map equivalence:
- ;; (map (lambda (x) x) y) == y
- (car actuals))
- ((and-map
- (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
- (cdr e))
- ;; eta map equivalence:
- ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
- `(map (primitive ,(car e))
- ,@(map (let ((r (map cons formals actuals)))
- (lambda (x) (cdr (assq (cadr x) r))))
- (cdr e))))
- (else `(map (lambda ,formals ,e) ,@actuals))))))
-
- (define gen-cons
- (lambda (x y)
- (case (car y)
- ((quote)
- (if (eq? (car x) 'quote)
- `(quote (,(cadr x) . ,(cadr y)))
- (if (eq? (cadr y) '())
- `(list ,x)
- `(cons ,x ,y))))
- ((list) `(list ,x ,@(cdr y)))
- (else `(cons ,x ,y)))))
-
- (define gen-append
- (lambda (x y)
- (if (equal? y '(quote ()))
- x
- `(append ,x ,y))))
-
- (define gen-vector
- (lambda (x)
- (cond
- ((eq? (car x) 'list) `(vector ,@(cdr x)))
- ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
- (else `(list->vector ,x)))))
-
-
- (define regen
- (lambda (x)
- (case (car x)
- ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
- ((primitive) (build-primref no-source (cadr x)))
- ((quote) (build-data no-source (cadr x)))
- ((lambda)
- (if (list? (cadr x))
- (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
- (error "how did we get here" x)))
- (else (build-application no-source
- (build-primref no-source (car x))
- (map regen (cdr x)))))))
-
- (lambda (e r w s mod)
- (let ((e (source-wrap e w s mod)))
- (syntax-case e ()
- ((_ x)
+ (global-extend
+ 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis? mod)
+ (if (id? e)
+ (call-with-values (lambda ()
+ (resolve-identifier e empty-wrap r mod #f))
+ (lambda (type value mod)
+ (case type
+ ((syntax)
+ (call-with-values
+ (lambda () (gen-ref src (car value) (cdr value) maps))
+ (lambda (var maps)
+ (values `(ref ,var) maps))))
+ (else
+ (if (ellipsis? e)
+ (syntax-violation 'syntax "misplaced ellipsis" src)
+ (values `(quote ,e) maps))))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? #'dots)
+ (gen-syntax src #'e r maps (lambda (x) #f) mod))
+ ((x dots . y)
+ ;; this could be about a dozen lines of code, except that we
+ ;; choose to handle #'(x ... ...) forms
+ (ellipsis? #'dots)
+ (let f ((y #'y)
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'x r
+ (cons '() maps) ellipsis? mod))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis"
+ src)
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? #'dots)
+ (f #'y
+ (lambda (maps)
(call-with-values
- (lambda () (gen-syntax e #'x r '() ellipsis? mod))
- (lambda (e maps) (regen e))))
- (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-violation 'syntax "extra ellipsis" src)
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis? mod))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src #'x r maps ellipsis? mod))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src #'y r maps ellipsis? mod))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-violation 'syntax "missing ellipsis" src)
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ;; identity map equivalence:
+ ;; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((and-map
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ;; eta map equivalence:
+ ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x) (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda)
+ (if (list? (cadr x))
+ (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
+ (error "how did we get here" x)))
+ (else (build-primcall no-source (car x) (map regen (cdr x)))))))
+
+ (lambda (e r w s mod)
+ (let ((e (source-wrap e w s mod)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e #'x r '() ellipsis? mod))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))
(global-extend 'core 'lambda
(lambda (e r w s mod)
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
- (global-extend 'core 'set!
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ id val)
- (id? #'id)
- (let ((n (id-var-name #'id w))
- ;; Lookup id in its module
- (id-mod (if (syntax-object? #'id)
- (syntax-object-module #'id)
- mod)))
- (let ((b (lookup n r id-mod)))
- (case (binding-type b)
- ((lexical)
- (build-lexical-assignment s
- (syntax->datum #'id)
- (binding-value b)
- (expand #'val r w mod)))
- ((global)
- (build-global-assignment s n (expand #'val r w mod) id-mod))
- ((macro)
- (let ((p (binding-value b)))
- (if (procedure-property p 'variable-transformer)
- ;; As syntax-type does, call expand-macro with
- ;; the mod of the expression. Hmm.
- (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
- (syntax-violation 'set! "not a variable transformer"
- (wrap e w mod)
- (wrap #'id w id-mod)))))
- ((displaced-lexical)
- (syntax-violation 'set! "identifier out of context"
- (wrap #'id w mod)))
- (else (syntax-violation 'set! "bad set!"
- (source-wrap e w s mod)))))))
- ((_ (head tail ...) val)
- (call-with-values
- (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
- (lambda (type value formform ee ww ss modmod)
- (case type
- ((module-ref)
- (let ((val (expand #'val r w mod)))
- (call-with-values (lambda () (value #'(head tail ...) r w))
- (lambda (e r w s* mod)
- (syntax-case e ()
- (e (id? #'e)
- (build-global-assignment s (syntax->datum #'e)
- val mod)))))))
- (else
- (build-application s
- (expand #'(setter head) r w mod)
- (map (lambda (e) (expand e r w mod))
- #'(tail ... val))))))))
- (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+ (global-extend
+ 'core 'set!
+ (lambda (e r w s mod)
+ (syntax-case e ()
+ ((_ id val)
+ (id? #'id)
+ (call-with-values
+ (lambda () (resolve-identifier #'id w r mod #t))
+ (lambda (type value id-mod)
+ (case type
+ ((lexical)
+ (build-lexical-assignment s (syntax->datum #'id) value
+ (expand #'val r w mod)))
+ ((global)
+ (build-global-assignment s value (expand #'val r w mod) id-mod))
+ ((macro)
+ (if (procedure-property value 'variable-transformer)
+ ;; As syntax-type does, call expand-macro with
+ ;; the mod of the expression. Hmm.
+ (expand (expand-macro value e r w s #f mod) r empty-wrap mod)
+ (syntax-violation 'set! "not a variable transformer"
+ (wrap e w mod)
+ (wrap #'id w id-mod))))
+ ((displaced-lexical)
+ (syntax-violation 'set! "identifier out of context"
+ (wrap #'id w mod)))
+ (else
+ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))
+ ((_ (head tail ...) val)
+ (call-with-values
+ (lambda () (syntax-type #'head r empty-wrap no-source #f mod #t))
+ (lambda (type value ee* ee ww ss modmod)
+ (case type
+ ((module-ref)
+ (let ((val (expand #'val r w mod)))
+ (call-with-values (lambda () (value #'(head tail ...) r w))
+ (lambda (e r w s* mod)
+ (syntax-case e ()
+ (e (id? #'e)
+ (build-global-assignment s (syntax->datum #'e)
+ val mod)))))))
+ (else
+ (build-call s
+ (expand #'(setter head) r w mod)
+ (map (lambda (e) (expand e r w mod))
+ #'(tail ... val))))))))
+ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@
(lambda (e r w)
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
- (build-application no-source
- (build-primref no-source 'apply)
- (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
- (expand exp
- (extend-env
- labels
- (map (lambda (var level)
- (make-binding 'syntax `(,var . ,level)))
- new-vars
- (map cdr pvars))
- r)
- (make-binding-wrap ids labels empty-wrap)
- mod))
- y))))))
+ (build-primcall
+ no-source
+ 'apply
+ (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
+ (expand exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)
+ mod))
+ y))))))
(define gen-clause
(lambda (x keys clauses r pat fender exp mod)
(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)
(expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
- (build-application no-source
- (build-simple-lambda
- no-source (list (syntax->datum #'pat)) #f (list var)
- '()
- (expand #'exp
- (extend-env labels
- (list (make-binding 'syntax `(,var . 0)))
- r)
- (make-binding-wrap #'(pat)
- labels empty-wrap)
- mod))
- (list x))))
+ (build-call no-source
+ (build-simple-lambda
+ no-source (list (syntax->datum #'pat)) #f (list var)
+ '()
+ (expand #'exp
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap #'(pat)
+ labels empty-wrap)
+ mod))
+ (list x))))
(gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod)))
((pat fender exp)
#'(key ...))
(let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x
- (build-application s
- (build-simple-lambda no-source (list 'tmp) #f (list x) '()
- (gen-syntax-case (build-lexical-reference 'value no-source
- 'tmp x)
- #'(key ...) #'(m ...)
- r
- mod))
- (list (expand #'val r empty-wrap mod))))
+ (build-call s
+ (build-simple-lambda no-source (list 'tmp) #f (list x) '()
+ (gen-syntax-case (build-lexical-reference 'value no-source
+ 'tmp x)
+ #'(key ...) #'(m ...)
+ r
+ mod))
+ (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds expand-top's mode m with 'e (for
(syntax-object-expression id)
(strip-anti-mark (syntax-object-wrap id))
r
- (syntax-object-module id)))
+ (syntax-object-module id)
+ ;; FIXME: come up with a better policy for
+ ;; resolve-syntax-parameters
+ #t))
(lambda (type value mod)
(case type
((lexical) (values 'lexical value))
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...)))
((_ (k ...) docstring ((keyword . pattern) template) ...)
(string? (syntax->datum #'docstring))
#((macro-type . syntax-rules)
(patterns pattern ...))
(syntax-case x (k ...)
- ((dummy . pattern) #'template)
+ ((_ . pattern) #'template)
...))))))
(define-syntax define-syntax-rule
;;; installed-scm-file
-;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2011 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
\f
(define-module (ice-9 weak-vector)
- :export (make-weak-vector list->weak-vector weak-vector weak-vector?
- make-weak-key-alist-vector
- make-weak-value-alist-vector
- make-doubly-weak-alist-vector
- weak-key-alist-vector?
- weak-value-alist-vector?
- doubly-weak-alist-vector?) ; C
- )
+ #:export (make-weak-vector list->weak-vector weak-vector weak-vector?))
-(%init-weaks-builtins) ; defined in libguile/weaks.c
+(eval-when (load eval compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_weak_vector_builtins"))
;;; 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))))))))
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax-rule (@impl 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
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
+ <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<dynref> dynref? make-dynref dynref-src dynref-fluid
<dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
+ list->seq
+
parse-tree-il
unparse-tree-il
tree-il->scheme
;; (<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)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(<let-values> exp body)
- (<dynwind> winder body unwinder)
+ (<dynwind> winder pre body post unwinder)
(<dynref> fluid)
(<dynset> fluid exp)
(<prompt> tag body handler)
\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)))
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
- ((dynwind ,winder ,body ,unwinder)
- (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
+ ((dynwind ,winder ,pre ,body ,post ,unwinder)
+ (make-dynwind loc (retrans winder) (retrans pre)
+ (retrans body)
+ (retrans post) (retrans unwinder)))
((dynlet ,fluids ,vals ,body)
(make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
((<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)))
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- ((<dynwind> winder body unwinder)
- `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
- ,(unparse-tree-il unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre)
+ ,(unparse-tree-il body)
+ ,(unparse-tree-il post) ,(unparse-tree-il unwinder)))
((<dynlet> fluids vals body)
`(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
((<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
+ (lambda (x)
+ (list (tree-il->scheme x))))))
((<let> gensyms vals body)
`(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
`(call-with-values (lambda () ,(tree-il->scheme exp))
,(tree-il->scheme (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder body unwinder)
`(dynamic-wind ,(tree-il->scheme winder)
(lambda () ,(tree-il->scheme body))
,(tree-il->scheme unwinder)))
((<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)
(down tree result)))))
((<let-values> exp body)
(up tree (loop body (loop exp (down tree result)))))
- ((<dynwind> body winder unwinder)
+ ((<dynwind> winder pre body post unwinder)
(up tree (loop unwinder
- (loop winder
- (loop body (down tree result))))))
+ (loop post
+ (loop body
+ (loop pre
+ (loop winder
+ (down tree result))))))))
((<dynlet> fluids vals body)
(up tree (loop body
(loop vals
(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)
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- ((<dynwind> body winder unwinder)
- (let*-values (((seed ...) (foldts body seed ...))
- ((seed ...) (foldts winder seed ...)))
+ ((<dynwind> winder pre body post unwinder)
+ (let*-values (((seed ...) (foldts winder seed ...))
+ ((seed ...) (foldts pre seed ...))
+ ((seed ...) (foldts body seed ...))
+ ((seed ...) (foldts post seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
(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)))
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
(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)))
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
- ((<dynwind> body winder unwinder)
- (set! (dynwind-body x) (lp body))
+ ((<dynwind> winder pre body post unwinder)
(set! (dynwind-winder x) (lp winder))
+ (set! (dynwind-pre x) (lp pre))
+ (set! (dynwind-body x) (lp body))
+ (set! (dynwind-post x) (lp post))
(set! (dynwind-unwinder x) (lp unwinder)))
((<dynlet> fluids vals body)
(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
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
(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
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
(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)))
(match x
(($ <const> _ (? string? exp))
exp)
- (($ <application> _ (? (cut gettext? <> env))
+ (($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
- (($ <application> _ (? (cut ngettext? <> env))
+ (($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
- (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
- (($ <application> src ($ <module-ref> _ '(guile)
- (or 'format 'simple-format))
+ (($ <call> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
(post-order!
(lambda (x)
(match x
- (($ <sequence> src (tail))
- tail)
- (($ <sequence> src exps)
- (and (any sequence? exps)
- (make-sequence src
- (append-map (lambda (x)
- (if (sequence? x)
- (sequence-exps x)
- (list x)))
- exps))))
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
(else #f)))
(define (thunk-application? x)
(match x
- (($ <application> _
+ (($ <call> _
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
()) #t)
(_ #f)))
(define thunk
(make-lambda #f '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))
- (make-application #f thunk '()))
+ (make-call #f thunk '()))
;; This code has a nasty job to do: to ensure that either the
;; handler is escape-only, or the body is the application of a
((class-of . 1) . class-of)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)
+ ((string-length . 1) . string-length)
+ ((string-ref . 2) . string-ref)
+ ((vector-length . 1) . vector-length)
((vector-ref . 2) . vector-ref)
((vector-set! . 3) . vector-set)
((variable-ref . 1) . variable-ref)
(emit-code src (make-glil-const exp))))
(maybe-emit-return))
- ;; FIXME: should represent sequence as exps tail
- ((<sequence> exps)
- (let lp ((exps exps))
- (if (null? (cdr exps))
- (comp-tail (car exps))
- (begin
- (comp-drop (car exps))
- (lp (cdr exps))))))
-
- ((<application> src proc args)
- ;; FIXME: need a better pattern-matcher here
+ ((<seq> head tail)
+ (comp-drop head)
+ (comp-tail tail))
+
+ ((<call> src proc args)
(cond
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@apply)
- (>= (length args) 1))
- (let ((proc (car args))
- (args (cdr args)))
- (cond
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
- (not (eq? context 'push)) (not (eq? context 'vals)))
- ;; tail: (lambda () (apply values '(1 2)))
- ;; drop: (lambda () (apply values '(1 2)) 3)
- ;; push: (lambda () (list (apply values '(10 12)) 1))
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((tail)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'return/values* (length args))))))
-
- (else
- (case context
- ((tail)
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
- ((push)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (for-each comp-push args)
- (emit-code src (make-glil-call 'apply (1+ (length args))))
- (maybe-emit-return))
- ((vals)
- (comp-vals
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args))
- MVRA)
- (maybe-emit-return))
- ((drop)
- ;; Well, shit. The proc might return any number of
- ;; values (including 0), since it's in a drop context,
- ;; yet apply does not create a MV continuation. So we
- ;; mv-call out to our trampoline instead.
- (comp-drop
- (make-application src (make-primitive-ref #f 'apply)
- (cons proc args)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values))
- ;; tail: (lambda () (values '(1 2)))
- ;; drop: (lambda () (values '(1 2)) 3)
- ;; push: (lambda () (list (values '(10 12)) 1))
- ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
- (case context
- ((drop) (for-each comp-drop args) (maybe-emit-return))
- ((push)
- (case (length args)
- ((0)
- ;; FIXME: This is surely an error. We need to add a
- ;; values-mismatch warning pass.
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push proc)
- (emit-code src (make-glil-call 'call 0))
- (maybe-emit-return))
- (else
- ;; Taking advantage of unspecified order of evaluation of
- ;; arguments.
- (for-each comp-drop (cdr args))
- (comp-push (car 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 (let ((len (length args)))
- (if (= len 1)
- (make-glil-call 'return 1)
- (make-glil-call 'return/values len)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-values)
- (= (length args) 2))
- ;; CONSUMER
- ;; PRODUCER
- ;; (mv-call MV)
- ;; ([tail]-call 1)
- ;; goto POST
- ;; MV: [tail-]call/nargs
- ;; POST: (maybe-drop)
- (case context
- ((vals)
- ;; Fall back.
- (comp-vals
- (make-application src (make-primitive-ref #f 'call-with-values)
- args)
- MVRA)
- (maybe-emit-return))
- (else
- (let ((MV (make-label)) (POST (make-label))
- (producer (car args)) (consumer (cadr args)))
- (if (not (eq? context 'tail))
- (emit-code src (make-glil-call 'new-frame 0)))
- (comp-push consumer)
- (emit-code src (make-glil-call 'new-frame 0))
- (comp-push producer)
- (emit-code src (make-glil-mv-call 0 MV))
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call 1)))
- (else (emit-code src (make-glil-call 'call 1))
- (emit-branch #f 'br POST)))
- (emit-label MV)
- (case context
- ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
- (else (emit-code src (make-glil-call 'call/nargs 0))
- (emit-label POST)
- (if (eq? context 'drop)
- (emit-code #f (make-glil-call 'drop 1)))
- (maybe-emit-return)))))))
-
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) '@call-with-current-continuation)
- (= (length args) 1))
- (case context
- ((tail)
- (comp-push (car args))
- (emit-code src (make-glil-call 'tail-call/cc 1)))
- ((vals)
- (comp-vals
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args)
- MVRA)
- (maybe-emit-return))
- ((push)
- (comp-push (car args))
- (emit-code src (make-glil-call 'call/cc 1))
- (maybe-emit-return))
- ((drop)
- ;; Crap. Just like `apply' in drop context.
- (comp-drop
- (make-application
- src (make-primitive-ref #f 'call-with-current-continuation)
- args))
- (maybe-emit-return))))
-
- ;; A hack for variable-set, the opcode for which takes its args
- ;; reversed, relative to the variable-set! function
- ((and (primitive-ref? proc)
- (eq? (primitive-ref-name proc) 'variable-set!)
- (= (length args) 2))
- (comp-push (cadr args))
- (comp-push (car args))
- (emit-code src (make-glil-call 'variable-set 2))
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
-
- ((and (primitive-ref? proc)
- (or (hash-ref *primcall-ops*
- (cons (primitive-ref-name proc) (length args)))
- (hash-ref *primcall-ops* (primitive-ref-name proc))))
- => (lambda (op)
- (for-each comp-push args)
- (emit-code src (make-glil-call op (length args)))
- (case (instruction-pushes op)
- ((0)
- (case context
- ((tail push vals) (emit-code #f (make-glil-void))))
- (maybe-emit-return))
- ((1)
- (case context
- ((drop) (emit-code #f (make-glil-call 'drop 1))))
- (maybe-emit-return))
- ((-1)
- ;; A control instruction, like return/values. Here we
- ;; just have to hope that the author of the tree-il
- ;; knew what they were doing.
- *unspecified*)
- (else
- (error "bad primitive op: too many pushes"
- op (instruction-pushes op))))))
-
;; call to the same lambda-case in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
(emit-branch #f 'br RA)
(emit-label POST)))))))))
+ ((<primcall> src name args)
+ (pmatch (cons name args)
+ ((@apply ,proc . ,args)
+ (cond
+ ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
+ (not (eq? context 'push)) (not (eq? context 'vals)))
+ ;; tail: (lambda () (apply values '(1 2)))
+ ;; drop: (lambda () (apply values '(1 2)) 3)
+ ;; push: (lambda () (list (apply values '(10 12)) 1))
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((tail)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'return/values* (length args))))))
+
+ (else
+ (case context
+ ((tail)
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
+ ((push)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push proc)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call 'apply (1+ (length args))))
+ (maybe-emit-return))
+ (else
+ (comp-tail (make-primcall src 'apply (cons proc args))))))))
+
+ ((values . _)
+ ;; tail: (lambda () (values '(1 2)))
+ ;; drop: (lambda () (values '(1 2)) 3)
+ ;; push: (lambda () (list (values '(10 12)) 1))
+ ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
+ (case context
+ ((drop) (for-each comp-drop args) (maybe-emit-return))
+ ((push)
+ (case (length args)
+ ((0)
+ ;; FIXME: This is surely an error. We need to add a
+ ;; values-mismatch warning pass.
+ (comp-push (make-call src (make-primitive-ref #f 'values)
+ '())))
+ (else
+ ;; Taking advantage of unspecified order of evaluation of
+ ;; arguments.
+ (for-each comp-drop (cdr args))
+ (comp-push (car 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 (let ((len (length args)))
+ (if (= len 1)
+ (make-glil-call 'return 1)
+ (make-glil-call 'return/values len)))))))
+
+ ((@call-with-values ,producer ,consumer)
+ ;; CONSUMER
+ ;; PRODUCER
+ ;; (mv-call MV)
+ ;; ([tail]-call 1)
+ ;; goto POST
+ ;; MV: [tail-]call/nargs
+ ;; POST: (maybe-drop)
+ (case context
+ ((vals)
+ ;; Fall back.
+ (comp-tail (make-primcall src 'call-with-values args)))
+ (else
+ (let ((MV (make-label)) (POST (make-label)))
+ (if (not (eq? context 'tail))
+ (emit-code src (make-glil-call 'new-frame 0)))
+ (comp-push consumer)
+ (emit-code src (make-glil-call 'new-frame 0))
+ (comp-push producer)
+ (emit-code src (make-glil-mv-call 0 MV))
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call 1)))
+ (else (emit-code src (make-glil-call 'call 1))
+ (emit-branch #f 'br POST)))
+ (emit-label MV)
+ (case context
+ ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
+ (else (emit-code src (make-glil-call 'call/nargs 0))
+ (emit-label POST)
+ (if (eq? context 'drop)
+ (emit-code #f (make-glil-call 'drop 1)))
+ (maybe-emit-return)))))))
+
+ ((@call-with-current-continuation ,proc)
+ (case context
+ ((tail)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'tail-call/cc 1)))
+ ((vals)
+ (comp-vals
+ (make-primcall src 'call-with-current-continuation args)
+ MVRA)
+ (maybe-emit-return))
+ ((push)
+ (comp-push proc)
+ (emit-code src (make-glil-call 'call/cc 1))
+ (maybe-emit-return))
+ ((drop)
+ ;; Fall back.
+ (comp-tail
+ (make-primcall src 'call-with-current-continuation args)))))
+
+ ;; A hack for variable-set, the opcode for which takes its args
+ ;; reversed, relative to the variable-set! function
+ ((variable-set! ,var ,val)
+ (comp-push val)
+ (comp-push var)
+ (emit-code src (make-glil-call 'variable-set 2))
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+
+ (else
+ (cond
+ ((or (hash-ref *primcall-ops* (cons name (length args)))
+ (hash-ref *primcall-ops* name))
+ => (lambda (op)
+ (for-each comp-push args)
+ (emit-code src (make-glil-call op (length args)))
+ (case (instruction-pushes op)
+ ((0)
+ (case context
+ ((tail push vals) (emit-code #f (make-glil-void))))
+ (maybe-emit-return))
+ ((1)
+ (case context
+ ((drop) (emit-code #f (make-glil-call 'drop 1))))
+ (maybe-emit-return))
+ ((-1)
+ ;; A control instruction, like return/values. Here we
+ ;; just have to hope that the author of the tree-il
+ ;; knew what they were doing.
+ *unspecified*)
+ (else
+ (error "bad primitive op: too many pushes"
+ op (instruction-pushes op))))))
+ (else
+ ;; Fall back to the normal compilation strategy.
+ (comp-tail (make-call src (make-primitive-ref #f name) args)))))))
+
((<conditional> src test consequent alternate)
;; TEST
;; (br-if-not L1)
;; 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))))
;; to have body's return value(s) on the stack while the unwinder runs,
;; then proceed with returning or dropping or what-have-you, interacting
;; with RA and MVRA. What have you, I say.
- ((<dynwind> src body winder unwinder)
+ ((<dynwind> src winder pre body post unwinder)
(comp-push winder)
(comp-push unwinder)
- (comp-drop (make-application src winder '()))
+ (comp-drop pre)
(emit-code #f (make-glil-call 'wind 2))
(case context
(comp-vals body MV)
;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '())))
+ (comp-drop post))
((vals)
(let ((MV (make-label)))
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
;; compile body, discarding values. then unwind...
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
- (comp-drop (make-application src unwinder '()))
+ (comp-drop post)
;; and fall through, or goto RA if there is one.
(if RA
(emit-branch #f 'br RA)))))
(for-each (cut visit <> env) fluids)
(for-each (cut visit <> env) vals)
(visit body env))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(visit winder env)
+ (visit pre env)
(visit body env)
+ (visit post env)
(visit unwinder env))
(($ <dynref> src fluid)
(visit fluid env))
(visit condition env)
(visit subsequent env)
(visit alternate env))
- (($ <application> src proc args)
+ (($ <primcall> src name args)
(cond
+ ((not (symbol? name))
+ (error "expected symbolic operator" exp))
((not (list? args))
(error "expected list of args" args))
(else
- (visit proc env)
(for-each (cut visit <> env) args))))
- (($ <sequence> src exps)
+ (($ <call> src proc args)
(cond
- ((not (list? exps))
- (error "expected list of exps" exp))
- ((null? exps)
- (error "expected more than one exp" exp))
+ ((not (list? args))
+ (error "expected list of args" args))
(else
- (for-each (cut visit <> env) exps))))
+ (visit proc env)
+ (for-each (cut visit <> env) args))))
+ (($ <seq> src head tail)
+ (visit head env)
+ (visit tail env))
(($ <prompt> src tag body handler)
(visit tag env)
(visit body env)
(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.
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(else #f)))
"Discard all but the first value of X."
(if (singly-valued-expression? x)
x
- (make-application (tree-il-src x)
- (make-primitive-ref #f 'values)
- (list x))))
+ (make-primcall (tree-il-src x) 'values (list x))))
;; Peval will do a one-pass analysis on the source program to determine
;; the set of assigned lexicals, and to identify unreferenced and
(%set-operand-residual-value!
op
(match val
- (($ <application> src ($ <primitive-ref> _ 'values) (first))
+ (($ <primcall> src 'values (first))
;; The continuation of a residualized binding does not need the
;; introduced `values' node, so undo the effects of truncation.
first)
(define local-toplevel-env
;; The top-level environment of the module being compiled.
- (match exp
- (($ <toplevel-define> _ name)
- (vhash-consq name #t env))
- (($ <sequence> _ exps)
- (fold (lambda (x r)
- (match x
- (($ <toplevel-define> _ name)
- (vhash-consq name #t r))
- (_ r)))
- env
- exps))
- (_ env)))
+ (let ()
+ (define (env-folder x env)
+ (match x
+ (($ <toplevel-define> _ name)
+ (vhash-consq name #t env))
+ (($ <seq> _ head tail)
+ (env-folder tail (env-folder head env)))
+ (_ env)))
+ (env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
(define* (residualize-lexical op #:optional ctx val)
(log 'residualize op)
(set-operand-residualize?! op #t)
- (if (memq ctx '(value values))
+ (if (eq? ctx 'value)
(set-operand-residual-value! op val))
(make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
(values #t results))))
(lambda _
(values #f '()))))
-
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
- (make-application src (make-primitive-ref src 'values)
- values))))
+ (make-primcall src 'values values))))
(define (residualize-call)
- (make-application src (make-primitive-ref #f name) args))
+ (make-primcall src name args))
(cond
((every const? args)
(let-values (((success? values)
($ <dynset>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
- (($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive? name)))
+ (($ <primcall> src (? singly-valued-primitive? name))
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
;; Statically-known number of values.
- (($ <application> src ($ <primitive-ref> _ 'values) vals)
+ (($ <primcall> src 'values vals)
(and (= (length names) (length vals))
(make-let src names gensyms vals body)))
(($ <conditional>) #f)
;; Bail on other applications.
- (($ <application>) #f)
+ (($ <call>) #f)
+ (($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynwind> src winder body unwinder)
+ (($ <dynwind> src winder pre body post unwinder)
(let ((body (loop body)))
(and body
- (make-dynwind src winder body unwinder))))
+ (make-dynwind src winder pre body post unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
- (($ <sequence> src exps)
- (match exps
- ((head ... tail)
- (let ((tail (loop tail)))
- (and tail
- (make-sequence src (append head (list tail)))))))))))
+ (($ <seq> src head tail)
+ (let ((tail (loop tail)))
+ (and tail (make-seq src head tail)))))))
(define (constant-expression? x)
;; Return true if X is constant, for the purposes of copying or
(($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate)))
- (($ <application> _ ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> _ 'values exps)
(and (not (null? exps))
(every loop exps)))
- (($ <application> _ ($ <primitive-ref> _ name) args)
+ (($ <primcall> _ name args)
(and (effect-free-primitive? name)
(not (constructor-primitive? name))
- (not (accessor-primitive? name))
(types-check? name args)
- (every loop args)))
- (($ <application> _ ($ <lambda> _ _ body) args)
+ (if (accessor-primitive? name)
+ (every const? args)
+ (every loop args))))
+ (($ <call> _ ($ <lambda> _ _ body) args)
(and (loop body) (every loop args)))
- (($ <sequence> _ exps)
- (every loop exps))
+ (($ <seq> _ head tail)
+ (and (loop head) (loop tail)))
(($ <let> _ _ syms vals body)
(and (not (any assigned-lexical? syms))
(every loop vals) (loop body)))
(if (null? effects)
body
(let ((effect-vals (map operand-residual-value effects)))
- (make-sequence #f (reverse (cons body effect-vals)))))))
+ (list->seq #f (reverse (cons body effect-vals)))))))
(if (null? values)
body
(let ((values (reverse values)))
(let ((exp (for-effect exp)))
(if (void? exp)
exp
- (make-sequence src (list exp (make-void #f)))))
+ (make-seq src exp (make-void #f))))
(begin
(set-operand-residualize?! op #t)
(make-lexical-set src name (operand-sym op) (for-value exp))))))
(body (loop body env counter ctx)))
(cond
((const? body)
- (for-tail (make-sequence src (append vals (list body)))))
+ (for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) new))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons new vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
- (make-sequence
+ (list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
(else #f)))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynwind> src winder body unwinder)
- (let ((pre (for-value winder))
- (body (for-tail body))
- (post (for-value unwinder)))
- (cond
- ((not (constant-expression? pre))
- (cond
- ((not (constant-expression? post))
- (let ((pre-sym (gensym "pre-")) (post-sym (gensym "post-")))
- (record-new-temporary! 'pre pre-sym 1)
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(pre post) (list pre-sym post-sym) (list pre post)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (let ((pre-sym (gensym "pre-")))
- (record-new-temporary! 'pre pre-sym 1)
- (make-let src '(pre) (list pre-sym) (list pre)
- (make-dynwind src
- (make-lexical-ref #f 'pre pre-sym)
- body
- post))))))
- ((not (constant-expression? post))
- (let ((post-sym (gensym "post-")))
- (record-new-temporary! 'post post-sym 1)
- (make-let src '(post) (list post-sym) (list post)
- (make-dynwind src
- pre
- body
- (make-lexical-ref #f 'post post-sym)))))
- (else
- (make-dynwind src pre body post)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (make-dynwind src (for-value winder) (for-effect pre)
+ (for-tail body)
+ (for-effect post) (for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
- (if (local-toplevel? name)
- exp
- (let ((exp (resolve-primitives! exp cenv)))
- (if (primitive-ref? exp)
- (for-tail exp)
- exp))))
+ exp)
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
(make-conditional src condition
(for-tail subsequent)
(for-tail alternate)))))
- (($ <application> src
- ($ <primitive-ref> _ '@call-with-values)
+ (($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
- (for-tail (make-let-values src (make-application src producer '())
+ (for-tail (make-let-values src (make-call src producer '())
consumer)))
- (($ <application> src ($ <primitive-ref> _ 'values) exps)
+ (($ <primcall> src 'dynamic-wind (w thunk u))
+ (for-tail
+ (cond
+ ((not (constant-expression? w))
+ (cond
+ ((not (constant-expression? u))
+ (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
+ (record-new-temporary! 'w w-sym 2)
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(w u) (list w-sym u-sym) (list w u)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (let ((w-sym (gensym "w ")))
+ (record-new-temporary! 'w w-sym 2)
+ (make-let src '(w) (list w-sym) (list w)
+ (make-dynwind
+ src
+ (make-lexical-ref #f 'w w-sym)
+ (make-call #f (make-lexical-ref #f 'w w-sym) '())
+ (make-call #f thunk '())
+ (make-call #f u '())
+ u))))))
+ ((not (constant-expression? u))
+ (let ((u-sym (gensym "u ")))
+ (record-new-temporary! 'u u-sym 2)
+ (make-let src '(u) (list u-sym) (list u)
+ (make-dynwind
+ src
+ w
+ (make-call #f w '())
+ (make-call #f thunk '())
+ (make-call #f (make-lexical-ref #f 'u u-sym) '())
+ (make-lexical-ref #f 'u u-sym)))))
+ (else
+ (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
+ (make-call #f u '()) u)))))
+
+ (($ <primcall> src 'values exps)
(cond
((null? exps)
(if (eq? ctx 'effect)
((value test effect) #t)
(else (null? (cdr vals))))
(every singly-valued-expression? vals))
- (for-tail (make-sequence src (append (cdr vals) (list (car vals)))))
- (make-application src (make-primitive-ref #f 'values) vals))))))
- (($ <application> src orig-proc orig-args)
+ (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
+ (make-primcall src 'values vals))))))
+
+ (($ <primcall> src (? constructor-primitive? name) args)
+ (cond
+ ((and (memq ctx '(effect test))
+ (match (cons name args)
+ ((or ('cons _ _)
+ ('list . _)
+ ('vector . _)
+ ('make-prompt-tag)
+ ('make-prompt-tag ($ <const> _ (? string?))))
+ #t)
+ (_ #f)))
+ ;; Some expressions can be folded without visiting the
+ ;; arguments for value.
+ (let ((res (if (eq? ctx 'effect)
+ (make-void #f)
+ (make-const #f #t))))
+ (for-tail (list->seq src (append args (list res))))))
+ (else
+ (match (cons name (map for-value args))
+ (('cons x ($ <const> _ (? (cut eq? <> '()))))
+ (make-primcall src 'list (list x)))
+ (('cons x ($ <primcall> _ 'list elts))
+ (make-primcall src 'list (cons x elts)))
+ ((name . args)
+ (make-primcall src name args))))))
+
+ (($ <primcall> src (? accessor-primitive? name) args)
+ (match (cons name (map for-value args))
+ ;; FIXME: these for-tail recursions could take place outside
+ ;; an effort counter.
+ (('car ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src tail head)))
+ (('cdr ($ <primcall> src 'cons (head tail)))
+ (for-tail (make-seq src head tail)))
+ (('car ($ <primcall> src 'list (head . tail)))
+ (for-tail (list->seq src (append tail (list head)))))
+ (('cdr ($ <primcall> src 'list (head . tail)))
+ (for-tail (make-seq src head (make-primcall #f 'list tail))))
+
+ (('car ($ <const> src (head . tail)))
+ (for-tail (make-const src head)))
+ (('cdr ($ <const> src (head . tail)))
+ (for-tail (make-const src tail)))
+ (((or 'memq 'memv) k ($ <const> _ (elts ...)))
+ ;; FIXME: factor
+ (case ctx
+ ((effect)
+ (for-tail
+ (make-seq src k (make-void #f))))
+ ((test)
+ (cond
+ ((const? k)
+ ;; A shortcut. The `else' case would handle it, but
+ ;; this way is faster.
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (and (member (const-exp k) elts) #t))))
+ ((null? elts)
+ (for-tail
+ (make-seq src k (make-const #f #f))))
+ (else
+ (let ((t (gensym "t "))
+ (eq (if (eq? name 'memq) 'eq? 'eqv?)))
+ (record-new-temporary! 't t (length elts))
+ (for-tail
+ (make-let
+ src (list 't) (list t) (list k)
+ (let lp ((elts elts))
+ (define test
+ (make-primcall #f eq
+ (list (make-lexical-ref #f 't t)
+ (make-const #f (car elts)))))
+ (if (null? (cdr elts))
+ test
+ (make-conditional src test
+ (make-const #f #t)
+ (lp (cdr elts)))))))))))
+ (else
+ (cond
+ ((const? k)
+ (let ((member (case name ((memq) memq) ((memv) memv))))
+ (make-const #f (member (const-exp k) elts))))
+ ((null? elts)
+ (for-tail (make-seq src k (make-const #f #f))))
+ (else
+ (make-primcall src name (list k (make-const #f elts))))))))
+ ((name . args)
+ (fold-constants src name args ctx))))
+
+ (($ <primcall> src (? equality-primitive? name) (a b))
+ (let ((val-a (for-value a))
+ (val-b (for-value b)))
+ (log 'equality-primitive name val-a val-b)
+ (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
+ (eq? (lexical-ref-gensym val-a)
+ (lexical-ref-gensym val-b)))
+ (for-tail (make-const #f #t)))
+ (else
+ (fold-constants src name (list val-a val-b) ctx)))))
+
+ (($ <primcall> src (? effect-free-primitive? name) args)
+ (fold-constants src name (map for-value args) ctx))
+
+ (($ <primcall> src name args)
+ (make-primcall src name (map for-value args)))
+
+ (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let ((proc (visit orig-proc 'operator)))
(match proc
- (($ <primitive-ref> _ (? constructor-primitive? name))
- (cond
- ((and (memq ctx '(effect test))
- (match (cons name orig-args)
- ((or ('cons _ _)
- ('list . _)
- ('vector . _)
- ('make-prompt-tag)
- ('make-prompt-tag ($ <const> _ (? string?))))
- #t)
- (_ #f)))
- ;; Some expressions can be folded without visiting the
- ;; arguments for value.
- (let ((res (if (eq? ctx 'effect)
- (make-void #f)
- (make-const #f #t))))
- (for-tail (make-sequence src (append orig-args (list res))))))
- (else
- (match (cons name (map for-value orig-args))
- (('cons head tail)
- (match tail
- (($ <const> src (? (cut eq? <> '())))
- (make-application src (make-primitive-ref #f 'list)
- (list head)))
- (($ <application> src ($ <primitive-ref> _ 'list) elts)
- (make-application src (make-primitive-ref #f 'list)
- (cons head elts)))
- (_ (make-application src proc (list head tail)))))
- ((_ . args)
- (make-application src proc args))))))
- (($ <primitive-ref> _ (? accessor-primitive? name))
- (match (cons name (map for-value orig-args))
- ;; FIXME: these for-tail recursions could take place outside
- ;; an effort counter.
- (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list tail head))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
- (for-tail (make-sequence src (list head tail))))
- (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence src (append tail (list head)))))
- (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
- (for-tail (make-sequence
- src
- (list head
- (make-application
- src (make-primitive-ref #f 'list) tail)))))
-
- (('car ($ <const> src (head . tail)))
- (for-tail (make-const src head)))
- (('cdr ($ <const> src (head . tail)))
- (for-tail (make-const src tail)))
- (((or 'memq 'memv) k ($ <const> _ (elts ...)))
- ;; FIXME: factor
- (case ctx
- ((effect)
- (for-tail
- (make-sequence src (list k (make-void #f)))))
- ((test)
- (cond
- ((const? k)
- ;; A shortcut. The `else' case would handle it, but
- ;; this way is faster.
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (and (member (const-exp k) elts) #t))))
- ((null? elts)
- (for-tail
- (make-sequence src (list k (make-const #f #f)))))
- (else
- (let ((t (gensym "t-"))
- (eq (if (eq? name 'memq) 'eq? 'eqv?)))
- (record-new-temporary! 't t (length elts))
- (for-tail
- (make-let
- src (list 't) (list t) (list k)
- (let lp ((elts elts))
- (define test
- (make-application
- #f (make-primitive-ref #f eq)
- (list (make-lexical-ref #f 't t)
- (make-const #f (car elts)))))
- (if (null? (cdr elts))
- test
- (make-conditional src test
- (make-const #f #t)
- (lp (cdr elts)))))))))))
- (else
- (cond
- ((const? k)
- (let ((member (case name ((memq) memq) ((memv) memv))))
- (make-const #f (member (const-exp k) elts))))
- ((null? elts)
- (for-tail (make-sequence src (list k (make-const #f #f)))))
- (else
- (make-application src proc (list k (make-const #f elts))))))))
- ((_ . args)
- (or (fold-constants src name args ctx)
- (make-application src proc args)))))
- (($ <primitive-ref> _ (? effect-free-primitive? name))
- (let ((args (map for-value orig-args)))
- (or (fold-constants src name args ctx)
- (make-application src proc args))))
+ (($ <primitive-ref> _ name)
+ (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt #f #f inits gensyms body #f))
;; Simple case: no rest, no keyword arguments.
(cond
((or (< nargs nreq) (> nargs (+ nreq nopt)))
;; An error, or effecting arguments.
- (make-application src (for-call orig-proc)
- (map for-value orig-args)))
+ (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
(let/ec k
(define (abort)
(log 'inline-abort exp)
- (k (make-application src (for-call orig-proc)
- (map for-value orig-args))))
+ (k (make-call src (for-call orig-proc)
+ (map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
(log 'inline-end result exp)
result)))))
(_
- (make-application src (for-call orig-proc)
- (map for-value orig-args))))))
+ (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
new
(loop body env counter ctx)
(and alt (for-tail alt)))))
- (($ <sequence> src exps)
- (let lp ((exps exps) (effects '()))
- (match exps
- ((last)
- (if (null? effects)
- (for-tail last)
- (make-sequence
- src
- (reverse (cons (for-tail last) effects)))))
- ((head . rest)
- (let ((head (for-effect head)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) effects))
- ((void? head)
- (lp rest effects))
- (else
- (lp rest (cons head effects)))))))))
+ (($ <seq> src head tail)
+ (let ((head (for-effect head))
+ (tail (for-tail tail)))
+ (if (void? head)
+ tail
+ (make-seq src
+ (if (and (seq? head)
+ (void? (seq-tail head)))
+ (seq-head head)
+ head)
+ tail))))
(($ <prompt> src tag body handler)
(define (singly-used-definition x)
(cond
(singly-used-definition (visit-operand x counter 'value 10 10))))
(else x)))
(match (singly-used-definition tag)
- (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
- (or () ((? constant-expression?))))
+ (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
;; There is no way that an <abort> could know the tag
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? accessor-primitive?
- singly-valued-primitive?))
+ singly-valued-primitive? equality-primitive?))
(define *interesting-primitive-names*
'(apply @apply
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- vector-ref vector-set!
+ vector-length vector-ref vector-set!
variable-ref variable-set!
variable-bound?
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? struct? string?
- string-length
+ string-length vector-length
;; These all should get expanded out by expand-primitives!.
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+(define *equality-primitives*
+ '(eq? eqv? equal?))
+
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
(define *singly-valued-primitive-table* (make-hash-table))
+(define *equality-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
(for-each (lambda (x)
(hashq-set! *singly-valued-primitive-table* x #t))
*singly-valued-primitives*)
+(for-each (lambda (x)
+ (hashq-set! *equality-primitive-table* x #t))
+ *equality-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
(hashq-ref *effect+exceptions-free-primitive-table* prim))
(define (singly-valued-primitive? prim)
(hashq-ref *singly-valued-primitive-table* prim))
+(define (equality-primitive? prim)
+ (hashq-ref *equality-primitive-table* prim))
(define (resolve-primitives! x mod)
+ (define local-definitions
+ (make-hash-table))
+
+ (let collect-local-definitions ((x x))
+ (record-case x
+ ((<toplevel-define> name)
+ (hashq-set! local-definitions name #t))
+ ((<seq> head tail)
+ (collect-local-definitions head)
+ (collect-local-definitions tail))
+ (else #f)))
+
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
- (and=> (hashq-ref *interesting-primitive-vars*
- (module-variable mod name))
+ (and=> (and (not (hashq-ref local-definitions name))
+ (hashq-ref *interesting-primitive-vars*
+ (module-variable mod name)))
(lambda (name) (make-primitive-ref src name))))
((<module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for
(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)
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
-(hashq-set! *primitive-expand-table*
- 'dynamic-wind
- (case-lambda
- ((src pre thunk post)
- (let ((PRE (gensym "pre-"))
- (THUNK (gensym "thunk-"))
- (POST (gensym "post-")))
- (make-let
- src
- '(pre thunk post)
- (list PRE THUNK POST)
- (list pre thunk post)
- (make-dynwind
- src
- (make-lexical-ref #f 'pre PRE)
- (make-application #f (make-lexical-ref #f 'thunk THUNK) '())
- (make-lexical-ref #f 'post POST)))))
- (else #f)))
-
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
+ (make-call #f (make-lexical-ref #f 'pre PRE) '())
expr
+ (make-call #f (make-lexical-ref #f 'post POST) '())
(make-lexical-ref #f 'post POST)))))))
(hashq-set! *primitive-expand-table*
;; 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!" exps env))))
(define-language tree-il
#:title "Tree Intermediate Language"
;;;;
(define-module (oop goops)
- :use-module (srfi srfi-1)
- :export-syntax (define-class class standard-define-class
- define-generic define-accessor define-method
- define-extended-generic define-extended-generics
- method)
- :export (is-a? class-of
- ensure-metaclass ensure-metaclass-with-supers
- make-class
- make-generic ensure-generic
- make-extended-generic
- make-accessor ensure-accessor
- add-method!
- class-slot-ref class-slot-set! slot-unbound slot-missing
- slot-definition-name slot-definition-options
- slot-definition-allocation
- slot-definition-getter slot-definition-setter
- slot-definition-accessor
- slot-definition-init-value slot-definition-init-form
- slot-definition-init-thunk slot-definition-init-keyword
- slot-init-function class-slot-definition
- method-source
- compute-cpl compute-std-cpl compute-get-n-set compute-slots
- compute-getter-method compute-setter-method
- allocate-instance initialize make-instance make
- no-next-method no-applicable-method no-method
- change-class update-instance-for-different-class
- shallow-clone deep-clone
- class-redefinition
- apply-generic apply-method apply-methods
- compute-applicable-methods %compute-applicable-methods
- method-more-specific? sort-applicable-methods
- class-subclasses class-methods
- goops-error
- min-fixnum max-fixnum
- ;;; *fixme* Should go into goops.c
- instance? slot-ref-using-class
- slot-set-using-class! slot-bound-using-class?
- slot-exists-using-class? slot-ref slot-set! slot-bound?
- class-name class-direct-supers class-direct-subclasses
- class-direct-methods class-direct-slots class-precedence-list
- class-slots
- generic-function-name
- generic-function-methods method-generic-function
- method-specializers method-formals
- primitive-generic-generic enable-primitive-generic!
- method-procedure accessor-method-slot-definition
- slot-exists? make find-method get-keyword)
- :no-backtrace)
+ #:use-module (srfi srfi-1)
+ #:export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ #:export ( ;; The root of everything.
+ <top>
+ <class> <object>
+
+ ;; Slot types.
+ <foreign-slot> <protected-slot> <hidden-slot> <opaque-slot>
+ <read-only-slot> <self-slot> <protected-opaque-slot>
+ <protected-hidden-slot> <protected-read-only-slot>
+ <scm-slot> <int-slot> <float-slot> <double-slot>
+
+ ;; Methods are implementations of generic functions.
+ <method> <accessor-method>
+
+ ;; Applicable objects, either procedures or applicable structs.
+ <procedure-class> <applicable>
+ <procedure> <primitive-generic>
+
+ ;; Applicable structs.
+ <applicable-struct-class>
+ <applicable-struct>
+ <generic> <extended-generic>
+ <generic-with-setter> <extended-generic-with-setter>
+ <accessor> <extended-accessor>
+
+ ;; Types with their own allocated typecodes.
+ <boolean> <char> <list> <pair> <null> <string> <symbol>
+ <vector> <bytevector> <uvec> <foreign> <hashtable>
+ <fluid> <dynamic-state> <frame> <objcode> <vm> <vm-continuation>
+
+ ;; Numbers.
+ <number> <complex> <real> <integer> <fraction>
+
+ ;; Unknown.
+ <unknown>
+
+ ;; Particular SMOB data types. All SMOB types have
+ ;; corresponding classes, which may be obtained via class-of,
+ ;; once you have an instance. Perhaps FIXME to provide a
+ ;; smob-type-name->class procedure.
+ <arbiter> <promise> <thread> <mutex> <condition-variable>
+ <regexp> <hook> <bitvector> <random-state> <async>
+ <directory> <keyword> <array> <character-set>
+ <dynamic-object> <guardian> <macro>
+
+ ;; Modules.
+ <module>
+
+ ;; Ports.
+ <port> <input-port> <output-port> <input-output-port>
+
+ ;; Like SMOB types, all port types have their own classes,
+ ;; which can be accessed via `class-of' once you have an
+ ;; instance. Here we export bindings just for file ports.
+ <file-port>
+ <file-input-port> <file-output-port> <file-input-output-port>
+
+ is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ add-method!
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+
+;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound?
+ class-name class-direct-supers class-direct-subclasses
+ class-direct-methods class-direct-slots class-precedence-list
+ class-slots
+ generic-function-name
+ generic-function-methods method-generic-function
+ method-specializers method-formals
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword)
+ #:no-backtrace)
(define *goops-module* (current-module))
(oop goops compile))
\f
+;; FIXME: deprecate.
(eval-when (eval load compile)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
;;; Handling of duplicate bindings in the module system
;;;
+(define (find-subclass super name)
+ (let lp ((classes (class-direct-subclasses super)))
+ (cond
+ ((null? classes)
+ (error "class not found" name))
+ ((and (slot-bound? (car classes) 'name)
+ (eq? (class-name (car classes)) name))
+ (car classes))
+ (else
+ (lp (cdr classes))))))
+
+;; A record type.
+(define <module> (find-subclass <top> '<module>))
+
(define-method (merge-generics (module <module>)
(name <symbol>)
(int1 <module>)
;; Tell C code that the main bulk of Goops has been loaded
(%goops-loaded)
+
+
+\f
+
+;;;
+;;; {SMOB and port classes}
+;;;
+
+(define <arbiter> (find-subclass <top> '<arbiter>))
+(define <promise> (find-subclass <top> '<promise>))
+(define <thread> (find-subclass <top> '<thread>))
+(define <mutex> (find-subclass <top> '<mutex>))
+(define <condition-variable> (find-subclass <top> '<condition-variable>))
+(define <regexp> (find-subclass <top> '<regexp>))
+(define <hook> (find-subclass <top> '<hook>))
+(define <bitvector> (find-subclass <top> '<bitvector>))
+(define <random-state> (find-subclass <top> '<random-state>))
+(define <async> (find-subclass <top> '<async>))
+(define <directory> (find-subclass <top> '<directory>))
+(define <keyword> (find-subclass <top> '<keyword>))
+(define <array> (find-subclass <top> '<array>))
+(define <character-set> (find-subclass <top> '<character-set>))
+(define <dynamic-object> (find-subclass <top> '<dynamic-object>))
+(define <guardian> (find-subclass <applicable> '<guardian>))
+(define <macro> (find-subclass <top> '<macro>))
+
+(define (define-class-subtree class)
+ (define! (class-name class) class)
+ (for-each define-class-subtree (class-direct-subclasses class)))
+
+(define-class-subtree (find-subclass <port> '<file-port>))
;; The vtable of all condition types.
;; vtable fields: vtable, self, printer
;; user fields: id, parent, all-field-names
- (make-vtable-vtable "prprpr" 0
- (lambda (ct port)
- (if (eq? ct %condition-type-vtable)
- (display "#<condition-type-vtable>")
- (format port "#<condition-type ~a ~a>"
- (condition-type-id ct)
- (number->string (object-address ct)
- 16))))))
+ (let ((s (make-vtable (string-append standard-vtable-fields "prprpr")
+ (lambda (ct port)
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+ (set-struct-vtable-name! s 'condition-type)
+ s))
(define (%make-condition-type layout id parent all-fields)
(let ((struct (make-struct %condition-type-vtable 0
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(lambda (ptr)
- ;; XXX: We can't use `hash-create-handle!' +
- ;; `set-cdr!' here because the former would create a
- ;; weak-cdr pair but the latter wouldn't register a
- ;; disappearing link (see `scm_hash_fn_set_x'.)
(or (hash-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
-/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011
* 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#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);
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));
((@ (system foreign) sizeof) '*))
(define %objcode-cookie-size
- (string-length "GOOF----LE-8-2.0"))
+ (string-length "GOOF----LE-8"))
(define (test-target triplet endian word-size)
(pass-if (format #f "target `~a' honored" triplet)
#f)))
(write-objcode (bytecode->objcode b) p)
(let ((cookie (make-bytevector %objcode-cookie-size))
- (expected (format #f "GOOF----~a-~a-~a"
+ (expected (format #f "GOOF----~a-~a"
(cond ((eq? endian (endianness little))
"LE")
((eq? endian (endianness big))
(else
(error "unknown endianness"
endian)))
- word-size
- (effective-version))))
+ word-size)))
(bytevector-copy! (get-objcode) 0 cookie 0
%objcode-cookie-size)
(string=? (utf8->string cookie) expected)))))))))
(pass-if "opt, eval"
(equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
(current-module)))
- '(2 1 #f)))
-
- (if (include-deprecated-features)
- (pass-if-exception "set-procedure-properties! arity"
- '(misc-error . "arity is a read-only property")
- (set-procedure-properties! (lambda x x) '((arity . 3))))
- #t))
+ '(2 1 #f))))
(define-record-type simple-rtd)
(define-record-type
(specified-rtd specified-rtd-constructor specified-rtd-predicate))
-(define-record-type parent-rtd (fields x y))
+;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
+;; literal.
+(define-record-type *parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
- (parent-rtd (record-type-descriptor parent-rtd)
- (record-constructor-descriptor parent-rtd))
+ (parent-rtd (record-type-descriptor *parent-rtd)
+ (record-constructor-descriptor *parent-rtd))
(fields z))
-(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
(fields (mutable mutable-bar)
(mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
(defined? 'specified-rtd-constructor)))
(pass-if "parent-rtd clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
(pass-if "parent clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd) *parent-rtd))
(pass-if "protocol clause includes specified protocol"
(let ((protocol-record (make-protocol-rtd 1 2)))
(with-latin1-locale body ...)
(begin body ...)))))
+(define char-code-limit 256)
+
;; Since `regexp-quote' uses string ports, and since it is used below
;; with non-ASCII characters, these ports must be Unicode-capable.
(define-syntax with-unicode
(pass-if-syntax-error "(define)"
exception:generic-syncase-error
(eval '(define)
- (interaction-environment)))))
+ (interaction-environment))))
+
+ (pass-if "module scoping"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-1)
+ #:export (define-10))
+ (define-syntax-rule (define-10 name)
+ (begin
+ (define t 10)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-2)
+ #:use-module (top-level-define/module-scoping-1))
+ (define-10 foo)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, same symbolic name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-3))
+ (define a 10)
+ (define-module (top-level-define/module-scoping-4)
+ #:use-module (top-level-define/module-scoping-3))
+ (define a (@@ (top-level-define/module-scoping-3) a))
+ a)
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, introduced names"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-5)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-6)
+ #:use-module (top-level-define/module-scoping-5))
+ (define-constant foo 10)
+ (define-constant bar 20)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, duplicate introduced name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-7)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-8)
+ #:use-module (top-level-define/module-scoping-7))
+ (define-constant foo 10)
+ (define-constant foo 20)
+ (foo))
+ (current-module))
+ 20)))
(with-test-prefix "internal define"
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
+ (syntax-rules ()
((_ in pat)
- (pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
(pass-if-peval in pat
(expand-primitives!
(resolve-primitives!
(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 without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
(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))))
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
+ (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
;; simple bindings -> let
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
- (apply (toplevel foo) (lexical x x1) (lexical y y1)))
+ (call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20)
(bind (x #f 0) (y #f 1))
;; complex bindings -> box and set! within let
(assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (begin (const #f) (const 2)))
+ (primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2))
- (const 3))
+ (primcall values
+ (primcall values (const 1) (const 2))
+ (const 3))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (const 3) (call return/values 2)))
(assert-tree-il->glil
- (apply (primitive +)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall +
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
;; Testing `(values foo)' in push context with RA.
(assert-tree-il->glil without-partial-evaluation
- (apply (primitive cdr)
- (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
- ((lambda ((name . lp))
- (lambda-case ((() #f #f #f () ())
- (apply (toplevel values) (const (one two)))))))
- (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
+ (primcall cdr
+ (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
+ ((lambda ((name . lp))
+ (lambda-case ((() #f #f #f () ())
+ (primcall values (const (one two)))))))
+ (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
(program () (std-prelude 0 0 #f) (label _)
(branch br _) ;; entering the fix, jump to :2
;; :1 body of lp, jump to :3
(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)
(f)))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, let-values (requires primitive expansion for
;; `call-with-values'.)
(let ((x 0))
(+ a b))))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values.
(let ((x 1) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(let ((x (values 1 'a)) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(or (values 1 2) 3)
(const 1))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
;; This must not be a constant.
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
+ (primcall cons (const 0)
+ (primcall cons (const 1)
+ (primcall cons (const 2)
+ (const (3 4 5))))))
;; These two tests doesn't work any more because we changed the way we
;; deal with constants -- now the algorithm will see a construction as
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
+ (primcall list
+ (primcall cons (const 1) (const 1))
+ (primcall cons (const 2) (const 2))
+ (primcall cons (const 3) (const 3))))
;;
;; See above.
#;
r
(loop (1- i) (cons (cons i i) r))))
(let (r) (_)
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
+ ((primcall list
+ (primcall cons (const 3) (const 3))))
(let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
+ ((primcall cons
+ (primcall cons (const 2) (const 2))
+ (lexical r _)))
+ (primcall cons
+ (primcall cons (const 1) (const 1))
+ (lexical r _)))))
;; See above.
(pass-if-peval
(car r)
(loop (1- i) (cons i r))))
(let (r) (_)
- ((apply (primitive list) (const 4)))
+ ((primcall list (const 4)))
(let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
+ ((primcall cons
+ (const 3)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
+ ((primcall cons
+ (const 2)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
+ ((primcall cons
+ (const 1)
+ (lexical r _)))
+ (primcall car
+ (lexical r _)))))))
;; Static sums.
(pass-if-peval
(loop (cdr l) (+ sum (car l)))))
(const 10))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((string->chars
(lambda (s)
(define (char-at n)
(loop (1+ i)))
'())))))
(string->chars "yo"))
- (apply (primitive list) (const #\y) (const #\o)))
+ (primcall list (const #\y) (const #\o)))
(pass-if-peval
;; Primitives in module-refs are resolved (the expansion of `pmatch'
(pmatch '(a b c d)
((a b . _)
#t)))
- (begin
- (apply . _)
- (const #t)))
+ (seq (call . _)
+ (const #t)))
(pass-if-peval
;; Mutability preserved.
((lambda (x y z) (list x y z)) 1 2 3)
- (apply (primitive list) (const 1) (const 2) (const 3)))
+ (primcall list (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
(y (car x)))
(set-car! x 0)
y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
+ (let (x) (_) ((primcall list (const 1)))
+ (let (y) (_) ((primcall car (lexical x _)))
+ (seq
+ (primcall set-car! (lexical x _) (const 0))
(lexical y _)))))
(pass-if-peval
(let ((y (car x)))
(set-car! x 0)
y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
+ (let (y) (_) ((primcall car (toplevel x)))
+ (seq
+ (primcall set-car! (toplevel x) (const 0))
(lexical y _))))
(pass-if-peval
((lambda _
(lambda-case
(((x) _ _ _ _ _)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
+ (call (lexical x _) (lexical x _))))))
+ (call (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
(begin
(define (+ x y) (pk x y))
(+ 1 2))
- (begin
+ (seq
(define +
(lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
+ (call (toplevel pk) (lexical x _) (lexical y _))))))
+ (call (toplevel +) (const 1) (const 2))))
(pass-if-peval
;; First-order, effects preserved.
(let ((x 2))
(do-something!)
x)
- (begin
- (apply (toplevel do-something!))
+ (seq
+ (call (toplevel do-something!))
(const 2)))
(pass-if-peval
;; First order, residual bindings removed.
(let ((x 2) (y 3))
(* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
+ (primcall * (const 5) (toplevel z)))
(pass-if-peval
;; First order, with lambda.
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (apply (primitive +) (lexical x _) (const 9)))))))
+ (primcall + (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
(y 3))
(+ (* x (f x y))
(f something x)))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
+ (primcall +
+ (primcall *
+ (const 2)
+ (primcall + ; (f 2 3)
+ (primcall *
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (primcall +
+ (primcall *
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
(pass-if-peval
;; First order, with lambda inlined & specialized 3 times.
(f -1 y)
(f 2 y)
(f z y)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (primcall
+ +
+ (const 0) ; (f 1 0)
+ (primcall
+ +
+ (seq (toplevel y) (const -1)) ; (f -1 y)
+ (primcall
+ +
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (primcall > (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _))))))))
(pass-if-peval
;; First order, conditional.
(lambda ()
(lambda-case
(((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
+ (call (toplevel display) (lexical x _))))))
(pass-if-peval
;; First order, recursive procedure.
(foo)
x)
(let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
+ (seq
+ (call (toplevel foo))
(lexical x _))))
(pass-if-peval
(lambda (x)
(+ x 1))
'(2 3))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
+ (let (y) (_) ((call (toplevel foo)))
+ (primcall + (lexical y _) (const 7))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (apply (primitive 1+) (toplevel top)))
+ (primcall 1+ (toplevel top)))
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
- (apply (lexical fold _)
+ (call (lexical fold _)
(primitive *)
(toplevel x)
(const 1)
(lambda ()
(lambda-case
(((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
+ (primcall 1- (lexical x2 _))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus,
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2))))))
+ (peval (expand-primitives!
+ (resolve-primitives!
+ (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)
+ (current-module)))))
+ ((primcall cons
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (primcall +
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (primcall +
+ (const 2)
+ (lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
- (begin (apply (toplevel foo!))
- (const 10)))
+ (seq (call (toplevel foo!))
+ (const 10)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
;; Memv with non-constant list. It could fold but doesn't
;; currently.
(memv 1 (list 3 2 1))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
+ (primcall memv
+ (const 1)
+ (primcall list (const 3) (const 2) (const 1))))
(pass-if-peval
;; Memv with non-constant key, constant list, test context
((3 2 1) 'a)
(else 'b))
(let (key) (_) ((toplevel foo))
- (if (if (apply (primitive eqv?) (lexical key _) (const 3))
+ (if (if (primcall eqv? (lexical key _) (const 3))
(const #t)
- (if (apply (primitive eqv?) (lexical key _) (const 2))
+ (if (primcall eqv? (lexical key _) (const 2))
(const #t)
- (apply (primitive eqv?) (lexical key _) (const 1))))
+ (primcall eqv? (lexical key _) (const 1))))
(const a)
(const b))))
(pass-if-peval
- ;; Memv with non-constant key, empty list, test context. Currently
- ;; doesn't fold entirely.
+ ;; Memv with non-constant key, empty list, test context.
(case foo
(() 'a)
(else 'b))
- (begin (toplevel foo) (const b)))
+ (seq (toplevel foo) (const 'b)))
;;
;; Below are cases where constant propagation should bail out.
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
+ ((call (toplevel make-vector) (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
+ (primcall vector-set!
+ (lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
;; Mutable lexical is not propagated.
(lambda ()
v))
(let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ ((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
((() #f #f #f () ())
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
(+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
+ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+ (call (toplevel frob!))
+ (call (toplevel display) (const chbouib))))
+ (let (y) (_) ((primcall * (lexical x _) (const 2)))
+ (primcall +
+ (lexical x _)
+ (primcall + (lexical x _) (lexical y _))))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
(make-list 10)
(list 1 2 3))
(let (x y z) (_ _ _)
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ())))))
+ ((primcall vector (const 1) (const 2) (const 3))
+ (call (toplevel make-list) (const 10))
+ (primcall list (const 1) (const 2) (const 3)))
+ (seq
+ (primcall vector-set!
+ (lexical x _) (const 0) (const 0))
+ (seq (primcall set-car!
+ (lexical y _) (const 0))
+ (primcall set-cdr!
+ (lexical z _) (const ()))))))
(pass-if-peval
(let ((foo top-foo) (bar top-bar))
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
+ (primcall +
+ (primcall + (lexical foo _) (lexical foo _))
+ (primcall + (lexical bar _) (lexical bar _)))))
(pass-if-peval
;; Fresh objects are not turned into constants, nor are constants
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
+ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+ (primcall cons (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
(set! x 3)
x)
(let (x) (_) ((const 2))
- (begin
+ (seq
(set! (lexical x _) (const 3))
(lexical x _))))
(frob f) ; may mutate `x'
x)
(letrec (x) (_) ((const 0))
- (begin
- (apply (toplevel frob) (lambda _ _))
+ (seq
+ (call (toplevel frob) (lambda _ _))
(lexical x _))))
(pass-if-peval
(let ((x (make-foo)))
(frob! x) ; may mutate `x'
x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
+ (let (x) (_) ((call (toplevel make-foo)))
+ (seq
+ (call (toplevel frob!) (lexical x _))
(lexical x _))))
(pass-if-peval
(lambda-case
(((x) #f #f #f () (_))
(if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
+ (call (lexical loop _)
+ (primcall 1-
+ (lexical x _))))))))
+ (call (lexical loop _) (toplevel x))))
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
(if (> y 0)
(loop x (1- y))
(foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
+ (let (x) (_) ((call (toplevel top)))
+ (call (toplevel foo) (lexical x _) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
+ (if (primcall >
+ (lexical y _) (const 0))
_ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
+ (call (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
(and (< x top)
(loop (1+ x))))
(letrec (loop) (_) ((lambda . _))
- (apply (lexical loop _) (const 0))))
+ (call (lexical loop _) (const 0))))
(pass-if-peval
;; This test checks that the `start' binding is indeed residualized.
(let ((here (let ((start pos)) (lambda () start))))
(here)))
(let (pos) (_) ((const 0))
- (begin
+ (seq
(set! (lexical pos _) (const 1))
(let (here) (_) (_)
- (apply (lexical here _))))))
+ (call (lexical here _))))))
(pass-if-peval
;; FIXME: should this one residualize the binding?
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _)))))
+ (call (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
(lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _))))))
+ (call (lexical a _))))))
(let (d)
(_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
+ ((call (toplevel foo) (lexical b _)))
+ (call (lexical c _) (lexical d _)))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
- (apply (primitive cons) (const 1) (const '#nil)))
+ (primcall cons (const 1) (const '#nil)))
(pass-if-peval
;; Constant folding: cons
(pass-if-peval
;; Constant folding: cons
(begin (cons (foo) 2) #f)
- (begin (apply (toplevel foo)) (const #f)))
+ (seq (call (toplevel foo)) (const #f)))
(pass-if-peval
;; Constant folding: cons
(pass-if-peval
;; Constant folding: car+cons, impure
(car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+cons, impure
(cdr (cons (bar) 0))
- (begin (apply (toplevel bar)) (const 0)))
+ (seq (call (toplevel bar)) (const 0)))
(pass-if-peval
;; Constant folding: car+list
(pass-if-peval
;; Constant folding: cdr+list
(cdr (list 1 0))
- (apply (primitive list) (const 0)))
+ (primcall list (const 0)))
(pass-if-peval
;; Constant folding: car+list, impure
(car (list 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+list, impure
(cdr (list (bar) 0))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+ (seq (call (toplevel bar)) (primcall list (const 0))))
+
+ (pass-if-peval
+ ;; Equality primitive: same lexical
+ (let ((x (random))) (eq? x x))
+ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
+ ;; Equality primitive: merge lexical identities
+ (let* ((x (random)) (y x)) (eq? x y))
+ (seq (call (toplevel random)) (const #t)))
(pass-if-peval
- resolve-primitives
;; Non-constant guards get lexical bindings.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical w _)
+ (call (lexical w _))
+ (toplevel bar)
+ (call (lexical u _))
+ (lexical u _))))
(pass-if-peval
- resolve-primitives
;; Constant guards don't need lexical bindings.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
(dynwind
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
+ (toplevel foo)
(toplevel bar)
+ (toplevel baz)
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(const 1))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag
(const 1))
(pass-if-peval
- resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided.
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _)))))
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _)))))
\f
'(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)
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
- (vhash-assq k vh))))
+ (vhash-assoc k vh))))
#t
keys
values)
- (not (vhash-assq 'x vh)))))
+ (not (vhash-assoc 'x vh)))))
(pass-if "vhash as vlist"
(let* ((keys '(a b c d e f g h i))
exception:wrong-type-arg
(list->weak-vector 32)))
- (with-test-prefix "make-weak-key-alist-vector"
+ (with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (make-weak-key-alist-vector 17)
+ (make-weak-key-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-key-alist-vector '(bad arg))))
- (with-test-prefix "make-weak-value-alist-vector"
+ (make-weak-key-hash-table '(bad arg))))
+ (with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (make-weak-value-alist-vector 17)
+ (make-weak-value-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-value-alist-vector '(bad arg))))
+ (make-weak-value-hash-table '(bad arg))))
- (with-test-prefix "make-doubly-weak-alist-vector"
+ (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (make-doubly-weak-alist-vector 17)
+ (make-doubly-weak-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-doubly-weak-alist-vector '(bad arg)))))
+ (make-doubly-weak-hash-table '(bad arg)))))
(or (not value)
(equal? value initial-value)))
- (let ((x (make-weak-key-alist-vector 17))
- (y (make-weak-value-alist-vector 17))
- (z (make-doubly-weak-alist-vector 17))
+ (let ((x (make-weak-key-hash-table 17))
+ (y (make-weak-value-hash-table 17))
+ (z (make-doubly-weak-hash-table 17))
(test-key "foo")
(test-value "bar"))
(with-test-prefix
HCoop / bpt / guile.git / commitdiff