diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e3cf25823..8098b4ffb 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -162,18 +162,10 @@ appropriate module first, though: Returns @code{#t} iff @var{obj} is a compiled procedure. @end deffn -@deffn {Scheme Procedure} program-bytecode program -@deffnx {C Function} scm_program_bytecode (program) -Returns the object code associated with this program, as a -@code{u8vector}. -@end deffn - -@deffn {Scheme Procedure} program-base program -@deffnx {C Function} scm_program_base (program) -Returns the address in memory corresponding to the start of -@var{program}'s object code, as an integer. This is useful mostly when -you map the value of an instruction pointer from the VM to actual -instructions. +@deffn {Scheme Procedure} program-objcode program +@deffnx {C Function} scm_program_objcode (program) +Returns the object code associated with this program. @xref{Bytecode +and Objcode}, for more information. @end deffn @deffn {Scheme Procedure} program-objects program @@ -184,9 +176,9 @@ vector. @xref{VM Programs}, for more information. @deffn {Scheme Procedure} program-module program @deffnx {C Function} scm_program_module (program) -Returns the module that was current when this program was created. -Free variables in this program are looked up with respect to this -module. +Returns the module that was current when this program was created. Can +return @code{#f} if the compiler could determine that this information +was unnecessary. @end deffn @deffn {Scheme Procedure} program-external program @@ -250,9 +242,9 @@ REPL. The only tricky bit is that @var{extp} is a boolean, declaring whether the binding is heap-allocated or not. @xref{VM Concepts}, for more information. -Note that bindings information are stored in a program as part of its -metadata thunk, so including them in the generated object code does -not impose a runtime performance penalty. +Note that bindings information is stored in a program as part of its +metadata thunk, so including it in the generated object code does not +impose a runtime performance penalty. @end deffn @deffn {Scheme Procedure} program-sources program diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 27d8f79c8..0d68abfc6 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -22,9 +22,10 @@ know how to compile your .scm file. @menu * Compiler Tower:: * The Scheme Compiler:: -* GHIL:: +* Tree-IL:: * GLIL:: -* Object Code:: +* Assembly:: +* Bytecode and Objcode:: * Extending the Compiler:: @end menu @@ -52,7 +53,7 @@ They are registered with the @code{define-language} form. @deffn {Scheme Syntax} define-language @ name title version reader printer @ -[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f] +[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] Define a language. This syntax defines a @code{#} object, bound to @var{name} @@ -62,17 +63,15 @@ for Scheme: @example (define-language scheme - #:title "Guile Scheme" - #:version "0.5" - #:reader read - #:read-file read-file - #:compilers `((,ghil . ,compile-ghil)) - #:evaluator (lambda (x module) (primitive-eval x)) - #:printer write) + #:title "Guile Scheme" + #:version "0.5" + #:reader read + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) + #:evaluator (lambda (x module) (primitive-eval x)) + #:printer write) @end example - -In this example, from @code{(language scheme spec)}, @code{read-file} -reads expressions from a port and wraps them in a @code{begin} block. @end deffn The interesting thing about having languages defined this way is that @@ -85,12 +84,12 @@ Guile Scheme interpreter 0.5 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> +tree-il@@(guile-user)> @end example Languages can be looked up by name, as they were above. @@ -128,17 +127,25 @@ The normal tower of languages when compiling Scheme goes like this: @itemize @item Scheme, which we know and love -@item Guile High Intermediate Language (GHIL) +@item Tree Intermediate Language (Tree-IL) @item Guile Low Intermediate Language (GLIL) -@item Object code +@item Assembly +@item Bytecode +@item Objcode @end itemize Object code may be serialized to disk directly, though it has a cookie -and version prepended to the front. But when compiling Scheme at -run time, you want a Scheme value, e.g. a compiled procedure. For this -reason, so as not to break the abstraction, Guile defines a fake -language, @code{value}. Compiling to @code{value} loads the object -code into a procedure, and wakes the sleeping giant. +and version prepended to the front. But when compiling Scheme at run +time, you want a Scheme value: for example, a compiled procedure. For +this reason, so as not to break the abstraction, Guile defines a fake +language at the bottom of the tower: + +@itemize +@item Value +@end itemize + +Compiling to @code{value} loads the object code into a procedure, and +wakes the sleeping giant. Perhaps this strangeness can be explained by example: @code{compile-file} defaults to compiling to object code, because it @@ -156,340 +163,254 @@ different worlds indefinitely, as shown by the following quine: @node The Scheme Compiler @subsection The Scheme Compiler -The job of the Scheme compiler is to expand all macros and to resolve -all symbols to lexical variables. Its target language, GHIL, is fairly -close to Scheme itself, so this process is not very complicated. +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 Scheme compiler is driven by a table of @dfn{translators}, -declared with the @code{define-scheme-translator} form, defined in the -module, @code{(language scheme compile-ghil)}. +The tricky and amusing thing about the Scheme-to-Tree-IL compiler is +that it is completely implemented by the macro expander. Since the +macro expander has to run over all of the source code already in order +to expand macros, it might as well do the analysis at the same time, +producing Tree-IL expressions directly. -@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2... -The best documentation of this form is probably an example. Here is -the translator for @code{if}: +Because this compiler is actually the macro expander, it is +extensible. Any macro which the user writes becomes part of the +compiler. -@example -(define-scheme-translator if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) - ((,test ,then ,else) - (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) -@end example +The Scheme-to-Tree-IL expander may be invoked using the generic +@code{compile} procedure: -The match syntax is from the @code{pmatch} macro, defined in -@code{(system base pmatch)}. The result of a clause should be a valid -GHIL value. If no clause matches, a syntax error is signalled. +@lisp +(compile '(+ 1 2) #:from 'scheme #:to 'tree-il) +@result{} + #< src: #f + proc: #< src: #f name: +> + args: (#< src: #f exp: 1> + #< src: #f exp: 2>)> +@end lisp -In the body of the clauses, the following bindings are introduced: -@itemize -@item @code{e}, the current environment -@item @code{l}, the current source location (or @code{#f}) -@item @code{retrans}, a procedure that may be called to compile -subexpressions -@end itemize +Or, since Tree-IL is so close to Scheme, it is often useful to expand +Scheme to Tree-IL, then translate back to Scheme. For that reason the +expander provides two interfaces. The former is equivalent to calling +@code{(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for +``compile''. With @code{'e} (the default), the result is translated +back to Scheme: -Note that translators are looked up by @emph{value}, not by name. That -is to say, the translator is keyed under the @emph{value} of -@code{if}, which normally prints as @code{#}. -@end deffn +@lisp +(sc-expand '(+ 1 2)) +@result{} (+ 1 2) +(sc-expand '(let ((x 10)) (* x x))) +@result{} (let ((x84 10)) (* x84 x84)) +@end lisp -Users can extend the compiler by defining new translators. -Additionally, some forms can be inlined directly to -instructions -- @xref{Inlined Scheme Instructions}, for a list. The -actual inliners are defined in @code{(language scheme inline)}: +The second example shows that as part of its job, the macro expander +renames lexically-bound variables. The original names are preserved +when compiling to Tree-IL, but can't be represented in Scheme: a +lexical binding only has one name. It is for this reason that the +@emph{native} output of the expander is @emph{not} Scheme. There's too +much information we would lose if we translated to Scheme directly: +lexical variable names, source locations, and module hygiene. -@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2... -Defines an inliner for @code{head}. As in -@code{define-scheme-translator}, inliners are keyed by value and not -by name. +Note however that @code{sc-expand} does not have the same signature as +@code{compile-tree-il}. @code{compile-tree-il} is a small wrapper +around @code{sc-expand}, to make it conform to the general form of +compiler procedures in Guile's language tower. -Expressions are matched on their arities. For example: +Compiler procedures take two arguments, an expression and an +environment. They return three values: the compiled expression, the +corresponding environment for the target language, and a +``continuation environment''. The compiled expression and environment +will serve as input to the next language's compiler. The +``continuation environment'' can be used to compile another expression +from the same source language within the same module. -@example -(define-inline eq? - (x y) (eq? x y)) -@end example +For example, you might compile the expression, @code{(define-module +(foo))}. This will result in a Tree-IL expression and environment. But +if you compiled a second expression, you would want to take into +account the compile-time effect of compiling the previous expression, +which puts the user in the @code{(foo)} module. That is purpose of the +``continuation environment''; you would pass it as the environment +when compiling the subsequent expression. -This inlines calls to the Scheme procedure, @code{eq?}, to the -instruction @code{eq?}. - -A more complicated example would be: - -@example -(define-inline + - () 0 - (x) x - (x y) (add x y) - (x y . rest) (add x (+ y . rest))) -@end example -@end deffn - -Compilers take two arguments, an expression and an environment, and -return two values as well: an expression in the target language, and -an environment suitable for the target language. The format of the -environment is language-dependent. - -For Scheme, an environment may be one of three things: +For Scheme, an environment may be one of two things: @itemize @item @code{#f}, in which case compilation is performed in the context -of the current module; -@item a module, which specifies the context of the compilation; or -@item a @dfn{compile environment}, which specifies lexical variables -as well. +of the current module; or +@item a module, which specifies the context of the compilation. @end itemize -The format of a compile environment for scheme is @code{(@var{module} -@var{lexicals} . @var{externals})}, though users are strongly -discouraged from constructing these environments themselves. Instead, -if you need this functionality -- as in GOOPS' dynamic method compiler --- capture an environment with @code{compile-time-environment}, then -pass that environment to @code{compile}. +@node Tree-IL +@subsection Tree-IL -@deffn {Scheme Procedure} compile-time-environment -A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -@code{#f} if called from the interpreter. -@end deffn - -@node GHIL -@subsection GHIL - -Guile High Intermediate Language (GHIL) is a structured intermediate +Tree Intermediate Language (Tree-IL) is a structured intermediate language that is close in expressive power to Scheme. It is an expanded, pre-analyzed Scheme. -GHIL is ``structured'' in the sense that its representation is based -on records, not S-expressions. This gives a rigidity to the language -that ensures that compiling to a lower-level language only requires a -limited set of transformations. Practically speaking, consider the -GHIL type, @code{}, which has fields named @code{env}, -@code{loc}, and @code{exp}. Instances of this type are records created -via @code{make-ghil-quote}, and whose fields are accessed as -@code{ghil-quote-env}, @code{ghil-quote-loc}, and -@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}. -@xref{Records}, for more information on records. +Tree-IL is ``structured'' in the sense that its representation is +based on records, not S-expressions. This gives a rigidity to the +language that ensures that compiling to a lower-level language only +requires a limited set of transformations. Practically speaking, +consider the Tree-IL type, @code{}, which has two fields, +@code{src} and @code{exp}. Instances of this type are records created +via @code{make-const}, and whose fields are accessed as +@code{const-src}, and @code{const-exp}. There is also a predicate, +@code{const?}. @xref{Records}, for more information on records. -Expressions of GHIL name their environments explicitly, and all -variables are referenced by identity in addition to by name. -@code{(language ghil)} defines a number of routines to deal explicitly -with variables and environments: +@c alpha renaming -@deftp {Scheme Variable} [table='()] -A toplevel environment. The @var{table} holds all toplevel variables -that have been resolved in this environment. -@end deftp -@deftp {Scheme Variable} parent [table='()] [variables='()] -A lexical environment. @var{parent} will be the enclosing lexical -environment, or a toplevel environment. @var{table} holds an alist -mapping symbols to variables bound in this environment, while -@var{variables} holds a cumulative list of all variables ever defined -in this environment. +All Tree-IL types have a @code{src} slot, which holds source location +information for the expression. This information, if present, will be +residualized into the compiled object code, allowing backtraces to +show source information. The format of @code{src} is the same as that +returned by Guile's @code{source-properties} function. @xref{Source +Properties}, for more information. -Lexical environments correspond to procedures. Bindings introduced -e.g. by Scheme's @code{let} add to the bindings in a lexical -environment. An example of a case in which a variable might be in -@var{variables} but not in @var{table} would be a variable that is in -the same procedure, but is out of scope. -@end deftp -@deftp {Scheme Variable} env name kind [index=#f] -A variable. @var{kind} is one of @code{argument}, @code{local}, -@code{external}, @code{toplevel}, @code{public}, or @code{private}; -see the procedures below for more information. @var{index} is used in -compilation. -@end deftp - -@deffn {Scheme Procedure} ghil-var-is-bound? env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it or @code{#f} if none is found. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-ref! env sym -Recursively look up a variable named @var{sym} in @var{env}, and -return it. If the symbol was not bound, return a new toplevel -variable. -@end deffn -@deffn {Scheme Procedure} ghil-var-for-set! env sym -Like @code{ghil-var-for-ref!}, except that the returned variable will -be marked as @code{external}. @xref{Variables and the VM}. -@end deffn -@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym -Return an existing or new toplevel variable named @var{sym}. -@var{toplevel-env} must be a toplevel environment. -@end deffn -@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface? -Return a variable that will be resolved at run-time with respect to a -specific module named @var{modname}. If @var{interface?} is true, the -variable will be of type @code{public}, otherwise @code{private}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-environment env syms func -Bind @var{syms} to fresh variables within a new lexical environment -whose parent is @var{env}, and call @var{func} as @code{(@var{func} -@var{new-env} @var{new-vars})}. -@end deffn -@deffn {Scheme Procedure} call-with-ghil-bindings env syms func -Like @code{call-with-ghil-environment}, except the existing -environment @var{env} is re-used. For that reason, @var{func} is -invoked as @code{(@var{func} @var{new-vars})} -@end deffn - -In the aforementioned @code{} type, the @var{env} slot -holds a pointer to the environment in which the expression occurs. The -@var{loc} slot holds source location information, so that errors -corresponding to this expression can be mapped back to the initial -expression in the higher-level language, e.g. Scheme. @xref{Compiled -Procedures}, for more information on source location objects. - -GHIL also has a declarative serialization format, which makes writing -and reading it a tractable problem for the human mind. Since all GHIL -language constructs contain @code{env} and @code{loc} pointers, they -are left out of the serialization. (Serializing @code{env} structures -would be difficult, as they are often circular.) What is left is the -type of expression, and the remaining slots defined in the expression -type. - -For example, an S-expression representation of the @code{} -expression would be: +Although Tree-IL objects are represented internally using records, +there is also an equivalent S-expression external representation for +each kind of Tree-IL. For example, an the S-expression representation +of @code{#} expression would be: @example -(quote 3) +(const 3) @end example -It's deceptively like Scheme. The general rule is, for a type defined -as @code{ env loc @var{slot1} @var{slot2}...}, the -S-expression representation will be @code{(@var{foo} @var{slot1} -@var{slot2}...)}. Users may program with this format directly at the -REPL: +Users may program with this format directly at the REPL: @example -scheme@@(guile-user)> ,language ghil -Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0 +scheme@@(guile-user)> ,language tree-il +Tree Intermediate Language interpreter 1.0 on Guile 1.9.0 Copyright (C) 2001-2008 Free Software Foundation, Inc. Enter `,help' for help. -ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10)) +tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10)) @result{} 42 @end example -For convenience, some slots are serialized as rest arguments; those -are noted below. The other caveat is that variables are serialized as -their names only, and not their identities. +The @code{src} fields are left out of the external representation. -@deftp {Scheme Variable} env loc -The unspecified value. +@deftp {Scheme Variable} src +@deftpx {External Representation} (void) +An empty expression. In practice, equivalent to Scheme's @code{(if #f +#f)}. @end deftp -@deftp {Scheme Variable} env loc exp -A quoted expression. +@deftp {Scheme Variable} src exp +@deftpx {External Representation} (const @var{exp}) +A constant. +@end deftp +@deftp {Scheme Variable} src name +@deftpx {External Representation} (primitive @var{name}) +A reference to a ``primitive''. A primitive is a procedure that, when +compiled, may be open-coded. For example, @code{cons} is usually +recognized as a primitive, so that it compiles down to a single +instruction. -Note that unlike in Scheme, there are no self-quoting expressions; all -constants must come from @code{quote} expressions. +Compilation of Tree-IL usually begins with a pass that resolves some +@code{} and @code{} expressions to +@code{} expressions. The actual compilation pass +has special cases for applications of certain primitives, like +@code{apply} or @code{cons}. @end deftp -@deftp {Scheme Variable} env loc exp -A quasiquoted expression. The expression is treated as a constant, -except for embedded @code{unquote} and @code{unquote-splicing} forms. +@deftp {Scheme Variable} src name gensym +@deftpx {External Representation} (lexical @var{name} @var{gensym}) +A reference to a lexically-bound variable. The @var{name} is the +original name of the variable in the source program. @var{gensym} is a +unique identifier for this variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote}; only valid within a quasiquote. +@deftp {Scheme Variable} src name gensym exp +@deftpx {External Representation} (set! (lexical @var{name} @var{gensym}) @var{exp}) +Sets a lexically-bound variable. @end deftp -@deftp {Scheme Variable} env loc exp -Like Scheme's @code{unquote-splicing}; only valid within a quasiquote. +@deftp {Scheme Variable} src mod name public? +@deftpx {External Representation} (@@ @var{mod} @var{name}) +@deftpx {External Representation} (@@@@ @var{mod} @var{name}) +A reference to a variable in a specific module. @var{mod} should be +the name of the module, e.g. @code{(guile-user)}. + +If @var{public?} is true, the variable named @var{name} will be looked +up in @var{mod}'s public interface, and serialized with @code{@@}; +otherwise it will be looked up among the module's private bindings, +and is serialized with @code{@@@@}. @end deftp -@deftp {Scheme Variable} env loc var -A variable reference. Note that for purposes of serialization, -@var{var} is serialized as its name, as a symbol. +@deftp {Scheme Variable} src mod name public? exp +@deftpx {External Representation} (set! (@@ @var{mod} @var{name}) @var{exp}) +@deftpx {External Representation} (set! (@@@@ @var{mod} @var{name}) @var{exp}) +Sets a variable in a specific module. @end deftp -@deftp {Scheme Variable} env loc var val -A variable mutation. @var{var} is serialized as a symbol. +@deftp {Scheme Variable} src name +@deftpx {External Representation} (toplevel @var{name}) +References a variable from the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc var val -A toplevel variable definition. See @code{ghil-var-define!}. +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (set! (toplevel @var{name}) @var{exp}) +Sets a variable in the current procedure's module. @end deftp -@deftp {Scheme Variable} env loc test then else +@deftp {Scheme Variable} src name exp +@deftpx {External Representation} (define (toplevel @var{name}) @var{exp}) +Defines a new top-level variable in the current procedure's module. +@end deftp +@deftp {Scheme Variable} src test then else +@deftpx {External Representation} (if @var{test} @var{then} @var{else}) A conditional. Note that @var{else} is not optional. @end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{and}. -@end deftp -@deftp {Scheme Variable} env loc . exps -Like Scheme's @code{or}. -@end deftp -@deftp {Scheme Variable} env loc . body -Like Scheme's @code{begin}. -@end deftp -@deftp {Scheme Variable} env loc vars exprs . body -Like a deconstructed @code{let}: each element of @var{vars} will be -bound to the corresponding GHIL expression in @var{exprs}. - -Note that for purposes of the serialization format, @var{exprs} are -evaluated before the new bindings are added to the environment. For -@code{letrec} semantics, there also exists a @code{bindrec} parse -flavor. This is useful for writing GHIL at the REPL, but the -serializer does not currently have the cleverness needed to determine -whether a @code{} has @code{let} or @code{letrec} -semantics, and thus only serializes @code{} as @code{bind}. -@end deftp -@deftp {Scheme Variable} env loc vars rest producer . body -Like Scheme's @code{receive} -- binds the values returned by -applying @code{producer}, which should be a thunk, to the -@code{lambda}-like bindings described by @var{vars} and @var{rest}. -@end deftp -@deftp {Scheme Variable} env loc vars rest meta . body -A closure. @var{vars} is the argument list, serialized as a list of -symbols. @var{rest} is a boolean, which is @code{#t} iff the last -argument is a rest argument. @var{meta} is an association list of -properties. The actual @var{body} should be a list of GHIL -expressions. -@end deftp -@deftp {Scheme Variable} env loc proc . args +@deftp {Scheme Variable} src proc args +@deftpx {External Representation} (apply @var{proc} . @var{args}) A procedure call. @end deftp -@deftp {Scheme Variable} env loc producer consumer -Like Scheme's @code{call-with-values}. +@deftp {Scheme Variable} src exps +@deftpx {External Representation} (begin . @var{exps}) +Like Scheme's @code{begin}. @end deftp -@deftp {Scheme Variable} env loc op . args -An inlined VM instruction. @var{op} should be the instruction name as -a symbol, and @var{args} should be its arguments, as GHIL expressions. +@deftp {Scheme Variable} src names vars meta body +@deftpx {External Representation} (lambda @var{names} @var{vars} @var{meta} @var{body}) +A closure. @var{names} is original binding form, as given in the +source code, which may be an improper list. @var{vars} are gensyms +corresponding to the @var{names}. @var{meta} is an association list of +properties. The actual @var{body} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -Like Scheme's @code{values}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (let @var{names} @var{vars} @var{vals} @var{exp}) +Lexical binding, like Scheme's @code{let}. @var{names} are the +original binding names, @var{vars} are gensyms corresponding to the +@var{names}, and @var{vals} are Tree-IL expressions for the values. +@var{exp} is a single Tree-IL expression. @end deftp -@deftp {Scheme Variable} env loc . values -@var{values} are as in the Scheme expression, @code{(apply values . -@var{vals})}. -@end deftp -@deftp {Scheme Variable} env loc -Produces, at run-time, a reification of the environment at compile -time. Used in the implementation of Scheme's -@code{compile-time-environment}. +@deftp {Scheme Variable} src names vars vals exp +@deftpx {External Representation} (letrec @var{names} @var{vars} @var{vals} @var{exp}) +A version of @code{} that creates recursive bindings, like +Scheme's @code{letrec}. @end deftp -GHIL implements a compiler to GLIL that recursively traverses GHIL -expressions, writing out GLIL expressions into a linear list. The -compiler also keeps some state as to whether the current expression is -in tail context, and whether its value will be used in future -computations. This state allows the compiler not to emit code for -constant expressions that will not be used (e.g. docstrings), and to -perform tail calls when in tail position. +@c FIXME -- need to revive this one +@c @deftp {Scheme Variable} src vars rest producer . body +@c Like Scheme's @code{receive} -- binds the values returned by +@c applying @code{producer}, which should be a thunk, to the +@c @code{lambda}-like bindings described by @var{vars} and @var{rest}. +@c @end deftp -Just as the Scheme to GHIL compiler introduced new hidden state---the -environment---the GHIL to GLIL compiler introduces more state, the -stack. While not represented explicitly, the stack is present in the -compilation of each GHIL expression: compiling a GHIL expression -should leave the run-time value stack in the same state. For example, -if the intermediate value stack has two elements before evaluating an -@code{if} expression, it should have two elements after that -expression. +Tree-IL implements a compiler to GLIL that recursively traverses +Tree-IL expressions, writing out GLIL expressions into a linear list. +The compiler also keeps some state as to whether the current +expression is in tail context, and whether its value will be used in +future computations. This state allows the compiler not to emit code +for constant expressions that will not be used (e.g. docstrings), and +to perform tail calls when in tail position. + +In the future, there will be a pass at the beginning of the +Tree-IL->GLIL compilation step to perform inlining, copy propagation, +dead code elimination, and constant folding. Interested readers are encouraged to read the implementation in -@code{(language ghil compile-glil)} for more details. +@code{(language tree-il compile-glil)} for more details. @node GLIL @subsection GLIL Guile Low Intermediate Language (GLIL) is a structured intermediate -language whose expressions closely mirror the functionality of Guile's -VM instruction set. +language whose expressions more closely approximate Guile's VM +instruction set. Its expression types are defined in @code{(language glil)}, and as with GHIL, some of its fields parse as rest arguments. @@ -499,8 +420,8 @@ A unit of code that at run-time will correspond to a compiled procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts} collectively define the program's arity; see @ref{Compiled Procedures}, for more information. @var{meta} should be an alist of -properties, as in @code{}. @var{body} is a list of GLIL -expressions. +properties, as in Tree IL's @code{}. @var{body} is a list of +GLIL expressions. @end deftp @deftp {Scheme Variable} . vars An advisory expression that notes a liveness extent for a set of @@ -534,24 +455,23 @@ offset within a VM program. @end deftp @deftp {Scheme Variable} loc Records source information for the preceding expression. @var{loc} -should be a vector, @code{#(@var{line} @var{column} @var{filename})}. +should be an association list of containing @code{line} @code{column}, +and @code{filename} keys, e.g. as returned by +@code{source-properties}. @end deftp @deftp {Scheme Variable} Pushes the unspecified value on the stack. @end deftp @deftp {Scheme Variable} obj Pushes a constant value onto the stack. @var{obj} must be a number, -string, symbol, keyword, boolean, character, or a pair or vector or -list thereof, or the empty list. -@end deftp -@deftp {Scheme Variable} op index -Accesses an argument on the stack. If @var{op} is @code{ref}, the -argument is pushed onto the stack; if it is @code{set}, the argument -is set from the top value on the stack, which is popped off. +string, symbol, keyword, boolean, character, the empty list, or a pair +or vector of constants. @end deftp @deftp {Scheme Variable} op index -Like @code{}, but for local variables. @xref{Stack -Layout}, for more information. +Accesses a lexically bound variable from the stack. If @var{op} is +@code{ref}, the value is pushed onto the stack; if it is @code{set}, +the variable is set from the top value on the stack, which is popped +off. @xref{Stack Layout}, for more information. @end deftp @deftp {Scheme Variable} op depth index Accesses a heap-allocated variable, addressed by @var{depth}, the nth @@ -563,8 +483,8 @@ Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set}, or @code{define}. @end deftp @deftp {Scheme Variable} op mod name public? -Accesses a variable within a specific module. See -@code{ghil-var-at-module!}, for more information. +Accesses a variable within a specific module. See Tree-IL's +@code{}, for more information. @end deftp @deftp {Scheme Variable} label Creates a new label. @var{label} can be any Scheme value, and should @@ -607,23 +527,143 @@ Just as in all of Guile's compilers, an environment is passed to the GLIL-to-object code compiler, and one is returned as well, along with the object code. -@node Object Code -@subsection Object Code +@node Assembly +@subsection Assembly -Object code is the serialization of the raw instruction stream of a -program, ready for interpretation by the VM. Procedures related to -object code are defined in the @code{(system vm objcode)} module. +Assembly is an S-expression-based, human-readable representation of +the actual bytecodes that will be emitted for the VM. As such, it is a +useful intermediate language both for compilation and for +decompilation. + +Besides the fact that it is not a record-based language, assembly +differs from GLIL in four main ways: + +@itemize +@item Labels have been resolved to byte offsets in the program. +@item Constants inside procedures have either been expressed as inline +instructions, and possibly cached in object arrays. +@item Procedures with metadata (source location information, liveness +extents, procedure names, generic properties, etc) have had their +metadata serialized out to thunks. +@item All expressions correspond directly to VM instructions -- i.e., +there is no @code{} which can be a ref or a set. +@end itemize + +Assembly is isomorphic to the bytecode that it compiles to. You can +compile to bytecode, then decompile back to assembly, and you have the +same assembly code. + +The general form of assembly instructions is the following: + +@lisp +(@var{inst} @var{arg} ...) +@end lisp + +The @var{inst} names a VM instruction, and its @var{arg}s will be +embedded in the instruction stream. The easiest way to see assembly is +to play around with it at the REPL, as can be seen in this annotated +example: + +@example +scheme@@(guile-user)> (compile '(lambda (x) (+ x x)) #:to 'assembly) +(load-program 0 0 0 0 + () ; Labels + 60 ; Length + #f ; Metadata + (make-false) ; object table for the returned lambda + (nop) + (nop) ; Alignment. Since assembly has already resolved its labels + (nop) ; to offsets, and programs must be 8-byte aligned since their + (nop) ; object code is mmap'd directly to structures, assembly + (nop) ; has to have the alignment embedded in it. + (nop) + (load-program 1 0 0 0 + () + 6 + ; This is the metadata thunk for the returned procedure. + (load-program 0 0 0 0 () 21 #f + (load-symbol "x") ; Name and liveness extent for @code{x}. + (make-false) + (make-int8:0) ; Some instruction+arg combinations + (make-int8:0) ; have abbreviations. + (make-int8 6) + (list 0 5) + (list 0 1) + (make-eol) + (list 0 2) + (return)) + ; And here, the actual code. + (local-ref 0) + (local-ref 0) + (add) + (return)) + ; Return our new procedure. + (return)) +@end example + +Of course you can switch the REPL to assembly and enter in assembly +S-expressions directly, like with other languages, though it is more +difficult, given that the length fields have to be correct. + +@node Bytecode and Objcode +@subsection Bytecode and Objcode + +Finally, the raw bytes. There are actually two different ``languages'' +here, corresponding to two different ways to represent the bytes. + +``Bytecode'' represents code as uniform byte vectors, useful for +structuring and destructuring code on the Scheme level. Bytecode is +the next step down from assembly: + +@example +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly) +@result{} (load-program 0 0 0 0 () 6 #f + (make-int8 32) (make-int8 10) (add) (return)) +scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode) +@result{} #u8(0 0 0 0 6 0 0 0 0 0 0 0 10 32 10 10 100 48) +@end example + +``Objcode'' is bytecode, but mapped directly to a C structure, +@code{struct scm_objcode}: + +@example +struct scm_objcode @{ + scm_t_uint8 nargs; + scm_t_uint8 nrest; + scm_t_uint8 nlocs; + scm_t_uint8 nexts; + scm_t_uint32 len; + scm_t_uint32 metalen; + scm_t_uint8 base[0]; +@}; +@end example + +As one might imagine, objcode imposes a minimum length on the +bytecode. Also, the multibyte fields are in native endianness, which +makes objcode (and bytecode) system-dependent. Indeed, in the short +example above, all but the last 5 bytes were the program's header. + +Objcode also has a couple of important efficiency hacks. First, +objcode may be mapped directly from disk, allowing compiled code to be +loaded quickly, often from the system's disk cache, and shared among +multiple processes. Secondly, objcode may be embedded in other +objcode, allowing procedures to have the text of other procedures +inlined into their bodies, without the need for separate allocation of +the code. Of course, the objcode object itself does need to be +allocated. + +Procedures related to objcode are defined in the @code{(system vm +objcode)} module. @deffn {Scheme Procedure} objcode? obj @deffnx {C Function} scm_objcode_p (obj) Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise. @end deffn -@deffn {Scheme Procedure} bytecode->objcode bytecode nlocs nexts -@deffnx {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts) +@deffn {Scheme Procedure} bytecode->objcode bytecode +@deffnx {C Function} scm_bytecode_to_objcode (bytecode,) Makes a bytecode object from @var{bytecode}, which should be a -@code{u8vector}. @var{nlocs} and @var{nexts} denote the number of -stack and heap variables to reserve when this objcode is executed. +@code{u8vector}. @end deffn @deffn {Scheme Variable} load-objcode file @@ -631,21 +671,28 @@ stack and heap variables to reserve when this objcode is executed. Load object code from a file named @var{file}. The file will be mapped into memory via @code{mmap}, so this is a very fast operation. -On disk, object code has an eight-byte cookie prepended to it, so that -we will not execute arbitrary garbage. In addition, two more bytes are -reserved for @var{nlocs} and @var{nexts}. +On disk, object code has an eight-byte cookie prepended to it, to +prevent accidental loading of arbitrary garbage. +@end deffn + +@deffn {Scheme Variable} write-objcode objcode file +@deffnx {C Function} scm_write_objcode (objcode) +Write object code out to a file, prepending the eight-byte cookie. @end deffn @deffn {Scheme Variable} objcode->u8vector objcode @deffnx {C Function} scm_objcode_to_u8vector (objcode) -Copy object code out to a @code{u8vector} for analysis by Scheme. The -ten-byte header is included. +Copy object code out to a @code{u8vector} for analysis by Scheme. @end deffn -@deffn {Scheme Variable} objcode->program objcode [external='()] -@deffnx {C Function} scm_objcode_to_program (objcode, external) +The following procedure is actually in @code{(system vm program)}, but +we'll mention it here: + +@deffn {Scheme Variable} make-program objcode objtable [external='()] +@deffnx {C Function} scm_make_program (objcode, objtable, external) Load up object code into a Scheme program. The resulting program will -be a thunk that captures closure variables from @var{external}. +have @var{objtable} as its object table, which should be a vector or +@code{#f}, and will capture the closure variables from @var{external}. @end deffn Object code from a file may be disassembled at the REPL via the @@ -689,7 +736,7 @@ fruit, running programs of interest under a system-level profiler and determining which improvements would give the most bang for the buck. There are many well-known efficiency hacks in the literature: Dybvig's letrec optimization, individual boxing of heap-allocated values (and -then store the boxes on the stack directory), optimized case-lambda +then store the boxes on the stack directly), optimized case-lambda expressions, stack underflow and overflow handlers, etc. Highly recommended papers: Dybvig's HOCS, Ghuloum's compiler paper. diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 042645200..49b420c50 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -111,7 +111,7 @@ The registers that a VM has are as follows: In other architectures, the instruction pointer is sometimes called the ``program counter'' (pc). This set of registers is pretty typical for stack machines; their exact meanings in the context of Guile's VM -is described in the next section. +are described in the next section. A virtual machine executes by loading a compiled procedure, and executing the object code associated with that procedure. Of course, @@ -119,14 +119,17 @@ that procedure may call other procedures, tail-call others, ad infinitum---indeed, within a guile whose modules have all been compiled to object code, one might never leave the virtual machine. -@c wingo: I wish the following were true, but currently we just use -@c the one engine. This kind of thing is possible tho. +@c wingo: The following is true, but I don't know in what context to +@c describe it. A documentation FIXME. @c A VM may have one of three engines: reckless, regular, or debugging. @c Reckless engine is fastest but dangerous. Regular engine is normally @c fail-safe and reasonably fast. Debugging engine is safest and @c functional but very slow. +@c (Actually we have just a regular and a debugging engine; normally +@c we use the latter, it's almost as fast as the ``regular'' engine.) + @node Stack Layout @subsection Stack Layout @@ -174,7 +177,7 @@ The structure of the fixed part of an application frame is as follows: In the above drawing, the stack grows upward. The intermediate values stored in the application of this frame are stored above @code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the -@code{struct scm_program*} data associated with the program at +@code{struct scm_objcode} data associated with the program at @code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the compiled procedure, which will be discussed later. @@ -226,7 +229,7 @@ programs are implemented, @xref{VM Programs}. @node Variables and the VM @subsection Variables and the VM -Let's think about the following Scheme code as an example: +Consider the following Scheme code as an example: @example (define (foo a) @@ -236,22 +239,15 @@ Let's think about the following Scheme code as an example: Within the lambda expression, "foo" is a top-level variable, "a" is a lexically captured variable, and "b" is a local variable. -That is to say: @code{b} may safely be allocated on the stack, as -there is no enclosed procedure that references it, nor is it ever -mutated. +@code{b} may safely be allocated on the stack, as there is no enclosed +procedure that references it, nor is it ever mutated. @code{a}, on the other hand, is referenced by an enclosed procedure, that of the lambda. Thus it must be allocated on the heap, as it may (and will) outlive the dynamic extent of the invocation of @code{foo}. -@code{foo} is a toplevel variable, as mandated by Scheme's semantics: - -@example - (define proc (foo 'bar)) ; assuming prev. definition of @code{foo} - (define foo 42) ; redefinition - (proc 'baz) - @result{} (42 bar baz) -@end example +@code{foo} is a top-level variable, because it names the procedure +@code{foo}, which is here defined at the top-level. Note that variables that are mutated (via @code{set!}) must be allocated on the heap, even if they are local variables. This is @@ -276,6 +272,7 @@ You can pick apart these pieces with the accessors in @code{(system vm program)}. @xref{Compiled Procedures}, for a full API reference. @cindex object table +@cindex object array The object array of a compiled procedure, also known as the @dfn{object table}, holds all Scheme objects whose values are known not to change across invocations of the procedure: constant strings, @@ -293,31 +290,27 @@ instruction, which uses the object vector, and are almost as fast as local variable references. We can see how these concepts tie together by disassembling the -@code{foo} function to see what is going on: +@code{foo} function we defined earlier to see what is going on: @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo Disassembly of #: -Bytecode: - 0 (local-ref 0) ;; `a' (arg) 2 (external-set 0) ;; `a' (arg) - 4 (object-ref 0) ;; # - 6 (make-closure) at (unknown file):0:16 + 4 (object-ref 1) ;; #:0:16 (b)> + 6 (make-closure) 7 (return) ---------------------------------------- -Disassembly of #: +Disassembly of #:0:16 (b)>: -Bytecode: - - 0 (toplevel-ref 0) ;; `list' - 2 (toplevel-ref 1) ;; `foo' - 4 (external-ref 0) ;; (closure variable) - 6 (local-ref 0) ;; `b' (arg) - 8 (goto/args 3) at (unknown file):0:28 + 0 (toplevel-ref 1) ;; `foo' + 2 (external-ref 0) ;; (closure variable) + 4 (local-ref 0) ;; `b' (arg) + 6 (list 0 3) ;; 3 elements at (unknown file):0:28 + 9 (return) @end smallexample At @code{ip} 0 and 2, we do the copy from argument to heap for @@ -336,8 +329,9 @@ Control Instructions}, for more details. Then we see a reference to an external variable, corresponding to @code{a}. The disassembler doesn't have enough information to give a name to that variable, so it just marks it as being a ``closure -variable''. Finally we see the reference to @code{b}, then a tail call -(@code{goto/args}) with three arguments. +variable''. Finally we see the reference to @code{b}, then the +@code{list} opcode, an inline implementation of the @code{list} scheme +routine. @node Instruction Set @subsection Instruction Set @@ -365,7 +359,8 @@ their own test-and-branch instructions: @end example In addition, some Scheme primitives have their own inline -implementations, e.g. @code{cons}. +implementations, e.g. @code{cons}, and @code{list}, as we saw in the +previous section. So Guile's instruction set is a @emph{complete} instruction set, in that it provides the instructions that are suited to the problem, and @@ -421,12 +416,6 @@ efficient in the future via addressing by frame and index. Currently, external variables are all consed onto a list, which results in O(N) lookup time. -@deffn Instruction externals -Pushes the current list of external variables onto the stack. This -instruction is used in the implementation of -@code{compile-time-environment}. @xref{The Scheme Compiler}. -@end deffn - @deffn Instruction toplevel-ref index Push the value of the toplevel binding whose location is stored in at position @var{index} in the object table. @@ -440,11 +429,11 @@ created. Alternately, the lookup may be performed relative to a particular module, determined at compile-time (e.g. via @code{@@} or @code{@@@@}). In that case, the cell in the object table holds a list: -@code{(@var{modname} @var{sym} @var{interface?})}. The symbol -@var{sym} will be looked up in the module named @var{modname} (a list -of symbols). The lookup will be performed against the module's public -interface, unless @var{interface?} is @code{#f}, which it is for -example when compiling @code{@@@@}. +@code{(@var{modname} @var{sym} @var{public?})}. The symbol @var{sym} +will be looked up in the module named @var{modname} (a list of +symbols). The lookup will be performed against the module's public +interface, unless @var{public?} is @code{#f}, which it is for example +when compiling @code{@@@@}. In any case, if the symbol is unbound, an error is signalled. Otherwise the initial form is replaced with the looked-up variable, an @@ -550,8 +539,9 @@ may be encoded in 1, 2, or 4 bytes. @deffn Instruction load-integer length @deffnx Instruction load-unsigned-integer length -Load a 32-bit integer (respectively unsigned integer) from the -instruction stream. +Load a 32-bit integer or unsigned integer from the instruction stream. +The bytes of the integer are read in order of decreasing significance +(i.e., big-endian). @end deffn @deffn Instruction load-number length Load an arbitrary number from the instruction stream. The number is @@ -573,43 +563,23 @@ the current toplevel environment, creating the binding if necessary. Push the variable corresponding to the binding. @end deffn -@deffn Instruction load-program length +@deffn Instruction load-program Load bytecode from the instruction stream, and push a compiled -procedure. This instruction pops the following values from the stack: +procedure. -@itemize -@item Optionally, a thunk, which when called should return metadata -associated with this program---for example its name, the names of its -arguments, its documentation string, debugging information, etc. +This instruction pops one value from the stack: the program's object +table, as a vector, or @code{#f} in the case that the program has no +object table. A program that does not reference toplevel bindings and +does not use @code{object-ref} does not need an object table. -Normally, this thunk its itself a compiled procedure (with no -metadata). Metadata is represented this way so that the initial load -of a procedure is fast: the VM just mmap's the thunk and goes. The -symbols and pairs associated with the metadata are only created if the -user asks for them. - -For information on the format of the thunk's return value, -@xref{Compiled Procedures}. -@item Optionally, the program's object table, as a vector. - -A program that does not reference toplevel bindings and does not use -@code{object-ref} does not need an object table. -@item Finally, either one immediate integer or four immediate integers -representing the arity of the program. - -In the four-fixnum case, the values are respectively the number of -arguments taken by the function (@var{nargs}), the number of @dfn{rest -arguments} (@var{nrest}, 0 or 1), the number of local variables -(@var{nlocs}) and the number of external variables (@var{nexts}) -(@pxref{Environment Control Instructions}). - -The common single-fixnum case represents all of these values within a -16-bit bitmask. -@end itemize +This instruction is unlike the rest of the loading instructions, +because instead of parsing its data, it directly maps the instruction +stream onto a C structure, @code{struct scm_objcode}. @xref{Bytecode +and Objcode}, for more information. The resulting compiled procedure will not have any ``external'' -variables captured, so it will be loaded only once but may be used -many times to create closures. +variables captured, so it may be loaded only once but used many times +to create closures. @end deffn Finally, while this instruction is not strictly a ``loading'' @@ -620,7 +590,10 @@ here: Pop the program object from the stack, capture the current set of ``external'' variables, and assign those external variables to a copy of the program. Push the new program object, which shares state with -the original program. Also captures the current module. +the original program. + +At the time of this writing, the space overhead of closures is 4 words +per closure. @end deffn @node Procedural Instructions @@ -640,22 +613,24 @@ set to the returned value. @deffn Instruction call nargs Call the procedure located at @code{sp[-nargs]} with the @var{nargs} -arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}. +arguments located from @code{sp[-nargs + 1]} to @code{sp[0]}. + +For compiled procedures, this instruction sets up a new stack frame, +as described in @ref{Stack Layout}, and then dispatches to the first +instruction in the called procedure, relying on the called procedure +to return one value to the newly-created continuation. Because the new +frame pointer will point to sp[-nargs + 1], the arguments don't have +to be shuffled around -- they are already in place. For non-compiled procedures (continuations, primitives, and interpreted procedures), @code{call} will pop the procedure and arguments off the stack, and push the result of calling @code{scm_apply}. - -For compiled procedures, this instruction sets up a new stack frame, -as described in @ref{Stack Layout}, and then dispatches to the first -instruction in the called procedure, relying on the called procedure -to return one value to the newly-created continuation. @end deffn @deffn Instruction goto/args nargs Like @code{call}, but reusing the current continuation. This -instruction implements tail calling as required by RnRS. +instruction implements tail calls as required by RnRS. For compiled procedures, that means that @code{goto/args} reuses the current frame instead of building a new one. The @code{goto/*} @@ -726,14 +701,14 @@ values. This is an optimization for the common @code{(apply values @deffn Instruction truncate-values nbinds nrest Used in multiple-value continuations, this instruction takes the -values that are on the stack (including the number-of-value marker) +values that are on the stack (including the number-of-values marker) and truncates them for a binding construct. For example, a call to @code{(receive (x y . z) (foo) ...)} would, logically speaking, pop off the values returned from @code{(foo)} and push them as three values, corresponding to @code{x}, @code{y}, and @code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would -be 1 (to indicate that one of the bindings was a rest arguments). +be 1 (to indicate that one of the bindings was a rest argument). Signals an error if there is an insufficient number of values. @end deffn @@ -779,12 +754,14 @@ Push @var{value}, an 8-bit character, onto the stack. @deffn Instruction list n Pops off the top @var{n} values off of the stack, consing them up into a list, then pushes that list on the stack. What was the topmost value -will be the last element in the list. +will be the last element in the list. @var{n} is a two-byte value, +most significant byte first. @end deffn @deffn Instruction vector n Create and fill a vector with the top @var{n} values from the stack, -popping off those values and pushing on the resulting vector. +popping off those values and pushing on the resulting vector. @var{n} +is a two-byte value, like in @code{vector}. @end deffn @deffn Instruction mark @@ -850,9 +827,8 @@ Pushes ``the unspecified value'' onto the stack. @subsubsection Inlined Scheme Instructions The Scheme compiler can recognize the application of standard Scheme -procedures, or unbound variables that look like they are bound to -standard Scheme procedures. It tries to inline these small operations -to avoid the overhead of creating new stack frames. +procedures. It tries to inline these small operations to avoid the +overhead of creating new stack frames. Since most of these operations are historically implemented as C primitives, not inlining them would entail constantly calling out from @@ -876,12 +852,12 @@ stream. @deffnx Instruction eqv? x y @deffnx Instruction equal? x y @deffnx Instruction pair? x y -@deffnx Instruction list? x y +@deffnx Instruction list? x @deffnx Instruction set-car! pair x @deffnx Instruction set-cdr! pair x @deffnx Instruction slot-ref struct n @deffnx Instruction slot-set struct n x -@deffnx Instruction cons x +@deffnx Instruction cons x y @deffnx Instruction car x @deffnx Instruction cdr x Inlined implementations of their Scheme equivalents. diff --git a/guile-readline/ice-9/readline.scm b/guile-readline/ice-9/readline.scm index c35602f0c..19dda94db 100644 --- a/guile-readline/ice-9/readline.scm +++ b/guile-readline/ice-9/readline.scm @@ -169,24 +169,22 @@ (define-public (set-readline-read-hook! h) (set! read-hook h)) -(if (provided? 'regex) - (begin - (define-public apropos-completion-function - (let ((completions '())) - (lambda (text cont?) - (if (not cont?) - (set! completions - (map symbol->string - (apropos-internal - (string-append "^" (regexp-quote text)))))) - (if (null? completions) - #f - (let ((retval (car completions))) - (begin (set! completions (cdr completions)) - retval)))))) +(define-public apropos-completion-function + (let ((completions '())) + (lambda (text cont?) + (if (not cont?) + (set! completions + (map symbol->string + (apropos-internal + (string-append "^" (regexp-quote text)))))) + (if (null? completions) + #f + (let ((retval (car completions))) + (begin (set! completions (cdr completions)) + retval)))))) - (set! *readline-completion-function* apropos-completion-function) - )) +(if (provided? 'regex) + (set! *readline-completion-function* apropos-completion-function)) (define-public (with-readline-completion-function completer thunk) "With @var{completer} as readline completion function, call @var{thunk}." diff --git a/lang/Makefile.am b/lang/Makefile.am index 6dc2e2902..97c440d75 100644 --- a/lang/Makefile.am +++ b/lang/Makefile.am @@ -28,6 +28,7 @@ elisp_sources = \ elisp/example.el \ elisp/interface.scm \ elisp/transform.scm \ + elisp/expand.scm \ elisp/variables.scm \ \ elisp/primitives/buffers.scm \ diff --git a/lang/elisp/expand.scm b/lang/elisp/expand.scm new file mode 100644 index 000000000..0599d5984 --- /dev/null +++ b/lang/elisp/expand.scm @@ -0,0 +1,4 @@ +(define-module (lang elisp expand) + #:export (expand)) + +(define (expand x) x) diff --git a/lang/elisp/interface.scm b/lang/elisp/interface.scm index 1e0758569..fcd748f65 100644 --- a/lang/elisp/interface.scm +++ b/lang/elisp/interface.scm @@ -1,4 +1,5 @@ (define-module (lang elisp interface) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module ((lang elisp internals load) #:select ((load . elisp:load))) @@ -66,31 +67,39 @@ one of the directories of @code{load-path}." (string->symbol (string-append "imports:" (number->string counter))))))) -(define-macro (use-elisp-file file-name . imports) - "Load Elisp code file @var{file-name} and import its definitions +(define use-elisp-file + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp code file @var{file-name} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-file ,file-name) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((file-name (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-file ,file-name) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) -(define-macro (use-elisp-library library . imports) - "Load Elisp library @var{library} and import its definitions into +(define use-elisp-library + (procedure->memoizing-macro + (lambda (exp env) + "Load Elisp library @var{library} and import its definitions into the current Scheme module. If any @var{imports} are specified, they are interpreted as selection and renaming specifiers as per @code{use-modules}." - (let ((export-module-name (export-module-name))) - `(begin - (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) - (beautify-user-module! (resolve-module ',export-module-name)) - (load-elisp-library ,library) - (use-modules (,export-module-name ,@imports)) - (fluid-set! ,elisp-export-module #f)))) + (let ((library (cadr exp)) + (env (cddr exp))) + (let ((export-module-name (export-module-name))) + `(begin + (fluid-set! ,elisp-export-module (resolve-module ',export-module-name)) + (beautify-user-module! (resolve-module ',export-module-name)) + (load-elisp-library ,library) + (use-modules (,export-module-name ,@imports)) + (fluid-set! ,elisp-export-module #f))))))) (define (export-to-elisp . defs) "Export procedures and variables specified by @var{defs} to Elisp. diff --git a/lang/elisp/internals/lambda.scm b/lang/elisp/internals/lambda.scm index 9917c08bd..f7c7a4d01 100644 --- a/lang/elisp/internals/lambda.scm +++ b/lang/elisp/internals/lambda.scm @@ -1,4 +1,5 @@ (define-module (lang elisp internals lambda) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals fset) #:use-module (lang elisp transform) #:export (parse-formals diff --git a/lang/elisp/primitives/fns.scm b/lang/elisp/primitives/fns.scm index f7a4aa003..7beb8a51c 100644 --- a/lang/elisp/primitives/fns.scm +++ b/lang/elisp/primitives/fns.scm @@ -26,7 +26,8 @@ (fset 'symbol-function fref/error-if-void) -(fset 'macroexpand macroexpand) +;; FIXME -- lost in the syncase conversion +;; (fset 'macroexpand macroexpand) (fset 'subrp (lambda (obj) diff --git a/lang/elisp/primitives/syntax.scm b/lang/elisp/primitives/syntax.scm index 6babb3dd3..118b3bc0c 100644 --- a/lang/elisp/primitives/syntax.scm +++ b/lang/elisp/primitives/syntax.scm @@ -1,4 +1,5 @@ (define-module (lang elisp primitives syntax) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals evaluation) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals lambda) diff --git a/lang/elisp/transform.scm b/lang/elisp/transform.scm index ee288a722..09159c073 100644 --- a/lang/elisp/transform.scm +++ b/lang/elisp/transform.scm @@ -1,4 +1,5 @@ (define-module (lang elisp transform) + #:use-syntax (lang elisp expand) #:use-module (lang elisp internals trace) #:use-module (lang elisp internals fset) #:use-module (lang elisp internals evaluation) @@ -26,23 +27,27 @@ (define (syntax-error x) (error "Syntax error in expression" x)) -(define-macro (scheme exp . module) - (let ((m (if (null? module) - the-root-module - (save-module-excursion - (lambda () - ;; In order for `resolve-module' to work as - ;; expected, the current module must contain the - ;; `app' variable. This is not true for #:pure - ;; modules, specifically (lang elisp base). So, - ;; switch to the root module (guile) before calling - ;; resolve-module. - (set-current-module the-root-module) - (resolve-module (car module))))))) - (let ((x `(,eval (,quote ,exp) ,m))) - ;;(write x) - ;;(newline) - x))) +(define scheme + (procedure->memoizing-macro + (lambda (exp env) + (let ((exp (cadr exp)) + (module (cddr exp))) + (let ((m (if (null? module) + the-root-module + (save-module-excursion + (lambda () + ;; In order for `resolve-module' to work as + ;; expected, the current module must contain the + ;; `app' variable. This is not true for #:pure + ;; modules, specifically (lang elisp base). So, + ;; switch to the root module (guile) before calling + ;; resolve-module. + (set-current-module the-root-module) + (resolve-module (car module))))))) + (let ((x `(,eval (,quote ,exp) ,m))) + ;;(write x) + ;;(newline) + x)))))) (define (transformer x) (cond ((pair? x) diff --git a/libguile/eval.c b/libguile/eval.c index 19ac0b155..05af5a1c5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2140,6 +2140,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env) unmemoize_exprs (SCM_CDR (expr), env)); } +SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when); +SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when); +SCM_SYMBOL (sym_eval, "eval"); +SCM_SYMBOL (sym_load, "load"); + + +SCM +scm_m_eval_when (SCM expr, SCM env SCM_UNUSED) +{ + ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr); + + if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr))) + || scm_is_true (scm_memq (sym_load, scm_cadr (expr)))) + return scm_cons (SCM_IM_BEGIN, scm_cddr (expr)); + + return scm_list_1 (SCM_IM_BEGIN); +} + #if 0 /* See futures.h for a comment why futures are not enabled. diff --git a/libguile/eval.h b/libguile/eval.h index f3ec2e19c..b017f2e02 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -100,6 +100,7 @@ SCM_API SCM scm_sym_atapply; SCM_API SCM scm_sym_atcall_cc; SCM_API SCM scm_sym_at_call_with_values; SCM_API SCM scm_sym_delay; +SCM_API SCM scm_sym_eval_when; SCM_API SCM scm_sym_arrow; SCM_API SCM scm_sym_else; SCM_API SCM scm_sym_apply; @@ -146,6 +147,7 @@ SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env); SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env); SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env); SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env); +SCM_API SCM scm_m_eval_when (SCM xorig, SCM env); SCM_API int scm_badargsp (SCM formals, SCM args); SCM_API SCM scm_call_0 (SCM proc); SCM_API SCM scm_call_1 (SCM proc, SCM arg1); diff --git a/libguile/frames.c b/libguile/frames.c index f53cade95..c08fd3134 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #if HAVE_CONFIG_H # include @@ -45,6 +21,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" diff --git a/libguile/frames.h b/libguile/frames.h index 836763700..d74476ac8 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2.1 of the License, or (at your option) any later version. * - * 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_FRAMES_H_ #define _SCM_FRAMES_H_ @@ -97,7 +73,7 @@ * Heap frames */ -extern scm_t_bits scm_tc16_vm_frame; +SCM_API scm_t_bits scm_tc16_vm_frame; struct scm_vm_frame { @@ -118,24 +94,24 @@ struct scm_vm_frame #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) /* FIXME rename scm_byte_t */ -extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, +SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, scm_byte_t *ip, scm_t_ptrdiff offset); -extern SCM scm_vm_frame_p (SCM obj); -extern SCM scm_vm_frame_program (SCM frame); -extern SCM scm_vm_frame_arguments (SCM frame); -extern SCM scm_vm_frame_source (SCM frame); -extern SCM scm_vm_frame_local_ref (SCM frame, SCM index); -extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); -extern SCM scm_vm_frame_return_address (SCM frame); -extern SCM scm_vm_frame_mv_return_address (SCM frame); -extern SCM scm_vm_frame_dynamic_link (SCM frame); -extern SCM scm_vm_frame_external_link (SCM frame); -extern SCM scm_vm_frame_stack (SCM frame); +SCM_API SCM scm_vm_frame_p (SCM obj); +SCM_API SCM scm_vm_frame_program (SCM frame); +SCM_API SCM scm_vm_frame_arguments (SCM frame); +SCM_API SCM scm_vm_frame_source (SCM frame); +SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index); +SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val); +SCM_API SCM scm_vm_frame_return_address (SCM frame); +SCM_API SCM scm_vm_frame_mv_return_address (SCM frame); +SCM_API SCM scm_vm_frame_dynamic_link (SCM frame); +SCM_API SCM scm_vm_frame_external_link (SCM frame); +SCM_API SCM scm_vm_frame_stack (SCM frame); -extern SCM scm_c_vm_frame_prev (SCM frame); +SCM_API SCM scm_c_vm_frame_prev (SCM frame); -extern void scm_bootstrap_frames (void); -extern void scm_init_frames (void); +SCM_INTERNAL void scm_bootstrap_frames (void); +SCM_INTERNAL void scm_init_frames (void); #endif /* _SCM_FRAMES_H_ */ diff --git a/libguile/instructions.c b/libguile/instructions.c index 4f504f0a2..f0f52e422 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -1,49 +1,27 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #if HAVE_CONFIG_H # include #endif #include + +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" diff --git a/libguile/instructions.h b/libguile/instructions.h index 4968671b5..f4f45b371 100644 --- a/libguile/instructions.h +++ b/libguile/instructions.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_INSTRUCTIONS_H_ #define _SCM_INSTRUCTIONS_H_ @@ -57,16 +33,16 @@ enum scm_opcode { scm_op_last = SCM_VM_NUM_INSTRUCTIONS }; -extern SCM scm_instruction_list (void); -extern SCM scm_instruction_p (SCM obj); -extern SCM scm_instruction_length (SCM inst); -extern SCM scm_instruction_pops (SCM inst); -extern SCM scm_instruction_pushes (SCM inst); -extern SCM scm_instruction_to_opcode (SCM inst); -extern SCM scm_opcode_to_instruction (SCM op); +SCM_API SCM scm_instruction_list (void); +SCM_API SCM scm_instruction_p (SCM obj); +SCM_API SCM scm_instruction_length (SCM inst); +SCM_API SCM scm_instruction_pops (SCM inst); +SCM_API SCM scm_instruction_pushes (SCM inst); +SCM_API SCM scm_instruction_to_opcode (SCM inst); +SCM_API SCM scm_opcode_to_instruction (SCM op); -extern void scm_bootstrap_instructions (void); -extern void scm_init_instructions (void); +SCM_INTERNAL void scm_bootstrap_instructions (void); +SCM_INTERNAL void scm_init_instructions (void); #endif /* _SCM_INSTRUCTIONS_H_ */ diff --git a/libguile/macros.c b/libguile/macros.c index d132c0159..ca3e83e29 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -48,10 +48,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE, macro, port, pstate))) { + scm_puts ("#<", port); + + if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro)) + scm_puts ("extended-", port); + if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code)) - scm_puts ("#', port); } return 1; } +static SCM +macro_mark (SCM macro) +{ + if (SCM_MACRO_IS_EXTENDED (macro)) + { scm_gc_mark (SCM_SMOB_OBJECT_2 (macro)); + scm_gc_mark (SCM_SMOB_OBJECT_3 (macro)); + } + return SCM_SMOB_OBJECT (macro); +} + static SCM makmac (SCM code, scm_t_bits flags) { @@ -164,11 +187,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0, #endif +SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0, + (SCM type, SCM binding), + "Return a @dfn{macro} that requires expansion by syntax-case.\n" + "While users should not call this function, it is useful to know\n" + "that syntax-case macros are represented as Guile primitive macros.") +#define FUNC_NAME s_scm_make_syncase_macro +{ + SCM z; + SCM_VALIDATE_SYMBOL (1, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0, + (SCM m, SCM type, SCM binding), + "Extend a core macro @var{m} with a syntax-case binding.") +#define FUNC_NAME s_scm_make_extended_syncase_macro +{ + SCM z; + SCM_VALIDATE_SMOB (1, m, macro); + SCM_VALIDATE_SYMBOL (2, type); + + SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type), + SCM_UNPACK (binding)); + SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED); + return z; +} +#undef FUNC_NAME + + SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, (SCM obj), - "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n" - "syntax transformer.") + "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n" + "syntax transformer, or a syntax-case macro.") #define FUNC_NAME s_scm_macro_p { return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj)); @@ -182,14 +239,15 @@ SCM_SYMBOL (scm_sym_macro, "macro"); #endif SCM_SYMBOL (scm_sym_mmacro, "macro!"); SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!"); +SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro"); SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, (SCM m), - "Return one of the symbols @code{syntax}, @code{macro} or\n" - "@code{macro!}, depending on whether @var{m} is a syntax\n" - "transformer, a regular macro, or a memoizing macro,\n" - "respectively. If @var{m} is not a macro, @code{#f} is\n" - "returned.") + "Return one of the symbols @code{syntax}, @code{macro},\n" + "@code{macro!}, or @code{syntax-case}, depending on whether\n" + "@var{m} is a syntax transformer, a regular macro, a memoizing\n" + "macro, or a syntax-case macro, respectively. If @var{m} is\n" + "not a macro, @code{#f} is returned.") #define FUNC_NAME s_scm_macro_type { if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m)) @@ -202,6 +260,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, #endif case 2: return scm_sym_mmacro; case 3: return scm_sym_bimacro; + case 4: return scm_sym_syncase_macro; default: scm_wrong_type_arg (FUNC_NAME, 1, m); } } @@ -214,7 +273,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, #define FUNC_NAME s_scm_macro_name { SCM_VALIDATE_SMOB (1, m, macro); - return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m))); + if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m)))) + return scm_procedure_name (SCM_SMOB_OBJECT (m)); + return SCM_BOOL_F; } #undef FUNC_NAME @@ -236,6 +297,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0, + (SCM m), + "Return the type of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_type +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_2 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0, + (SCM m), + "Return the binding of the macro @var{m}.") +#define FUNC_NAME s_scm_syncase_macro_binding +{ + SCM_VALIDATE_SMOB (1, m, macro); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_3 (m); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + SCM scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() ) { @@ -249,7 +338,7 @@ void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); - scm_set_smob_mark (scm_tc16_macro, scm_markcdr); + scm_set_smob_mark (scm_tc16_macro, macro_mark); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" } diff --git a/libguile/macros.h b/libguile/macros.h index e1de77ff9..5e3d64a55 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -29,9 +29,15 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACRO_TYPE_BITS (3) +#define SCM_MACRO_TYPE_MASK ((1< @@ -51,6 +27,7 @@ #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "programs.h" #include "objcodes.h" diff --git a/libguile/objcodes.h b/libguile/objcodes.h index 222691668..acd43a600 100644 --- a/libguile/objcodes.h +++ b/libguile/objcodes.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2.1 of the License, or (at your option) any later version. * - * 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_OBJCODES_H_ #define _SCM_OBJCODES_H_ @@ -60,7 +36,7 @@ struct scm_objcode { #define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) #define SCM_F_OBJCODE_IS_SLICE (1<<2) -extern scm_t_bits scm_tc16_objcode; +SCM_API scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x)) #define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x)) @@ -80,15 +56,15 @@ extern scm_t_bits scm_tc16_objcode; #define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE) SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr); -extern SCM scm_load_objcode (SCM file); -extern SCM scm_objcode_p (SCM obj); -extern SCM scm_objcode_meta (SCM objcode); -extern SCM scm_bytecode_to_objcode (SCM bytecode); -extern SCM scm_objcode_to_bytecode (SCM objcode); -extern SCM scm_write_objcode (SCM objcode, SCM port); +SCM_API SCM scm_load_objcode (SCM file); +SCM_API SCM scm_objcode_p (SCM obj); +SCM_API SCM scm_objcode_meta (SCM objcode); +SCM_API SCM scm_bytecode_to_objcode (SCM bytecode); +SCM_API SCM scm_objcode_to_bytecode (SCM objcode); +SCM_API SCM scm_write_objcode (SCM objcode, SCM port); -extern void scm_bootstrap_objcodes (void); -extern void scm_init_objcodes (void); +SCM_INTERNAL void scm_bootstrap_objcodes (void); +SCM_INTERNAL void scm_init_objcodes (void); #endif /* _SCM_OBJCODES_H_ */ diff --git a/libguile/programs.c b/libguile/programs.c index 8e8982994..68e0b8541 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,49 +1,26 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #if HAVE_CONFIG_H # include #endif #include +#include "_scm.h" #include "vm-bootstrap.h" #include "instructions.h" #include "modules.h" diff --git a/libguile/programs.h b/libguile/programs.h index 68a6936a2..ae819ef85 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_PROGRAMS_H_ #define _SCM_PROGRAMS_H_ @@ -51,7 +27,7 @@ typedef unsigned char scm_byte_t; -extern scm_t_bits scm_tc16_program; +SCM_API scm_t_bits scm_tc16_program; #define SCM_F_PROGRAM_IS_BOOT (1<<0) @@ -63,27 +39,27 @@ extern scm_t_bits scm_tc16_program; #define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P) #define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT) -extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM externals); -extern SCM scm_program_p (SCM obj); -extern SCM scm_program_base (SCM program); -extern SCM scm_program_arity (SCM program); -extern SCM scm_program_meta (SCM program); -extern SCM scm_program_bindings (SCM program); -extern SCM scm_program_sources (SCM program); -extern SCM scm_program_source (SCM program, SCM ip); -extern SCM scm_program_properties (SCM program); -extern SCM scm_program_name (SCM program); -extern SCM scm_program_objects (SCM program); -extern SCM scm_program_module (SCM program); -extern SCM scm_program_external (SCM program); -extern SCM scm_program_external_set_x (SCM program, SCM external); -extern SCM scm_program_objcode (SCM program); +SCM_API SCM scm_program_p (SCM obj); +SCM_API SCM scm_program_base (SCM program); +SCM_API SCM scm_program_arity (SCM program); +SCM_API SCM scm_program_meta (SCM program); +SCM_API SCM scm_program_bindings (SCM program); +SCM_API SCM scm_program_sources (SCM program); +SCM_API SCM scm_program_source (SCM program, SCM ip); +SCM_API SCM scm_program_properties (SCM program); +SCM_API SCM scm_program_name (SCM program); +SCM_API SCM scm_program_objects (SCM program); +SCM_API SCM scm_program_module (SCM program); +SCM_API SCM scm_program_external (SCM program); +SCM_API SCM scm_program_external_set_x (SCM program, SCM external); +SCM_API SCM scm_program_objcode (SCM program); -extern SCM scm_c_program_source (SCM program, size_t ip); +SCM_API SCM scm_c_program_source (SCM program, size_t ip); -extern void scm_bootstrap_programs (void); -extern void scm_init_programs (void); +SCM_INTERNAL void scm_bootstrap_programs (void); +SCM_INTERNAL void scm_init_programs (void); #endif /* _SCM_PROGRAMS_H_ */ diff --git a/libguile/read.c b/libguile/read.c index 61806f263..3493ba03f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -182,6 +182,7 @@ static SCM *scm_read_hash_procedures; /* Read an SCSH block comment. */ static inline SCM scm_read_scsh_block_comment (int chr, SCM port); +static SCM scm_read_commented_expression (int chr, SCM port); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Return zero if the whole token fits in BUF, non-zero otherwise. */ @@ -257,6 +258,9 @@ flush_ws (SCM port, const char *eoferr) case '!': scm_read_scsh_block_comment (c, port); break; + case ';': + scm_read_commented_expression (c, port); + break; default: scm_ungetc (c, port); return '#'; @@ -700,6 +704,65 @@ scm_read_quote (int chr, SCM port) return p; } +SCM_SYMBOL (sym_syntax, "syntax"); +SCM_SYMBOL (sym_quasisyntax, "quasisyntax"); +SCM_SYMBOL (sym_unsyntax, "unsyntax"); +SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); + +static SCM +scm_read_syntax (int chr, SCM port) +{ + SCM p; + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + + switch (chr) + { + case '`': + p = sym_quasisyntax; + break; + + case '\'': + p = sym_syntax; + break; + + case ',': + { + int c; + + c = scm_getc (port); + if ('@' == c) + p = sym_unsyntax_splicing; + else + { + scm_ungetc (c, port); + p = sym_unsyntax; + } + break; + } + + default: + fprintf (stderr, "%s: unhandled syntax character (%i)\n", + "scm_read_syntax", chr); + abort (); + } + + p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); + if (SCM_RECORD_POSITIONS_P) + scm_whash_insert (scm_source_whash, p, + scm_make_srcprops (line, column, + SCM_FILENAME (port), + SCM_COPY_SOURCE_P + ? (scm_cons2 (SCM_CAR (p), + SCM_CAR (SCM_CDR (p)), + SCM_EOL)) + : SCM_UNDEFINED, + SCM_EOL)); + + + return p; +} + static inline SCM scm_read_semicolon_comment (int chr, SCM port) { @@ -862,6 +925,20 @@ scm_read_scsh_block_comment (int chr, SCM port) return SCM_UNSPECIFIED; } +static SCM +scm_read_commented_expression (int chr, SCM port) +{ + int c; + + c = flush_ws (port, (char *) NULL); + if (EOF == c) + scm_i_input_error ("read_commented_expression", port, + "no expression after #; comment", SCM_EOL); + scm_ungetc (c, port); + scm_read_expression (port); + return SCM_UNSPECIFIED; +} + static SCM scm_read_extended_symbol (int chr, SCM port) { @@ -1023,6 +1100,12 @@ scm_read_sharp (int chr, SCM port) return (scm_read_extended_symbol (chr, port)); case '!': return (scm_read_scsh_block_comment (chr, port)); + case ';': + return (scm_read_commented_expression (chr, port)); + case '`': + case '\'': + case ',': + return (scm_read_syntax (chr, port)); default: result = scm_read_sharp_extension (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h index beecf0fc2..587766a67 100644 --- a/libguile/vm-bootstrap.h +++ b/libguile/vm-bootstrap.h @@ -1,48 +1,24 @@ /* Copyright (C) 2001 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 2.1 of the License, or (at your option) any later version. * - * 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * 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 General Public License for more details. + * 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 General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_VM_BOOTSTRAP_H_ #define _SCM_VM_BOOTSTRAP_H_ -extern void scm_bootstrap_vm (void); +SCM_INTERNAL void scm_bootstrap_vm (void); #endif /* _SCM_VM_BOOTSTRAP_H_ */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 45251fd70..f43f8c7fe 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 included in vm.c multiple times */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 6bb235401..8c919f630 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 included in vm_engine.c */ @@ -147,8 +123,12 @@ #ifdef VM_ENABLE_PARANOID_ASSERTIONS #define CHECK_IP() \ do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0) +#define ASSERT_BOUND(x) \ + do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \ + } while (0) #else #define CHECK_IP() +#define ASSERT_BOUND(x) #endif /* Get a local copy of the program's "object table" (i.e. the vector of diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h index 7ad2b9da8..02dfbc4d0 100644 --- a/libguile/vm-expand.h +++ b/libguile/vm-expand.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef VM_LABEL #define VM_LABEL(tag) l_##tag diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c index 4af60265e..38dea32b9 100644 --- a/libguile/vm-i-scheme.c +++ b/libguile/vm-i-scheme.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 included in vm_engine.c */ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 5468604d2..42f2b1973 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -230,6 +230,7 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1) VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1) { PUSH (LOCAL_REF (FETCH ())); + ASSERT_BOUND (*sp); NEXT; } @@ -244,6 +245,7 @@ VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1) } CHECK_EXTERNAL(e); PUSH (SCM_CAR (e)); + ASSERT_BOUND (*sp); NEXT; } @@ -408,12 +410,6 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) NEXT; } -VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1) -{ - PUSH (external); - NEXT; -} - /* * branch and jump diff --git a/libguile/vm.c b/libguile/vm.c index 38d085c99..081a691ff 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. * - * This program is distributed in the hope that it will be useful, + * 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 2.1 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 General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #if HAVE_CONFIG_H # include @@ -46,6 +22,7 @@ #include #include #include +#include "_scm.h" #include "vm-bootstrap.h" #include "frames.h" #include "instructions.h" diff --git a/libguile/vm.h b/libguile/vm.h index 5c38f9ffa..2f2b617ce 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,43 +1,19 @@ /* Copyright (C) 2001 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 2.1 of the License, or (at your option) any later version. * - * 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 - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, + * 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 General Public License for more details. + * 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 General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * 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 + */ #ifndef _SCM_VM_H_ #define _SCM_VM_H_ @@ -78,37 +54,37 @@ struct scm_vm { SCM trace_frame; /* a frame being traced */ }; -extern SCM scm_the_vm_fluid; +SCM_API SCM scm_the_vm_fluid; #define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x) #define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm)) #define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P) -extern SCM scm_the_vm (); -extern SCM scm_make_vm (void); -extern SCM scm_vm_apply (SCM vm, SCM program, SCM args); -extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); -extern SCM scm_vm_option_ref (SCM vm, SCM key); -extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_the_vm (); +SCM_API SCM scm_make_vm (void); +SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args); +SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs); +SCM_API SCM scm_vm_option_ref (SCM vm, SCM key); +SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_version (void); -extern SCM scm_the_vm (void); -extern SCM scm_vm_p (SCM obj); -extern SCM scm_vm_ip (SCM vm); -extern SCM scm_vm_sp (SCM vm); -extern SCM scm_vm_fp (SCM vm); -extern SCM scm_vm_boot_hook (SCM vm); -extern SCM scm_vm_halt_hook (SCM vm); -extern SCM scm_vm_next_hook (SCM vm); -extern SCM scm_vm_break_hook (SCM vm); -extern SCM scm_vm_enter_hook (SCM vm); -extern SCM scm_vm_apply_hook (SCM vm); -extern SCM scm_vm_exit_hook (SCM vm); -extern SCM scm_vm_return_hook (SCM vm); -extern SCM scm_vm_option (SCM vm, SCM key); -extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); -extern SCM scm_vm_stats (SCM vm); -extern SCM scm_vm_trace_frame (SCM vm); +SCM_API SCM scm_vm_version (void); +SCM_API SCM scm_the_vm (void); +SCM_API SCM scm_vm_p (SCM obj); +SCM_API SCM scm_vm_ip (SCM vm); +SCM_API SCM scm_vm_sp (SCM vm); +SCM_API SCM scm_vm_fp (SCM vm); +SCM_API SCM scm_vm_boot_hook (SCM vm); +SCM_API SCM scm_vm_halt_hook (SCM vm); +SCM_API SCM scm_vm_next_hook (SCM vm); +SCM_API SCM scm_vm_break_hook (SCM vm); +SCM_API SCM scm_vm_enter_hook (SCM vm); +SCM_API SCM scm_vm_apply_hook (SCM vm); +SCM_API SCM scm_vm_exit_hook (SCM vm); +SCM_API SCM scm_vm_return_hook (SCM vm); +SCM_API SCM scm_vm_option (SCM vm, SCM key); +SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val); +SCM_API SCM scm_vm_stats (SCM vm); +SCM_API SCM scm_vm_trace_frame (SCM vm); struct scm_vm_cont { scm_byte_t *ip; @@ -119,16 +95,16 @@ struct scm_vm_cont { scm_t_ptrdiff reloc; }; -extern scm_t_bits scm_tc16_vm_cont; +SCM_API scm_t_bits scm_tc16_vm_cont; #define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ) #define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT)) -extern SCM scm_vm_capture_continuations (void); -extern void scm_vm_reinstate_continuations (SCM conts); +SCM_API SCM scm_vm_capture_continuations (void); +SCM_API void scm_vm_reinstate_continuations (SCM conts); -extern SCM scm_load_compiled_with_vm (SCM file); +SCM_API SCM scm_load_compiled_with_vm (SCM file); -extern void scm_init_vm (void); +SCM_INTERNAL void scm_init_vm (void); #endif /* _SCM_VM_H_ */ diff --git a/module/Makefile.am b/module/Makefile.am index d149bb64a..9d9a839a1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -31,22 +31,15 @@ modpath = # putting these core modules first. SOURCES = \ - ice-9/psyntax-pp.scm \ + ice-9/psyntax-pp.scm \ system/base/pmatch.scm system/base/syntax.scm \ system/base/compile.scm system/base/language.scm \ \ - system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ - system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ - system/vm/trace.scm system/vm/vm.scm \ - \ - system/xref.scm \ - \ - system/repl/repl.scm system/repl/common.scm \ - system/repl/command.scm \ - \ + language/tree-il.scm \ language/ghil.scm language/glil.scm language/assembly.scm \ \ - $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \ + $(SCHEME_LANG_SOURCES) \ + $(TREE_IL_LANG_SOURCES) \ $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \ $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \ $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \ @@ -55,7 +48,8 @@ SOURCES = \ $(SRFI_SOURCES) \ $(RNRS_SOURCES) \ $(OOP_SOURCES) \ - \ + $(SYSTEM_SOURCES) \ + $(ECMASCRIPT_LANG_SOURCES) \ $(SCRIPTS_SOURCES) ## test.scm is not currently installed. @@ -72,10 +66,19 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm SCHEME_LANG_SOURCES = \ - language/scheme/amatch.scm language/scheme/expand.scm \ - language/scheme/compile-ghil.scm language/scheme/spec.scm \ + language/scheme/compile-ghil.scm \ + language/scheme/spec.scm \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ language/scheme/inline.scm +TREE_IL_LANG_SOURCES = \ + language/tree-il/primitives.scm \ + language/tree-il/optimize.scm \ + language/tree-il/analyze.scm \ + language/tree-il/compile-glil.scm \ + language/tree-il/spec.scm + GHIL_LANG_SOURCES = \ language/ghil/spec.scm language/ghil/compile-glil.scm @@ -141,7 +144,6 @@ ICE_9_SOURCES = \ ice-9/debugger.scm \ ice-9/documentation.scm \ ice-9/emacs.scm \ - ice-9/expand-support.scm \ ice-9/expect.scm \ ice-9/format.scm \ ice-9/getopt-long.scm \ @@ -199,6 +201,7 @@ SRFI_SOURCES = \ srfi/srfi-14.scm \ srfi/srfi-16.scm \ srfi/srfi-17.scm \ + srfi/srfi-18.scm \ srfi/srfi-19.scm \ srfi/srfi-26.scm \ srfi/srfi-31.scm \ @@ -231,6 +234,16 @@ OOP_SOURCES = \ oop/goops/accessors.scm \ oop/goops/simple.scm +SYSTEM_SOURCES = \ + system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \ + system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \ + system/vm/trace.scm system/vm/vm.scm \ + \ + system/xref.scm \ + \ + system/repl/repl.scm system/repl/common.scm \ + system/repl/command.scm + EXTRA_DIST += oop/ChangeLog-2008 NOCOMP_SOURCES = \ @@ -247,5 +260,4 @@ NOCOMP_SOURCES = \ ice-9/debugging/steps.scm \ ice-9/debugging/trace.scm \ ice-9/debugging/traps.scm \ - ice-9/debugging/trc.scm \ - srfi/srfi-18.scm + ice-9/debugging/trc.scm diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 48d822bfc..44066312a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -33,6 +33,13 @@ +;; Before compiling, make sure any symbols are resolved in the (guile) +;; module, the primary location of those symbols, rather than in +;; (guile-user), the default module that we compile in. + +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;; {R4RS compliance} ;;; @@ -86,6 +93,42 @@ (define (provided? feature) (and (memq feature *features*) #t)) + + +;;; {and-map and or-map} +;;; +;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) +;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) +;;; + +;; and-map f l +;; +;; Apply f to successive elements of l until exhaustion or f returns #f. +;; If returning early, return #f. Otherwise, return the last value returned +;; by f. If f has never been called because l is empty, return #t. +;; +(define (and-map f lst) + (let loop ((result #t) + (l lst)) + (and result + (or (and (null? l) + result) + (loop (f (car l)) (cdr l)))))) + +;; or-map f l +;; +;; Apply f to successive elements of l until exhaustion or while f returns #f. +;; If returning early, return the return value of f. +;; +(define (or-map f lst) + (let loop ((result #f) + (l lst)) + (or result + (and (not (null? l)) + (loop (f (car l)) (cdr l)))))) + + + ;; let format alias simple-format until the more complete version is loaded (define format simple-format) @@ -125,97 +168,181 @@ -;; Before the module system boots, there are no module names. But -;; psyntax does want a module-name definition, so give it one. +;; Define a minimal stub of the module API for psyntax, before modules +;; have booted. (define (module-name x) + '(guile)) +(define (module-define! module sym val) + (let ((v (hashq-ref (%get-pre-modules-obarray) sym))) + (if v + (variable-set! v val) + (hashq-set! (%get-pre-modules-obarray) sym + (make-variable val))))) +(define (module-ref module sym) + (let ((v (module-variable module sym))) + (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) +(define (resolve-module . args) #f) -;; (eval-when (situation...) form...) -;; -;; Evaluate certain code based on the situation that eval-when is used -;; in. There are three situations defined. -;; -;; `load' triggers when a file is loaded via `load', or when a compiled -;; file is loaded. -;; -;; `compile' triggers when an expression is compiled. -;; -;; `eval' triggers when code is evaluated interactively, as at the REPL -;; or via the `compile' or `eval' procedures. +;; Input hook to syncase -- so that we might be able to pass annotated +;; expressions in. Currently disabled. Maybe we should just use +;; source-properties directly. +(define (annotation? x) #f) -;; NB: this macro is only ever expanded by the interpreter. The compiler -;; notices it and interprets the situations differently. -(define eval-when - (procedure->memoizing-macro - (lambda (exp env) - (let ((situations (cadr exp)) - (body (cddr exp))) - (if (or (memq 'load situations) - (memq 'eval situations)) - `(begin . ,body)))))) +;; API provided by psyntax +(define syntax-violation #f) +(define datum->syntax #f) +(define syntax->datum #f) +(define identifier? #f) +(define generate-temporaries #f) +(define bound-identifier=? #f) +(define free-identifier=? #f) +(define sc-expand #f) + +;; $sc-expand is an implementation detail of psyntax. It is used by +;; expanded macros, to dispatch an input against a set of patterns. +(define $sc-dispatch #f) + +;; Load it up! +(primitive-load-path "ice-9/psyntax-pp") + +;; %pre-modules-transformer is the Scheme expander from now until the +;; module system has booted up. +(define %pre-modules-transformer sc-expand) + +(define-syntax and + (syntax-rules () + ((_) #t) + ((_ x) x) + ((_ x y ...) (if x (and y ...) #f)))) + +(define-syntax or + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x y ...) (let ((t x)) (if t t (or y ...)))))) + +;; The "maybe-more" bits are something of a hack, so that we can support +;; SRFI-61. Rewrites into a standalone syntax-case macro would be +;; appreciated. +(define-syntax cond + (syntax-rules (=> else) + ((_ "maybe-more" test consequent) + (if test consequent)) + + ((_ "maybe-more" test consequent clause ...) + (if test consequent (cond clause ...))) + + ((_ (else else1 else2 ...)) + (begin else1 else2 ...)) + + ((_ (test => receiver) more-clause ...) + (let ((t test)) + (cond "maybe-more" t (receiver t) more-clause ...))) + + ((_ (generator guard => receiver) more-clause ...) + (call-with-values (lambda () generator) + (lambda t + (cond "maybe-more" + (apply guard t) (apply receiver t) more-clause ...)))) + + ((_ (test => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(test => receiver ...))) + ((_ (generator guard => receiver ...) more-clause ...) + (syntax-violation 'cond "wrong number of receiver expressions" + '(generator guard => receiver ...))) + + ((_ (test) more-clause ...) + (let ((t test)) + (cond "maybe-more" t t more-clause ...))) + + ((_ (test body1 body2 ...) more-clause ...) + (cond "maybe-more" + test (begin body1 body2 ...) more-clause ...)))) + +(define-syntax case + (syntax-rules (else) + ((case (key ...) + clauses ...) + (let ((atom-key (key ...))) + (case atom-key clauses ...))) + ((case key + (else result1 result2 ...)) + (begin result1 result2 ...)) + ((case key + ((atoms ...) result1 result2 ...)) + (if (memv key '(atoms ...)) + (begin result1 result2 ...))) + ((case key + ((atoms ...) result1 result2 ...) + clause clauses ...) + (if (memv key '(atoms ...)) + (begin result1 result2 ...) + (case key clause clauses ...))))) + +(define-syntax do + (syntax-rules () + ((do ((var init step ...) ...) + (test expr ...) + command ...) + (letrec + ((loop + (lambda (var ...) + (if test + (begin + (if #f #f) + expr ...) + (begin + command + ... + (loop (do "step" var step ...) + ...)))))) + (loop init ...))) + ((do "step" x) + x) + ((do "step" x y) + y))) + +(define-syntax delay + (syntax-rules () + ((_ exp) (make-promise (lambda () exp))))) -;; Before compiling, make sure any symbols are resolved in the (guile) -;; module, the primary location of those symbols, rather than in -;; (guile-user), the default module that we compile in. - -(eval-when (compile) - (set-current-module (resolve-module '(guile)))) - ;;; {Defmacros} ;;; -;;; Depends on: features, eval-case -;;; -(define macro-table (make-weak-key-hash-table 61)) -(define xformer-table (make-weak-key-hash-table 61)) +(define-syntax define-macro + (lambda (x) + "Define a defmacro." + (syntax-case x () + ((_ (macro . args) doc body1 body ...) + (string? (syntax->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ (macro . args) body ...) + (syntax (define-macro macro #f (lambda args body ...)))) + ((_ macro doc transformer) + (or (string? (syntax->datum (syntax doc))) + (not (syntax->datum (syntax doc)))) + (syntax + (define-syntax macro + (lambda (y) + doc + (syntax-case y () + ((_ . args) + (let ((v (syntax->datum (syntax args)))) + (datum->syntax y (apply transformer v)))))))))))) -(define (defmacro? m) (hashq-ref macro-table m)) -(define (assert-defmacro?! m) (hashq-set! macro-table m #t)) -(define (defmacro-transformer m) (hashq-ref xformer-table m)) -(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) - -(define defmacro:transformer - (lambda (f) - (let* ((xform (lambda (exp env) - (copy-tree (apply f (cdr exp))))) - (a (procedure->memoizing-macro xform))) - (assert-defmacro?! a) - (set-defmacro-transformer! a f) - a))) - - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - (let ((transformer `(lambda ,parms ,@body))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))))) - (defmacro:transformer defmacro-transformer))) - - -;; XXX - should the definition of the car really be looked up in the -;; current module? - -(define (macroexpand-1 e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (apply (defmacro-transformer val) (cdr e)) - e))) - (#t e))) - -(define (macroexpand e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (local-ref (list a))))) - (if (defmacro? val) - (macroexpand (apply (defmacro-transformer val) (cdr e))) - e))) - (#t e))) +(define-syntax defmacro + (lambda (x) + "Define a defmacro, with the old lispy defun syntax." + (syntax-case x () + ((_ macro args doc body1 body ...) + (string? (syntax->datum (syntax doc))) + (syntax (define-macro macro doc (lambda args body1 body ...)))) + ((_ macro args body ...) + (syntax (define-macro macro #f (lambda args body ...))))))) (provide 'defmacro) @@ -477,40 +604,6 @@ -;;; {and-map and or-map} -;;; -;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; - -;; and-map f l -;; -;; Apply f to successive elements of l until exhaustion or f returns #f. -;; If returning early, return #f. Otherwise, return the last value returned -;; by f. If f has never been called because l is empty, return #t. -;; -(define (and-map f lst) - (let loop ((result #t) - (l lst)) - (and result - (or (and (null? l) - result) - (loop (f (car l)) (cdr l)))))) - -;; or-map f l -;; -;; Apply f to successive elements of l until exhaustion or while f returns #f. -;; If returning early, return the return value of f. -;; -(define (or-map f lst) - (let loop ((result #f) - (l lst)) - (or result - (and (not (null? l)) - (loop (f (car l)) (cdr l)))))) - - - (if (provided? 'posix) (primitive-load-path "ice-9/posix")) @@ -757,6 +850,26 @@ (start-stack 'load-stack (primitive-load-path name))) +(define %load-verbosely #f) +(define (assert-load-verbosity v) (set! %load-verbosely v)) + +(define (%load-announce file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display "loading ") + (display file) + (newline) + (force-output))))) + +(set! %load-hook %load-announce) + +(define (load name . reader) + (with-fluid* current-reader (and (pair? reader) (car reader)) + (lambda () + (start-stack 'load-stack + (primitive-load name))))) @@ -848,9 +961,6 @@ ;;; Reader code for various "#c" forms. ;;; -(read-hash-extend #\' (lambda (c port) - (read port))) - (define read-eval? (make-fluid)) (fluid-set! read-eval? #f) (read-hash-extend #\. @@ -1133,11 +1243,8 @@ (define (%print-module mod port) ; unused args: depth length style table) (display "#<" port) (display (or (module-kind mod) "module") port) - (let ((name (module-name mod))) - (if name - (begin - (display " " port) - (display name port)))) + (display " " port) + (display (module-name mod) port) (display " " port) (display (number->string (object-address mod) 16) port) (display ">" port)) @@ -1194,7 +1301,8 @@ "Lazy-binder expected to be a procedure or #f." binder)) (let ((module (module-constructor (make-hash-table size) - uses binder #f #f #f #f #f + uses binder #f %pre-modules-transformer + #f #f #f (make-hash-table %default-import-size) '() (make-weak-key-hash-table 31)))) @@ -1219,7 +1327,7 @@ (define module-transformer (record-accessor module-type 'transformer)) (define set-module-transformer! (record-modifier module-type 'transformer)) -(define module-name (record-accessor module-type 'name)) +;; (define module-name (record-accessor module-type 'name)) wait until mods are booted (define set-module-name! (record-modifier module-type 'name)) (define module-kind (record-accessor module-type 'kind)) (define set-module-kind! (record-modifier module-type 'kind)) @@ -1363,7 +1471,9 @@ ;; or its uses? ;; (define (module-bound? m v) - (module-search module-locally-bound? m v)) + (let ((var (module-variable m v))) + (and var + (variable-bound? var)))) ;;; {Is a symbol interned in a module?} ;;; @@ -1799,7 +1909,7 @@ val (let ((m (make-module 31))) (set-module-kind! m 'directory) - (set-module-name! m (append (or (module-name module) '()) + (set-module-name! m (append (module-name module) (list (car name)))) (module-define! module (car name) m) m))) @@ -1853,22 +1963,31 @@ (define default-duplicate-binding-procedures #f) (define %app (make-module 31)) +(set-module-name! %app '(%app)) (define app %app) ;; for backwards compatability -(local-define '(%app modules) (make-module 31)) +(let ((m (make-module 31))) + (set-module-name! m '()) + (local-define '(%app modules) m)) (local-define '(%app modules guile) the-root-module) ;; This boots the module system. All bindings needed by modules.c ;; must have been defined by now. ;; (set-current-module the-root-module) +;; definition deferred for syncase's benefit. +(define module-name + (let ((accessor (record-accessor module-type 'name))) + (lambda (mod) + (or (accessor mod) + (begin + (set-module-name! mod (list (gensym))) + (accessor mod)))))) ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name) - (or (begin-deprecated (try-module-linked name)) - (try-module-autoload name) - (begin-deprecated (try-module-dynamic-link name)))) + (try-module-autoload name)) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -2002,23 +2121,34 @@ ((#:use-module #:use-syntax) (or (pair? (cdr kws)) (unrecognized kws)) - (let* ((interface-args (cadr kws)) - (interface (apply resolve-interface interface-args))) - (and (eq? (car kws) #:use-syntax) - (or (symbol? (caar interface-args)) - (error "invalid module name for use-syntax" - (car interface-args))) - (set-module-transformer! - module - (module-ref interface - (car (last-pair (car interface-args))) - #f))) + (cond + ((equal? (caadr kws) '(ice-9 syncase)) + (issue-deprecation-warning + "(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.") (loop (cddr kws) - (cons interface reversed-interfaces) + reversed-interfaces exports re-exports replacements - autoloads))) + autoloads)) + (else + (let* ((interface-args (cadr kws)) + (interface (apply resolve-interface interface-args))) + (and (eq? (car kws) #:use-syntax) + (or (symbol? (caar interface-args)) + (error "invalid module name for use-syntax" + (car interface-args))) + (set-module-transformer! + module + (module-ref interface + (car (last-pair (car interface-args))) + #f))) + (loop (cddr kws) + (cons interface reversed-interfaces) + exports + re-exports + replacements + autoloads))))) ((#:autoload) (or (and (pair? (cdr kws)) (pair? (cddr kws))) (unrecognized kws)) @@ -2310,11 +2440,12 @@ module '(ice-9 q) '(make-q q-length))}." (define (set-repl-prompt! v) (set! scm-repl-prompt v)) (define (default-pre-unwind-handler key . args) - (save-stack pre-unwind-handler-dispatch) + (save-stack 1) (apply throw key args)) -(define (pre-unwind-handler-dispatch key . args) - (apply default-pre-unwind-handler key args)) +(begin-deprecated + (define (pre-unwind-handler-dispatch key . args) + (apply default-pre-unwind-handler key args))) (define abort-hook (make-hook)) @@ -2391,15 +2522,7 @@ module '(ice-9 q) '(make-q q-length))}." (else (apply bad-throw key args))))))) - ;; Note that having just `pre-unwind-handler-dispatch' - ;; here is connected with the mechanism that - ;; produces a nice backtrace upon error. If, for - ;; example, this is replaced with (lambda args - ;; (apply pre-unwind-handler-dispatch args)), the stack - ;; cutting (in save-stack) goes wrong and ends up - ;; saving no stack at all, so there is no - ;; backtrace. - pre-unwind-handler-dispatch))) + default-pre-unwind-handler))) (if next (loop next) status))) (set! set-batch-mode?! (lambda (arg) @@ -2674,32 +2797,6 @@ module '(ice-9 q) '(make-q q-length))}." `(with-fluids* (list ,@fluids) (list ,@values) (lambda () ,@body))))) - - -;;; {Macros} -;;; - -;; actually....hobbit might be able to hack these with a little -;; coaxing -;; - -(define (primitive-macro? m) - (and (macro? m) - (not (macro-transformer m)))) - -(defmacro define-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(eval-when - (eval load compile) - (define ,name (defmacro:transformer ,transformer))))) - - - - ;;; {While} ;;; ;;; with `continue' and `break'. @@ -2839,50 +2936,33 @@ module '(ice-9 q) '(make-q q-length))}." (defmacro use-syntax (spec) `(eval-when (eval load compile) - ,@(if (pair? spec) - `((process-use-modules (list - (list ,@(compile-interface-spec spec)))) - (set-module-transformer! (current-module) - ,(car (last-pair spec)))) - `((set-module-transformer! (current-module) ,spec))) - *unspecified*)) + (issue-deprecation-warning + "`use-syntax' is deprecated. Please contact guile-devel for more info.") + (process-use-modules (list (list ,@(compile-interface-spec spec)))) + *unspecified*)) ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed ;; as soon as guile supports hygienic macros. -(define define-private define) +(define-syntax define-private + (syntax-rules () + ((_ foo bar) + (define foo bar)))) -(defmacro define-public args - (define (syntax) - (error "bad syntax" (list 'define-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (define-private ,@args) - (export ,name)))))) +(define-syntax define-public + (syntax-rules () + ((_ (name . args) . body) + (define-public name (lambda args . body))) + ((_ name val) + (begin + (define name val) + (export name))))) -(defmacro defmacro-public args - (define (syntax) - (error "bad syntax" (list 'defmacro-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - (else (syntax)))) - (cond - ((null? args) - (syntax)) - (#t - (let ((name (defined-name (car args)))) - `(begin - (export-syntax ,name) - (defmacro ,@args)))))) +(define-syntax defmacro-public + (syntax-rules () + ((_ name args . body) + (begin + (defmacro name args . body) + (export-syntax name))))) ;; Export a local variable @@ -2936,19 +3016,6 @@ module '(ice-9 q) '(make-q q-length))}." (define load load-module) - - -;;; {Compiler interface} -;;; -;;; The full compiler interface can be found in (system). Here we put a -;;; few useful procedures into the global namespace. - -(module-autoload! the-scm-module - '(system base compile) - '(compile - compile-time-environment)) - - ;;; {Parameters} @@ -3371,6 +3438,13 @@ module '(ice-9 q) '(make-q q-length))}." ;;; Place the user in the guile-user module. ;;; -(define-module (guile-user)) +;;; FIXME: annotate ? +;; (define (syncase exp) +;; (with-fluids ((expansion-eval-closure +;; (module-eval-closure (current-module)))) +;; (deannotate/source-properties (sc-expand (annotate exp))))) + +(define-module (guile-user) + #:autoload (system base compile) (compile)) ;;; boot-9.scm ends here diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 10a307be1..2b8eec0d2 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -1,27 +1,20 @@ -(use-modules (ice-9 syncase)) - -;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls -;; `eval' int he `interaction-environment' aka the current module and -;; it expects to have `andmap' there. The reason for this escapes me -;; at the moment. -;; -(define-module (ice-9 syncase)) - -(define source (list-ref (command-line) 1)) -(define target (list-ref (command-line) 2)) - -(let ((in (open-input-file source)) - (out (open-output-file (string-append target ".tmp")))) - (let loop ((x (read in))) - (if (eof-object? x) - (begin - (close-port out) - (close-port in)) - (begin - (write (strip-expansion-structures - (sc-expand3 x 'c '(compile load eval))) - out) - (newline out) - (loop (read in)))))) - -(system (format #f "mv -f ~s.tmp ~s" target target)) +(use-modules (language tree-il)) +(let ((source (list-ref (command-line) 1)) + (target (list-ref (command-line) 2))) + (let ((in (open-input-file source)) + (out (open-output-file (string-append target ".tmp")))) + (write '(eval-when (compile) (set-current-module (resolve-module '(guile)))) + out) + (newline out) + (let loop ((x (read in))) + (if (eof-object? x) + (begin + (close-port out) + (close-port in)) + (begin + (write (tree-il->scheme + (sc-expand x 'c '(compile load eval))) + out) + (newline out) + (loop (read in)))))) + (system (format #f "mv -f ~s.tmp ~s" target target))) diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index c5f447e78..92d31cabc 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -195,15 +195,11 @@ OBJECT can be a procedure, macro or any object that has its `documentation' property set." (or (and (procedure? object) (proc-doc object)) - (and (defmacro? object) - (proc-doc (defmacro-transformer object))) - (and (macro? object) - (let ((transformer (macro-transformer object))) - (and transformer - (proc-doc transformer)))) (object-property object 'documentation) (and (program? object) (program-documentation object)) + (and (macro? object) + (object-documentation (macro-transformer object))) (and (procedure? object) (not (closure? object)) (procedure-name object) diff --git a/module/ice-9/expand-support.scm b/module/ice-9/expand-support.scm deleted file mode 100644 index 372d959a5..000000000 --- a/module/ice-9/expand-support.scm +++ /dev/null @@ -1,169 +0,0 @@ -;;;; Copyright (C) 2009 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 2.1 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 expand-support) - :export ( annotation? annotate deannotate make-annotation - annotation-expression annotation-source annotation-stripped - set-annotation-stripped! - deannotate/source-properties - - make-module-ref - module-ref-symbol module-ref-modname module-ref-public? - - make-lexical - lexical-name lexical-gensym - - strip-expansion-structures)) - -(define - (make-vtable "prprpw" - (lambda (struct port) - (display "#" port)))) - -(define (annotation? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-annotation e s . stripped?) - (if (null? stripped?) - (make-struct 0 e s #f) - (apply make-struct 0 e s stripped?))) - -(define (annotation-expression a) - (struct-ref a 0)) -(define (annotation-source a) - (struct-ref a 1)) -(define (annotation-stripped a) - (struct-ref a 2)) -(define (set-annotation-stripped! a stripped?) - (struct-set! a 2 stripped?)) - -(define (annotate e) - (let ((p (if (pair? e) (source-properties e) #f)) - (out (cond ((and (list? e) (not (null? e))) - (map annotate e)) - ((pair? e) - (cons (annotate (car e)) (annotate (cdr e)))) - (else e)))) - (if (pair? p) - (make-annotation out p #f) - out))) - -(define (deannotate e) - (cond ((list? e) - (map deannotate e)) - ((pair? e) - (cons (deannotate (car e)) (deannotate (cdr e)))) - ((annotation? e) (deannotate (annotation-expression e))) - (else e))) - -(define (deannotate/source-properties e) - (cond ((list? e) - (map deannotate/source-properties e)) - ((pair? e) - (cons (deannotate/source-properties (car e)) - (deannotate/source-properties (cdr e)))) - ((annotation? e) - (let ((e (deannotate/source-properties (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - (else e))) - - - -(define - (make-vtable "prprpr" - (lambda (struct port) - (display "#<" port) - (display (if (module-ref-public? struct) "@ " "@@ ") port) - (display (module-ref-modname struct) port) - (display " " port) - (display (module-ref-symbol struct) port) - (display ">" port)))) - -(define (module-ref? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-module-ref modname symbol public?) - (make-struct 0 modname symbol public?)) - -(define (module-ref-modname a) - (struct-ref a 0)) -(define (module-ref-symbol a) - (struct-ref a 1)) -(define (module-ref-public? a) - (struct-ref a 2)) - - - -(define - (make-vtable "prpr" - (lambda (struct port) - (display "#" port)))) - -(define (lexical? x) - (and (struct? x) (eq? (struct-vtable x) ))) - -(define (make-lexical name gensym) - (make-struct 0 name gensym)) - -(define (lexical-name a) - (struct-ref a 0)) -(define (lexical-gensym a) - (struct-ref a 1)) - - - -(define (strip-expansion-structures e) - (cond ((list? e) - (map strip-expansion-structures e)) - ((pair? e) - (cons (strip-expansion-structures (car e)) - (strip-expansion-structures (cdr e)))) - ((annotation? e) - (let ((e (strip-expansion-structures (annotation-expression e))) - (source (annotation-source e))) - (if (pair? e) - (set-source-properties! e source)) - e)) - ((module-ref? e) - (cond - ((or (not (module-ref-modname e)) - (eq? (module-ref-modname e) - (module-name (current-module))) - (and (not (module-ref-public? e)) - (not (module-variable - (resolve-module (module-ref-modname e)) - (module-ref-symbol e))))) - (module-ref-symbol e)) - (else - `(,(if (module-ref-public? e) '@ '@@) - ,(module-ref-modname e) - ,(module-ref-symbol e))))) - ((lexical? e) - (lexical-gensym e)) - ((record? e) - (error "unexpected record in expansion" e)) - (else e))) diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index e6fe56063..baa4d5aad 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -194,6 +194,6 @@ (define match:runtime-structures #f) (define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v))) (define match:primitive-vector? vector?) -(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) +(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296))))) (defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311)))) -(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) +(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335))))) diff --git a/module/ice-9/networking.scm b/module/ice-9/networking.scm index c0218821f..9a30fc5b6 100644 --- a/module/ice-9/networking.scm +++ b/module/ice-9/networking.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (gethostbyaddr addr) (gethost addr)) (define (gethostbyname name) (gethost name)) diff --git a/module/ice-9/null.scm b/module/ice-9/null.scm index b9212e605..3f9f5b0a5 100644 --- a/module/ice-9/null.scm +++ b/module/ice-9/null.scm @@ -18,7 +18,6 @@ ;;;; The null environment - only syntactic bindings (define-module (ice-9 null) - :use-module (ice-9 syncase) :re-export-syntax (define quote lambda if set! cond case and or diff --git a/module/ice-9/occam-channel.scm b/module/ice-9/occam-channel.scm index e28f73d3b..e04ecac5b 100644 --- a/module/ice-9/occam-channel.scm +++ b/module/ice-9/occam-channel.scm @@ -17,7 +17,6 @@ ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 occam-channel) - #:use-syntax (ice-9 syncase) #:use-module (oop goops) #:use-module (ice-9 threads) #:export-syntax (alt diff --git a/module/ice-9/posix.scm b/module/ice-9/posix.scm index 53d01a026..dd1a12690 100644 --- a/module/ice-9/posix.scm +++ b/module/ice-9/posix.scm @@ -17,6 +17,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (define (stat:dev f) (vector-ref f 0)) (define (stat:ino f) (vector-ref f 1)) (define (stat:mode f) (vector-ref f 2)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 02d9e9975..f33f49286 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,11 +1,13 @@ -(letrec ((syntmp-lambda-var-list-153 (lambda (syntmp-vars-544) (let syntmp-lvl-545 ((syntmp-vars-546 syntmp-vars-544) (syntmp-ls-547 (quote ())) (syntmp-w-548 (quote (())))) (cond ((pair? syntmp-vars-546) (syntmp-lvl-545 (cdr syntmp-vars-546) (cons (syntmp-wrap-132 (car syntmp-vars-546) syntmp-w-548 #f) syntmp-ls-547) syntmp-w-548)) ((syntmp-id?-104 syntmp-vars-546) (cons (syntmp-wrap-132 syntmp-vars-546 syntmp-w-548 #f) syntmp-ls-547)) ((null? syntmp-vars-546) syntmp-ls-547) ((syntmp-syntax-object?-88 syntmp-vars-546) (syntmp-lvl-545 (syntmp-syntax-object-expression-89 syntmp-vars-546) syntmp-ls-547 (syntmp-join-wraps-123 syntmp-w-548 (syntmp-syntax-object-wrap-90 syntmp-vars-546)))) ((annotation? syntmp-vars-546) (syntmp-lvl-545 (annotation-expression syntmp-vars-546) syntmp-ls-547 syntmp-w-548)) (else (cons syntmp-vars-546 syntmp-ls-547)))))) (syntmp-gen-var-152 (lambda (syntmp-id-549) (let ((syntmp-id-550 (if (syntmp-syntax-object?-88 syntmp-id-549) (syntmp-syntax-object-expression-89 syntmp-id-549) syntmp-id-549))) (if (annotation? syntmp-id-550) (syntmp-build-annotated-81 (annotation-source syntmp-id-550) (gensym (symbol->string (annotation-expression syntmp-id-550)))) (syntmp-build-annotated-81 #f (gensym (symbol->string syntmp-id-550))))))) (syntmp-strip-151 (lambda (syntmp-x-551 syntmp-w-552) (if (memq (quote top) (syntmp-wrap-marks-107 syntmp-w-552)) (if (or (annotation? syntmp-x-551) (and (pair? syntmp-x-551) (annotation? (car syntmp-x-551)))) (syntmp-strip-annotation-150 syntmp-x-551 #f) syntmp-x-551) (let syntmp-f-553 ((syntmp-x-554 syntmp-x-551)) (cond ((syntmp-syntax-object?-88 syntmp-x-554) (syntmp-strip-151 (syntmp-syntax-object-expression-89 syntmp-x-554) (syntmp-syntax-object-wrap-90 syntmp-x-554))) ((pair? syntmp-x-554) (let ((syntmp-a-555 (syntmp-f-553 (car syntmp-x-554))) (syntmp-d-556 (syntmp-f-553 (cdr syntmp-x-554)))) (if (and (eq? syntmp-a-555 (car syntmp-x-554)) (eq? syntmp-d-556 (cdr syntmp-x-554))) syntmp-x-554 (cons syntmp-a-555 syntmp-d-556)))) ((vector? syntmp-x-554) (let ((syntmp-old-557 (vector->list syntmp-x-554))) (let ((syntmp-new-558 (map syntmp-f-553 syntmp-old-557))) (if (andmap eq? syntmp-old-557 syntmp-new-558) syntmp-x-554 (list->vector syntmp-new-558))))) (else syntmp-x-554)))))) (syntmp-strip-annotation-150 (lambda (syntmp-x-559 syntmp-parent-560) (cond ((pair? syntmp-x-559) (let ((syntmp-new-561 (cons #f #f))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-561)) (set-car! syntmp-new-561 (syntmp-strip-annotation-150 (car syntmp-x-559) #f)) (set-cdr! syntmp-new-561 (syntmp-strip-annotation-150 (cdr syntmp-x-559) #f)) syntmp-new-561))) ((annotation? syntmp-x-559) (or (annotation-stripped syntmp-x-559) (syntmp-strip-annotation-150 (annotation-expression syntmp-x-559) syntmp-x-559))) ((vector? syntmp-x-559) (let ((syntmp-new-562 (make-vector (vector-length syntmp-x-559)))) (begin (if syntmp-parent-560 (set-annotation-stripped! syntmp-parent-560 syntmp-new-562)) (let syntmp-loop-563 ((syntmp-i-564 (- (vector-length syntmp-x-559) 1))) (unless (syntmp-fx<-75 syntmp-i-564 0) (vector-set! syntmp-new-562 syntmp-i-564 (syntmp-strip-annotation-150 (vector-ref syntmp-x-559 syntmp-i-564) #f)) (syntmp-loop-563 (syntmp-fx--73 syntmp-i-564 1)))) syntmp-new-562))) (else syntmp-x-559)))) (syntmp-ellipsis?-149 (lambda (syntmp-x-565) (and (syntmp-nonsymbol-id?-103 syntmp-x-565) (syntmp-free-id=?-127 syntmp-x-565 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))))))) (syntmp-chi-void-148 (lambda () (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote void)))))) (syntmp-eval-local-transformer-147 (lambda (syntmp-expanded-566 syntmp-mod-567) (let ((syntmp-p-568 (syntmp-local-eval-hook-77 syntmp-expanded-566 syntmp-mod-567))) (if (procedure? syntmp-p-568) syntmp-p-568 (syntax-error syntmp-p-568 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-146 (lambda (syntmp-rec?-569 syntmp-e-570 syntmp-r-571 syntmp-w-572 syntmp-s-573 syntmp-mod-574 syntmp-k-575) ((lambda (syntmp-tmp-576) ((lambda (syntmp-tmp-577) (if syntmp-tmp-577 (apply (lambda (syntmp-_-578 syntmp-id-579 syntmp-val-580 syntmp-e1-581 syntmp-e2-582) (let ((syntmp-ids-583 syntmp-id-579)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-583)) (syntax-error syntmp-e-570 "duplicate bound keyword in") (let ((syntmp-labels-585 (syntmp-gen-labels-110 syntmp-ids-583))) (let ((syntmp-new-w-586 (syntmp-make-binding-wrap-121 syntmp-ids-583 syntmp-labels-585 syntmp-w-572))) (syntmp-k-575 (cons syntmp-e1-581 syntmp-e2-582) (syntmp-extend-env-98 syntmp-labels-585 (let ((syntmp-w-588 (if syntmp-rec?-569 syntmp-new-w-586 syntmp-w-572)) (syntmp-trans-r-589 (syntmp-macros-only-env-100 syntmp-r-571))) (map (lambda (syntmp-x-590) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-590 syntmp-trans-r-589 syntmp-w-588 syntmp-mod-574) syntmp-mod-574))) syntmp-val-580)) syntmp-r-571) syntmp-new-w-586 syntmp-s-573 syntmp-mod-574)))))) syntmp-tmp-577) ((lambda (syntmp-_-592) (syntax-error (syntmp-source-wrap-133 syntmp-e-570 syntmp-w-572 syntmp-s-573 syntmp-mod-574))) syntmp-tmp-576))) (syntax-dispatch syntmp-tmp-576 (quote (any #(each (any any)) any . each-any))))) syntmp-e-570))) (syntmp-chi-lambda-clause-145 (lambda (syntmp-e-593 syntmp-c-594 syntmp-r-595 syntmp-w-596 syntmp-mod-597 syntmp-k-598) ((lambda (syntmp-tmp-599) ((lambda (syntmp-tmp-600) (if syntmp-tmp-600 (apply (lambda (syntmp-id-601 syntmp-e1-602 syntmp-e2-603) (let ((syntmp-ids-604 syntmp-id-601)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-604)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-606 (syntmp-gen-labels-110 syntmp-ids-604)) (syntmp-new-vars-607 (map syntmp-gen-var-152 syntmp-ids-604))) (syntmp-k-598 syntmp-new-vars-607 (syntmp-chi-body-144 (cons syntmp-e1-602 syntmp-e2-603) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-606 syntmp-new-vars-607 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-ids-604 syntmp-labels-606 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-600) ((lambda (syntmp-tmp-609) (if syntmp-tmp-609 (apply (lambda (syntmp-ids-610 syntmp-e1-611 syntmp-e2-612) (let ((syntmp-old-ids-613 (syntmp-lambda-var-list-153 syntmp-ids-610))) (if (not (syntmp-valid-bound-ids?-129 syntmp-old-ids-613)) (syntax-error syntmp-e-593 "invalid parameter list in") (let ((syntmp-labels-614 (syntmp-gen-labels-110 syntmp-old-ids-613)) (syntmp-new-vars-615 (map syntmp-gen-var-152 syntmp-old-ids-613))) (syntmp-k-598 (let syntmp-f-616 ((syntmp-ls1-617 (cdr syntmp-new-vars-615)) (syntmp-ls2-618 (car syntmp-new-vars-615))) (if (null? syntmp-ls1-617) syntmp-ls2-618 (syntmp-f-616 (cdr syntmp-ls1-617) (cons (car syntmp-ls1-617) syntmp-ls2-618)))) (syntmp-chi-body-144 (cons syntmp-e1-611 syntmp-e2-612) syntmp-e-593 (syntmp-extend-var-env-99 syntmp-labels-614 syntmp-new-vars-615 syntmp-r-595) (syntmp-make-binding-wrap-121 syntmp-old-ids-613 syntmp-labels-614 syntmp-w-596) syntmp-mod-597)))))) syntmp-tmp-609) ((lambda (syntmp-_-620) (syntax-error syntmp-e-593)) syntmp-tmp-599))) (syntax-dispatch syntmp-tmp-599 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-599 (quote (each-any any . each-any))))) syntmp-c-594))) (syntmp-chi-body-144 (lambda (syntmp-body-621 syntmp-outer-form-622 syntmp-r-623 syntmp-w-624 syntmp-mod-625) (let ((syntmp-r-626 (cons (quote ("placeholder" placeholder)) syntmp-r-623))) (let ((syntmp-ribcage-627 (syntmp-make-ribcage-111 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-628 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-624) (cons syntmp-ribcage-627 (syntmp-wrap-subst-108 syntmp-w-624))))) (let syntmp-parse-629 ((syntmp-body-630 (map (lambda (syntmp-x-636) (cons syntmp-r-626 (syntmp-wrap-132 syntmp-x-636 syntmp-w-628 syntmp-mod-625))) syntmp-body-621)) (syntmp-ids-631 (quote ())) (syntmp-labels-632 (quote ())) (syntmp-vars-633 (quote ())) (syntmp-vals-634 (quote ())) (syntmp-bindings-635 (quote ()))) (if (null? syntmp-body-630) (syntax-error syntmp-outer-form-622 "no expressions in body") (let ((syntmp-e-637 (cdar syntmp-body-630)) (syntmp-er-638 (caar syntmp-body-630))) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-637 syntmp-er-638 (quote (())) #f syntmp-ribcage-627 syntmp-mod-625)) (lambda (syntmp-type-639 syntmp-value-640 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644) (let ((syntmp-t-645 syntmp-type-639)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-647 (syntmp-gen-label-109))) (let ((syntmp-var-648 (syntmp-gen-var-152 syntmp-id-646))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-646 syntmp-label-647) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-646 syntmp-ids-631) (cons syntmp-label-647 syntmp-labels-632) (cons syntmp-var-648 syntmp-vars-633) (cons (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644)) syntmp-vals-634) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-635))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-132 syntmp-value-640 syntmp-w-642 syntmp-mod-644)) (syntmp-label-650 (syntmp-gen-label-109))) (begin (syntmp-extend-ribcage!-120 syntmp-ribcage-627 syntmp-id-649 syntmp-label-650) (syntmp-parse-629 (cdr syntmp-body-630) (cons syntmp-id-649 syntmp-ids-631) (cons syntmp-label-650 syntmp-labels-632) syntmp-vars-633 syntmp-vals-634 (cons (cons (quote macro) (cons syntmp-er-638 (syntmp-wrap-132 syntmp-e-641 syntmp-w-642 syntmp-mod-644))) syntmp-bindings-635)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-629 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-630) (cons (cons syntmp-er-638 (syntmp-wrap-132 (car syntmp-forms-656) syntmp-w-642 syntmp-mod-644)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-641) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-640 syntmp-e-641 syntmp-er-638 syntmp-w-642 syntmp-s-643 syntmp-mod-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661 syntmp-mod-662) (syntmp-parse-629 (let syntmp-f-663 ((syntmp-forms-664 syntmp-forms-658)) (if (null? syntmp-forms-664) (cdr syntmp-body-630) (cons (cons syntmp-er-659 (syntmp-wrap-132 (car syntmp-forms-664) syntmp-w-660 syntmp-mod-662)) (syntmp-f-663 (cdr syntmp-forms-664))))) syntmp-ids-631 syntmp-labels-632 syntmp-vars-633 syntmp-vals-634 syntmp-bindings-635))) (if (null? syntmp-ids-631) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-665) (syntmp-chi-140 (cdr syntmp-x-665) (car syntmp-x-665) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))) (begin (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-631)) (syntax-error syntmp-outer-form-622 "invalid or duplicate identifier in definition")) (let syntmp-loop-666 ((syntmp-bs-667 syntmp-bindings-635) (syntmp-er-cache-668 #f) (syntmp-r-cache-669 #f)) (if (not (null? syntmp-bs-667)) (let ((syntmp-b-670 (car syntmp-bs-667))) (if (eq? (car syntmp-b-670) (quote macro)) (let ((syntmp-er-671 (cadr syntmp-b-670))) (let ((syntmp-r-cache-672 (if (eq? syntmp-er-671 syntmp-er-cache-668) syntmp-r-cache-669 (syntmp-macros-only-env-100 syntmp-er-671)))) (begin (set-cdr! syntmp-b-670 (syntmp-eval-local-transformer-147 (syntmp-chi-140 (cddr syntmp-b-670) syntmp-r-cache-672 (quote (())) syntmp-mod-644) syntmp-mod-644)) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-671 syntmp-r-cache-672)))) (syntmp-loop-666 (cdr syntmp-bs-667) syntmp-er-cache-668 syntmp-r-cache-669))))) (set-cdr! syntmp-r-626 (syntmp-extend-env-98 syntmp-labels-632 syntmp-bindings-635 (cdr syntmp-r-626))) (syntmp-build-letrec-86 #f syntmp-vars-633 (map (lambda (syntmp-x-673) (syntmp-chi-140 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())) syntmp-mod-644)) syntmp-vals-634) (syntmp-build-sequence-83 #f (map (lambda (syntmp-x-674) (syntmp-chi-140 (cdr syntmp-x-674) (car syntmp-x-674) (quote (())) syntmp-mod-644)) (cons (cons syntmp-er-638 (syntmp-source-wrap-133 syntmp-e-641 syntmp-w-642 syntmp-s-643 syntmp-mod-644)) (cdr syntmp-body-630)))))))))))))))))))))) (syntmp-chi-macro-143 (lambda (syntmp-p-675 syntmp-e-676 syntmp-r-677 syntmp-w-678 syntmp-rib-679 syntmp-mod-680) (letrec ((syntmp-rebuild-macro-output-681 (lambda (syntmp-x-682 syntmp-m-683) (cond ((pair? syntmp-x-682) (cons (syntmp-rebuild-macro-output-681 (car syntmp-x-682) syntmp-m-683) (syntmp-rebuild-macro-output-681 (cdr syntmp-x-682) syntmp-m-683))) ((syntmp-syntax-object?-88 syntmp-x-682) (let ((syntmp-w-684 (syntmp-syntax-object-wrap-90 syntmp-x-682))) (let ((syntmp-ms-685 (syntmp-wrap-marks-107 syntmp-w-684)) (syntmp-s-686 (syntmp-wrap-subst-108 syntmp-w-684))) (if (and (pair? syntmp-ms-685) (eq? (car syntmp-ms-685) #f)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cdr syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cdr syntmp-s-686)) (cdr syntmp-s-686))) (syntmp-syntax-object-module-91 syntmp-x-682)) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-682) (syntmp-make-wrap-106 (cons syntmp-m-683 syntmp-ms-685) (if syntmp-rib-679 (cons syntmp-rib-679 (cons (quote shift) syntmp-s-686)) (cons (quote shift) syntmp-s-686))) (module-name (procedure-module syntmp-p-675))))))) ((vector? syntmp-x-682) (let ((syntmp-n-687 (vector-length syntmp-x-682))) (let ((syntmp-v-688 (make-vector syntmp-n-687))) (let syntmp-doloop-689 ((syntmp-i-690 0)) (if (syntmp-fx=-74 syntmp-i-690 syntmp-n-687) syntmp-v-688 (begin (vector-set! syntmp-v-688 syntmp-i-690 (syntmp-rebuild-macro-output-681 (vector-ref syntmp-x-682 syntmp-i-690) syntmp-m-683)) (syntmp-doloop-689 (syntmp-fx+-72 syntmp-i-690 1)))))))) ((symbol? syntmp-x-682) (syntax-error syntmp-x-682 "encountered raw symbol in macro output")) (else syntmp-x-682))))) (syntmp-rebuild-macro-output-681 (syntmp-p-675 (syntmp-wrap-132 syntmp-e-676 (syntmp-anti-mark-119 syntmp-w-678) syntmp-mod-680)) (string #\m))))) (syntmp-chi-application-142 (lambda (syntmp-x-691 syntmp-e-692 syntmp-r-693 syntmp-w-694 syntmp-s-695 syntmp-mod-696) ((lambda (syntmp-tmp-697) ((lambda (syntmp-tmp-698) (if syntmp-tmp-698 (apply (lambda (syntmp-e0-699 syntmp-e1-700) (syntmp-build-annotated-81 syntmp-s-695 (cons syntmp-x-691 (map (lambda (syntmp-e-701) (syntmp-chi-140 syntmp-e-701 syntmp-r-693 syntmp-w-694 syntmp-mod-696)) syntmp-e1-700)))) syntmp-tmp-698) (syntax-error syntmp-tmp-697))) (syntax-dispatch syntmp-tmp-697 (quote (any . each-any))))) syntmp-e-692))) (syntmp-chi-expr-141 (lambda (syntmp-type-703 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (let ((syntmp-t-710 syntmp-type-703)) (if (memv syntmp-t-710 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-708 syntmp-value-704) (if (memv syntmp-t-710 (quote (core external-macro))) (syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-704 syntmp-e-705)) (lambda (syntmp-id-711 syntmp-mod-712) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-712 syntmp-id-711 #f)))) (if (memv syntmp-t-710 (quote (lexical-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) syntmp-value-704) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (global-call))) (syntmp-chi-application-142 (syntmp-build-annotated-81 (syntmp-source-annotation-95 (car syntmp-e-705)) (make-module-ref (if (syntmp-syntax-object?-88 (car syntmp-e-705)) (syntmp-syntax-object-module-91 (car syntmp-e-705)) syntmp-mod-709) syntmp-value-704 #f)) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (constant))) (syntmp-build-data-82 syntmp-s-708 (syntmp-strip-151 (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (quote (())))) (if (memv syntmp-t-710 (quote (global))) (syntmp-build-annotated-81 syntmp-s-708 (make-module-ref syntmp-mod-709 syntmp-value-704 #f)) (if (memv syntmp-t-710 (quote (call))) (syntmp-chi-application-142 (syntmp-chi-140 (car syntmp-e-705) syntmp-r-706 syntmp-w-707 syntmp-mod-709) syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (if (memv syntmp-t-710 (quote (begin-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-e1-716 syntmp-e2-717) (syntmp-chi-sequence-134 (cons syntmp-e1-716 syntmp-e2-717) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709)) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-704 syntmp-e-705 syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709 syntmp-chi-sequence-134) (if (memv syntmp-t-710 (quote (eval-when-form))) ((lambda (syntmp-tmp-719) ((lambda (syntmp-tmp-720) (if syntmp-tmp-720 (apply (lambda (syntmp-_-721 syntmp-x-722 syntmp-e1-723 syntmp-e2-724) (let ((syntmp-when-list-725 (syntmp-chi-when-list-137 syntmp-e-705 syntmp-x-722 syntmp-w-707))) (if (memq (quote eval) syntmp-when-list-725) (syntmp-chi-sequence-134 (cons syntmp-e1-723 syntmp-e2-724) syntmp-r-706 syntmp-w-707 syntmp-s-708 syntmp-mod-709) (syntmp-chi-void-148)))) syntmp-tmp-720) (syntax-error syntmp-tmp-719))) (syntax-dispatch syntmp-tmp-719 (quote (any each-any any . each-any))))) syntmp-e-705) (if (memv syntmp-t-710 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-132 syntmp-value-704 syntmp-w-707 syntmp-mod-709) "invalid context for definition of") (if (memv syntmp-t-710 (quote (syntax))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to pattern variable outside syntax form") (if (memv syntmp-t-710 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-133 syntmp-e-705 syntmp-w-707 syntmp-s-708 syntmp-mod-709))))))))))))))))))) (syntmp-chi-140 (lambda (syntmp-e-728 syntmp-r-729 syntmp-w-730 syntmp-mod-731) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-728 syntmp-r-729 syntmp-w-730 #f #f syntmp-mod-731)) (lambda (syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-w-735 syntmp-s-736 syntmp-mod-737) (syntmp-chi-expr-141 syntmp-type-732 syntmp-value-733 syntmp-e-734 syntmp-r-729 syntmp-w-735 syntmp-s-736 syntmp-mod-737))))) (syntmp-chi-top-139 (lambda (syntmp-e-738 syntmp-r-739 syntmp-w-740 syntmp-m-741 syntmp-esew-742 syntmp-mod-743) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-e-738 syntmp-r-739 syntmp-w-740 #f #f syntmp-mod-743)) (lambda (syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-w-761 syntmp-s-762 syntmp-mod-763) (let ((syntmp-t-764 syntmp-type-758)) (if (memv syntmp-t-764 (quote (begin-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767) (syntmp-chi-void-148)) syntmp-tmp-766) ((lambda (syntmp-tmp-768) (if syntmp-tmp-768 (apply (lambda (syntmp-_-769 syntmp-e1-770 syntmp-e2-771) (syntmp-chi-top-sequence-135 (cons syntmp-e1-770 syntmp-e2-771) syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-m-741 syntmp-esew-742 syntmp-mod-763)) syntmp-tmp-768) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-765 (quote (any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (local-syntax-form))) (syntmp-chi-local-syntax-146 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763 (lambda (syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-mod-777) (syntmp-chi-top-sequence-135 syntmp-body-773 syntmp-r-774 syntmp-w-775 syntmp-s-776 syntmp-m-741 syntmp-esew-742 syntmp-mod-777))) (if (memv syntmp-t-764 (quote (eval-when-form))) ((lambda (syntmp-tmp-778) ((lambda (syntmp-tmp-779) (if syntmp-tmp-779 (apply (lambda (syntmp-_-780 syntmp-x-781 syntmp-e1-782 syntmp-e2-783) (let ((syntmp-when-list-784 (syntmp-chi-when-list-137 syntmp-e-760 syntmp-x-781 syntmp-w-761)) (syntmp-body-785 (cons syntmp-e1-782 syntmp-e2-783))) (cond ((eq? syntmp-m-741 (quote e)) (if (memq (quote eval) syntmp-when-list-784) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) (syntmp-chi-void-148))) ((memq (quote load) syntmp-when-list-784) (if (or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c&e) (quote (compile load)) syntmp-mod-763) (if (memq syntmp-m-741 (quote (c c&e))) (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote c) (quote (load)) syntmp-mod-763) (syntmp-chi-void-148)))) ((or (memq (quote compile) syntmp-when-list-784) (and (eq? syntmp-m-741 (quote c&e)) (memq (quote eval) syntmp-when-list-784))) (syntmp-top-level-eval-hook-76 (syntmp-chi-top-sequence-135 syntmp-body-785 syntmp-r-739 syntmp-w-761 syntmp-s-762 (quote e) (quote (eval)) syntmp-mod-763) syntmp-mod-763) (syntmp-chi-void-148)) (else (syntmp-chi-void-148))))) syntmp-tmp-779) (syntax-error syntmp-tmp-778))) (syntax-dispatch syntmp-tmp-778 (quote (any each-any any . each-any))))) syntmp-e-760) (if (memv syntmp-t-764 (quote (define-syntax-form))) (let ((syntmp-n-788 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761)) (syntmp-r-789 (syntmp-macros-only-env-100 syntmp-r-739))) (let ((syntmp-t-790 syntmp-m-741)) (if (memv syntmp-t-790 (quote (c))) (if (memq (quote compile) syntmp-esew-742) (let ((syntmp-e-791 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-791 syntmp-mod-763) (if (memq (quote load) syntmp-esew-742) syntmp-e-791 (syntmp-chi-void-148)))) (if (memq (quote load) syntmp-esew-742) (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) (syntmp-chi-void-148))) (if (memv syntmp-t-790 (quote (c&e))) (let ((syntmp-e-792 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)))) (begin (syntmp-top-level-eval-hook-76 syntmp-e-792 syntmp-mod-763) syntmp-e-792)) (begin (if (memq (quote eval) syntmp-esew-742) (syntmp-top-level-eval-hook-76 (syntmp-chi-install-global-136 syntmp-n-788 (syntmp-chi-140 syntmp-e-760 syntmp-r-789 syntmp-w-761 syntmp-mod-763)) syntmp-mod-763)) (syntmp-chi-void-148)))))) (if (memv syntmp-t-764 (quote (define-form))) (let ((syntmp-n-793 (syntmp-id-var-name-126 syntmp-value-759 syntmp-w-761))) (let ((syntmp-type-794 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-793 syntmp-r-739 syntmp-mod-763)))) (let ((syntmp-t-795 syntmp-type-794)) (if (memv syntmp-t-795 (quote (global))) (let ((syntmp-x-796 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-796 syntmp-mod-763)) syntmp-x-796)) (if (memv syntmp-t-795 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "identifier out of context") (if (eq? syntmp-type-794 (quote external-macro)) (let ((syntmp-x-797 (syntmp-build-annotated-81 syntmp-s-762 (list (quote define) syntmp-n-793 (syntmp-chi-140 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-mod-763))))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-797 syntmp-mod-763)) syntmp-x-797)) (syntax-error (syntmp-wrap-132 syntmp-value-759 syntmp-w-761 syntmp-mod-763) "cannot define keyword at top level"))))))) (let ((syntmp-x-798 (syntmp-chi-expr-141 syntmp-type-758 syntmp-value-759 syntmp-e-760 syntmp-r-739 syntmp-w-761 syntmp-s-762 syntmp-mod-763))) (begin (if (eq? syntmp-m-741 (quote c&e)) (syntmp-top-level-eval-hook-76 syntmp-x-798 syntmp-mod-763)) syntmp-x-798)))))))))))) (syntmp-syntax-type-138 (lambda (syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (cond ((symbol? syntmp-e-799) (let ((syntmp-n-805 (syntmp-id-var-name-126 syntmp-e-799 syntmp-w-801))) (let ((syntmp-b-806 (syntmp-lookup-101 syntmp-n-805 syntmp-r-800 syntmp-mod-804))) (let ((syntmp-type-807 (syntmp-binding-type-96 syntmp-b-806))) (let ((syntmp-t-808 syntmp-type-807)) (if (memv syntmp-t-808 (quote (lexical))) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (global))) (values syntmp-type-807 syntmp-n-805 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-808 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (values syntmp-type-807 (syntmp-binding-value-97 syntmp-b-806) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))))))) ((pair? syntmp-e-799) (let ((syntmp-first-809 (car syntmp-e-799))) (if (syntmp-id?-104 syntmp-first-809) (let ((syntmp-n-810 (syntmp-id-var-name-126 syntmp-first-809 syntmp-w-801))) (let ((syntmp-b-811 (syntmp-lookup-101 syntmp-n-810 syntmp-r-800 (or (and (syntmp-syntax-object?-88 syntmp-first-809) (syntmp-syntax-object-module-91 syntmp-first-809)) syntmp-mod-804)))) (let ((syntmp-type-812 (syntmp-binding-type-96 syntmp-b-811))) (let ((syntmp-t-813 syntmp-type-812)) (if (memv syntmp-t-813 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (global))) (values (quote global-call) syntmp-n-810 syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (macro))) (syntmp-syntax-type-138 (syntmp-chi-macro-143 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-r-800 syntmp-w-801 syntmp-rib-803 syntmp-mod-804) syntmp-r-800 (quote (())) syntmp-s-802 syntmp-rib-803 syntmp-mod-804) (if (memv syntmp-t-813 (quote (core external-macro module-ref))) (values syntmp-type-812 (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-97 syntmp-b-811) syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (begin))) (values (quote begin-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804) (if (memv syntmp-t-813 (quote (define))) ((lambda (syntmp-tmp-814) ((lambda (syntmp-tmp-815) (if (if syntmp-tmp-815 (apply (lambda (syntmp-_-816 syntmp-name-817 syntmp-val-818) (syntmp-id?-104 syntmp-name-817)) syntmp-tmp-815) #f) (apply (lambda (syntmp-_-819 syntmp-name-820 syntmp-val-821) (values (quote define-form) syntmp-name-820 syntmp-val-821 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-815) ((lambda (syntmp-tmp-822) (if (if syntmp-tmp-822 (apply (lambda (syntmp-_-823 syntmp-name-824 syntmp-args-825 syntmp-e1-826 syntmp-e2-827) (and (syntmp-id?-104 syntmp-name-824) (syntmp-valid-bound-ids?-129 (syntmp-lambda-var-list-153 syntmp-args-825)))) syntmp-tmp-822) #f) (apply (lambda (syntmp-_-828 syntmp-name-829 syntmp-args-830 syntmp-e1-831 syntmp-e2-832) (values (quote define-form) (syntmp-wrap-132 syntmp-name-829 syntmp-w-801 syntmp-mod-804) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) (syntmp-wrap-132 (cons syntmp-args-830 (cons syntmp-e1-831 syntmp-e2-832)) syntmp-w-801 syntmp-mod-804)) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-822) ((lambda (syntmp-tmp-834) (if (if syntmp-tmp-834 (apply (lambda (syntmp-_-835 syntmp-name-836) (syntmp-id?-104 syntmp-name-836)) syntmp-tmp-834) #f) (apply (lambda (syntmp-_-837 syntmp-name-838) (values (quote define-form) (syntmp-wrap-132 syntmp-name-838 syntmp-w-801 syntmp-mod-804) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote (())) syntmp-s-802 syntmp-mod-804)) syntmp-tmp-834) (syntax-error syntmp-tmp-814))) (syntax-dispatch syntmp-tmp-814 (quote (any any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-814 (quote (any any any))))) syntmp-e-799) (if (memv syntmp-t-813 (quote (define-syntax))) ((lambda (syntmp-tmp-839) ((lambda (syntmp-tmp-840) (if (if syntmp-tmp-840 (apply (lambda (syntmp-_-841 syntmp-name-842 syntmp-val-843) (syntmp-id?-104 syntmp-name-842)) syntmp-tmp-840) #f) (apply (lambda (syntmp-_-844 syntmp-name-845 syntmp-val-846) (values (quote define-syntax-form) syntmp-name-845 syntmp-val-846 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) syntmp-tmp-840) (syntax-error syntmp-tmp-839))) (syntax-dispatch syntmp-tmp-839 (quote (any any any))))) syntmp-e-799) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))))))))))))) (values (quote call) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)))) ((syntmp-syntax-object?-88 syntmp-e-799) (syntmp-syntax-type-138 (syntmp-syntax-object-expression-89 syntmp-e-799) syntmp-r-800 (syntmp-join-wraps-123 syntmp-w-801 (syntmp-syntax-object-wrap-90 syntmp-e-799)) #f syntmp-rib-803 (or (syntmp-syntax-object-module-91 syntmp-e-799) syntmp-mod-804))) ((annotation? syntmp-e-799) (syntmp-syntax-type-138 (annotation-expression syntmp-e-799) syntmp-r-800 syntmp-w-801 (annotation-source syntmp-e-799) syntmp-rib-803 syntmp-mod-804)) ((self-evaluating? syntmp-e-799) (values (quote constant) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804)) (else (values (quote other) #f syntmp-e-799 syntmp-w-801 syntmp-s-802 syntmp-mod-804))))) (syntmp-chi-when-list-137 (lambda (syntmp-e-847 syntmp-when-list-848 syntmp-w-849) (let syntmp-f-850 ((syntmp-when-list-851 syntmp-when-list-848) (syntmp-situations-852 (quote ()))) (if (null? syntmp-when-list-851) syntmp-situations-852 (syntmp-f-850 (cdr syntmp-when-list-851) (cons (let ((syntmp-x-853 (car syntmp-when-list-851))) (cond ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote compile)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote load)) ((syntmp-free-id=?-127 syntmp-x-853 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))) (quote eval)) (else (syntax-error (syntmp-wrap-132 syntmp-x-853 syntmp-w-849 #f) "invalid eval-when situation")))) syntmp-situations-852)))))) (syntmp-chi-install-global-136 (lambda (syntmp-name-854 syntmp-e-855) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote install-global-transformer)) (syntmp-build-data-82 #f syntmp-name-854) syntmp-e-855)))) (syntmp-chi-top-sequence-135 (lambda (syntmp-body-856 syntmp-r-857 syntmp-w-858 syntmp-s-859 syntmp-m-860 syntmp-esew-861 syntmp-mod-862) (syntmp-build-sequence-83 syntmp-s-859 (let syntmp-dobody-863 ((syntmp-body-864 syntmp-body-856) (syntmp-r-865 syntmp-r-857) (syntmp-w-866 syntmp-w-858) (syntmp-m-867 syntmp-m-860) (syntmp-esew-868 syntmp-esew-861) (syntmp-mod-869 syntmp-mod-862)) (if (null? syntmp-body-864) (quote ()) (let ((syntmp-first-870 (syntmp-chi-top-139 (car syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869))) (cons syntmp-first-870 (syntmp-dobody-863 (cdr syntmp-body-864) syntmp-r-865 syntmp-w-866 syntmp-m-867 syntmp-esew-868 syntmp-mod-869)))))))) (syntmp-chi-sequence-134 (lambda (syntmp-body-871 syntmp-r-872 syntmp-w-873 syntmp-s-874 syntmp-mod-875) (syntmp-build-sequence-83 syntmp-s-874 (let syntmp-dobody-876 ((syntmp-body-877 syntmp-body-871) (syntmp-r-878 syntmp-r-872) (syntmp-w-879 syntmp-w-873) (syntmp-mod-880 syntmp-mod-875)) (if (null? syntmp-body-877) (quote ()) (let ((syntmp-first-881 (syntmp-chi-140 (car syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880))) (cons syntmp-first-881 (syntmp-dobody-876 (cdr syntmp-body-877) syntmp-r-878 syntmp-w-879 syntmp-mod-880)))))))) (syntmp-source-wrap-133 (lambda (syntmp-x-882 syntmp-w-883 syntmp-s-884 syntmp-defmod-885) (syntmp-wrap-132 (if syntmp-s-884 (make-annotation syntmp-x-882 syntmp-s-884 #f) syntmp-x-882) syntmp-w-883 syntmp-defmod-885))) (syntmp-wrap-132 (lambda (syntmp-x-886 syntmp-w-887 syntmp-defmod-888) (cond ((and (null? (syntmp-wrap-marks-107 syntmp-w-887)) (null? (syntmp-wrap-subst-108 syntmp-w-887))) syntmp-x-886) ((syntmp-syntax-object?-88 syntmp-x-886) (syntmp-make-syntax-object-87 (syntmp-syntax-object-expression-89 syntmp-x-886) (syntmp-join-wraps-123 syntmp-w-887 (syntmp-syntax-object-wrap-90 syntmp-x-886)) (syntmp-syntax-object-module-91 syntmp-x-886))) ((null? syntmp-x-886) syntmp-x-886) (else (syntmp-make-syntax-object-87 syntmp-x-886 syntmp-w-887 syntmp-defmod-888))))) (syntmp-bound-id-member?-131 (lambda (syntmp-x-889 syntmp-list-890) (and (not (null? syntmp-list-890)) (or (syntmp-bound-id=?-128 syntmp-x-889 (car syntmp-list-890)) (syntmp-bound-id-member?-131 syntmp-x-889 (cdr syntmp-list-890)))))) (syntmp-distinct-bound-ids?-130 (lambda (syntmp-ids-891) (let syntmp-distinct?-892 ((syntmp-ids-893 syntmp-ids-891)) (or (null? syntmp-ids-893) (and (not (syntmp-bound-id-member?-131 (car syntmp-ids-893) (cdr syntmp-ids-893))) (syntmp-distinct?-892 (cdr syntmp-ids-893))))))) (syntmp-valid-bound-ids?-129 (lambda (syntmp-ids-894) (and (let syntmp-all-ids?-895 ((syntmp-ids-896 syntmp-ids-894)) (or (null? syntmp-ids-896) (and (syntmp-id?-104 (car syntmp-ids-896)) (syntmp-all-ids?-895 (cdr syntmp-ids-896))))) (syntmp-distinct-bound-ids?-130 syntmp-ids-894)))) (syntmp-bound-id=?-128 (lambda (syntmp-i-897 syntmp-j-898) (if (and (syntmp-syntax-object?-88 syntmp-i-897) (syntmp-syntax-object?-88 syntmp-j-898)) (and (eq? (let ((syntmp-e-899 (syntmp-syntax-object-expression-89 syntmp-i-897))) (if (annotation? syntmp-e-899) (annotation-expression syntmp-e-899) syntmp-e-899)) (let ((syntmp-e-900 (syntmp-syntax-object-expression-89 syntmp-j-898))) (if (annotation? syntmp-e-900) (annotation-expression syntmp-e-900) syntmp-e-900))) (syntmp-same-marks?-125 (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-i-897)) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-j-898)))) (eq? (let ((syntmp-e-901 syntmp-i-897)) (if (annotation? syntmp-e-901) (annotation-expression syntmp-e-901) syntmp-e-901)) (let ((syntmp-e-902 syntmp-j-898)) (if (annotation? syntmp-e-902) (annotation-expression syntmp-e-902) syntmp-e-902)))))) (syntmp-free-id=?-127 (lambda (syntmp-i-903 syntmp-j-904) (and (eq? (let ((syntmp-x-905 syntmp-i-903)) (let ((syntmp-e-906 (if (syntmp-syntax-object?-88 syntmp-x-905) (syntmp-syntax-object-expression-89 syntmp-x-905) syntmp-x-905))) (if (annotation? syntmp-e-906) (annotation-expression syntmp-e-906) syntmp-e-906))) (let ((syntmp-x-907 syntmp-j-904)) (let ((syntmp-e-908 (if (syntmp-syntax-object?-88 syntmp-x-907) (syntmp-syntax-object-expression-89 syntmp-x-907) syntmp-x-907))) (if (annotation? syntmp-e-908) (annotation-expression syntmp-e-908) syntmp-e-908)))) (eq? (syntmp-id-var-name-126 syntmp-i-903 (quote (()))) (syntmp-id-var-name-126 syntmp-j-904 (quote (()))))))) (syntmp-id-var-name-126 (lambda (syntmp-id-909 syntmp-w-910) (letrec ((syntmp-search-vector-rib-913 (lambda (syntmp-sym-924 syntmp-subst-925 syntmp-marks-926 syntmp-symnames-927 syntmp-ribcage-928) (let ((syntmp-n-929 (vector-length syntmp-symnames-927))) (let syntmp-f-930 ((syntmp-i-931 0)) (cond ((syntmp-fx=-74 syntmp-i-931 syntmp-n-929) (syntmp-search-911 syntmp-sym-924 (cdr syntmp-subst-925) syntmp-marks-926)) ((and (eq? (vector-ref syntmp-symnames-927 syntmp-i-931) syntmp-sym-924) (syntmp-same-marks?-125 syntmp-marks-926 (vector-ref (syntmp-ribcage-marks-114 syntmp-ribcage-928) syntmp-i-931))) (values (vector-ref (syntmp-ribcage-labels-115 syntmp-ribcage-928) syntmp-i-931) syntmp-marks-926)) (else (syntmp-f-930 (syntmp-fx+-72 syntmp-i-931 1)))))))) (syntmp-search-list-rib-912 (lambda (syntmp-sym-932 syntmp-subst-933 syntmp-marks-934 syntmp-symnames-935 syntmp-ribcage-936) (let syntmp-f-937 ((syntmp-symnames-938 syntmp-symnames-935) (syntmp-i-939 0)) (cond ((null? syntmp-symnames-938) (syntmp-search-911 syntmp-sym-932 (cdr syntmp-subst-933) syntmp-marks-934)) ((and (eq? (car syntmp-symnames-938) syntmp-sym-932) (syntmp-same-marks?-125 syntmp-marks-934 (list-ref (syntmp-ribcage-marks-114 syntmp-ribcage-936) syntmp-i-939))) (values (list-ref (syntmp-ribcage-labels-115 syntmp-ribcage-936) syntmp-i-939) syntmp-marks-934)) (else (syntmp-f-937 (cdr syntmp-symnames-938) (syntmp-fx+-72 syntmp-i-939 1))))))) (syntmp-search-911 (lambda (syntmp-sym-940 syntmp-subst-941 syntmp-marks-942) (if (null? syntmp-subst-941) (values #f syntmp-marks-942) (let ((syntmp-fst-943 (car syntmp-subst-941))) (if (eq? syntmp-fst-943 (quote shift)) (syntmp-search-911 syntmp-sym-940 (cdr syntmp-subst-941) (cdr syntmp-marks-942)) (let ((syntmp-symnames-944 (syntmp-ribcage-symnames-113 syntmp-fst-943))) (if (vector? syntmp-symnames-944) (syntmp-search-vector-rib-913 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943) (syntmp-search-list-rib-912 syntmp-sym-940 syntmp-subst-941 syntmp-marks-942 syntmp-symnames-944 syntmp-fst-943))))))))) (cond ((symbol? syntmp-id-909) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-909 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-946 . syntmp-ignore-945) syntmp-x-946)) syntmp-id-909)) ((syntmp-syntax-object?-88 syntmp-id-909) (let ((syntmp-id-947 (let ((syntmp-e-949 (syntmp-syntax-object-expression-89 syntmp-id-909))) (if (annotation? syntmp-e-949) (annotation-expression syntmp-e-949) syntmp-e-949))) (syntmp-w1-948 (syntmp-syntax-object-wrap-90 syntmp-id-909))) (let ((syntmp-marks-950 (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w1-948)))) (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w-910) syntmp-marks-950)) (lambda (syntmp-new-id-951 syntmp-marks-952) (or syntmp-new-id-951 (call-with-values (lambda () (syntmp-search-911 syntmp-id-947 (syntmp-wrap-subst-108 syntmp-w1-948) syntmp-marks-952)) (lambda (syntmp-x-954 . syntmp-ignore-953) syntmp-x-954)) syntmp-id-947)))))) ((annotation? syntmp-id-909) (let ((syntmp-id-955 (let ((syntmp-e-956 syntmp-id-909)) (if (annotation? syntmp-e-956) (annotation-expression syntmp-e-956) syntmp-e-956)))) (or (call-with-values (lambda () (syntmp-search-911 syntmp-id-955 (syntmp-wrap-subst-108 syntmp-w-910) (syntmp-wrap-marks-107 syntmp-w-910))) (lambda (syntmp-x-958 . syntmp-ignore-957) syntmp-x-958)) syntmp-id-955))) (else (syntmp-error-hook-78 (quote id-var-name) "invalid id" syntmp-id-909)))))) (syntmp-same-marks?-125 (lambda (syntmp-x-959 syntmp-y-960) (or (eq? syntmp-x-959 syntmp-y-960) (and (not (null? syntmp-x-959)) (not (null? syntmp-y-960)) (eq? (car syntmp-x-959) (car syntmp-y-960)) (syntmp-same-marks?-125 (cdr syntmp-x-959) (cdr syntmp-y-960)))))) (syntmp-join-marks-124 (lambda (syntmp-m1-961 syntmp-m2-962) (syntmp-smart-append-122 syntmp-m1-961 syntmp-m2-962))) (syntmp-join-wraps-123 (lambda (syntmp-w1-963 syntmp-w2-964) (let ((syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w1-963)) (syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w1-963))) (if (null? syntmp-m1-965) (if (null? syntmp-s1-966) syntmp-w2-964 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w2-964) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964)))) (syntmp-make-wrap-106 (syntmp-smart-append-122 syntmp-m1-965 (syntmp-wrap-marks-107 syntmp-w2-964)) (syntmp-smart-append-122 syntmp-s1-966 (syntmp-wrap-subst-108 syntmp-w2-964))))))) (syntmp-smart-append-122 (lambda (syntmp-m1-967 syntmp-m2-968) (if (null? syntmp-m2-968) syntmp-m1-967 (append syntmp-m1-967 syntmp-m2-968)))) (syntmp-make-binding-wrap-121 (lambda (syntmp-ids-969 syntmp-labels-970 syntmp-w-971) (if (null? syntmp-ids-969) syntmp-w-971 (syntmp-make-wrap-106 (syntmp-wrap-marks-107 syntmp-w-971) (cons (let ((syntmp-labelvec-972 (list->vector syntmp-labels-970))) (let ((syntmp-n-973 (vector-length syntmp-labelvec-972))) (let ((syntmp-symnamevec-974 (make-vector syntmp-n-973)) (syntmp-marksvec-975 (make-vector syntmp-n-973))) (begin (let syntmp-f-976 ((syntmp-ids-977 syntmp-ids-969) (syntmp-i-978 0)) (if (not (null? syntmp-ids-977)) (call-with-values (lambda () (syntmp-id-sym-name&marks-105 (car syntmp-ids-977) syntmp-w-971)) (lambda (syntmp-symname-979 syntmp-marks-980) (begin (vector-set! syntmp-symnamevec-974 syntmp-i-978 syntmp-symname-979) (vector-set! syntmp-marksvec-975 syntmp-i-978 syntmp-marks-980) (syntmp-f-976 (cdr syntmp-ids-977) (syntmp-fx+-72 syntmp-i-978 1))))))) (syntmp-make-ribcage-111 syntmp-symnamevec-974 syntmp-marksvec-975 syntmp-labelvec-972))))) (syntmp-wrap-subst-108 syntmp-w-971)))))) (syntmp-extend-ribcage!-120 (lambda (syntmp-ribcage-981 syntmp-id-982 syntmp-label-983) (begin (syntmp-set-ribcage-symnames!-116 syntmp-ribcage-981 (cons (let ((syntmp-e-984 (syntmp-syntax-object-expression-89 syntmp-id-982))) (if (annotation? syntmp-e-984) (annotation-expression syntmp-e-984) syntmp-e-984)) (syntmp-ribcage-symnames-113 syntmp-ribcage-981))) (syntmp-set-ribcage-marks!-117 syntmp-ribcage-981 (cons (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-id-982)) (syntmp-ribcage-marks-114 syntmp-ribcage-981))) (syntmp-set-ribcage-labels!-118 syntmp-ribcage-981 (cons syntmp-label-983 (syntmp-ribcage-labels-115 syntmp-ribcage-981)))))) (syntmp-anti-mark-119 (lambda (syntmp-w-985) (syntmp-make-wrap-106 (cons #f (syntmp-wrap-marks-107 syntmp-w-985)) (cons (quote shift) (syntmp-wrap-subst-108 syntmp-w-985))))) (syntmp-set-ribcage-labels!-118 (lambda (syntmp-x-986 syntmp-update-987) (vector-set! syntmp-x-986 3 syntmp-update-987))) (syntmp-set-ribcage-marks!-117 (lambda (syntmp-x-988 syntmp-update-989) (vector-set! syntmp-x-988 2 syntmp-update-989))) (syntmp-set-ribcage-symnames!-116 (lambda (syntmp-x-990 syntmp-update-991) (vector-set! syntmp-x-990 1 syntmp-update-991))) (syntmp-ribcage-labels-115 (lambda (syntmp-x-992) (vector-ref syntmp-x-992 3))) (syntmp-ribcage-marks-114 (lambda (syntmp-x-993) (vector-ref syntmp-x-993 2))) (syntmp-ribcage-symnames-113 (lambda (syntmp-x-994) (vector-ref syntmp-x-994 1))) (syntmp-ribcage?-112 (lambda (syntmp-x-995) (and (vector? syntmp-x-995) (= (vector-length syntmp-x-995) 4) (eq? (vector-ref syntmp-x-995 0) (quote ribcage))))) (syntmp-make-ribcage-111 (lambda (syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998) (vector (quote ribcage) syntmp-symnames-996 syntmp-marks-997 syntmp-labels-998))) (syntmp-gen-labels-110 (lambda (syntmp-ls-999) (if (null? syntmp-ls-999) (quote ()) (cons (syntmp-gen-label-109) (syntmp-gen-labels-110 (cdr syntmp-ls-999)))))) (syntmp-gen-label-109 (lambda () (string #\i))) (syntmp-wrap-subst-108 cdr) (syntmp-wrap-marks-107 car) (syntmp-make-wrap-106 cons) (syntmp-id-sym-name&marks-105 (lambda (syntmp-x-1000 syntmp-w-1001) (if (syntmp-syntax-object?-88 syntmp-x-1000) (values (let ((syntmp-e-1002 (syntmp-syntax-object-expression-89 syntmp-x-1000))) (if (annotation? syntmp-e-1002) (annotation-expression syntmp-e-1002) syntmp-e-1002)) (syntmp-join-marks-124 (syntmp-wrap-marks-107 syntmp-w-1001) (syntmp-wrap-marks-107 (syntmp-syntax-object-wrap-90 syntmp-x-1000)))) (values (let ((syntmp-e-1003 syntmp-x-1000)) (if (annotation? syntmp-e-1003) (annotation-expression syntmp-e-1003) syntmp-e-1003)) (syntmp-wrap-marks-107 syntmp-w-1001))))) (syntmp-id?-104 (lambda (syntmp-x-1004) (cond ((symbol? syntmp-x-1004) #t) ((syntmp-syntax-object?-88 syntmp-x-1004) (symbol? (let ((syntmp-e-1005 (syntmp-syntax-object-expression-89 syntmp-x-1004))) (if (annotation? syntmp-e-1005) (annotation-expression syntmp-e-1005) syntmp-e-1005)))) ((annotation? syntmp-x-1004) (symbol? (annotation-expression syntmp-x-1004))) (else #f)))) (syntmp-nonsymbol-id?-103 (lambda (syntmp-x-1006) (and (syntmp-syntax-object?-88 syntmp-x-1006) (symbol? (let ((syntmp-e-1007 (syntmp-syntax-object-expression-89 syntmp-x-1006))) (if (annotation? syntmp-e-1007) (annotation-expression syntmp-e-1007) syntmp-e-1007)))))) (syntmp-global-extend-102 (lambda (syntmp-type-1008 syntmp-sym-1009 syntmp-val-1010) (syntmp-put-global-definition-hook-79 syntmp-sym-1009 (cons syntmp-type-1008 syntmp-val-1010) (module-name (current-module))))) (syntmp-lookup-101 (lambda (syntmp-x-1011 syntmp-r-1012 syntmp-mod-1013) (cond ((assq syntmp-x-1011 syntmp-r-1012) => cdr) ((symbol? syntmp-x-1011) (or (syntmp-get-global-definition-hook-80 syntmp-x-1011 syntmp-mod-1013) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-100 (lambda (syntmp-r-1014) (if (null? syntmp-r-1014) (quote ()) (let ((syntmp-a-1015 (car syntmp-r-1014))) (if (eq? (cadr syntmp-a-1015) (quote macro)) (cons syntmp-a-1015 (syntmp-macros-only-env-100 (cdr syntmp-r-1014))) (syntmp-macros-only-env-100 (cdr syntmp-r-1014))))))) (syntmp-extend-var-env-99 (lambda (syntmp-labels-1016 syntmp-vars-1017 syntmp-r-1018) (if (null? syntmp-labels-1016) syntmp-r-1018 (syntmp-extend-var-env-99 (cdr syntmp-labels-1016) (cdr syntmp-vars-1017) (cons (cons (car syntmp-labels-1016) (cons (quote lexical) (car syntmp-vars-1017))) syntmp-r-1018))))) (syntmp-extend-env-98 (lambda (syntmp-labels-1019 syntmp-bindings-1020 syntmp-r-1021) (if (null? syntmp-labels-1019) syntmp-r-1021 (syntmp-extend-env-98 (cdr syntmp-labels-1019) (cdr syntmp-bindings-1020) (cons (cons (car syntmp-labels-1019) (car syntmp-bindings-1020)) syntmp-r-1021))))) (syntmp-binding-value-97 cdr) (syntmp-binding-type-96 car) (syntmp-source-annotation-95 (lambda (syntmp-x-1022) (cond ((annotation? syntmp-x-1022) (annotation-source syntmp-x-1022)) ((syntmp-syntax-object?-88 syntmp-x-1022) (syntmp-source-annotation-95 (syntmp-syntax-object-expression-89 syntmp-x-1022))) (else #f)))) (syntmp-set-syntax-object-module!-94 (lambda (syntmp-x-1023 syntmp-update-1024) (vector-set! syntmp-x-1023 3 syntmp-update-1024))) (syntmp-set-syntax-object-wrap!-93 (lambda (syntmp-x-1025 syntmp-update-1026) (vector-set! syntmp-x-1025 2 syntmp-update-1026))) (syntmp-set-syntax-object-expression!-92 (lambda (syntmp-x-1027 syntmp-update-1028) (vector-set! syntmp-x-1027 1 syntmp-update-1028))) (syntmp-syntax-object-module-91 (lambda (syntmp-x-1029) (vector-ref syntmp-x-1029 3))) (syntmp-syntax-object-wrap-90 (lambda (syntmp-x-1030) (vector-ref syntmp-x-1030 2))) (syntmp-syntax-object-expression-89 (lambda (syntmp-x-1031) (vector-ref syntmp-x-1031 1))) (syntmp-syntax-object?-88 (lambda (syntmp-x-1032) (and (vector? syntmp-x-1032) (= (vector-length syntmp-x-1032) 4) (eq? (vector-ref syntmp-x-1032 0) (quote syntax-object))))) (syntmp-make-syntax-object-87 (lambda (syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035) (vector (quote syntax-object) syntmp-expression-1033 syntmp-wrap-1034 syntmp-module-1035))) (syntmp-build-letrec-86 (lambda (syntmp-src-1036 syntmp-vars-1037 syntmp-val-exps-1038 syntmp-body-exp-1039) (if (null? syntmp-vars-1037) (syntmp-build-annotated-81 syntmp-src-1036 syntmp-body-exp-1039) (syntmp-build-annotated-81 syntmp-src-1036 (list (quote letrec) (map list syntmp-vars-1037 syntmp-val-exps-1038) syntmp-body-exp-1039))))) (syntmp-build-named-let-85 (lambda (syntmp-src-1040 syntmp-vars-1041 syntmp-val-exps-1042 syntmp-body-exp-1043) (if (null? syntmp-vars-1041) (syntmp-build-annotated-81 syntmp-src-1040 syntmp-body-exp-1043) (syntmp-build-annotated-81 syntmp-src-1040 (list (quote let) (car syntmp-vars-1041) (map list (cdr syntmp-vars-1041) syntmp-val-exps-1042) syntmp-body-exp-1043))))) (syntmp-build-let-84 (lambda (syntmp-src-1044 syntmp-vars-1045 syntmp-val-exps-1046 syntmp-body-exp-1047) (if (null? syntmp-vars-1045) (syntmp-build-annotated-81 syntmp-src-1044 syntmp-body-exp-1047) (syntmp-build-annotated-81 syntmp-src-1044 (list (quote let) (map list syntmp-vars-1045 syntmp-val-exps-1046) syntmp-body-exp-1047))))) (syntmp-build-sequence-83 (lambda (syntmp-src-1048 syntmp-exps-1049) (if (null? (cdr syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (car syntmp-exps-1049)) (syntmp-build-annotated-81 syntmp-src-1048 (cons (quote begin) syntmp-exps-1049))))) (syntmp-build-data-82 (lambda (syntmp-src-1050 syntmp-exp-1051) (if (and (self-evaluating? syntmp-exp-1051) (not (vector? syntmp-exp-1051))) (syntmp-build-annotated-81 syntmp-src-1050 syntmp-exp-1051) (syntmp-build-annotated-81 syntmp-src-1050 (list (quote quote) syntmp-exp-1051))))) (syntmp-build-annotated-81 (lambda (syntmp-src-1052 syntmp-exp-1053) (if (and syntmp-src-1052 (not (annotation? syntmp-exp-1053))) (make-annotation syntmp-exp-1053 syntmp-src-1052 #t) syntmp-exp-1053))) (syntmp-get-global-definition-hook-80 (lambda (syntmp-symbol-1054 syntmp-module-1055) (let ((syntmp-module-1056 (if syntmp-module-1055 (resolve-module syntmp-module-1055) (warn "wha" syntmp-symbol-1054 (current-module))))) (let ((syntmp-v-1057 (module-variable syntmp-module-1056 syntmp-symbol-1054))) (and syntmp-v-1057 (or (object-property syntmp-v-1057 (quote *sc-expander*)) (and (variable-bound? syntmp-v-1057) (macro? (variable-ref syntmp-v-1057)) (macro-transformer (variable-ref syntmp-v-1057)) guile-macro))))))) (syntmp-put-global-definition-hook-79 (lambda (syntmp-symbol-1058 syntmp-binding-1059 syntmp-module-1060) (let ((syntmp-module-1061 (if syntmp-module-1060 (resolve-module syntmp-module-1060) (warn "wha" syntmp-symbol-1058 (current-module))))) (let ((syntmp-v-1062 (or (module-variable syntmp-module-1061 syntmp-symbol-1058) (let ((syntmp-v-1063 (make-variable sc-macro))) (begin (module-add! syntmp-module-1061 syntmp-symbol-1058 syntmp-v-1063) syntmp-v-1063))))) (begin (if (not (and (symbol-property syntmp-symbol-1058 (quote primitive-syntax)) (eq? syntmp-module-1061 the-syncase-module))) (variable-set! syntmp-v-1062 sc-macro)) (set-object-property! syntmp-v-1062 (quote *sc-expander*) syntmp-binding-1059)))))) (syntmp-error-hook-78 (lambda (syntmp-who-1064 syntmp-why-1065 syntmp-what-1066) (error syntmp-who-1064 "~a ~s" syntmp-why-1065 syntmp-what-1066))) (syntmp-local-eval-hook-77 (lambda (syntmp-x-1067 syntmp-mod-1068) (eval (list syntmp-noexpand-71 syntmp-x-1067) (if syntmp-mod-1068 (resolve-module syntmp-mod-1068) (interaction-environment))))) (syntmp-top-level-eval-hook-76 (lambda (syntmp-x-1069 syntmp-mod-1070) (eval (list syntmp-noexpand-71 syntmp-x-1069) (if syntmp-mod-1070 (resolve-module syntmp-mod-1070) (interaction-environment))))) (syntmp-fx<-75 <) (syntmp-fx=-74 =) (syntmp-fx--73 -) (syntmp-fx+-72 +) (syntmp-noexpand-71 "noexpand")) (begin (syntmp-global-extend-102 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-102 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-102 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1071 syntmp-r-1072 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) ((lambda (syntmp-tmp-1076) ((lambda (syntmp-tmp-1077) (if (if syntmp-tmp-1077 (apply (lambda (syntmp-_-1078 syntmp-var-1079 syntmp-val-1080 syntmp-e1-1081 syntmp-e2-1082) (syntmp-valid-bound-ids?-129 syntmp-var-1079)) syntmp-tmp-1077) #f) (apply (lambda (syntmp-_-1084 syntmp-var-1085 syntmp-val-1086 syntmp-e1-1087 syntmp-e2-1088) (let ((syntmp-names-1089 (map (lambda (syntmp-x-1090) (syntmp-id-var-name-126 syntmp-x-1090 syntmp-w-1073)) syntmp-var-1085))) (begin (for-each (lambda (syntmp-id-1092 syntmp-n-1093) (let ((syntmp-t-1094 (syntmp-binding-type-96 (syntmp-lookup-101 syntmp-n-1093 syntmp-r-1072 syntmp-mod-1075)))) (if (memv syntmp-t-1094 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-133 syntmp-id-1092 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) "identifier out of context")))) syntmp-var-1085 syntmp-names-1089) (syntmp-chi-body-144 (cons syntmp-e1-1087 syntmp-e2-1088) (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075) (syntmp-extend-env-98 syntmp-names-1089 (let ((syntmp-trans-r-1097 (syntmp-macros-only-env-100 syntmp-r-1072))) (map (lambda (syntmp-x-1098) (cons (quote macro) (syntmp-eval-local-transformer-147 (syntmp-chi-140 syntmp-x-1098 syntmp-trans-r-1097 syntmp-w-1073 syntmp-mod-1075) syntmp-mod-1075))) syntmp-val-1086)) syntmp-r-1072) syntmp-w-1073 syntmp-mod-1075)))) syntmp-tmp-1077) ((lambda (syntmp-_-1100) (syntax-error (syntmp-source-wrap-133 syntmp-e-1071 syntmp-w-1073 syntmp-s-1074 syntmp-mod-1075))) syntmp-tmp-1076))) (syntax-dispatch syntmp-tmp-1076 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1071))) (syntmp-global-extend-102 (quote core) (quote quote) (lambda (syntmp-e-1101 syntmp-r-1102 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105) ((lambda (syntmp-tmp-1106) ((lambda (syntmp-tmp-1107) (if syntmp-tmp-1107 (apply (lambda (syntmp-_-1108 syntmp-e-1109) (syntmp-build-data-82 syntmp-s-1104 (syntmp-strip-151 syntmp-e-1109 syntmp-w-1103))) syntmp-tmp-1107) ((lambda (syntmp-_-1110) (syntax-error (syntmp-source-wrap-133 syntmp-e-1101 syntmp-w-1103 syntmp-s-1104 syntmp-mod-1105))) syntmp-tmp-1106))) (syntax-dispatch syntmp-tmp-1106 (quote (any any))))) syntmp-e-1101))) (syntmp-global-extend-102 (quote core) (quote syntax) (letrec ((syntmp-regen-1118 (lambda (syntmp-x-1119) (let ((syntmp-t-1120 (car syntmp-x-1119))) (if (memv syntmp-t-1120 (quote (ref))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (primitive))) (syntmp-build-annotated-81 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (quote))) (syntmp-build-data-82 #f (cadr syntmp-x-1119)) (if (memv syntmp-t-1120 (quote (lambda))) (syntmp-build-annotated-81 #f (list (quote lambda) (cadr syntmp-x-1119) (syntmp-regen-1118 (caddr syntmp-x-1119)))) (if (memv syntmp-t-1120 (quote (map))) (let ((syntmp-ls-1121 (map syntmp-regen-1118 (cdr syntmp-x-1119)))) (syntmp-build-annotated-81 #f (cons (if (syntmp-fx=-74 (length syntmp-ls-1121) 2) (syntmp-build-annotated-81 #f (quote map)) (syntmp-build-annotated-81 #f (quote map))) syntmp-ls-1121))) (syntmp-build-annotated-81 #f (cons (syntmp-build-annotated-81 #f (car syntmp-x-1119)) (map syntmp-regen-1118 (cdr syntmp-x-1119)))))))))))) (syntmp-gen-vector-1117 (lambda (syntmp-x-1122) (cond ((eq? (car syntmp-x-1122) (quote list)) (cons (quote vector) (cdr syntmp-x-1122))) ((eq? (car syntmp-x-1122) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1122)))) (else (list (quote list->vector) syntmp-x-1122))))) (syntmp-gen-append-1116 (lambda (syntmp-x-1123 syntmp-y-1124) (if (equal? syntmp-y-1124 (quote (quote ()))) syntmp-x-1123 (list (quote append) syntmp-x-1123 syntmp-y-1124)))) (syntmp-gen-cons-1115 (lambda (syntmp-x-1125 syntmp-y-1126) (let ((syntmp-t-1127 (car syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (quote))) (if (eq? (car syntmp-x-1125) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1125) (cadr syntmp-y-1126))) (if (eq? (cadr syntmp-y-1126) (quote ())) (list (quote list) syntmp-x-1125) (list (quote cons) syntmp-x-1125 syntmp-y-1126))) (if (memv syntmp-t-1127 (quote (list))) (cons (quote list) (cons syntmp-x-1125 (cdr syntmp-y-1126))) (list (quote cons) syntmp-x-1125 syntmp-y-1126)))))) (syntmp-gen-map-1114 (lambda (syntmp-e-1128 syntmp-map-env-1129) (let ((syntmp-formals-1130 (map cdr syntmp-map-env-1129)) (syntmp-actuals-1131 (map (lambda (syntmp-x-1132) (list (quote ref) (car syntmp-x-1132))) syntmp-map-env-1129))) (cond ((eq? (car syntmp-e-1128) (quote ref)) (car syntmp-actuals-1131)) ((andmap (lambda (syntmp-x-1133) (and (eq? (car syntmp-x-1133) (quote ref)) (memq (cadr syntmp-x-1133) syntmp-formals-1130))) (cdr syntmp-e-1128)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1128)) (map (let ((syntmp-r-1134 (map cons syntmp-formals-1130 syntmp-actuals-1131))) (lambda (syntmp-x-1135) (cdr (assq (cadr syntmp-x-1135) syntmp-r-1134)))) (cdr syntmp-e-1128))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1130 syntmp-e-1128) syntmp-actuals-1131))))))) (syntmp-gen-mappend-1113 (lambda (syntmp-e-1136 syntmp-map-env-1137) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1114 syntmp-e-1136 syntmp-map-env-1137)))) (syntmp-gen-ref-1112 (lambda (syntmp-src-1138 syntmp-var-1139 syntmp-level-1140 syntmp-maps-1141) (if (syntmp-fx=-74 syntmp-level-1140 0) (values syntmp-var-1139 syntmp-maps-1141) (if (null? syntmp-maps-1141) (syntax-error syntmp-src-1138 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1112 syntmp-src-1138 syntmp-var-1139 (syntmp-fx--73 syntmp-level-1140 1) (cdr syntmp-maps-1141))) (lambda (syntmp-outer-var-1142 syntmp-outer-maps-1143) (let ((syntmp-b-1144 (assq syntmp-outer-var-1142 (car syntmp-maps-1141)))) (if syntmp-b-1144 (values (cdr syntmp-b-1144) syntmp-maps-1141) (let ((syntmp-inner-var-1145 (syntmp-gen-var-152 (quote tmp)))) (values syntmp-inner-var-1145 (cons (cons (cons syntmp-outer-var-1142 syntmp-inner-var-1145) (car syntmp-maps-1141)) syntmp-outer-maps-1143))))))))))) (syntmp-gen-syntax-1111 (lambda (syntmp-src-1146 syntmp-e-1147 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151) (if (syntmp-id?-104 syntmp-e-1147) (let ((syntmp-label-1152 (syntmp-id-var-name-126 syntmp-e-1147 (quote (()))))) (let ((syntmp-b-1153 (syntmp-lookup-101 syntmp-label-1152 syntmp-r-1148 syntmp-mod-1151))) (if (eq? (syntmp-binding-type-96 syntmp-b-1153) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1154 (syntmp-binding-value-97 syntmp-b-1153))) (syntmp-gen-ref-1112 syntmp-src-1146 (car syntmp-var.lev-1154) (cdr syntmp-var.lev-1154) syntmp-maps-1149))) (lambda (syntmp-var-1155 syntmp-maps-1156) (values (list (quote ref) syntmp-var-1155) syntmp-maps-1156))) (if (syntmp-ellipsis?-1150 syntmp-e-1147) (syntax-error syntmp-src-1146 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149))))) ((lambda (syntmp-tmp-1157) ((lambda (syntmp-tmp-1158) (if (if syntmp-tmp-1158 (apply (lambda (syntmp-dots-1159 syntmp-e-1160) (syntmp-ellipsis?-1150 syntmp-dots-1159)) syntmp-tmp-1158) #f) (apply (lambda (syntmp-dots-1161 syntmp-e-1162) (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-e-1162 syntmp-r-1148 syntmp-maps-1149 (lambda (syntmp-x-1163) #f) syntmp-mod-1151)) syntmp-tmp-1158) ((lambda (syntmp-tmp-1164) (if (if syntmp-tmp-1164 (apply (lambda (syntmp-x-1165 syntmp-dots-1166 syntmp-y-1167) (syntmp-ellipsis?-1150 syntmp-dots-1166)) syntmp-tmp-1164) #f) (apply (lambda (syntmp-x-1168 syntmp-dots-1169 syntmp-y-1170) (let syntmp-f-1171 ((syntmp-y-1172 syntmp-y-1170) (syntmp-k-1173 (lambda (syntmp-maps-1174) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1168 syntmp-r-1148 (cons (quote ()) syntmp-maps-1174) syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1175 syntmp-maps-1176) (if (null? (car syntmp-maps-1176)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-map-1114 syntmp-x-1175 (car syntmp-maps-1176)) (cdr syntmp-maps-1176)))))))) ((lambda (syntmp-tmp-1177) ((lambda (syntmp-tmp-1178) (if (if syntmp-tmp-1178 (apply (lambda (syntmp-dots-1179 syntmp-y-1180) (syntmp-ellipsis?-1150 syntmp-dots-1179)) syntmp-tmp-1178) #f) (apply (lambda (syntmp-dots-1181 syntmp-y-1182) (syntmp-f-1171 syntmp-y-1182 (lambda (syntmp-maps-1183) (call-with-values (lambda () (syntmp-k-1173 (cons (quote ()) syntmp-maps-1183))) (lambda (syntmp-x-1184 syntmp-maps-1185) (if (null? (car syntmp-maps-1185)) (syntax-error syntmp-src-1146 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1113 syntmp-x-1184 (car syntmp-maps-1185)) (cdr syntmp-maps-1185)))))))) syntmp-tmp-1178) ((lambda (syntmp-_-1186) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1172 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1187 syntmp-maps-1188) (call-with-values (lambda () (syntmp-k-1173 syntmp-maps-1188)) (lambda (syntmp-x-1189 syntmp-maps-1190) (values (syntmp-gen-append-1116 syntmp-x-1189 syntmp-y-1187) syntmp-maps-1190)))))) syntmp-tmp-1177))) (syntax-dispatch syntmp-tmp-1177 (quote (any . any))))) syntmp-y-1172))) syntmp-tmp-1164) ((lambda (syntmp-tmp-1191) (if syntmp-tmp-1191 (apply (lambda (syntmp-x-1192 syntmp-y-1193) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-x-1192 syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-x-1194 syntmp-maps-1195) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 syntmp-y-1193 syntmp-r-1148 syntmp-maps-1195 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-y-1196 syntmp-maps-1197) (values (syntmp-gen-cons-1115 syntmp-x-1194 syntmp-y-1196) syntmp-maps-1197)))))) syntmp-tmp-1191) ((lambda (syntmp-tmp-1198) (if syntmp-tmp-1198 (apply (lambda (syntmp-e1-1199 syntmp-e2-1200) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-src-1146 (cons syntmp-e1-1199 syntmp-e2-1200) syntmp-r-1148 syntmp-maps-1149 syntmp-ellipsis?-1150 syntmp-mod-1151)) (lambda (syntmp-e-1202 syntmp-maps-1203) (values (syntmp-gen-vector-1117 syntmp-e-1202) syntmp-maps-1203)))) syntmp-tmp-1198) ((lambda (syntmp-_-1204) (values (list (quote quote) syntmp-e-1147) syntmp-maps-1149)) syntmp-tmp-1157))) (syntax-dispatch syntmp-tmp-1157 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1157 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1157 (quote (any any))))) syntmp-e-1147))))) (lambda (syntmp-e-1205 syntmp-r-1206 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209) (let ((syntmp-e-1210 (syntmp-source-wrap-133 syntmp-e-1205 syntmp-w-1207 syntmp-s-1208 syntmp-mod-1209))) ((lambda (syntmp-tmp-1211) ((lambda (syntmp-tmp-1212) (if syntmp-tmp-1212 (apply (lambda (syntmp-_-1213 syntmp-x-1214) (call-with-values (lambda () (syntmp-gen-syntax-1111 syntmp-e-1210 syntmp-x-1214 syntmp-r-1206 (quote ()) syntmp-ellipsis?-149 syntmp-mod-1209)) (lambda (syntmp-e-1215 syntmp-maps-1216) (syntmp-regen-1118 syntmp-e-1215)))) syntmp-tmp-1212) ((lambda (syntmp-_-1217) (syntax-error syntmp-e-1210)) syntmp-tmp-1211))) (syntax-dispatch syntmp-tmp-1211 (quote (any any))))) syntmp-e-1210))))) (syntmp-global-extend-102 (quote core) (quote lambda) (lambda (syntmp-e-1218 syntmp-r-1219 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) ((lambda (syntmp-tmp-1223) ((lambda (syntmp-tmp-1224) (if syntmp-tmp-1224 (apply (lambda (syntmp-_-1225 syntmp-c-1226) (syntmp-chi-lambda-clause-145 (syntmp-source-wrap-133 syntmp-e-1218 syntmp-w-1220 syntmp-s-1221 syntmp-mod-1222) syntmp-c-1226 syntmp-r-1219 syntmp-w-1220 syntmp-mod-1222 (lambda (syntmp-vars-1227 syntmp-body-1228) (syntmp-build-annotated-81 syntmp-s-1221 (list (quote lambda) syntmp-vars-1227 syntmp-body-1228))))) syntmp-tmp-1224) (syntax-error syntmp-tmp-1223))) (syntax-dispatch syntmp-tmp-1223 (quote (any . any))))) syntmp-e-1218))) (syntmp-global-extend-102 (quote core) (quote let) (letrec ((syntmp-chi-let-1229 (lambda (syntmp-e-1230 syntmp-r-1231 syntmp-w-1232 syntmp-s-1233 syntmp-mod-1234 syntmp-constructor-1235 syntmp-ids-1236 syntmp-vals-1237 syntmp-exps-1238) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1236)) (syntax-error syntmp-e-1230 "duplicate bound variable in") (let ((syntmp-labels-1239 (syntmp-gen-labels-110 syntmp-ids-1236)) (syntmp-new-vars-1240 (map syntmp-gen-var-152 syntmp-ids-1236))) (let ((syntmp-nw-1241 (syntmp-make-binding-wrap-121 syntmp-ids-1236 syntmp-labels-1239 syntmp-w-1232)) (syntmp-nr-1242 (syntmp-extend-var-env-99 syntmp-labels-1239 syntmp-new-vars-1240 syntmp-r-1231))) (syntmp-constructor-1235 syntmp-s-1233 syntmp-new-vars-1240 (map (lambda (syntmp-x-1243) (syntmp-chi-140 syntmp-x-1243 syntmp-r-1231 syntmp-w-1232 syntmp-mod-1234)) syntmp-vals-1237) (syntmp-chi-body-144 syntmp-exps-1238 (syntmp-source-wrap-133 syntmp-e-1230 syntmp-nw-1241 syntmp-s-1233 syntmp-mod-1234) syntmp-nr-1242 syntmp-nw-1241 syntmp-mod-1234)))))))) (lambda (syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248) ((lambda (syntmp-tmp-1249) ((lambda (syntmp-tmp-1250) (if syntmp-tmp-1250 (apply (lambda (syntmp-_-1251 syntmp-id-1252 syntmp-val-1253 syntmp-e1-1254 syntmp-e2-1255) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-let-84 syntmp-id-1252 syntmp-val-1253 (cons syntmp-e1-1254 syntmp-e2-1255))) syntmp-tmp-1250) ((lambda (syntmp-tmp-1259) (if (if syntmp-tmp-1259 (apply (lambda (syntmp-_-1260 syntmp-f-1261 syntmp-id-1262 syntmp-val-1263 syntmp-e1-1264 syntmp-e2-1265) (syntmp-id?-104 syntmp-f-1261)) syntmp-tmp-1259) #f) (apply (lambda (syntmp-_-1266 syntmp-f-1267 syntmp-id-1268 syntmp-val-1269 syntmp-e1-1270 syntmp-e2-1271) (syntmp-chi-let-1229 syntmp-e-1244 syntmp-r-1245 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248 syntmp-build-named-let-85 (cons syntmp-f-1267 syntmp-id-1268) syntmp-val-1269 (cons syntmp-e1-1270 syntmp-e2-1271))) syntmp-tmp-1259) ((lambda (syntmp-_-1275) (syntax-error (syntmp-source-wrap-133 syntmp-e-1244 syntmp-w-1246 syntmp-s-1247 syntmp-mod-1248))) syntmp-tmp-1249))) (syntax-dispatch syntmp-tmp-1249 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1249 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1244)))) (syntmp-global-extend-102 (quote core) (quote letrec) (lambda (syntmp-e-1276 syntmp-r-1277 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280) ((lambda (syntmp-tmp-1281) ((lambda (syntmp-tmp-1282) (if syntmp-tmp-1282 (apply (lambda (syntmp-_-1283 syntmp-id-1284 syntmp-val-1285 syntmp-e1-1286 syntmp-e2-1287) (let ((syntmp-ids-1288 syntmp-id-1284)) (if (not (syntmp-valid-bound-ids?-129 syntmp-ids-1288)) (syntax-error syntmp-e-1276 "duplicate bound variable in") (let ((syntmp-labels-1290 (syntmp-gen-labels-110 syntmp-ids-1288)) (syntmp-new-vars-1291 (map syntmp-gen-var-152 syntmp-ids-1288))) (let ((syntmp-w-1292 (syntmp-make-binding-wrap-121 syntmp-ids-1288 syntmp-labels-1290 syntmp-w-1278)) (syntmp-r-1293 (syntmp-extend-var-env-99 syntmp-labels-1290 syntmp-new-vars-1291 syntmp-r-1277))) (syntmp-build-letrec-86 syntmp-s-1279 syntmp-new-vars-1291 (map (lambda (syntmp-x-1294) (syntmp-chi-140 syntmp-x-1294 syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280)) syntmp-val-1285) (syntmp-chi-body-144 (cons syntmp-e1-1286 syntmp-e2-1287) (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1292 syntmp-s-1279 syntmp-mod-1280) syntmp-r-1293 syntmp-w-1292 syntmp-mod-1280))))))) syntmp-tmp-1282) ((lambda (syntmp-_-1297) (syntax-error (syntmp-source-wrap-133 syntmp-e-1276 syntmp-w-1278 syntmp-s-1279 syntmp-mod-1280))) syntmp-tmp-1281))) (syntax-dispatch syntmp-tmp-1281 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1276))) (syntmp-global-extend-102 (quote core) (quote set!) (lambda (syntmp-e-1298 syntmp-r-1299 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302) ((lambda (syntmp-tmp-1303) ((lambda (syntmp-tmp-1304) (if (if syntmp-tmp-1304 (apply (lambda (syntmp-_-1305 syntmp-id-1306 syntmp-val-1307) (syntmp-id?-104 syntmp-id-1306)) syntmp-tmp-1304) #f) (apply (lambda (syntmp-_-1308 syntmp-id-1309 syntmp-val-1310) (let ((syntmp-val-1311 (syntmp-chi-140 syntmp-val-1310 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (syntmp-n-1312 (syntmp-id-var-name-126 syntmp-id-1309 syntmp-w-1300))) (let ((syntmp-b-1313 (syntmp-lookup-101 syntmp-n-1312 syntmp-r-1299 syntmp-mod-1302))) (let ((syntmp-t-1314 (syntmp-binding-type-96 syntmp-b-1313))) (if (memv syntmp-t-1314 (quote (lexical))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (syntmp-binding-value-97 syntmp-b-1313) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (global))) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1302 syntmp-n-1312 #f) syntmp-val-1311)) (if (memv syntmp-t-1314 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-132 syntmp-id-1309 syntmp-w-1300 syntmp-mod-1302) "identifier out of context") (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))))))))) syntmp-tmp-1304) ((lambda (syntmp-tmp-1315) (if syntmp-tmp-1315 (apply (lambda (syntmp-_-1316 syntmp-head-1317 syntmp-tail-1318 syntmp-val-1319) (call-with-values (lambda () (syntmp-syntax-type-138 syntmp-head-1317 syntmp-r-1299 (quote (())) #f #f syntmp-mod-1302)) (lambda (syntmp-type-1320 syntmp-value-1321 syntmp-ee-1322 syntmp-ww-1323 syntmp-ss-1324 syntmp-modmod-1325) (let ((syntmp-t-1326 syntmp-type-1320)) (if (memv syntmp-t-1326 (quote (module-ref))) (call-with-values (lambda () (syntmp-value-1321 (cons syntmp-head-1317 syntmp-tail-1318))) (lambda (syntmp-id-1328 syntmp-mod-1329) (syntmp-build-annotated-81 syntmp-s-1301 (list (quote set!) (make-module-ref syntmp-mod-1329 syntmp-id-1328 #f) syntmp-val-1319)))) (syntmp-build-annotated-81 syntmp-s-1301 (cons (syntmp-chi-140 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-head-1317) syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302) (map (lambda (syntmp-e-1330) (syntmp-chi-140 syntmp-e-1330 syntmp-r-1299 syntmp-w-1300 syntmp-mod-1302)) (append syntmp-tail-1318 (list syntmp-val-1319)))))))))) syntmp-tmp-1315) ((lambda (syntmp-_-1332) (syntax-error (syntmp-source-wrap-133 syntmp-e-1298 syntmp-w-1300 syntmp-s-1301 syntmp-mod-1302))) syntmp-tmp-1303))) (syntax-dispatch syntmp-tmp-1303 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1303 (quote (any any any))))) syntmp-e-1298))) (syntmp-global-extend-102 (quote module-ref) (quote @) (lambda (syntmp-e-1333) ((lambda (syntmp-tmp-1334) ((lambda (syntmp-tmp-1335) (if (if syntmp-tmp-1335 (apply (lambda (syntmp-_-1336 syntmp-mod-1337 syntmp-id-1338) (and (andmap syntmp-id?-104 syntmp-mod-1337) (syntmp-id?-104 syntmp-id-1338))) syntmp-tmp-1335) #f) (apply (lambda (syntmp-_-1340 syntmp-mod-1341 syntmp-id-1342) (values (syntax-object->datum syntmp-id-1342) (syntax-object->datum (append syntmp-mod-1341 (quote (#(syntax-object %module-public-interface ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase)))))))) syntmp-tmp-1335) (syntax-error syntmp-tmp-1334))) (syntax-dispatch syntmp-tmp-1334 (quote (any each-any any))))) syntmp-e-1333))) (syntmp-global-extend-102 (quote module-ref) (quote @@) (lambda (syntmp-e-1344) ((lambda (syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if (if syntmp-tmp-1346 (apply (lambda (syntmp-_-1347 syntmp-mod-1348 syntmp-id-1349) (and (andmap syntmp-id?-104 syntmp-mod-1348) (syntmp-id?-104 syntmp-id-1349))) syntmp-tmp-1346) #f) (apply (lambda (syntmp-_-1351 syntmp-mod-1352 syntmp-id-1353) (values (syntax-object->datum syntmp-id-1353) (syntax-object->datum syntmp-mod-1352))) syntmp-tmp-1346) (syntax-error syntmp-tmp-1345))) (syntax-dispatch syntmp-tmp-1345 (quote (any each-any any))))) syntmp-e-1344))) (syntmp-global-extend-102 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-102 (quote define) (quote define) (quote ())) (syntmp-global-extend-102 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-102 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-102 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1358 (lambda (syntmp-x-1359 syntmp-keys-1360 syntmp-clauses-1361 syntmp-r-1362 syntmp-mod-1363) (if (null? syntmp-clauses-1361) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-error)) syntmp-x-1359)) ((lambda (syntmp-tmp-1364) ((lambda (syntmp-tmp-1365) (if syntmp-tmp-1365 (apply (lambda (syntmp-pat-1366 syntmp-exp-1367) (if (and (syntmp-id?-104 syntmp-pat-1366) (andmap (lambda (syntmp-x-1368) (not (syntmp-free-id=?-127 syntmp-pat-1366 syntmp-x-1368))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate 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 build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application build-annotated get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))) (ice-9 syncase))) syntmp-keys-1360))) (let ((syntmp-labels-1369 (list (syntmp-gen-label-109))) (syntmp-var-1370 (syntmp-gen-var-152 syntmp-pat-1366))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-var-1370) (syntmp-chi-140 syntmp-exp-1367 (syntmp-extend-env-98 syntmp-labels-1369 (list (cons (quote syntax) (cons syntmp-var-1370 0))) syntmp-r-1362) (syntmp-make-binding-wrap-121 (list syntmp-pat-1366) syntmp-labels-1369 (quote (()))) syntmp-mod-1363))) syntmp-x-1359))) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1366 #t syntmp-exp-1367 syntmp-mod-1363))) syntmp-tmp-1365) ((lambda (syntmp-tmp-1371) (if syntmp-tmp-1371 (apply (lambda (syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374) (syntmp-gen-clause-1357 syntmp-x-1359 syntmp-keys-1360 (cdr syntmp-clauses-1361) syntmp-r-1362 syntmp-pat-1372 syntmp-fender-1373 syntmp-exp-1374 syntmp-mod-1363)) syntmp-tmp-1371) ((lambda (syntmp-_-1375) (syntax-error (car syntmp-clauses-1361) "invalid syntax-case clause")) syntmp-tmp-1364))) (syntax-dispatch syntmp-tmp-1364 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1364 (quote (any any))))) (car syntmp-clauses-1361))))) (syntmp-gen-clause-1357 (lambda (syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-pat-1380 syntmp-fender-1381 syntmp-exp-1382 syntmp-mod-1383) (call-with-values (lambda () (syntmp-convert-pattern-1355 syntmp-pat-1380 syntmp-keys-1377)) (lambda (syntmp-p-1384 syntmp-pvars-1385) (cond ((not (syntmp-distinct-bound-ids?-130 (map car syntmp-pvars-1385))) (syntax-error syntmp-pat-1380 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1386) (not (syntmp-ellipsis?-149 (car syntmp-x-1386)))) syntmp-pvars-1385)) (syntax-error syntmp-pat-1380 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1387 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-y-1387) (let ((syntmp-y-1388 (syntmp-build-annotated-81 #f syntmp-y-1387))) (syntmp-build-annotated-81 #f (list (quote if) ((lambda (syntmp-tmp-1389) ((lambda (syntmp-tmp-1390) (if syntmp-tmp-1390 (apply (lambda () syntmp-y-1388) syntmp-tmp-1390) ((lambda (syntmp-_-1391) (syntmp-build-annotated-81 #f (list (quote if) syntmp-y-1388 (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-fender-1381 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-build-data-82 #f #f)))) syntmp-tmp-1389))) (syntax-dispatch syntmp-tmp-1389 (quote #(atom #t))))) syntmp-fender-1381) (syntmp-build-dispatch-call-1356 syntmp-pvars-1385 syntmp-exp-1382 syntmp-y-1388 syntmp-r-1379 syntmp-mod-1383) (syntmp-gen-syntax-case-1358 syntmp-x-1376 syntmp-keys-1377 syntmp-clauses-1378 syntmp-r-1379 syntmp-mod-1383)))))) (if (eq? syntmp-p-1384 (quote any)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote list)) syntmp-x-1376)) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote syntax-dispatch)) syntmp-x-1376 (syntmp-build-data-82 #f syntmp-p-1384))))))))))))) (syntmp-build-dispatch-call-1356 (lambda (syntmp-pvars-1392 syntmp-exp-1393 syntmp-y-1394 syntmp-r-1395 syntmp-mod-1396) (let ((syntmp-ids-1397 (map car syntmp-pvars-1392)) (syntmp-levels-1398 (map cdr syntmp-pvars-1392))) (let ((syntmp-labels-1399 (syntmp-gen-labels-110 syntmp-ids-1397)) (syntmp-new-vars-1400 (map syntmp-gen-var-152 syntmp-ids-1397))) (syntmp-build-annotated-81 #f (list (syntmp-build-annotated-81 #f (quote apply)) (syntmp-build-annotated-81 #f (list (quote lambda) syntmp-new-vars-1400 (syntmp-chi-140 syntmp-exp-1393 (syntmp-extend-env-98 syntmp-labels-1399 (map (lambda (syntmp-var-1401 syntmp-level-1402) (cons (quote syntax) (cons syntmp-var-1401 syntmp-level-1402))) syntmp-new-vars-1400 (map cdr syntmp-pvars-1392)) syntmp-r-1395) (syntmp-make-binding-wrap-121 syntmp-ids-1397 syntmp-labels-1399 (quote (()))) syntmp-mod-1396))) syntmp-y-1394)))))) (syntmp-convert-pattern-1355 (lambda (syntmp-pattern-1403 syntmp-keys-1404) (let syntmp-cvt-1405 ((syntmp-p-1406 syntmp-pattern-1403) (syntmp-n-1407 0) (syntmp-ids-1408 (quote ()))) (if (syntmp-id?-104 syntmp-p-1406) (if (syntmp-bound-id-member?-131 syntmp-p-1406 syntmp-keys-1404) (values (vector (quote free-id) syntmp-p-1406) syntmp-ids-1408) (values (quote any) (cons (cons syntmp-p-1406 syntmp-n-1407) syntmp-ids-1408))) ((lambda (syntmp-tmp-1409) ((lambda (syntmp-tmp-1410) (if (if syntmp-tmp-1410 (apply (lambda (syntmp-x-1411 syntmp-dots-1412) (syntmp-ellipsis?-149 syntmp-dots-1412)) syntmp-tmp-1410) #f) (apply (lambda (syntmp-x-1413 syntmp-dots-1414) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1413 (syntmp-fx+-72 syntmp-n-1407 1) syntmp-ids-1408)) (lambda (syntmp-p-1415 syntmp-ids-1416) (values (if (eq? syntmp-p-1415 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1415)) syntmp-ids-1416)))) syntmp-tmp-1410) ((lambda (syntmp-tmp-1417) (if syntmp-tmp-1417 (apply (lambda (syntmp-x-1418 syntmp-y-1419) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-y-1419 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-y-1420 syntmp-ids-1421) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1418 syntmp-n-1407 syntmp-ids-1421)) (lambda (syntmp-x-1422 syntmp-ids-1423) (values (cons syntmp-x-1422 syntmp-y-1420) syntmp-ids-1423)))))) syntmp-tmp-1417) ((lambda (syntmp-tmp-1424) (if syntmp-tmp-1424 (apply (lambda () (values (quote ()) syntmp-ids-1408)) syntmp-tmp-1424) ((lambda (syntmp-tmp-1425) (if syntmp-tmp-1425 (apply (lambda (syntmp-x-1426) (call-with-values (lambda () (syntmp-cvt-1405 syntmp-x-1426 syntmp-n-1407 syntmp-ids-1408)) (lambda (syntmp-p-1428 syntmp-ids-1429) (values (vector (quote vector) syntmp-p-1428) syntmp-ids-1429)))) syntmp-tmp-1425) ((lambda (syntmp-x-1430) (values (vector (quote atom) (syntmp-strip-151 syntmp-p-1406 (quote (())))) syntmp-ids-1408)) syntmp-tmp-1409))) (syntax-dispatch syntmp-tmp-1409 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1409 (quote ()))))) (syntax-dispatch syntmp-tmp-1409 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1409 (quote (any any))))) syntmp-p-1406)))))) (lambda (syntmp-e-1431 syntmp-r-1432 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435) (let ((syntmp-e-1436 (syntmp-source-wrap-133 syntmp-e-1431 syntmp-w-1433 syntmp-s-1434 syntmp-mod-1435))) ((lambda (syntmp-tmp-1437) ((lambda (syntmp-tmp-1438) (if syntmp-tmp-1438 (apply (lambda (syntmp-_-1439 syntmp-val-1440 syntmp-key-1441 syntmp-m-1442) (if (andmap (lambda (syntmp-x-1443) (and (syntmp-id?-104 syntmp-x-1443) (not (syntmp-ellipsis?-149 syntmp-x-1443)))) syntmp-key-1441) (let ((syntmp-x-1445 (syntmp-gen-var-152 (quote tmp)))) (syntmp-build-annotated-81 syntmp-s-1434 (list (syntmp-build-annotated-81 #f (list (quote lambda) (list syntmp-x-1445) (syntmp-gen-syntax-case-1358 (syntmp-build-annotated-81 #f syntmp-x-1445) syntmp-key-1441 syntmp-m-1442 syntmp-r-1432 syntmp-mod-1435))) (syntmp-chi-140 syntmp-val-1440 syntmp-r-1432 (quote (())) syntmp-mod-1435)))) (syntax-error syntmp-e-1436 "invalid literals list in"))) syntmp-tmp-1438) (syntax-error syntmp-tmp-1437))) (syntax-dispatch syntmp-tmp-1437 (quote (any any each-any . each-any))))) syntmp-e-1436))))) (set! sc-expand (let ((syntmp-m-1448 (quote e)) (syntmp-esew-1449 (quote (eval)))) (lambda (syntmp-x-1450) (if (and (pair? syntmp-x-1450) (equal? (car syntmp-x-1450) syntmp-noexpand-71)) (cadr syntmp-x-1450) (syntmp-chi-top-139 syntmp-x-1450 (quote ()) (quote ((top))) syntmp-m-1448 syntmp-esew-1449 (module-name (current-module))))))) (set! sc-expand3 (let ((syntmp-m-1451 (quote e)) (syntmp-esew-1452 (quote (eval)))) (lambda (syntmp-x-1454 . syntmp-rest-1453) (if (and (pair? syntmp-x-1454) (equal? (car syntmp-x-1454) syntmp-noexpand-71)) (cadr syntmp-x-1454) (syntmp-chi-top-139 syntmp-x-1454 (quote ()) (quote ((top))) (if (null? syntmp-rest-1453) syntmp-m-1451 (car syntmp-rest-1453)) (if (or (null? syntmp-rest-1453) (null? (cdr syntmp-rest-1453))) syntmp-esew-1452 (cadr syntmp-rest-1453)) (module-name (current-module))))))) (set! identifier? (lambda (syntmp-x-1455) (syntmp-nonsymbol-id?-103 syntmp-x-1455))) (set! datum->syntax-object (lambda (syntmp-id-1456 syntmp-datum-1457) (syntmp-make-syntax-object-87 syntmp-datum-1457 (syntmp-syntax-object-wrap-90 syntmp-id-1456) #f))) (set! syntax-object->datum (lambda (syntmp-x-1458) (syntmp-strip-151 syntmp-x-1458 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1459) (begin (let ((syntmp-x-1460 syntmp-ls-1459)) (if (not (list? syntmp-x-1460)) (syntmp-error-hook-78 (quote generate-temporaries) "invalid argument" syntmp-x-1460))) (map (lambda (syntmp-x-1461) (syntmp-wrap-132 (gensym) (quote ((top))) #f)) syntmp-ls-1459)))) (set! free-identifier=? (lambda (syntmp-x-1462 syntmp-y-1463) (begin (let ((syntmp-x-1464 syntmp-x-1462)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1464)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1464))) (let ((syntmp-x-1465 syntmp-y-1463)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1465)) (syntmp-error-hook-78 (quote free-identifier=?) "invalid argument" syntmp-x-1465))) (syntmp-free-id=?-127 syntmp-x-1462 syntmp-y-1463)))) (set! bound-identifier=? (lambda (syntmp-x-1466 syntmp-y-1467) (begin (let ((syntmp-x-1468 syntmp-x-1466)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1468)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1468))) (let ((syntmp-x-1469 syntmp-y-1467)) (if (not (syntmp-nonsymbol-id?-103 syntmp-x-1469)) (syntmp-error-hook-78 (quote bound-identifier=?) "invalid argument" syntmp-x-1469))) (syntmp-bound-id=?-128 syntmp-x-1466 syntmp-y-1467)))) (set! syntax-error (lambda (syntmp-object-1471 . syntmp-messages-1470) (begin (for-each (lambda (syntmp-x-1472) (let ((syntmp-x-1473 syntmp-x-1472)) (if (not (string? syntmp-x-1473)) (syntmp-error-hook-78 (quote syntax-error) "invalid argument" syntmp-x-1473)))) syntmp-messages-1470) (let ((syntmp-message-1474 (if (null? syntmp-messages-1470) "invalid syntax" (apply string-append syntmp-messages-1470)))) (syntmp-error-hook-78 #f syntmp-message-1474 (syntmp-strip-151 syntmp-object-1471 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1475 syntmp-v-1476) (begin (let ((syntmp-x-1477 syntmp-sym-1475)) (if (not (symbol? syntmp-x-1477)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1477))) (let ((syntmp-x-1478 syntmp-v-1476)) (if (not (procedure? syntmp-x-1478)) (syntmp-error-hook-78 (quote define-syntax) "invalid argument" syntmp-x-1478))) (syntmp-global-extend-102 (quote macro) syntmp-sym-1475 syntmp-v-1476)))) (letrec ((syntmp-match-1483 (lambda (syntmp-e-1484 syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488) (cond ((not syntmp-r-1487) #f) ((eq? syntmp-p-1485 (quote any)) (cons (syntmp-wrap-132 syntmp-e-1484 syntmp-w-1486 syntmp-mod-1488) syntmp-r-1487)) ((syntmp-syntax-object?-88 syntmp-e-1484) (syntmp-match*-1482 (let ((syntmp-e-1489 (syntmp-syntax-object-expression-89 syntmp-e-1484))) (if (annotation? syntmp-e-1489) (annotation-expression syntmp-e-1489) syntmp-e-1489)) syntmp-p-1485 (syntmp-join-wraps-123 syntmp-w-1486 (syntmp-syntax-object-wrap-90 syntmp-e-1484)) syntmp-r-1487 (syntmp-syntax-object-module-91 syntmp-e-1484))) (else (syntmp-match*-1482 (let ((syntmp-e-1490 syntmp-e-1484)) (if (annotation? syntmp-e-1490) (annotation-expression syntmp-e-1490) syntmp-e-1490)) syntmp-p-1485 syntmp-w-1486 syntmp-r-1487 syntmp-mod-1488))))) (syntmp-match*-1482 (lambda (syntmp-e-1491 syntmp-p-1492 syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) (cond ((null? syntmp-p-1492) (and (null? syntmp-e-1491) syntmp-r-1494)) ((pair? syntmp-p-1492) (and (pair? syntmp-e-1491) (syntmp-match-1483 (car syntmp-e-1491) (car syntmp-p-1492) syntmp-w-1493 (syntmp-match-1483 (cdr syntmp-e-1491) (cdr syntmp-p-1492) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495) syntmp-mod-1495))) ((eq? syntmp-p-1492 (quote each-any)) (let ((syntmp-l-1496 (syntmp-match-each-any-1480 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1496 (cons syntmp-l-1496 syntmp-r-1494)))) (else (let ((syntmp-t-1497 (vector-ref syntmp-p-1492 0))) (if (memv syntmp-t-1497 (quote (each))) (if (null? syntmp-e-1491) (syntmp-match-empty-1481 (vector-ref syntmp-p-1492 1) syntmp-r-1494) (let ((syntmp-l-1498 (syntmp-match-each-1479 syntmp-e-1491 (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-mod-1495))) (and syntmp-l-1498 (let syntmp-collect-1499 ((syntmp-l-1500 syntmp-l-1498)) (if (null? (car syntmp-l-1500)) syntmp-r-1494 (cons (map car syntmp-l-1500) (syntmp-collect-1499 (map cdr syntmp-l-1500)))))))) (if (memv syntmp-t-1497 (quote (free-id))) (and (syntmp-id?-104 syntmp-e-1491) (syntmp-free-id=?-127 (syntmp-wrap-132 syntmp-e-1491 syntmp-w-1493 syntmp-mod-1495) (vector-ref syntmp-p-1492 1)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (atom))) (and (equal? (vector-ref syntmp-p-1492 1) (syntmp-strip-151 syntmp-e-1491 syntmp-w-1493)) syntmp-r-1494) (if (memv syntmp-t-1497 (quote (vector))) (and (vector? syntmp-e-1491) (syntmp-match-1483 (vector->list syntmp-e-1491) (vector-ref syntmp-p-1492 1) syntmp-w-1493 syntmp-r-1494 syntmp-mod-1495))))))))))) (syntmp-match-empty-1481 (lambda (syntmp-p-1501 syntmp-r-1502) (cond ((null? syntmp-p-1501) syntmp-r-1502) ((eq? syntmp-p-1501 (quote any)) (cons (quote ()) syntmp-r-1502)) ((pair? syntmp-p-1501) (syntmp-match-empty-1481 (car syntmp-p-1501) (syntmp-match-empty-1481 (cdr syntmp-p-1501) syntmp-r-1502))) ((eq? syntmp-p-1501 (quote each-any)) (cons (quote ()) syntmp-r-1502)) (else (let ((syntmp-t-1503 (vector-ref syntmp-p-1501 0))) (if (memv syntmp-t-1503 (quote (each))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502) (if (memv syntmp-t-1503 (quote (free-id atom))) syntmp-r-1502 (if (memv syntmp-t-1503 (quote (vector))) (syntmp-match-empty-1481 (vector-ref syntmp-p-1501 1) syntmp-r-1502))))))))) (syntmp-match-each-any-1480 (lambda (syntmp-e-1504 syntmp-w-1505 syntmp-mod-1506) (cond ((annotation? syntmp-e-1504) (syntmp-match-each-any-1480 (annotation-expression syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506)) ((pair? syntmp-e-1504) (let ((syntmp-l-1507 (syntmp-match-each-any-1480 (cdr syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506))) (and syntmp-l-1507 (cons (syntmp-wrap-132 (car syntmp-e-1504) syntmp-w-1505 syntmp-mod-1506) syntmp-l-1507)))) ((null? syntmp-e-1504) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1504) (syntmp-match-each-any-1480 (syntmp-syntax-object-expression-89 syntmp-e-1504) (syntmp-join-wraps-123 syntmp-w-1505 (syntmp-syntax-object-wrap-90 syntmp-e-1504)) syntmp-mod-1506)) (else #f)))) (syntmp-match-each-1479 (lambda (syntmp-e-1508 syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511) (cond ((annotation? syntmp-e-1508) (syntmp-match-each-1479 (annotation-expression syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511)) ((pair? syntmp-e-1508) (let ((syntmp-first-1512 (syntmp-match-1483 (car syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 (quote ()) syntmp-mod-1511))) (and syntmp-first-1512 (let ((syntmp-rest-1513 (syntmp-match-each-1479 (cdr syntmp-e-1508) syntmp-p-1509 syntmp-w-1510 syntmp-mod-1511))) (and syntmp-rest-1513 (cons syntmp-first-1512 syntmp-rest-1513)))))) ((null? syntmp-e-1508) (quote ())) ((syntmp-syntax-object?-88 syntmp-e-1508) (syntmp-match-each-1479 (syntmp-syntax-object-expression-89 syntmp-e-1508) syntmp-p-1509 (syntmp-join-wraps-123 syntmp-w-1510 (syntmp-syntax-object-wrap-90 syntmp-e-1508)) (syntmp-syntax-object-module-91 syntmp-e-1508))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1514 syntmp-p-1515) (cond ((eq? syntmp-p-1515 (quote any)) (list syntmp-e-1514)) ((syntmp-syntax-object?-88 syntmp-e-1514) (syntmp-match*-1482 (let ((syntmp-e-1516 (syntmp-syntax-object-expression-89 syntmp-e-1514))) (if (annotation? syntmp-e-1516) (annotation-expression syntmp-e-1516) syntmp-e-1516)) syntmp-p-1515 (syntmp-syntax-object-wrap-90 syntmp-e-1514) (quote ()) (syntmp-syntax-object-module-91 syntmp-e-1514))) (else (syntmp-match*-1482 (let ((syntmp-e-1517 syntmp-e-1514)) (if (annotation? syntmp-e-1517) (annotation-expression syntmp-e-1517) syntmp-e-1517)) syntmp-p-1515 (quote (())) (quote ()) #f))))) (set! sc-chi syntmp-chi-140))))) -(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1518) ((lambda (syntmp-tmp-1519) ((lambda (syntmp-tmp-1520) (if syntmp-tmp-1520 (apply (lambda (syntmp-_-1521 syntmp-e1-1522 syntmp-e2-1523) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1522 syntmp-e2-1523))) syntmp-tmp-1520) ((lambda (syntmp-tmp-1525) (if syntmp-tmp-1525 (apply (lambda (syntmp-_-1526 syntmp-out-1527 syntmp-in-1528 syntmp-e1-1529 syntmp-e2-1530) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1528 (quote ()) (list syntmp-out-1527 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1529 syntmp-e2-1530))))) syntmp-tmp-1525) ((lambda (syntmp-tmp-1532) (if syntmp-tmp-1532 (apply (lambda (syntmp-_-1533 syntmp-out-1534 syntmp-in-1535 syntmp-e1-1536 syntmp-e2-1537) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-in-1535) (quote ()) (list syntmp-out-1534 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1536 syntmp-e2-1537))))) syntmp-tmp-1532) (syntax-error syntmp-tmp-1519))) (syntax-dispatch syntmp-tmp-1519 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1519 (quote (any () any . each-any))))) syntmp-x-1518))) -(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1559) ((lambda (syntmp-tmp-1560) ((lambda (syntmp-tmp-1561) (if syntmp-tmp-1561 (apply (lambda (syntmp-_-1562 syntmp-k-1563 syntmp-keyword-1564 syntmp-pattern-1565 syntmp-template-1566) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-k-1563 (map (lambda (syntmp-tmp-1569 syntmp-tmp-1568) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1568) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-tmp-1569))) syntmp-template-1566 syntmp-pattern-1565)))))) syntmp-tmp-1561) (syntax-error syntmp-tmp-1560))) (syntax-dispatch syntmp-tmp-1560 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1559))) -(install-global-transformer (quote let*) (lambda (syntmp-x-1580) ((lambda (syntmp-tmp-1581) ((lambda (syntmp-tmp-1582) (if (if syntmp-tmp-1582 (apply (lambda (syntmp-let*-1583 syntmp-x-1584 syntmp-v-1585 syntmp-e1-1586 syntmp-e2-1587) (andmap identifier? syntmp-x-1584)) syntmp-tmp-1582) #f) (apply (lambda (syntmp-let*-1589 syntmp-x-1590 syntmp-v-1591 syntmp-e1-1592 syntmp-e2-1593) (let syntmp-f-1594 ((syntmp-bindings-1595 (map list syntmp-x-1590 syntmp-v-1591))) (if (null? syntmp-bindings-1595) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons (quote ()) (cons syntmp-e1-1592 syntmp-e2-1593))) ((lambda (syntmp-tmp-1599) ((lambda (syntmp-tmp-1600) (if syntmp-tmp-1600 (apply (lambda (syntmp-body-1601 syntmp-binding-1602) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list syntmp-binding-1602) syntmp-body-1601)) syntmp-tmp-1600) (syntax-error syntmp-tmp-1599))) (syntax-dispatch syntmp-tmp-1599 (quote (any any))))) (list (syntmp-f-1594 (cdr syntmp-bindings-1595)) (car syntmp-bindings-1595)))))) syntmp-tmp-1582) (syntax-error syntmp-tmp-1581))) (syntax-dispatch syntmp-tmp-1581 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1580))) -(install-global-transformer (quote do) (lambda (syntmp-orig-x-1622) ((lambda (syntmp-tmp-1623) ((lambda (syntmp-tmp-1624) (if syntmp-tmp-1624 (apply (lambda (syntmp-_-1625 syntmp-var-1626 syntmp-init-1627 syntmp-step-1628 syntmp-e0-1629 syntmp-e1-1630 syntmp-c-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-step-1634) ((lambda (syntmp-tmp-1635) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1636) ((lambda (syntmp-tmp-1641) (if syntmp-tmp-1641 (apply (lambda (syntmp-e1-1642 syntmp-e2-1643) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (map list syntmp-var-1626 syntmp-init-1627) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e0-1629 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1642 syntmp-e2-1643)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) (append syntmp-c-1631 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (ice-9 syncase))) syntmp-step-1634))))))) syntmp-tmp-1641) (syntax-error syntmp-tmp-1635))) (syntax-dispatch syntmp-tmp-1635 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1635 (quote ())))) syntmp-e1-1630)) syntmp-tmp-1633) (syntax-error syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote each-any)))) (map (lambda (syntmp-v-1650 syntmp-s-1651) ((lambda (syntmp-tmp-1652) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda () syntmp-v-1650) syntmp-tmp-1653) ((lambda (syntmp-tmp-1654) (if syntmp-tmp-1654 (apply (lambda (syntmp-e-1655) syntmp-e-1655) syntmp-tmp-1654) ((lambda (syntmp-_-1656) (syntax-error syntmp-orig-x-1622)) syntmp-tmp-1652))) (syntax-dispatch syntmp-tmp-1652 (quote (any)))))) (syntax-dispatch syntmp-tmp-1652 (quote ())))) syntmp-s-1651)) syntmp-var-1626 syntmp-step-1628))) syntmp-tmp-1624) (syntax-error syntmp-tmp-1623))) (syntax-dispatch syntmp-tmp-1623 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1622))) -(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1684 (lambda (syntmp-x-1688 syntmp-y-1689) ((lambda (syntmp-tmp-1690) ((lambda (syntmp-tmp-1691) (if syntmp-tmp-1691 (apply (lambda (syntmp-x-1692 syntmp-y-1693) ((lambda (syntmp-tmp-1694) ((lambda (syntmp-tmp-1695) (if syntmp-tmp-1695 (apply (lambda (syntmp-dy-1696) ((lambda (syntmp-tmp-1697) ((lambda (syntmp-tmp-1698) (if syntmp-tmp-1698 (apply (lambda (syntmp-dx-1699) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-dx-1699 syntmp-dy-1696))) syntmp-tmp-1698) ((lambda (syntmp-_-1700) (if (null? syntmp-dy-1696) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693))) syntmp-tmp-1697))) (syntax-dispatch syntmp-tmp-1697 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-x-1692)) syntmp-tmp-1695) ((lambda (syntmp-tmp-1701) (if syntmp-tmp-1701 (apply (lambda (syntmp-stuff-1702) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (cons syntmp-x-1692 syntmp-stuff-1702))) syntmp-tmp-1701) ((lambda (syntmp-else-1703) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1692 syntmp-y-1693)) syntmp-tmp-1694))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . any)))))) (syntax-dispatch syntmp-tmp-1694 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-y-1693)) syntmp-tmp-1691) (syntax-error syntmp-tmp-1690))) (syntax-dispatch syntmp-tmp-1690 (quote (any any))))) (list syntmp-x-1688 syntmp-y-1689)))) (syntmp-quasiappend-1685 (lambda (syntmp-x-1704 syntmp-y-1705) ((lambda (syntmp-tmp-1706) ((lambda (syntmp-tmp-1707) (if syntmp-tmp-1707 (apply (lambda (syntmp-x-1708 syntmp-y-1709) ((lambda (syntmp-tmp-1710) ((lambda (syntmp-tmp-1711) (if syntmp-tmp-1711 (apply (lambda () syntmp-x-1708) syntmp-tmp-1711) ((lambda (syntmp-_-1712) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1708 syntmp-y-1709)) syntmp-tmp-1710))) (syntax-dispatch syntmp-tmp-1710 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) ()))))) syntmp-y-1709)) syntmp-tmp-1707) (syntax-error syntmp-tmp-1706))) (syntax-dispatch syntmp-tmp-1706 (quote (any any))))) (list syntmp-x-1704 syntmp-y-1705)))) (syntmp-quasivector-1686 (lambda (syntmp-x-1713) ((lambda (syntmp-tmp-1714) ((lambda (syntmp-x-1715) ((lambda (syntmp-tmp-1716) ((lambda (syntmp-tmp-1717) (if syntmp-tmp-1717 (apply (lambda (syntmp-x-1718) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) (list->vector syntmp-x-1718))) syntmp-tmp-1717) ((lambda (syntmp-tmp-1720) (if syntmp-tmp-1720 (apply (lambda (syntmp-x-1721) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1721)) syntmp-tmp-1720) ((lambda (syntmp-_-1723) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-x-1715)) syntmp-tmp-1716))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) . each-any)))))) (syntax-dispatch syntmp-tmp-1716 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) each-any))))) syntmp-x-1715)) syntmp-tmp-1714)) syntmp-x-1713))) (syntmp-quasi-1687 (lambda (syntmp-p-1724 syntmp-lev-1725) ((lambda (syntmp-tmp-1726) ((lambda (syntmp-tmp-1727) (if syntmp-tmp-1727 (apply (lambda (syntmp-p-1728) (if (= syntmp-lev-1725 0) syntmp-p-1728 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1728) (- syntmp-lev-1725 1))))) syntmp-tmp-1727) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-p-1730 syntmp-q-1731) (if (= syntmp-lev-1725 0) (syntmp-quasiappend-1685 syntmp-p-1730 (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)) (syntmp-quasicons-1684 (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1730) (- syntmp-lev-1725 1))) (syntmp-quasi-1687 syntmp-q-1731 syntmp-lev-1725)))) syntmp-tmp-1729) ((lambda (syntmp-tmp-1732) (if syntmp-tmp-1732 (apply (lambda (syntmp-p-1733) (syntmp-quasicons-1684 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase)))) (syntmp-quasi-1687 (list syntmp-p-1733) (+ syntmp-lev-1725 1)))) syntmp-tmp-1732) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-p-1735 syntmp-q-1736) (syntmp-quasicons-1684 (syntmp-quasi-1687 syntmp-p-1735 syntmp-lev-1725) (syntmp-quasi-1687 syntmp-q-1736 syntmp-lev-1725))) syntmp-tmp-1734) ((lambda (syntmp-tmp-1737) (if syntmp-tmp-1737 (apply (lambda (syntmp-x-1738) (syntmp-quasivector-1686 (syntmp-quasi-1687 syntmp-x-1738 syntmp-lev-1725))) syntmp-tmp-1737) ((lambda (syntmp-p-1740) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) syntmp-p-1740)) syntmp-tmp-1726))) (syntax-dispatch syntmp-tmp-1726 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any)))))) (syntax-dispatch syntmp-tmp-1726 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any) . any)))))) (syntax-dispatch syntmp-tmp-1726 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (ice-9 syncase))) any))))) syntmp-p-1724)))) (lambda (syntmp-x-1741) ((lambda (syntmp-tmp-1742) ((lambda (syntmp-tmp-1743) (if syntmp-tmp-1743 (apply (lambda (syntmp-_-1744 syntmp-e-1745) (syntmp-quasi-1687 syntmp-e-1745 0)) syntmp-tmp-1743) (syntax-error syntmp-tmp-1742))) (syntax-dispatch syntmp-tmp-1742 (quote (any any))))) syntmp-x-1741)))) -(install-global-transformer (quote include) (lambda (syntmp-x-1805) (letrec ((syntmp-read-file-1806 (lambda (syntmp-fn-1807 syntmp-k-1808) (let ((syntmp-p-1809 (open-input-file syntmp-fn-1807))) (let syntmp-f-1810 ((syntmp-x-1811 (read syntmp-p-1809))) (if (eof-object? syntmp-x-1811) (begin (close-input-port syntmp-p-1809) (quote ())) (cons (datum->syntax-object syntmp-k-1808 syntmp-x-1811) (syntmp-f-1810 (read syntmp-p-1809))))))))) ((lambda (syntmp-tmp-1812) ((lambda (syntmp-tmp-1813) (if syntmp-tmp-1813 (apply (lambda (syntmp-k-1814 syntmp-filename-1815) (let ((syntmp-fn-1816 (syntax-object->datum syntmp-filename-1815))) ((lambda (syntmp-tmp-1817) ((lambda (syntmp-tmp-1818) (if syntmp-tmp-1818 (apply (lambda (syntmp-exp-1819) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-exp-1819)) syntmp-tmp-1818) (syntax-error syntmp-tmp-1817))) (syntax-dispatch syntmp-tmp-1817 (quote each-any)))) (syntmp-read-file-1806 syntmp-fn-1816 syntmp-k-1814)))) syntmp-tmp-1813) (syntax-error syntmp-tmp-1812))) (syntax-dispatch syntmp-tmp-1812 (quote (any any))))) syntmp-x-1805)))) -(install-global-transformer (quote unquote) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1840))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836))) -(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1846) ((lambda (syntmp-tmp-1847) ((lambda (syntmp-tmp-1848) (if syntmp-tmp-1848 (apply (lambda (syntmp-_-1849 syntmp-e-1850) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1850))) syntmp-tmp-1848) (syntax-error syntmp-tmp-1847))) (syntax-dispatch syntmp-tmp-1847 (quote (any any))))) syntmp-x-1846))) -(install-global-transformer (quote case) (lambda (syntmp-x-1856) ((lambda (syntmp-tmp-1857) ((lambda (syntmp-tmp-1858) (if syntmp-tmp-1858 (apply (lambda (syntmp-_-1859 syntmp-e-1860 syntmp-m1-1861 syntmp-m2-1862) ((lambda (syntmp-tmp-1863) ((lambda (syntmp-body-1864) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1860)) syntmp-body-1864)) syntmp-tmp-1863)) (let syntmp-f-1865 ((syntmp-clause-1866 syntmp-m1-1861) (syntmp-clauses-1867 syntmp-m2-1862)) (if (null? syntmp-clauses-1867) ((lambda (syntmp-tmp-1869) ((lambda (syntmp-tmp-1870) (if syntmp-tmp-1870 (apply (lambda (syntmp-e1-1871 syntmp-e2-1872) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1871 syntmp-e2-1872))) syntmp-tmp-1870) ((lambda (syntmp-tmp-1874) (if syntmp-tmp-1874 (apply (lambda (syntmp-k-1875 syntmp-e1-1876 syntmp-e2-1877) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1875)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1876 syntmp-e2-1877)))) syntmp-tmp-1874) ((lambda (syntmp-_-1880) (syntax-error syntmp-x-1856)) syntmp-tmp-1869))) (syntax-dispatch syntmp-tmp-1869 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1869 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) any . each-any))))) syntmp-clause-1866) ((lambda (syntmp-tmp-1881) ((lambda (syntmp-rest-1882) ((lambda (syntmp-tmp-1883) ((lambda (syntmp-tmp-1884) (if syntmp-tmp-1884 (apply (lambda (syntmp-k-1885 syntmp-e1-1886 syntmp-e2-1887) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-k-1885)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e1-1886 syntmp-e2-1887)) syntmp-rest-1882)) syntmp-tmp-1884) ((lambda (syntmp-_-1890) (syntax-error syntmp-x-1856)) syntmp-tmp-1883))) (syntax-dispatch syntmp-tmp-1883 (quote (each-any any . each-any))))) syntmp-clause-1866)) syntmp-tmp-1881)) (syntmp-f-1865 (car syntmp-clauses-1867) (cdr syntmp-clauses-1867))))))) syntmp-tmp-1858) (syntax-error syntmp-tmp-1857))) (syntax-dispatch syntmp-tmp-1857 (quote (any any any . each-any))))) syntmp-x-1856))) -(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1920) ((lambda (syntmp-tmp-1921) ((lambda (syntmp-tmp-1922) (if syntmp-tmp-1922 (apply (lambda (syntmp-_-1923 syntmp-e-1924) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) syntmp-e-1924)) (list (cons syntmp-_-1923 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase))) (cons syntmp-e-1924 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (ice-9 syncase)))))))))) syntmp-tmp-1922) (syntax-error syntmp-tmp-1921))) (syntax-dispatch syntmp-tmp-1921 (quote (any any))))) syntmp-x-1920))) +(eval-when (compile) (set-current-module (resolve-module (quote (guile))))) +(if #f #f) +(letrec ((and-map*151 (lambda (f191 first190 . rest189) (let ((t192 (null? first190))) (if t192 t192 (if (null? rest189) (letrec ((andmap193 (lambda (first194) (let ((x195 (car first194)) (first196 (cdr first194))) (if (null? first196) (f191 x195) (if (f191 x195) (andmap193 first196) #f)))))) (andmap193 first190)) (letrec ((andmap197 (lambda (first198 rest199) (let ((x200 (car first198)) (xr201 (map car rest199)) (first202 (cdr first198)) (rest203 (map cdr rest199))) (if (null? first202) (apply f191 (cons x200 xr201)) (if (apply f191 (cons x200 xr201)) (andmap197 first202 rest203) #f)))))) (andmap197 first190 rest189)))))))) (letrec ((lambda-var-list296 (lambda (vars420) (letrec ((lvl421 (lambda (vars422 ls423 w424) (if (pair? vars422) (lvl421 (cdr vars422) (cons (wrap276 (car vars422) w424 #f) ls423) w424) (if (id?248 vars422) (cons (wrap276 vars422 w424 #f) ls423) (if (null? vars422) ls423 (if (syntax-object?232 vars422) (lvl421 (syntax-object-expression233 vars422) ls423 (join-wraps267 w424 (syntax-object-wrap234 vars422))) (cons vars422 ls423)))))))) (lvl421 vars420 (quote ()) (quote (())))))) (gen-var295 (lambda (id425) (let ((id426 (if (syntax-object?232 id425) (syntax-object-expression233 id425) id425))) (gensym (symbol->string id426))))) (strip294 (lambda (x427 w428) (if (memq (quote top) (wrap-marks251 w428)) x427 (letrec ((f429 (lambda (x430) (if (syntax-object?232 x430) (strip294 (syntax-object-expression233 x430) (syntax-object-wrap234 x430)) (if (pair? x430) (let ((a431 (f429 (car x430))) (d432 (f429 (cdr x430)))) (if (if (eq? a431 (car x430)) (eq? d432 (cdr x430)) #f) x430 (cons a431 d432))) (if (vector? x430) (let ((old433 (vector->list x430))) (let ((new434 (map f429 old433))) (if (and-map*151 eq? old433 new434) x430 (list->vector new434)))) x430)))))) (f429 x427))))) (ellipsis?293 (lambda (x435) (if (nonsymbol-id?247 x435) (free-id=?271 x435 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) #f))) (chi-void292 (lambda () (build-void214 #f))) (eval-local-transformer291 (lambda (expanded436 mod437) (let ((p438 (local-eval-hook211 expanded436 mod437))) (if (procedure? p438) p438 (syntax-violation #f "nonprocedure transformer" p438))))) (chi-local-syntax290 (lambda (rec?439 e440 r441 w442 s443 mod444 k445) ((lambda (tmp446) ((lambda (tmp447) (if tmp447 (apply (lambda (_448 id449 val450 e1451 e2452) (let ((ids453 id449)) (if (not (valid-bound-ids?273 ids453)) (syntax-violation #f "duplicate bound keyword" e440) (let ((labels455 (gen-labels254 ids453))) (let ((new-w456 (make-binding-wrap265 ids453 labels455 w442))) (k445 (cons e1451 e2452) (extend-env242 labels455 (let ((w458 (if rec?439 new-w456 w442)) (trans-r459 (macros-only-env244 r441))) (map (lambda (x460) (cons (quote macro) (eval-local-transformer291 (chi284 x460 trans-r459 w458 mod444) mod444))) val450)) r441) new-w456 s443 mod444)))))) tmp447) ((lambda (_462) (syntax-violation #f "bad local syntax definition" (source-wrap277 e440 w442 s443 mod444))) tmp446))) ($sc-dispatch tmp446 (quote (any #(each (any any)) any . each-any))))) e440))) (chi-lambda-clause289 (lambda (e463 docstring464 c465 r466 w467 mod468 k469) ((lambda (tmp470) ((lambda (tmp471) (if (if tmp471 (apply (lambda (args472 doc473 e1474 e2475) (if (string? (syntax->datum doc473)) (not docstring464) #f)) tmp471) #f) (apply (lambda (args476 doc477 e1478 e2479) (chi-lambda-clause289 e463 doc477 (cons args476 (cons e1478 e2479)) r466 w467 mod468 k469)) tmp471) ((lambda (tmp481) (if tmp481 (apply (lambda (id482 e1483 e2484) (let ((ids485 id482)) (if (not (valid-bound-ids?273 ids485)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels487 (gen-labels254 ids485)) (new-vars488 (map gen-var295 ids485))) (k469 (map syntax->datum ids485) new-vars488 (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1483 e2484) e463 (extend-var-env243 labels487 new-vars488 r466) (make-binding-wrap265 ids485 labels487 w467) mod468)))))) tmp481) ((lambda (tmp490) (if tmp490 (apply (lambda (ids491 e1492 e2493) (let ((old-ids494 (lambda-var-list296 ids491))) (if (not (valid-bound-ids?273 old-ids494)) (syntax-violation (quote lambda) "invalid parameter list" e463) (let ((labels495 (gen-labels254 old-ids494)) (new-vars496 (map gen-var295 old-ids494))) (k469 (letrec ((f497 (lambda (ls1498 ls2499) (if (null? ls1498) (syntax->datum ls2499) (f497 (cdr ls1498) (cons (syntax->datum (car ls1498)) ls2499)))))) (f497 (cdr old-ids494) (car old-ids494))) (letrec ((f500 (lambda (ls1501 ls2502) (if (null? ls1501) ls2502 (f500 (cdr ls1501) (cons (car ls1501) ls2502)))))) (f500 (cdr new-vars496) (car new-vars496))) (if docstring464 (syntax->datum docstring464) #f) (chi-body288 (cons e1492 e2493) e463 (extend-var-env243 labels495 new-vars496 r466) (make-binding-wrap265 old-ids494 labels495 w467) mod468)))))) tmp490) ((lambda (_504) (syntax-violation (quote lambda) "bad lambda" e463)) tmp470))) ($sc-dispatch tmp470 (quote (any any . each-any)))))) ($sc-dispatch tmp470 (quote (each-any any . each-any)))))) ($sc-dispatch tmp470 (quote (any any any . each-any))))) c465))) (chi-body288 (lambda (body505 outer-form506 r507 w508 mod509) (let ((r510 (cons (quote ("placeholder" placeholder)) r507))) (let ((ribcage511 (make-ribcage255 (quote ()) (quote ()) (quote ())))) (let ((w512 (make-wrap250 (wrap-marks251 w508) (cons ribcage511 (wrap-subst252 w508))))) (letrec ((parse513 (lambda (body514 ids515 labels516 var-ids517 vars518 vals519 bindings520) (if (null? body514) (syntax-violation #f "no expressions in body" outer-form506) (let ((e522 (cdar body514)) (er523 (caar body514))) (call-with-values (lambda () (syntax-type282 e522 er523 (quote (())) (source-annotation239 er523) ribcage511 mod509)) (lambda (type524 value525 e526 w527 s528 mod529) (if (memv type524 (quote (define-form))) (let ((id530 (wrap276 value525 w527 mod529)) (label531 (gen-label253))) (let ((var532 (gen-var295 id530))) (begin (extend-ribcage!264 ribcage511 id530 label531) (parse513 (cdr body514) (cons id530 ids515) (cons label531 labels516) (cons id530 var-ids517) (cons var532 vars518) (cons (cons er523 (wrap276 e526 w527 mod529)) vals519) (cons (cons (quote lexical) var532) bindings520))))) (if (memv type524 (quote (define-syntax-form))) (let ((id533 (wrap276 value525 w527 mod529)) (label534 (gen-label253))) (begin (extend-ribcage!264 ribcage511 id533 label534) (parse513 (cdr body514) (cons id533 ids515) (cons label534 labels516) var-ids517 vars518 vals519 (cons (cons (quote macro) (cons er523 (wrap276 e526 w527 mod529))) bindings520)))) (if (memv type524 (quote (begin-form))) ((lambda (tmp535) ((lambda (tmp536) (if tmp536 (apply (lambda (_537 e1538) (parse513 (letrec ((f539 (lambda (forms540) (if (null? forms540) (cdr body514) (cons (cons er523 (wrap276 (car forms540) w527 mod529)) (f539 (cdr forms540))))))) (f539 e1538)) ids515 labels516 var-ids517 vars518 vals519 bindings520)) tmp536) (syntax-violation #f "source expression failed to match any pattern" tmp535))) ($sc-dispatch tmp535 (quote (any . each-any))))) e526) (if (memv type524 (quote (local-syntax-form))) (chi-local-syntax290 value525 e526 er523 w527 s528 mod529 (lambda (forms542 er543 w544 s545 mod546) (parse513 (letrec ((f547 (lambda (forms548) (if (null? forms548) (cdr body514) (cons (cons er543 (wrap276 (car forms548) w544 mod546)) (f547 (cdr forms548))))))) (f547 forms542)) ids515 labels516 var-ids517 vars518 vals519 bindings520))) (if (null? ids515) (build-sequence227 #f (map (lambda (x549) (chi284 (cdr x549) (car x549) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))) (begin (if (not (valid-bound-ids?273 ids515)) (syntax-violation #f "invalid or duplicate identifier in definition" outer-form506)) (letrec ((loop550 (lambda (bs551 er-cache552 r-cache553) (if (not (null? bs551)) (let ((b554 (car bs551))) (if (eq? (car b554) (quote macro)) (let ((er555 (cadr b554))) (let ((r-cache556 (if (eq? er555 er-cache552) r-cache553 (macros-only-env244 er555)))) (begin (set-cdr! b554 (eval-local-transformer291 (chi284 (cddr b554) r-cache556 (quote (())) mod529) mod529)) (loop550 (cdr bs551) er555 r-cache556)))) (loop550 (cdr bs551) er-cache552 r-cache553))))))) (loop550 bindings520 #f #f)) (set-cdr! r510 (extend-env242 labels516 bindings520 (cdr r510))) (build-letrec230 #f (map syntax->datum var-ids517) vars518 (map (lambda (x557) (chi284 (cdr x557) (car x557) (quote (())) mod529)) vals519) (build-sequence227 #f (map (lambda (x558) (chi284 (cdr x558) (car x558) (quote (())) mod529)) (cons (cons er523 (source-wrap277 e526 w527 s528 mod529)) (cdr body514)))))))))))))))))) (parse513 (map (lambda (x521) (cons r510 (wrap276 x521 w512 mod509))) body505) (quote ()) (quote ()) (quote ()) (quote ()) (quote ()) (quote ())))))))) (chi-macro287 (lambda (p559 e560 r561 w562 rib563 mod564) (letrec ((rebuild-macro-output565 (lambda (x566 m567) (if (pair? x566) (cons (rebuild-macro-output565 (car x566) m567) (rebuild-macro-output565 (cdr x566) m567)) (if (syntax-object?232 x566) (let ((w568 (syntax-object-wrap234 x566))) (let ((ms569 (wrap-marks251 w568)) (s570 (wrap-subst252 w568))) (if (if (pair? ms569) (eq? (car ms569) #f) #f) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cdr ms569) (if rib563 (cons rib563 (cdr s570)) (cdr s570))) (syntax-object-module235 x566)) (make-syntax-object231 (syntax-object-expression233 x566) (make-wrap250 (cons m567 ms569) (if rib563 (cons rib563 (cons (quote shift) s570)) (cons (quote shift) s570))) (let ((pmod571 (procedure-module p559))) (if pmod571 (cons (quote hygiene) (module-name pmod571)) (quote (hygiene guile)))))))) (if (vector? x566) (let ((n572 (vector-length x566))) (let ((v573 (make-vector n572))) (letrec ((loop574 (lambda (i575) (if (fx=208 i575 n572) (begin (if #f #f) v573) (begin (vector-set! v573 i575 (rebuild-macro-output565 (vector-ref x566 i575) m567)) (loop574 (fx+206 i575 1))))))) (loop574 0)))) (if (symbol? x566) (syntax-violation #f "encountered raw symbol in macro output" (source-wrap277 e560 w562 s mod564) x566) x566))))))) (rebuild-macro-output565 (p559 (wrap276 e560 (anti-mark263 w562) mod564)) (string #\m))))) (chi-application286 (lambda (x576 e577 r578 w579 s580 mod581) ((lambda (tmp582) ((lambda (tmp583) (if tmp583 (apply (lambda (e0584 e1585) (build-application215 s580 x576 (map (lambda (e586) (chi284 e586 r578 w579 mod581)) e1585))) tmp583) (syntax-violation #f "source expression failed to match any pattern" tmp582))) ($sc-dispatch tmp582 (quote (any . each-any))))) e577))) (chi-expr285 (lambda (type588 value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (lexical))) (build-lexical-reference217 (quote value) s593 e590 value589) (if (memv type588 (quote (core external-macro))) (value589 e590 r591 w592 s593 mod594) (if (memv type588 (quote (module-ref))) (call-with-values (lambda () (value589 e590)) (lambda (id595 mod596) (build-global-reference220 s593 id595 mod596))) (if (memv type588 (quote (lexical-call))) (chi-application286 (build-lexical-reference217 (quote fun) (source-annotation239 (car e590)) (car e590) value589) e590 r591 w592 s593 mod594) (if (memv type588 (quote (global-call))) (chi-application286 (build-global-reference220 (source-annotation239 (car e590)) value589 (if (syntax-object?232 (car e590)) (syntax-object-module235 (car e590)) mod594)) e590 r591 w592 s593 mod594) (if (memv type588 (quote (constant))) (build-data226 s593 (strip294 (source-wrap277 e590 w592 s593 mod594) (quote (())))) (if (memv type588 (quote (global))) (build-global-reference220 s593 value589 mod594) (if (memv type588 (quote (call))) (chi-application286 (chi284 (car e590) r591 w592 mod594) e590 r591 w592 s593 mod594) (if (memv type588 (quote (begin-form))) ((lambda (tmp597) ((lambda (tmp598) (if tmp598 (apply (lambda (_599 e1600 e2601) (chi-sequence278 (cons e1600 e2601) r591 w592 s593 mod594)) tmp598) (syntax-violation #f "source expression failed to match any pattern" tmp597))) ($sc-dispatch tmp597 (quote (any any . each-any))))) e590) (if (memv type588 (quote (local-syntax-form))) (chi-local-syntax290 value589 e590 r591 w592 s593 mod594 chi-sequence278) (if (memv type588 (quote (eval-when-form))) ((lambda (tmp603) ((lambda (tmp604) (if tmp604 (apply (lambda (_605 x606 e1607 e2608) (let ((when-list609 (chi-when-list281 e590 x606 w592))) (if (memq (quote eval) when-list609) (chi-sequence278 (cons e1607 e2608) r591 w592 s593 mod594) (chi-void292)))) tmp604) (syntax-violation #f "source expression failed to match any pattern" tmp603))) ($sc-dispatch tmp603 (quote (any each-any any . each-any))))) e590) (if (memv type588 (quote (define-form define-syntax-form))) (syntax-violation #f "definition in expression context" e590 (wrap276 value589 w592 mod594)) (if (memv type588 (quote (syntax))) (syntax-violation #f "reference to pattern variable outside syntax form" (source-wrap277 e590 w592 s593 mod594)) (if (memv type588 (quote (displaced-lexical))) (syntax-violation #f "reference to identifier outside its scope" (source-wrap277 e590 w592 s593 mod594)) (syntax-violation #f "unexpected syntax" (source-wrap277 e590 w592 s593 mod594)))))))))))))))))) (chi284 (lambda (e612 r613 w614 mod615) (call-with-values (lambda () (syntax-type282 e612 r613 w614 (source-annotation239 e612) #f mod615)) (lambda (type616 value617 e618 w619 s620 mod621) (chi-expr285 type616 value617 e618 r613 w619 s620 mod621))))) (chi-top283 (lambda (e622 r623 w624 m625 esew626 mod627) (call-with-values (lambda () (syntax-type282 e622 r623 w624 (source-annotation239 e622) #f mod627)) (lambda (type635 value636 e637 w638 s639 mod640) (if (memv type635 (quote (begin-form))) ((lambda (tmp641) ((lambda (tmp642) (if tmp642 (apply (lambda (_643) (chi-void292)) tmp642) ((lambda (tmp644) (if tmp644 (apply (lambda (_645 e1646 e2647) (chi-top-sequence279 (cons e1646 e2647) r623 w638 s639 m625 esew626 mod640)) tmp644) (syntax-violation #f "source expression failed to match any pattern" tmp641))) ($sc-dispatch tmp641 (quote (any any . each-any)))))) ($sc-dispatch tmp641 (quote (any))))) e637) (if (memv type635 (quote (local-syntax-form))) (chi-local-syntax290 value636 e637 r623 w638 s639 mod640 (lambda (body649 r650 w651 s652 mod653) (chi-top-sequence279 body649 r650 w651 s652 m625 esew626 mod653))) (if (memv type635 (quote (eval-when-form))) ((lambda (tmp654) ((lambda (tmp655) (if tmp655 (apply (lambda (_656 x657 e1658 e2659) (let ((when-list660 (chi-when-list281 e637 x657 w638)) (body661 (cons e1658 e2659))) (if (eq? m625 (quote e)) (if (memq (quote eval) when-list660) (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) (chi-void292)) (if (memq (quote load) when-list660) (if (let ((t664 (memq (quote compile) when-list660))) (if t664 t664 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (chi-top-sequence279 body661 r623 w638 s639 (quote c&e) (quote (compile load)) mod640) (if (memq m625 (quote (c c&e))) (chi-top-sequence279 body661 r623 w638 s639 (quote c) (quote (load)) mod640) (chi-void292))) (if (let ((t665 (memq (quote compile) when-list660))) (if t665 t665 (if (eq? m625 (quote c&e)) (memq (quote eval) when-list660) #f))) (begin (top-level-eval-hook210 (chi-top-sequence279 body661 r623 w638 s639 (quote e) (quote (eval)) mod640) mod640) (chi-void292)) (chi-void292)))))) tmp655) (syntax-violation #f "source expression failed to match any pattern" tmp654))) ($sc-dispatch tmp654 (quote (any each-any any . each-any))))) e637) (if (memv type635 (quote (define-syntax-form))) (let ((n666 (id-var-name270 value636 w638)) (r667 (macros-only-env244 r623))) (if (memv m625 (quote (c))) (if (memq (quote compile) esew626) (let ((e668 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e668 mod640) (if (memq (quote load) esew626) e668 (chi-void292)))) (if (memq (quote load) esew626) (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) (chi-void292))) (if (memv m625 (quote (c&e))) (let ((e669 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)))) (begin (top-level-eval-hook210 e669 mod640) e669)) (begin (if (memq (quote eval) esew626) (top-level-eval-hook210 (chi-install-global280 n666 (chi284 e637 r667 w638 mod640)) mod640)) (chi-void292))))) (if (memv type635 (quote (define-form))) (let ((n670 (id-var-name270 value636 w638))) (let ((type671 (binding-type240 (lookup245 n670 r623 mod640)))) (if (memv type671 (quote (global core macro module-ref))) (let ((x672 (build-global-definition223 s639 n670 (chi284 e637 r623 w638 mod640)))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x672 mod640)) x672)) (if (memv type671 (quote (displaced-lexical))) (syntax-violation #f "identifier out of context" e637 (wrap276 value636 w638 mod640)) (syntax-violation #f "cannot define keyword at top level" e637 (wrap276 value636 w638 mod640)))))) (let ((x673 (chi-expr285 type635 value636 e637 r623 w638 s639 mod640))) (begin (if (eq? m625 (quote c&e)) (top-level-eval-hook210 x673 mod640)) x673))))))))))) (syntax-type282 (lambda (e674 r675 w676 s677 rib678 mod679) (if (symbol? e674) (let ((n680 (id-var-name270 e674 w676))) (let ((b681 (lookup245 n680 r675 mod679))) (let ((type682 (binding-type240 b681))) (if (memv type682 (quote (lexical))) (values type682 (binding-value241 b681) e674 w676 s677 mod679) (if (memv type682 (quote (global))) (values type682 n680 e674 w676 s677 mod679) (if (memv type682 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b681) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (values type682 (binding-value241 b681) e674 w676 s677 mod679))))))) (if (pair? e674) (let ((first683 (car e674))) (if (id?248 first683) (let ((n684 (id-var-name270 first683 w676))) (let ((b685 (lookup245 n684 r675 (let ((t686 (if (syntax-object?232 first683) (syntax-object-module235 first683) #f))) (if t686 t686 mod679))))) (let ((type687 (binding-type240 b685))) (if (memv type687 (quote (lexical))) (values (quote lexical-call) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (global))) (values (quote global-call) n684 e674 w676 s677 mod679) (if (memv type687 (quote (macro))) (syntax-type282 (chi-macro287 (binding-value241 b685) e674 r675 w676 rib678 mod679) r675 (quote (())) s677 rib678 mod679) (if (memv type687 (quote (core external-macro module-ref))) (values type687 (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (local-syntax))) (values (quote local-syntax-form) (binding-value241 b685) e674 w676 s677 mod679) (if (memv type687 (quote (begin))) (values (quote begin-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (eval-when))) (values (quote eval-when-form) #f e674 w676 s677 mod679) (if (memv type687 (quote (define))) ((lambda (tmp688) ((lambda (tmp689) (if (if tmp689 (apply (lambda (_690 name691 val692) (id?248 name691)) tmp689) #f) (apply (lambda (_693 name694 val695) (values (quote define-form) name694 val695 w676 s677 mod679)) tmp689) ((lambda (tmp696) (if (if tmp696 (apply (lambda (_697 name698 args699 e1700 e2701) (if (id?248 name698) (valid-bound-ids?273 (lambda-var-list296 args699)) #f)) tmp696) #f) (apply (lambda (_702 name703 args704 e1705 e2706) (values (quote define-form) (wrap276 name703 w676 mod679) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) (wrap276 (cons args704 (cons e1705 e2706)) w676 mod679)) (quote (())) s677 mod679)) tmp696) ((lambda (tmp708) (if (if tmp708 (apply (lambda (_709 name710) (id?248 name710)) tmp708) #f) (apply (lambda (_711 name712) (values (quote define-form) (wrap276 name712 w676 mod679) (quote (#(syntax-object if ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)) #(syntax-object #f ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(e r w s rib mod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote (())) s677 mod679)) tmp708) (syntax-violation #f "source expression failed to match any pattern" tmp688))) ($sc-dispatch tmp688 (quote (any any)))))) ($sc-dispatch tmp688 (quote (any (any . any) any . each-any)))))) ($sc-dispatch tmp688 (quote (any any any))))) e674) (if (memv type687 (quote (define-syntax))) ((lambda (tmp713) ((lambda (tmp714) (if (if tmp714 (apply (lambda (_715 name716 val717) (id?248 name716)) tmp714) #f) (apply (lambda (_718 name719 val720) (values (quote define-syntax-form) name719 val720 w676 s677 mod679)) tmp714) (syntax-violation #f "source expression failed to match any pattern" tmp713))) ($sc-dispatch tmp713 (quote (any any any))))) e674) (values (quote call) #f e674 w676 s677 mod679))))))))))))) (values (quote call) #f e674 w676 s677 mod679))) (if (syntax-object?232 e674) (syntax-type282 (syntax-object-expression233 e674) r675 (join-wraps267 w676 (syntax-object-wrap234 e674)) s677 rib678 (let ((t721 (syntax-object-module235 e674))) (if t721 t721 mod679))) (if (self-evaluating? e674) (values (quote constant) #f e674 w676 s677 mod679) (values (quote other) #f e674 w676 s677 mod679))))))) (chi-when-list281 (lambda (e722 when-list723 w724) (letrec ((f725 (lambda (when-list726 situations727) (if (null? when-list726) situations727 (f725 (cdr when-list726) (cons (let ((x728 (car when-list726))) (if (free-id=?271 x728 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote compile) (if (free-id=?271 x728 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote load) (if (free-id=?271 x728 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile)))) (quote eval) (syntax-violation (quote eval-when) "invalid situation" e722 (wrap276 x728 w724 #f)))))) situations727)))))) (f725 when-list723 (quote ()))))) (chi-install-global280 (lambda (name729 e730) (build-global-definition223 #f name729 (if (let ((v731 (module-variable (current-module) name729))) (if v731 (if (variable-bound? v731) (if (macro? (variable-ref v731)) (not (eq? (macro-type (variable-ref v731)) (quote syncase-macro))) #f) #f) #f)) (build-application215 #f (build-primref225 #f (quote make-extended-syncase-macro)) (list (build-application215 #f (build-primref225 #f (quote module-ref)) (list (build-application215 #f (build-primref225 #f (quote current-module)) (quote ())) (build-data226 #f name729))) (build-data226 #f (quote macro)) e730)) (build-application215 #f (build-primref225 #f (quote make-syncase-macro)) (list (build-data226 #f (quote macro)) e730)))))) (chi-top-sequence279 (lambda (body732 r733 w734 s735 m736 esew737 mod738) (build-sequence227 s735 (letrec ((dobody739 (lambda (body740 r741 w742 m743 esew744 mod745) (if (null? body740) (quote ()) (let ((first746 (chi-top283 (car body740) r741 w742 m743 esew744 mod745))) (cons first746 (dobody739 (cdr body740) r741 w742 m743 esew744 mod745))))))) (dobody739 body732 r733 w734 m736 esew737 mod738))))) (chi-sequence278 (lambda (body747 r748 w749 s750 mod751) (build-sequence227 s750 (letrec ((dobody752 (lambda (body753 r754 w755 mod756) (if (null? body753) (quote ()) (let ((first757 (chi284 (car body753) r754 w755 mod756))) (cons first757 (dobody752 (cdr body753) r754 w755 mod756))))))) (dobody752 body747 r748 w749 mod751))))) (source-wrap277 (lambda (x758 w759 s760 defmod761) (begin (if (if s760 (pair? x758) #f) (set-source-properties! x758 s760)) (wrap276 x758 w759 defmod761)))) (wrap276 (lambda (x762 w763 defmod764) (if (if (null? (wrap-marks251 w763)) (null? (wrap-subst252 w763)) #f) x762 (if (syntax-object?232 x762) (make-syntax-object231 (syntax-object-expression233 x762) (join-wraps267 w763 (syntax-object-wrap234 x762)) (syntax-object-module235 x762)) (if (null? x762) x762 (make-syntax-object231 x762 w763 defmod764)))))) (bound-id-member?275 (lambda (x765 list766) (if (not (null? list766)) (let ((t767 (bound-id=?272 x765 (car list766)))) (if t767 t767 (bound-id-member?275 x765 (cdr list766)))) #f))) (distinct-bound-ids?274 (lambda (ids768) (letrec ((distinct?769 (lambda (ids770) (let ((t771 (null? ids770))) (if t771 t771 (if (not (bound-id-member?275 (car ids770) (cdr ids770))) (distinct?769 (cdr ids770)) #f)))))) (distinct?769 ids768)))) (valid-bound-ids?273 (lambda (ids772) (if (letrec ((all-ids?773 (lambda (ids774) (let ((t775 (null? ids774))) (if t775 t775 (if (id?248 (car ids774)) (all-ids?773 (cdr ids774)) #f)))))) (all-ids?773 ids772)) (distinct-bound-ids?274 ids772) #f))) (bound-id=?272 (lambda (i776 j777) (if (if (syntax-object?232 i776) (syntax-object?232 j777) #f) (if (eq? (syntax-object-expression233 i776) (syntax-object-expression233 j777)) (same-marks?269 (wrap-marks251 (syntax-object-wrap234 i776)) (wrap-marks251 (syntax-object-wrap234 j777))) #f) (eq? i776 j777)))) (free-id=?271 (lambda (i778 j779) (if (eq? (let ((x780 i778)) (if (syntax-object?232 x780) (syntax-object-expression233 x780) x780)) (let ((x781 j779)) (if (syntax-object?232 x781) (syntax-object-expression233 x781) x781))) (eq? (id-var-name270 i778 (quote (()))) (id-var-name270 j779 (quote (())))) #f))) (id-var-name270 (lambda (id782 w783) (letrec ((search-vector-rib786 (lambda (sym792 subst793 marks794 symnames795 ribcage796) (let ((n797 (vector-length symnames795))) (letrec ((f798 (lambda (i799) (if (fx=208 i799 n797) (search784 sym792 (cdr subst793) marks794) (if (if (eq? (vector-ref symnames795 i799) sym792) (same-marks?269 marks794 (vector-ref (ribcage-marks258 ribcage796) i799)) #f) (values (vector-ref (ribcage-labels259 ribcage796) i799) marks794) (f798 (fx+206 i799 1))))))) (f798 0))))) (search-list-rib785 (lambda (sym800 subst801 marks802 symnames803 ribcage804) (letrec ((f805 (lambda (symnames806 i807) (if (null? symnames806) (search784 sym800 (cdr subst801) marks802) (if (if (eq? (car symnames806) sym800) (same-marks?269 marks802 (list-ref (ribcage-marks258 ribcage804) i807)) #f) (values (list-ref (ribcage-labels259 ribcage804) i807) marks802) (f805 (cdr symnames806) (fx+206 i807 1))))))) (f805 symnames803 0)))) (search784 (lambda (sym808 subst809 marks810) (if (null? subst809) (values #f marks810) (let ((fst811 (car subst809))) (if (eq? fst811 (quote shift)) (search784 sym808 (cdr subst809) (cdr marks810)) (let ((symnames812 (ribcage-symnames257 fst811))) (if (vector? symnames812) (search-vector-rib786 sym808 subst809 marks810 symnames812 fst811) (search-list-rib785 sym808 subst809 marks810 symnames812 fst811))))))))) (if (symbol? id782) (let ((t813 (call-with-values (lambda () (search784 id782 (wrap-subst252 w783) (wrap-marks251 w783))) (lambda (x815 . ignore814) x815)))) (if t813 t813 id782)) (if (syntax-object?232 id782) (let ((id816 (syntax-object-expression233 id782)) (w1817 (syntax-object-wrap234 id782))) (let ((marks818 (join-marks268 (wrap-marks251 w783) (wrap-marks251 w1817)))) (call-with-values (lambda () (search784 id816 (wrap-subst252 w783) marks818)) (lambda (new-id819 marks820) (let ((t821 new-id819)) (if t821 t821 (let ((t822 (call-with-values (lambda () (search784 id816 (wrap-subst252 w1817) marks820)) (lambda (x824 . ignore823) x824)))) (if t822 t822 id816)))))))) (syntax-violation (quote id-var-name) "invalid id" id782)))))) (same-marks?269 (lambda (x825 y826) (let ((t827 (eq? x825 y826))) (if t827 t827 (if (not (null? x825)) (if (not (null? y826)) (if (eq? (car x825) (car y826)) (same-marks?269 (cdr x825) (cdr y826)) #f) #f) #f))))) (join-marks268 (lambda (m1828 m2829) (smart-append266 m1828 m2829))) (join-wraps267 (lambda (w1830 w2831) (let ((m1832 (wrap-marks251 w1830)) (s1833 (wrap-subst252 w1830))) (if (null? m1832) (if (null? s1833) w2831 (make-wrap250 (wrap-marks251 w2831) (smart-append266 s1833 (wrap-subst252 w2831)))) (make-wrap250 (smart-append266 m1832 (wrap-marks251 w2831)) (smart-append266 s1833 (wrap-subst252 w2831))))))) (smart-append266 (lambda (m1834 m2835) (if (null? m2835) m1834 (append m1834 m2835)))) (make-binding-wrap265 (lambda (ids836 labels837 w838) (if (null? ids836) w838 (make-wrap250 (wrap-marks251 w838) (cons (let ((labelvec839 (list->vector labels837))) (let ((n840 (vector-length labelvec839))) (let ((symnamevec841 (make-vector n840)) (marksvec842 (make-vector n840))) (begin (letrec ((f843 (lambda (ids844 i845) (if (not (null? ids844)) (call-with-values (lambda () (id-sym-name&marks249 (car ids844) w838)) (lambda (symname846 marks847) (begin (vector-set! symnamevec841 i845 symname846) (vector-set! marksvec842 i845 marks847) (f843 (cdr ids844) (fx+206 i845 1))))))))) (f843 ids836 0)) (make-ribcage255 symnamevec841 marksvec842 labelvec839))))) (wrap-subst252 w838)))))) (extend-ribcage!264 (lambda (ribcage848 id849 label850) (begin (set-ribcage-symnames!260 ribcage848 (cons (syntax-object-expression233 id849) (ribcage-symnames257 ribcage848))) (set-ribcage-marks!261 ribcage848 (cons (wrap-marks251 (syntax-object-wrap234 id849)) (ribcage-marks258 ribcage848))) (set-ribcage-labels!262 ribcage848 (cons label850 (ribcage-labels259 ribcage848)))))) (anti-mark263 (lambda (w851) (make-wrap250 (cons #f (wrap-marks251 w851)) (cons (quote shift) (wrap-subst252 w851))))) (set-ribcage-labels!262 (lambda (x852 update853) (vector-set! x852 3 update853))) (set-ribcage-marks!261 (lambda (x854 update855) (vector-set! x854 2 update855))) (set-ribcage-symnames!260 (lambda (x856 update857) (vector-set! x856 1 update857))) (ribcage-labels259 (lambda (x858) (vector-ref x858 3))) (ribcage-marks258 (lambda (x859) (vector-ref x859 2))) (ribcage-symnames257 (lambda (x860) (vector-ref x860 1))) (ribcage?256 (lambda (x861) (if (vector? x861) (if (= (vector-length x861) 4) (eq? (vector-ref x861 0) (quote ribcage)) #f) #f))) (make-ribcage255 (lambda (symnames862 marks863 labels864) (vector (quote ribcage) symnames862 marks863 labels864))) (gen-labels254 (lambda (ls865) (if (null? ls865) (quote ()) (cons (gen-label253) (gen-labels254 (cdr ls865)))))) (gen-label253 (lambda () (string #\i))) (wrap-subst252 cdr) (wrap-marks251 car) (make-wrap250 cons) (id-sym-name&marks249 (lambda (x866 w867) (if (syntax-object?232 x866) (values (syntax-object-expression233 x866) (join-marks268 (wrap-marks251 w867) (wrap-marks251 (syntax-object-wrap234 x866)))) (values x866 (wrap-marks251 w867))))) (id?248 (lambda (x868) (if (symbol? x868) #t (if (syntax-object?232 x868) (symbol? (syntax-object-expression233 x868)) #f)))) (nonsymbol-id?247 (lambda (x869) (if (syntax-object?232 x869) (symbol? (syntax-object-expression233 x869)) #f))) (global-extend246 (lambda (type870 sym871 val872) (put-global-definition-hook212 sym871 type870 val872))) (lookup245 (lambda (x873 r874 mod875) (let ((t876 (assq x873 r874))) (if t876 (cdr t876) (if (symbol? x873) (let ((t877 (get-global-definition-hook213 x873 mod875))) (if t877 t877 (quote (global)))) (quote (displaced-lexical))))))) (macros-only-env244 (lambda (r878) (if (null? r878) (quote ()) (let ((a879 (car r878))) (if (eq? (cadr a879) (quote macro)) (cons a879 (macros-only-env244 (cdr r878))) (macros-only-env244 (cdr r878))))))) (extend-var-env243 (lambda (labels880 vars881 r882) (if (null? labels880) r882 (extend-var-env243 (cdr labels880) (cdr vars881) (cons (cons (car labels880) (cons (quote lexical) (car vars881))) r882))))) (extend-env242 (lambda (labels883 bindings884 r885) (if (null? labels883) r885 (extend-env242 (cdr labels883) (cdr bindings884) (cons (cons (car labels883) (car bindings884)) r885))))) (binding-value241 cdr) (binding-type240 car) (source-annotation239 (lambda (x886) (if (syntax-object?232 x886) (source-annotation239 (syntax-object-expression233 x886)) (if (pair? x886) (let ((props887 (source-properties x886))) (if (pair? props887) props887 #f)) #f)))) (set-syntax-object-module!238 (lambda (x888 update889) (vector-set! x888 3 update889))) (set-syntax-object-wrap!237 (lambda (x890 update891) (vector-set! x890 2 update891))) (set-syntax-object-expression!236 (lambda (x892 update893) (vector-set! x892 1 update893))) (syntax-object-module235 (lambda (x894) (vector-ref x894 3))) (syntax-object-wrap234 (lambda (x895) (vector-ref x895 2))) (syntax-object-expression233 (lambda (x896) (vector-ref x896 1))) (syntax-object?232 (lambda (x897) (if (vector? x897) (if (= (vector-length x897) 4) (eq? (vector-ref x897 0) (quote syntax-object)) #f) #f))) (make-syntax-object231 (lambda (expression898 wrap899 module900) (vector (quote syntax-object) expression898 wrap899 module900))) (build-letrec230 (lambda (src901 ids902 vars903 val-exps904 body-exp905) (if (null? vars903) body-exp905 (let ((atom-key906 (fluid-ref *mode*205))) (if (memv atom-key906 (quote (c))) (begin (for-each maybe-name-value!222 ids902 val-exps904) ((@ (language tree-il) make-letrec) src901 ids902 vars903 val-exps904 body-exp905)) (list (quote letrec) (map list vars903 val-exps904) body-exp905)))))) (build-named-let229 (lambda (src907 ids908 vars909 val-exps910 body-exp911) (let ((f912 (car vars909)) (f-name913 (car ids908)) (vars914 (cdr vars909)) (ids915 (cdr ids908))) (let ((atom-key916 (fluid-ref *mode*205))) (if (memv atom-key916 (quote (c))) (let ((proc917 (build-lambda224 src907 ids915 vars914 #f body-exp911))) (begin (maybe-name-value!222 f-name913 proc917) (for-each maybe-name-value!222 ids915 val-exps910) ((@ (language tree-il) make-letrec) src907 (list f-name913) (list f912) (list proc917) (build-application215 src907 (build-lexical-reference217 (quote fun) src907 f-name913 f912) val-exps910)))) (list (quote let) f912 (map list vars914 val-exps910) body-exp911)))))) (build-let228 (lambda (src918 ids919 vars920 val-exps921 body-exp922) (if (null? vars920) body-exp922 (let ((atom-key923 (fluid-ref *mode*205))) (if (memv atom-key923 (quote (c))) (begin (for-each maybe-name-value!222 ids919 val-exps921) ((@ (language tree-il) make-let) src918 ids919 vars920 val-exps921 body-exp922)) (list (quote let) (map list vars920 val-exps921) body-exp922)))))) (build-sequence227 (lambda (src924 exps925) (if (null? (cdr exps925)) (car exps925) (let ((atom-key926 (fluid-ref *mode*205))) (if (memv atom-key926 (quote (c))) ((@ (language tree-il) make-sequence) src924 exps925) (cons (quote begin) exps925)))))) (build-data226 (lambda (src927 exp928) (let ((atom-key929 (fluid-ref *mode*205))) (if (memv atom-key929 (quote (c))) ((@ (language tree-il) make-const) src927 exp928) (if (if (self-evaluating? exp928) (not (vector? exp928)) #f) exp928 (list (quote quote) exp928)))))) (build-primref225 (lambda (src930 name931) (if (equal? (module-name (current-module)) (quote (guile))) (let ((atom-key932 (fluid-ref *mode*205))) (if (memv atom-key932 (quote (c))) ((@ (language tree-il) make-toplevel-ref) src930 name931) name931)) (let ((atom-key933 (fluid-ref *mode*205))) (if (memv atom-key933 (quote (c))) ((@ (language tree-il) make-module-ref) src930 (quote (guile)) name931 #f) (list (quote @@) (quote (guile)) name931)))))) (build-lambda224 (lambda (src934 ids935 vars936 docstring937 exp938) (let ((atom-key939 (fluid-ref *mode*205))) (if (memv atom-key939 (quote (c))) ((@ (language tree-il) make-lambda) src934 ids935 vars936 (if docstring937 (list (cons (quote documentation) docstring937)) (quote ())) exp938) (cons (quote lambda) (cons vars936 (append (if docstring937 (list docstring937) (quote ())) (list exp938)))))))) (build-global-definition223 (lambda (source940 var941 exp942) (let ((atom-key943 (fluid-ref *mode*205))) (if (memv atom-key943 (quote (c))) (begin (maybe-name-value!222 var941 exp942) ((@ (language tree-il) make-toplevel-define) source940 var941 exp942)) (list (quote define) var941 exp942))))) (maybe-name-value!222 (lambda (name944 val945) (if ((@ (language tree-il) lambda?) val945) (let ((meta946 ((@ (language tree-il) lambda-meta) val945))) (if (not (assq (quote name) meta946)) ((setter (@ (language tree-il) lambda-meta)) val945 (acons (quote name) name944 meta946))))))) (build-global-assignment221 (lambda (source947 var948 exp949 mod950) (analyze-variable219 mod950 var948 (lambda (mod951 var952 public?953) (let ((atom-key954 (fluid-ref *mode*205))) (if (memv atom-key954 (quote (c))) ((@ (language tree-il) make-module-set) source947 mod951 var952 public?953 exp949) (list (quote set!) (list (if public?953 (quote @) (quote @@)) mod951 var952) exp949)))) (lambda (var955) (let ((atom-key956 (fluid-ref *mode*205))) (if (memv atom-key956 (quote (c))) ((@ (language tree-il) make-toplevel-set) source947 var955 exp949) (list (quote set!) var955 exp949))))))) (build-global-reference220 (lambda (source957 var958 mod959) (analyze-variable219 mod959 var958 (lambda (mod960 var961 public?962) (let ((atom-key963 (fluid-ref *mode*205))) (if (memv atom-key963 (quote (c))) ((@ (language tree-il) make-module-ref) source957 mod960 var961 public?962) (list (if public?962 (quote @) (quote @@)) mod960 var961)))) (lambda (var964) (let ((atom-key965 (fluid-ref *mode*205))) (if (memv atom-key965 (quote (c))) ((@ (language tree-il) make-toplevel-ref) source957 var964) var964)))))) (analyze-variable219 (lambda (mod966 var967 modref-cont968 bare-cont969) (if (not mod966) (bare-cont969 var967) (let ((kind970 (car mod966)) (mod971 (cdr mod966))) (if (memv kind970 (quote (public))) (modref-cont968 mod971 var967 #t) (if (memv kind970 (quote (private))) (if (not (equal? mod971 (module-name (current-module)))) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (if (memv kind970 (quote (bare))) (bare-cont969 var967) (if (memv kind970 (quote (hygiene))) (if (if (not (equal? mod971 (module-name (current-module)))) (module-variable (resolve-module mod971) var967) #f) (modref-cont968 mod971 var967 #f) (bare-cont969 var967)) (syntax-violation #f "bad module kind" var967 mod971))))))))) (build-lexical-assignment218 (lambda (source972 name973 var974 exp975) (let ((atom-key976 (fluid-ref *mode*205))) (if (memv atom-key976 (quote (c))) ((@ (language tree-il) make-lexical-set) source972 name973 var974 exp975) (list (quote set!) var974 exp975))))) (build-lexical-reference217 (lambda (type977 source978 name979 var980) (let ((atom-key981 (fluid-ref *mode*205))) (if (memv atom-key981 (quote (c))) ((@ (language tree-il) make-lexical-ref) source978 name979 var980) var980)))) (build-conditional216 (lambda (source982 test-exp983 then-exp984 else-exp985) (let ((atom-key986 (fluid-ref *mode*205))) (if (memv atom-key986 (quote (c))) ((@ (language tree-il) make-conditional) source982 test-exp983 then-exp984 else-exp985) (if (equal? else-exp985 (quote (if #f #f))) (list (quote if) test-exp983 then-exp984) (list (quote if) test-exp983 then-exp984 else-exp985)))))) (build-application215 (lambda (source987 fun-exp988 arg-exps989) (let ((atom-key990 (fluid-ref *mode*205))) (if (memv atom-key990 (quote (c))) ((@ (language tree-il) make-application) source987 fun-exp988 arg-exps989) (cons fun-exp988 arg-exps989))))) (build-void214 (lambda (source991) (let ((atom-key992 (fluid-ref *mode*205))) (if (memv atom-key992 (quote (c))) ((@ (language tree-il) make-void) source991) (quote (if #f #f)))))) (get-global-definition-hook213 (lambda (symbol993 module994) (begin (if (if (not module994) (current-module) #f) (warn "module system is booted, we should have a module" symbol993)) (let ((v995 (module-variable (if module994 (resolve-module (cdr module994)) (current-module)) symbol993))) (if v995 (if (variable-bound? v995) (let ((val996 (variable-ref v995))) (if (macro? val996) (if (syncase-macro-type val996) (cons (syncase-macro-type val996) (syncase-macro-binding val996)) #f) #f)) #f) #f))))) (put-global-definition-hook212 (lambda (symbol997 type998 val999) (let ((existing1000 (let ((v1001 (module-variable (current-module) symbol997))) (if v1001 (if (variable-bound? v1001) (let ((val1002 (variable-ref v1001))) (if (macro? val1002) (if (not (syncase-macro-type val1002)) val1002 #f) #f)) #f) #f)))) (module-define! (current-module) symbol997 (if existing1000 (make-extended-syncase-macro existing1000 type998 val999) (make-syncase-macro type998 val999)))))) (local-eval-hook211 (lambda (x1003 mod1004) (primitive-eval (list noexpand204 (let ((atom-key1005 (fluid-ref *mode*205))) (if (memv atom-key1005 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1003) x1003)))))) (top-level-eval-hook210 (lambda (x1006 mod1007) (primitive-eval (list noexpand204 (let ((atom-key1008 (fluid-ref *mode*205))) (if (memv atom-key1008 (quote (c))) ((@ (language tree-il) tree-il->scheme) x1006) x1006)))))) (fx<209 <) (fx=208 =) (fx-207 -) (fx+206 +) (*mode*205 (make-fluid)) (noexpand204 "noexpand")) (begin (global-extend246 (quote local-syntax) (quote letrec-syntax) #t) (global-extend246 (quote local-syntax) (quote let-syntax) #f) (global-extend246 (quote core) (quote fluid-let-syntax) (lambda (e1009 r1010 w1011 s1012 mod1013) ((lambda (tmp1014) ((lambda (tmp1015) (if (if tmp1015 (apply (lambda (_1016 var1017 val1018 e11019 e21020) (valid-bound-ids?273 var1017)) tmp1015) #f) (apply (lambda (_1022 var1023 val1024 e11025 e21026) (let ((names1027 (map (lambda (x1028) (id-var-name270 x1028 w1011)) var1023))) (begin (for-each (lambda (id1030 n1031) (let ((atom-key1032 (binding-type240 (lookup245 n1031 r1010 mod1013)))) (if (memv atom-key1032 (quote (displaced-lexical))) (syntax-violation (quote fluid-let-syntax) "identifier out of context" e1009 (source-wrap277 id1030 w1011 s1012 mod1013))))) var1023 names1027) (chi-body288 (cons e11025 e21026) (source-wrap277 e1009 w1011 s1012 mod1013) (extend-env242 names1027 (let ((trans-r1035 (macros-only-env244 r1010))) (map (lambda (x1036) (cons (quote macro) (eval-local-transformer291 (chi284 x1036 trans-r1035 w1011 mod1013) mod1013))) val1024)) r1010) w1011 mod1013)))) tmp1015) ((lambda (_1038) (syntax-violation (quote fluid-let-syntax) "bad syntax" (source-wrap277 e1009 w1011 s1012 mod1013))) tmp1014))) ($sc-dispatch tmp1014 (quote (any #(each (any any)) any . each-any))))) e1009))) (global-extend246 (quote core) (quote quote) (lambda (e1039 r1040 w1041 s1042 mod1043) ((lambda (tmp1044) ((lambda (tmp1045) (if tmp1045 (apply (lambda (_1046 e1047) (build-data226 s1042 (strip294 e1047 w1041))) tmp1045) ((lambda (_1048) (syntax-violation (quote quote) "bad syntax" (source-wrap277 e1039 w1041 s1042 mod1043))) tmp1044))) ($sc-dispatch tmp1044 (quote (any any))))) e1039))) (global-extend246 (quote core) (quote syntax) (letrec ((regen1056 (lambda (x1057) (let ((atom-key1058 (car x1057))) (if (memv atom-key1058 (quote (ref))) (build-lexical-reference217 (quote value) #f (cadr x1057) (cadr x1057)) (if (memv atom-key1058 (quote (primitive))) (build-primref225 #f (cadr x1057)) (if (memv atom-key1058 (quote (quote))) (build-data226 #f (cadr x1057)) (if (memv atom-key1058 (quote (lambda))) (build-lambda224 #f (cadr x1057) (cadr x1057) #f (regen1056 (caddr x1057))) (build-application215 #f (build-primref225 #f (car x1057)) (map regen1056 (cdr x1057)))))))))) (gen-vector1055 (lambda (x1059) (if (eq? (car x1059) (quote list)) (cons (quote vector) (cdr x1059)) (if (eq? (car x1059) (quote quote)) (list (quote quote) (list->vector (cadr x1059))) (list (quote list->vector) x1059))))) (gen-append1054 (lambda (x1060 y1061) (if (equal? y1061 (quote (quote ()))) x1060 (list (quote append) x1060 y1061)))) (gen-cons1053 (lambda (x1062 y1063) (let ((atom-key1064 (car y1063))) (if (memv atom-key1064 (quote (quote))) (if (eq? (car x1062) (quote quote)) (list (quote quote) (cons (cadr x1062) (cadr y1063))) (if (eq? (cadr y1063) (quote ())) (list (quote list) x1062) (list (quote cons) x1062 y1063))) (if (memv atom-key1064 (quote (list))) (cons (quote list) (cons x1062 (cdr y1063))) (list (quote cons) x1062 y1063)))))) (gen-map1052 (lambda (e1065 map-env1066) (let ((formals1067 (map cdr map-env1066)) (actuals1068 (map (lambda (x1069) (list (quote ref) (car x1069))) map-env1066))) (if (eq? (car e1065) (quote ref)) (car actuals1068) (if (and-map (lambda (x1070) (if (eq? (car x1070) (quote ref)) (memq (cadr x1070) formals1067) #f)) (cdr e1065)) (cons (quote map) (cons (list (quote primitive) (car e1065)) (map (let ((r1071 (map cons formals1067 actuals1068))) (lambda (x1072) (cdr (assq (cadr x1072) r1071)))) (cdr e1065)))) (cons (quote map) (cons (list (quote lambda) formals1067 e1065) actuals1068))))))) (gen-mappend1051 (lambda (e1073 map-env1074) (list (quote apply) (quote (primitive append)) (gen-map1052 e1073 map-env1074)))) (gen-ref1050 (lambda (src1075 var1076 level1077 maps1078) (if (fx=208 level1077 0) (values var1076 maps1078) (if (null? maps1078) (syntax-violation (quote syntax) "missing ellipsis" src1075) (call-with-values (lambda () (gen-ref1050 src1075 var1076 (fx-207 level1077 1) (cdr maps1078))) (lambda (outer-var1079 outer-maps1080) (let ((b1081 (assq outer-var1079 (car maps1078)))) (if b1081 (values (cdr b1081) maps1078) (let ((inner-var1082 (gen-var295 (quote tmp)))) (values inner-var1082 (cons (cons (cons outer-var1079 inner-var1082) (car maps1078)) outer-maps1080))))))))))) (gen-syntax1049 (lambda (src1083 e1084 r1085 maps1086 ellipsis?1087 mod1088) (if (id?248 e1084) (let ((label1089 (id-var-name270 e1084 (quote (()))))) (let ((b1090 (lookup245 label1089 r1085 mod1088))) (if (eq? (binding-type240 b1090) (quote syntax)) (call-with-values (lambda () (let ((var.lev1091 (binding-value241 b1090))) (gen-ref1050 src1083 (car var.lev1091) (cdr var.lev1091) maps1086))) (lambda (var1092 maps1093) (values (list (quote ref) var1092) maps1093))) (if (ellipsis?1087 e1084) (syntax-violation (quote syntax) "misplaced ellipsis" src1083) (values (list (quote quote) e1084) maps1086))))) ((lambda (tmp1094) ((lambda (tmp1095) (if (if tmp1095 (apply (lambda (dots1096 e1097) (ellipsis?1087 dots1096)) tmp1095) #f) (apply (lambda (dots1098 e1099) (gen-syntax1049 src1083 e1099 r1085 maps1086 (lambda (x1100) #f) mod1088)) tmp1095) ((lambda (tmp1101) (if (if tmp1101 (apply (lambda (x1102 dots1103 y1104) (ellipsis?1087 dots1103)) tmp1101) #f) (apply (lambda (x1105 dots1106 y1107) (letrec ((f1108 (lambda (y1109 k1110) ((lambda (tmp1114) ((lambda (tmp1115) (if (if tmp1115 (apply (lambda (dots1116 y1117) (ellipsis?1087 dots1116)) tmp1115) #f) (apply (lambda (dots1118 y1119) (f1108 y1119 (lambda (maps1120) (call-with-values (lambda () (k1110 (cons (quote ()) maps1120))) (lambda (x1121 maps1122) (if (null? (car maps1122)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-mappend1051 x1121 (car maps1122)) (cdr maps1122)))))))) tmp1115) ((lambda (_1123) (call-with-values (lambda () (gen-syntax1049 src1083 y1109 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (y1124 maps1125) (call-with-values (lambda () (k1110 maps1125)) (lambda (x1126 maps1127) (values (gen-append1054 x1126 y1124) maps1127)))))) tmp1114))) ($sc-dispatch tmp1114 (quote (any . any))))) y1109)))) (f1108 y1107 (lambda (maps1111) (call-with-values (lambda () (gen-syntax1049 src1083 x1105 r1085 (cons (quote ()) maps1111) ellipsis?1087 mod1088)) (lambda (x1112 maps1113) (if (null? (car maps1113)) (syntax-violation (quote syntax) "extra ellipsis" src1083) (values (gen-map1052 x1112 (car maps1113)) (cdr maps1113))))))))) tmp1101) ((lambda (tmp1128) (if tmp1128 (apply (lambda (x1129 y1130) (call-with-values (lambda () (gen-syntax1049 src1083 x1129 r1085 maps1086 ellipsis?1087 mod1088)) (lambda (x1131 maps1132) (call-with-values (lambda () (gen-syntax1049 src1083 y1130 r1085 maps1132 ellipsis?1087 mod1088)) (lambda (y1133 maps1134) (values (gen-cons1053 x1131 y1133) maps1134)))))) tmp1128) ((lambda (tmp1135) (if tmp1135 (apply (lambda (e11136 e21137) (call-with-values (lambda () (gen-syntax1049 src1083 (cons e11136 e21137) r1085 maps1086 ellipsis?1087 mod1088)) (lambda (e1139 maps1140) (values (gen-vector1055 e1139) maps1140)))) tmp1135) ((lambda (_1141) (values (list (quote quote) e1084) maps1086)) tmp1094))) ($sc-dispatch tmp1094 (quote #(vector (any . each-any))))))) ($sc-dispatch tmp1094 (quote (any . any)))))) ($sc-dispatch tmp1094 (quote (any any . any)))))) ($sc-dispatch tmp1094 (quote (any any))))) e1084))))) (lambda (e1142 r1143 w1144 s1145 mod1146) (let ((e1147 (source-wrap277 e1142 w1144 s1145 mod1146))) ((lambda (tmp1148) ((lambda (tmp1149) (if tmp1149 (apply (lambda (_1150 x1151) (call-with-values (lambda () (gen-syntax1049 e1147 x1151 r1143 (quote ()) ellipsis?293 mod1146)) (lambda (e1152 maps1153) (regen1056 e1152)))) tmp1149) ((lambda (_1154) (syntax-violation (quote syntax) "bad `syntax' form" e1147)) tmp1148))) ($sc-dispatch tmp1148 (quote (any any))))) e1147))))) (global-extend246 (quote core) (quote lambda) (lambda (e1155 r1156 w1157 s1158 mod1159) ((lambda (tmp1160) ((lambda (tmp1161) (if tmp1161 (apply (lambda (_1162 c1163) (chi-lambda-clause289 (source-wrap277 e1155 w1157 s1158 mod1159) #f c1163 r1156 w1157 mod1159 (lambda (names1164 vars1165 docstring1166 body1167) (build-lambda224 s1158 names1164 vars1165 docstring1166 body1167)))) tmp1161) (syntax-violation #f "source expression failed to match any pattern" tmp1160))) ($sc-dispatch tmp1160 (quote (any . any))))) e1155))) (global-extend246 (quote core) (quote let) (letrec ((chi-let1168 (lambda (e1169 r1170 w1171 s1172 mod1173 constructor1174 ids1175 vals1176 exps1177) (if (not (valid-bound-ids?273 ids1175)) (syntax-violation (quote let) "duplicate bound variable" e1169) (let ((labels1178 (gen-labels254 ids1175)) (new-vars1179 (map gen-var295 ids1175))) (let ((nw1180 (make-binding-wrap265 ids1175 labels1178 w1171)) (nr1181 (extend-var-env243 labels1178 new-vars1179 r1170))) (constructor1174 s1172 (map syntax->datum ids1175) new-vars1179 (map (lambda (x1182) (chi284 x1182 r1170 w1171 mod1173)) vals1176) (chi-body288 exps1177 (source-wrap277 e1169 nw1180 s1172 mod1173) nr1181 nw1180 mod1173)))))))) (lambda (e1183 r1184 w1185 s1186 mod1187) ((lambda (tmp1188) ((lambda (tmp1189) (if (if tmp1189 (apply (lambda (_1190 id1191 val1192 e11193 e21194) (and-map id?248 id1191)) tmp1189) #f) (apply (lambda (_1196 id1197 val1198 e11199 e21200) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-let228 id1197 val1198 (cons e11199 e21200))) tmp1189) ((lambda (tmp1204) (if (if tmp1204 (apply (lambda (_1205 f1206 id1207 val1208 e11209 e21210) (if (id?248 f1206) (and-map id?248 id1207) #f)) tmp1204) #f) (apply (lambda (_1212 f1213 id1214 val1215 e11216 e21217) (chi-let1168 e1183 r1184 w1185 s1186 mod1187 build-named-let229 (cons f1213 id1214) val1215 (cons e11216 e21217))) tmp1204) ((lambda (_1221) (syntax-violation (quote let) "bad let" (source-wrap277 e1183 w1185 s1186 mod1187))) tmp1188))) ($sc-dispatch tmp1188 (quote (any any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1188 (quote (any #(each (any any)) any . each-any))))) e1183)))) (global-extend246 (quote core) (quote letrec) (lambda (e1222 r1223 w1224 s1225 mod1226) ((lambda (tmp1227) ((lambda (tmp1228) (if (if tmp1228 (apply (lambda (_1229 id1230 val1231 e11232 e21233) (and-map id?248 id1230)) tmp1228) #f) (apply (lambda (_1235 id1236 val1237 e11238 e21239) (let ((ids1240 id1236)) (if (not (valid-bound-ids?273 ids1240)) (syntax-violation (quote letrec) "duplicate bound variable" e1222) (let ((labels1242 (gen-labels254 ids1240)) (new-vars1243 (map gen-var295 ids1240))) (let ((w1244 (make-binding-wrap265 ids1240 labels1242 w1224)) (r1245 (extend-var-env243 labels1242 new-vars1243 r1223))) (build-letrec230 s1225 (map syntax->datum ids1240) new-vars1243 (map (lambda (x1246) (chi284 x1246 r1245 w1244 mod1226)) val1237) (chi-body288 (cons e11238 e21239) (source-wrap277 e1222 w1244 s1225 mod1226) r1245 w1244 mod1226))))))) tmp1228) ((lambda (_1249) (syntax-violation (quote letrec) "bad letrec" (source-wrap277 e1222 w1224 s1225 mod1226))) tmp1227))) ($sc-dispatch tmp1227 (quote (any #(each (any any)) any . each-any))))) e1222))) (global-extend246 (quote core) (quote set!) (lambda (e1250 r1251 w1252 s1253 mod1254) ((lambda (tmp1255) ((lambda (tmp1256) (if (if tmp1256 (apply (lambda (_1257 id1258 val1259) (id?248 id1258)) tmp1256) #f) (apply (lambda (_1260 id1261 val1262) (let ((val1263 (chi284 val1262 r1251 w1252 mod1254)) (n1264 (id-var-name270 id1261 w1252))) (let ((b1265 (lookup245 n1264 r1251 mod1254))) (let ((atom-key1266 (binding-type240 b1265))) (if (memv atom-key1266 (quote (lexical))) (build-lexical-assignment218 s1253 (syntax->datum id1261) (binding-value241 b1265) val1263) (if (memv atom-key1266 (quote (global))) (build-global-assignment221 s1253 n1264 val1263 mod1254) (if (memv atom-key1266 (quote (displaced-lexical))) (syntax-violation (quote set!) "identifier out of context" (wrap276 id1261 w1252 mod1254)) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))))))))) tmp1256) ((lambda (tmp1267) (if tmp1267 (apply (lambda (_1268 head1269 tail1270 val1271) (call-with-values (lambda () (syntax-type282 head1269 r1251 (quote (())) #f #f mod1254)) (lambda (type1272 value1273 ee1274 ww1275 ss1276 modmod1277) (if (memv type1272 (quote (module-ref))) (let ((val1278 (chi284 val1271 r1251 w1252 mod1254))) (call-with-values (lambda () (value1273 (cons head1269 tail1270))) (lambda (id1280 mod1281) (build-global-assignment221 s1253 id1280 val1278 mod1281)))) (build-application215 s1253 (chi284 (list (quote #(syntax-object setter ((top) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type value ee ww ss modmod) #((top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i")) #(ribcage #(_ head tail val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) head1269) r1251 w1252 mod1254) (map (lambda (e1282) (chi284 e1282 r1251 w1252 mod1254)) (append tail1270 (list val1271)))))))) tmp1267) ((lambda (_1284) (syntax-violation (quote set!) "bad set!" (source-wrap277 e1250 w1252 s1253 mod1254))) tmp1255))) ($sc-dispatch tmp1255 (quote (any (any . each-any) any)))))) ($sc-dispatch tmp1255 (quote (any any any))))) e1250))) (global-extend246 (quote module-ref) (quote @) (lambda (e1285) ((lambda (tmp1286) ((lambda (tmp1287) (if (if tmp1287 (apply (lambda (_1288 mod1289 id1290) (if (and-map id?248 mod1289) (id?248 id1290) #f)) tmp1287) #f) (apply (lambda (_1292 mod1293 id1294) (values (syntax->datum id1294) (syntax->datum (cons (quote #(syntax-object public ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1293)))) tmp1287) (syntax-violation #f "source expression failed to match any pattern" tmp1286))) ($sc-dispatch tmp1286 (quote (any each-any any))))) e1285))) (global-extend246 (quote module-ref) (quote @@) (lambda (e1296) ((lambda (tmp1297) ((lambda (tmp1298) (if (if tmp1298 (apply (lambda (_1299 mod1300 id1301) (if (and-map id?248 mod1300) (id?248 id1301) #f)) tmp1298) #f) (apply (lambda (_1303 mod1304 id1305) (values (syntax->datum id1305) (syntax->datum (cons (quote #(syntax-object private ((top) #(ribcage #(_ mod id) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) mod1304)))) tmp1298) (syntax-violation #f "source expression failed to match any pattern" tmp1297))) ($sc-dispatch tmp1297 (quote (any each-any any))))) e1296))) (global-extend246 (quote core) (quote if) (lambda (e1307 r1308 w1309 s1310 mod1311) ((lambda (tmp1312) ((lambda (tmp1313) (if tmp1313 (apply (lambda (_1314 test1315 then1316) (build-conditional216 s1310 (chi284 test1315 r1308 w1309 mod1311) (chi284 then1316 r1308 w1309 mod1311) (build-void214 #f))) tmp1313) ((lambda (tmp1317) (if tmp1317 (apply (lambda (_1318 test1319 then1320 else1321) (build-conditional216 s1310 (chi284 test1319 r1308 w1309 mod1311) (chi284 then1320 r1308 w1309 mod1311) (chi284 else1321 r1308 w1309 mod1311))) tmp1317) (syntax-violation #f "source expression failed to match any pattern" tmp1312))) ($sc-dispatch tmp1312 (quote (any any any any)))))) ($sc-dispatch tmp1312 (quote (any any any))))) e1307))) (global-extend246 (quote begin) (quote begin) (quote ())) (global-extend246 (quote define) (quote define) (quote ())) (global-extend246 (quote define-syntax) (quote define-syntax) (quote ())) (global-extend246 (quote eval-when) (quote eval-when) (quote ())) (global-extend246 (quote core) (quote syntax-case) (letrec ((gen-syntax-case1325 (lambda (x1326 keys1327 clauses1328 r1329 mod1330) (if (null? clauses1328) (build-application215 #f (build-primref225 #f (quote syntax-violation)) (list (build-data226 #f #f) (build-data226 #f "source expression failed to match any pattern") x1326)) ((lambda (tmp1331) ((lambda (tmp1332) (if tmp1332 (apply (lambda (pat1333 exp1334) (if (if (id?248 pat1333) (and-map (lambda (x1335) (not (free-id=?271 pat1333 x1335))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r mod) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source set-syntax-object-module! set-syntax-object-wrap! set-syntax-object-expression! syntax-object-module syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition maybe-name-value! build-global-assignment build-global-reference analyze-variable build-lexical-assignment build-lexical-reference build-conditional build-application build-void get-global-definition-hook put-global-definition-hook gensym-hook local-eval-hook top-level-eval-hook fx< fx= fx- fx+ *mode* noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure and-map*) ((top) (top)) ("i" "i"))) (hygiene guile))) keys1327)) #f) (let ((labels1336 (list (gen-label253))) (var1337 (gen-var295 pat1333))) (build-application215 #f (build-lambda224 #f (list (syntax->datum pat1333)) (list var1337) #f (chi284 exp1334 (extend-env242 labels1336 (list (cons (quote syntax) (cons var1337 0))) r1329) (make-binding-wrap265 (list pat1333) labels1336 (quote (()))) mod1330)) (list x1326))) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1333 #t exp1334 mod1330))) tmp1332) ((lambda (tmp1338) (if tmp1338 (apply (lambda (pat1339 fender1340 exp1341) (gen-clause1324 x1326 keys1327 (cdr clauses1328) r1329 pat1339 fender1340 exp1341 mod1330)) tmp1338) ((lambda (_1342) (syntax-violation (quote syntax-case) "invalid clause" (car clauses1328))) tmp1331))) ($sc-dispatch tmp1331 (quote (any any any)))))) ($sc-dispatch tmp1331 (quote (any any))))) (car clauses1328))))) (gen-clause1324 (lambda (x1343 keys1344 clauses1345 r1346 pat1347 fender1348 exp1349 mod1350) (call-with-values (lambda () (convert-pattern1322 pat1347 keys1344)) (lambda (p1351 pvars1352) (if (not (distinct-bound-ids?274 (map car pvars1352))) (syntax-violation (quote syntax-case) "duplicate pattern variable" pat1347) (if (not (and-map (lambda (x1353) (not (ellipsis?293 (car x1353)))) pvars1352)) (syntax-violation (quote syntax-case) "misplaced ellipsis" pat1347) (let ((y1354 (gen-var295 (quote tmp)))) (build-application215 #f (build-lambda224 #f (list (quote tmp)) (list y1354) #f (let ((y1355 (build-lexical-reference217 (quote value) #f (quote tmp) y1354))) (build-conditional216 #f ((lambda (tmp1356) ((lambda (tmp1357) (if tmp1357 (apply (lambda () y1355) tmp1357) ((lambda (_1358) (build-conditional216 #f y1355 (build-dispatch-call1323 pvars1352 fender1348 y1355 r1346 mod1350) (build-data226 #f #f))) tmp1356))) ($sc-dispatch tmp1356 (quote #(atom #t))))) fender1348) (build-dispatch-call1323 pvars1352 exp1349 y1355 r1346 mod1350) (gen-syntax-case1325 x1343 keys1344 clauses1345 r1346 mod1350)))) (list (if (eq? p1351 (quote any)) (build-application215 #f (build-primref225 #f (quote list)) (list x1343)) (build-application215 #f (build-primref225 #f (quote $sc-dispatch)) (list x1343 (build-data226 #f p1351))))))))))))) (build-dispatch-call1323 (lambda (pvars1359 exp1360 y1361 r1362 mod1363) (let ((ids1364 (map car pvars1359)) (levels1365 (map cdr pvars1359))) (let ((labels1366 (gen-labels254 ids1364)) (new-vars1367 (map gen-var295 ids1364))) (build-application215 #f (build-primref225 #f (quote apply)) (list (build-lambda224 #f (map syntax->datum ids1364) new-vars1367 #f (chi284 exp1360 (extend-env242 labels1366 (map (lambda (var1368 level1369) (cons (quote syntax) (cons var1368 level1369))) new-vars1367 (map cdr pvars1359)) r1362) (make-binding-wrap265 ids1364 labels1366 (quote (()))) mod1363)) y1361)))))) (convert-pattern1322 (lambda (pattern1370 keys1371) (letrec ((cvt1372 (lambda (p1373 n1374 ids1375) (if (id?248 p1373) (if (bound-id-member?275 p1373 keys1371) (values (vector (quote free-id) p1373) ids1375) (values (quote any) (cons (cons p1373 n1374) ids1375))) ((lambda (tmp1376) ((lambda (tmp1377) (if (if tmp1377 (apply (lambda (x1378 dots1379) (ellipsis?293 dots1379)) tmp1377) #f) (apply (lambda (x1380 dots1381) (call-with-values (lambda () (cvt1372 x1380 (fx+206 n1374 1) ids1375)) (lambda (p1382 ids1383) (values (if (eq? p1382 (quote any)) (quote each-any) (vector (quote each) p1382)) ids1383)))) tmp1377) ((lambda (tmp1384) (if tmp1384 (apply (lambda (x1385 y1386) (call-with-values (lambda () (cvt1372 y1386 n1374 ids1375)) (lambda (y1387 ids1388) (call-with-values (lambda () (cvt1372 x1385 n1374 ids1388)) (lambda (x1389 ids1390) (values (cons x1389 y1387) ids1390)))))) tmp1384) ((lambda (tmp1391) (if tmp1391 (apply (lambda () (values (quote ()) ids1375)) tmp1391) ((lambda (tmp1392) (if tmp1392 (apply (lambda (x1393) (call-with-values (lambda () (cvt1372 x1393 n1374 ids1375)) (lambda (p1395 ids1396) (values (vector (quote vector) p1395) ids1396)))) tmp1392) ((lambda (x1397) (values (vector (quote atom) (strip294 p1373 (quote (())))) ids1375)) tmp1376))) ($sc-dispatch tmp1376 (quote #(vector each-any)))))) ($sc-dispatch tmp1376 (quote ()))))) ($sc-dispatch tmp1376 (quote (any . any)))))) ($sc-dispatch tmp1376 (quote (any any))))) p1373))))) (cvt1372 pattern1370 0 (quote ())))))) (lambda (e1398 r1399 w1400 s1401 mod1402) (let ((e1403 (source-wrap277 e1398 w1400 s1401 mod1402))) ((lambda (tmp1404) ((lambda (tmp1405) (if tmp1405 (apply (lambda (_1406 val1407 key1408 m1409) (if (and-map (lambda (x1410) (if (id?248 x1410) (not (ellipsis?293 x1410)) #f)) key1408) (let ((x1412 (gen-var295 (quote tmp)))) (build-application215 s1401 (build-lambda224 #f (list (quote tmp)) (list x1412) #f (gen-syntax-case1325 (build-lexical-reference217 (quote value) #f (quote tmp) x1412) key1408 m1409 r1399 mod1402)) (list (chi284 val1407 r1399 (quote (())) mod1402)))) (syntax-violation (quote syntax-case) "invalid literals list" e1403))) tmp1405) (syntax-violation #f "source expression failed to match any pattern" tmp1404))) ($sc-dispatch tmp1404 (quote (any any each-any . each-any))))) e1403))))) (set! sc-expand (lambda (x1416 . rest1415) (if (if (pair? x1416) (equal? (car x1416) noexpand204) #f) (cadr x1416) (let ((m1417 (if (null? rest1415) (quote e) (car rest1415))) (esew1418 (if (let ((t1419 (null? rest1415))) (if t1419 t1419 (null? (cdr rest1415)))) (quote (eval)) (cadr rest1415)))) (with-fluid* *mode*205 m1417 (lambda () (chi-top283 x1416 (quote ()) (quote ((top))) m1417 esew1418 (cons (quote hygiene) (module-name (current-module)))))))))) (set! identifier? (lambda (x1420) (nonsymbol-id?247 x1420))) (set! datum->syntax (lambda (id1421 datum1422) (make-syntax-object231 datum1422 (syntax-object-wrap234 id1421) #f))) (set! syntax->datum (lambda (x1423) (strip294 x1423 (quote (()))))) (set! generate-temporaries (lambda (ls1424) (begin (let ((x1425 ls1424)) (if (not (list? x1425)) (syntax-violation (quote generate-temporaries) "invalid argument" x1425))) (map (lambda (x1426) (wrap276 (gensym) (quote ((top))) #f)) ls1424)))) (set! free-identifier=? (lambda (x1427 y1428) (begin (let ((x1429 x1427)) (if (not (nonsymbol-id?247 x1429)) (syntax-violation (quote free-identifier=?) "invalid argument" x1429))) (let ((x1430 y1428)) (if (not (nonsymbol-id?247 x1430)) (syntax-violation (quote free-identifier=?) "invalid argument" x1430))) (free-id=?271 x1427 y1428)))) (set! bound-identifier=? (lambda (x1431 y1432) (begin (let ((x1433 x1431)) (if (not (nonsymbol-id?247 x1433)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1433))) (let ((x1434 y1432)) (if (not (nonsymbol-id?247 x1434)) (syntax-violation (quote bound-identifier=?) "invalid argument" x1434))) (bound-id=?272 x1431 y1432)))) (set! syntax-violation (lambda (who1438 message1437 form1436 . subform1435) (begin (let ((x1439 who1438)) (if (not ((lambda (x1440) (let ((t1441 (not x1440))) (if t1441 t1441 (let ((t1442 (string? x1440))) (if t1442 t1442 (symbol? x1440)))))) x1439)) (syntax-violation (quote syntax-violation) "invalid argument" x1439))) (let ((x1443 message1437)) (if (not (string? x1443)) (syntax-violation (quote syntax-violation) "invalid argument" x1443))) (scm-error (quote syntax-error) (quote sc-expand) (string-append (if who1438 "~a: " "") "~a " (if (null? subform1435) "in ~a" "in subform `~s' of `~s'")) (let ((tail1444 (cons message1437 (map (lambda (x1445) (strip294 x1445 (quote (())))) (append subform1435 (list form1436)))))) (if who1438 (cons who1438 tail1444) tail1444)) #f)))) (letrec ((match1450 (lambda (e1451 p1452 w1453 r1454 mod1455) (if (not r1454) #f (if (eq? p1452 (quote any)) (cons (wrap276 e1451 w1453 mod1455) r1454) (if (syntax-object?232 e1451) (match*1449 (syntax-object-expression233 e1451) p1452 (join-wraps267 w1453 (syntax-object-wrap234 e1451)) r1454 (syntax-object-module235 e1451)) (match*1449 e1451 p1452 w1453 r1454 mod1455)))))) (match*1449 (lambda (e1456 p1457 w1458 r1459 mod1460) (if (null? p1457) (if (null? e1456) r1459 #f) (if (pair? p1457) (if (pair? e1456) (match1450 (car e1456) (car p1457) w1458 (match1450 (cdr e1456) (cdr p1457) w1458 r1459 mod1460) mod1460) #f) (if (eq? p1457 (quote each-any)) (let ((l1461 (match-each-any1447 e1456 w1458 mod1460))) (if l1461 (cons l1461 r1459) #f)) (let ((atom-key1462 (vector-ref p1457 0))) (if (memv atom-key1462 (quote (each))) (if (null? e1456) (match-empty1448 (vector-ref p1457 1) r1459) (let ((l1463 (match-each1446 e1456 (vector-ref p1457 1) w1458 mod1460))) (if l1463 (letrec ((collect1464 (lambda (l1465) (if (null? (car l1465)) r1459 (cons (map car l1465) (collect1464 (map cdr l1465))))))) (collect1464 l1463)) #f))) (if (memv atom-key1462 (quote (free-id))) (if (id?248 e1456) (if (free-id=?271 (wrap276 e1456 w1458 mod1460) (vector-ref p1457 1)) r1459 #f) #f) (if (memv atom-key1462 (quote (atom))) (if (equal? (vector-ref p1457 1) (strip294 e1456 w1458)) r1459 #f) (if (memv atom-key1462 (quote (vector))) (if (vector? e1456) (match1450 (vector->list e1456) (vector-ref p1457 1) w1458 r1459 mod1460) #f))))))))))) (match-empty1448 (lambda (p1466 r1467) (if (null? p1466) r1467 (if (eq? p1466 (quote any)) (cons (quote ()) r1467) (if (pair? p1466) (match-empty1448 (car p1466) (match-empty1448 (cdr p1466) r1467)) (if (eq? p1466 (quote each-any)) (cons (quote ()) r1467) (let ((atom-key1468 (vector-ref p1466 0))) (if (memv atom-key1468 (quote (each))) (match-empty1448 (vector-ref p1466 1) r1467) (if (memv atom-key1468 (quote (free-id atom))) r1467 (if (memv atom-key1468 (quote (vector))) (match-empty1448 (vector-ref p1466 1) r1467))))))))))) (match-each-any1447 (lambda (e1469 w1470 mod1471) (if (pair? e1469) (let ((l1472 (match-each-any1447 (cdr e1469) w1470 mod1471))) (if l1472 (cons (wrap276 (car e1469) w1470 mod1471) l1472) #f)) (if (null? e1469) (quote ()) (if (syntax-object?232 e1469) (match-each-any1447 (syntax-object-expression233 e1469) (join-wraps267 w1470 (syntax-object-wrap234 e1469)) mod1471) #f))))) (match-each1446 (lambda (e1473 p1474 w1475 mod1476) (if (pair? e1473) (let ((first1477 (match1450 (car e1473) p1474 w1475 (quote ()) mod1476))) (if first1477 (let ((rest1478 (match-each1446 (cdr e1473) p1474 w1475 mod1476))) (if rest1478 (cons first1477 rest1478) #f)) #f)) (if (null? e1473) (quote ()) (if (syntax-object?232 e1473) (match-each1446 (syntax-object-expression233 e1473) p1474 (join-wraps267 w1475 (syntax-object-wrap234 e1473)) (syntax-object-module235 e1473)) #f)))))) (set! $sc-dispatch (lambda (e1479 p1480) (if (eq? p1480 (quote any)) (list e1479) (if (syntax-object?232 e1479) (match*1449 (syntax-object-expression233 e1479) p1480 (syntax-object-wrap234 e1479) (quote ()) (syntax-object-module235 e1479)) (match*1449 e1479 p1480 (quote (())) (quote ()) #f))))))))) +(define with-syntax (make-syncase-macro (quote macro) (lambda (x1481) ((lambda (tmp1482) ((lambda (tmp1483) (if tmp1483 (apply (lambda (_1484 e11485 e21486) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11485 e21486))) tmp1483) ((lambda (tmp1488) (if tmp1488 (apply (lambda (_1489 out1490 in1491 e11492 e21493) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1491 (quote ()) (list out1490 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11492 e21493))))) tmp1488) ((lambda (tmp1495) (if tmp1495 (apply (lambda (_1496 out1497 in1498 e11499 e21500) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) in1498) (quote ()) (list out1497 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11499 e21500))))) tmp1495) (syntax-violation #f "source expression failed to match any pattern" tmp1482))) ($sc-dispatch tmp1482 (quote (any #(each (any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any ((any any)) any . each-any)))))) ($sc-dispatch tmp1482 (quote (any () any . each-any))))) x1481)))) +(define syntax-rules (make-syncase-macro (quote macro) (lambda (x1504) ((lambda (tmp1505) ((lambda (tmp1506) (if tmp1506 (apply (lambda (_1507 k1508 keyword1509 pattern1510 template1511) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons k1508 (map (lambda (tmp1514 tmp1513) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1513) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) tmp1514))) template1511 pattern1510)))))) tmp1506) (syntax-violation #f "source expression failed to match any pattern" tmp1505))) ($sc-dispatch tmp1505 (quote (any each-any . #(each ((any . any) any))))))) x1504)))) +(define let* (make-extended-syncase-macro (module-ref (current-module) (quote let*)) (quote macro) (lambda (x1515) ((lambda (tmp1516) ((lambda (tmp1517) (if (if tmp1517 (apply (lambda (let*1518 x1519 v1520 e11521 e21522) (and-map identifier? x1519)) tmp1517) #f) (apply (lambda (let*1524 x1525 v1526 e11527 e21528) (letrec ((f1529 (lambda (bindings1530) (if (null? bindings1530) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons (quote ()) (cons e11527 e21528))) ((lambda (tmp1534) ((lambda (tmp1535) (if tmp1535 (apply (lambda (body1536 binding1537) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list binding1537) body1536)) tmp1535) (syntax-violation #f "source expression failed to match any pattern" tmp1534))) ($sc-dispatch tmp1534 (quote (any any))))) (list (f1529 (cdr bindings1530)) (car bindings1530))))))) (f1529 (map list x1525 v1526)))) tmp1517) (syntax-violation #f "source expression failed to match any pattern" tmp1516))) ($sc-dispatch tmp1516 (quote (any #(each (any any)) any . each-any))))) x1515)))) +(define do (make-extended-syncase-macro (module-ref (current-module) (quote do)) (quote macro) (lambda (orig-x1538) ((lambda (tmp1539) ((lambda (tmp1540) (if tmp1540 (apply (lambda (_1541 var1542 init1543 step1544 e01545 e11546 c1547) ((lambda (tmp1548) ((lambda (tmp1549) (if tmp1549 (apply (lambda (step1550) ((lambda (tmp1551) ((lambda (tmp1552) (if tmp1552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1552) ((lambda (tmp1557) (if tmp1557 (apply (lambda (e11558 e21559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (map list var1542 init1543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) e01545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (cons e11558 e21559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) (append c1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))) (hygiene guile))) step1550))))))) tmp1557) (syntax-violation #f "source expression failed to match any pattern" tmp1551))) ($sc-dispatch tmp1551 (quote (any . each-any)))))) ($sc-dispatch tmp1551 (quote ())))) e11546)) tmp1549) (syntax-violation #f "source expression failed to match any pattern" tmp1548))) ($sc-dispatch tmp1548 (quote each-any)))) (map (lambda (v1566 s1567) ((lambda (tmp1568) ((lambda (tmp1569) (if tmp1569 (apply (lambda () v1566) tmp1569) ((lambda (tmp1570) (if tmp1570 (apply (lambda (e1571) e1571) tmp1570) ((lambda (_1572) (syntax-violation (quote do) "bad step expression" orig-x1538 s1567)) tmp1568))) ($sc-dispatch tmp1568 (quote (any)))))) ($sc-dispatch tmp1568 (quote ())))) s1567)) var1542 step1544))) tmp1540) (syntax-violation #f "source expression failed to match any pattern" tmp1539))) ($sc-dispatch tmp1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) orig-x1538)))) +(define quasiquote (make-extended-syncase-macro (module-ref (current-module) (quote quasiquote)) (quote macro) (letrec ((quasicons1575 (lambda (x1579 y1580) ((lambda (tmp1581) ((lambda (tmp1582) (if tmp1582 (apply (lambda (x1583 y1584) ((lambda (tmp1585) ((lambda (tmp1586) (if tmp1586 (apply (lambda (dy1587) ((lambda (tmp1588) ((lambda (tmp1589) (if tmp1589 (apply (lambda (dx1590) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons dx1590 dy1587))) tmp1589) ((lambda (_1591) (if (null? dy1587) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584))) tmp1588))) ($sc-dispatch tmp1588 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) x1583)) tmp1586) ((lambda (tmp1592) (if tmp1592 (apply (lambda (stuff1593) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (cons x1583 stuff1593))) tmp1592) ((lambda (else1594) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1583 y1584)) tmp1585))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1585 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) y1584)) tmp1582) (syntax-violation #f "source expression failed to match any pattern" tmp1581))) ($sc-dispatch tmp1581 (quote (any any))))) (list x1579 y1580)))) (quasiappend1576 (lambda (x1595 y1596) ((lambda (tmp1597) ((lambda (tmp1598) (if tmp1598 (apply (lambda (x1599 y1600) ((lambda (tmp1601) ((lambda (tmp1602) (if tmp1602 (apply (lambda () x1599) tmp1602) ((lambda (_1603) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1599 y1600)) tmp1601))) ($sc-dispatch tmp1601 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) ()))))) y1600)) tmp1598) (syntax-violation #f "source expression failed to match any pattern" tmp1597))) ($sc-dispatch tmp1597 (quote (any any))))) (list x1595 y1596)))) (quasivector1577 (lambda (x1604) ((lambda (tmp1605) ((lambda (x1606) ((lambda (tmp1607) ((lambda (tmp1608) (if tmp1608 (apply (lambda (x1609) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) (list->vector x1609))) tmp1608) ((lambda (tmp1611) (if tmp1611 (apply (lambda (x1612) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1612)) tmp1611) ((lambda (_1614) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) x1606)) tmp1607))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . each-any)))))) ($sc-dispatch tmp1607 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) each-any))))) x1606)) tmp1605)) x1604))) (quasi1578 (lambda (p1615 lev1616) ((lambda (tmp1617) ((lambda (tmp1618) (if tmp1618 (apply (lambda (p1619) (if (= lev1616 0) p1619 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1619) (- lev1616 1))))) tmp1618) ((lambda (tmp1620) (if (if tmp1620 (apply (lambda (args1621) (= lev1616 0)) tmp1620) #f) (apply (lambda (args1622) (syntax-violation (quote unquote) "unquote takes exactly one argument" p1615 (cons (quote #(syntax-object unquote ((top) #(ribcage #(args) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1622))) tmp1620) ((lambda (tmp1623) (if tmp1623 (apply (lambda (p1624 q1625) (if (= lev1616 0) (quasiappend1576 p1624 (quasi1578 q1625 lev1616)) (quasicons1575 (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1624) (- lev1616 1))) (quasi1578 q1625 lev1616)))) tmp1623) ((lambda (tmp1626) (if (if tmp1626 (apply (lambda (args1627 q1628) (= lev1616 0)) tmp1626) #f) (apply (lambda (args1629 q1630) (syntax-violation (quote unquote-splicing) "unquote-splicing takes exactly one argument" p1615 (cons (quote #(syntax-object unquote-splicing ((top) #(ribcage #(args q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) args1629))) tmp1626) ((lambda (tmp1631) (if tmp1631 (apply (lambda (p1632) (quasicons1575 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile)))) (quasi1578 (list p1632) (+ lev1616 1)))) tmp1631) ((lambda (tmp1633) (if tmp1633 (apply (lambda (p1634 q1635) (quasicons1575 (quasi1578 p1634 lev1616) (quasi1578 q1635 lev1616))) tmp1633) ((lambda (tmp1636) (if tmp1636 (apply (lambda (x1637) (quasivector1577 (quasi1578 x1637 lev1616))) tmp1636) ((lambda (p1639) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) p1639)) tmp1617))) ($sc-dispatch tmp1617 (quote #(vector each-any)))))) ($sc-dispatch tmp1617 (quote (any . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any) . any)))))) ($sc-dispatch tmp1617 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) . any)))))) ($sc-dispatch tmp1617 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))) (hygiene guile))) any))))) p1615)))) (lambda (x1640) ((lambda (tmp1641) ((lambda (tmp1642) (if tmp1642 (apply (lambda (_1643 e1644) (quasi1578 e1644 0)) tmp1642) (syntax-violation #f "source expression failed to match any pattern" tmp1641))) ($sc-dispatch tmp1641 (quote (any any))))) x1640))))) +(define include (make-syncase-macro (quote macro) (lambda (x1645) (letrec ((read-file1646 (lambda (fn1647 k1648) (let ((p1649 (open-input-file fn1647))) (letrec ((f1650 (lambda (x1651) (if (eof-object? x1651) (begin (close-input-port p1649) (quote ())) (cons (datum->syntax k1648 x1651) (f1650 (read p1649))))))) (f1650 (read p1649))))))) ((lambda (tmp1652) ((lambda (tmp1653) (if tmp1653 (apply (lambda (k1654 filename1655) (let ((fn1656 (syntax->datum filename1655))) ((lambda (tmp1657) ((lambda (tmp1658) (if tmp1658 (apply (lambda (exp1659) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) exp1659)) tmp1658) (syntax-violation #f "source expression failed to match any pattern" tmp1657))) ($sc-dispatch tmp1657 (quote each-any)))) (read-file1646 fn1656 k1654)))) tmp1653) (syntax-violation #f "source expression failed to match any pattern" tmp1652))) ($sc-dispatch tmp1652 (quote (any any))))) x1645))))) +(define unquote (make-syncase-macro (quote macro) (lambda (x1661) ((lambda (tmp1662) ((lambda (tmp1663) (if tmp1663 (apply (lambda (_1664 e1665) (syntax-violation (quote unquote) "expression not valid outside of quasiquote" x1661)) tmp1663) (syntax-violation #f "source expression failed to match any pattern" tmp1662))) ($sc-dispatch tmp1662 (quote (any any))))) x1661)))) +(define unquote-splicing (make-syncase-macro (quote macro) (lambda (x1666) ((lambda (tmp1667) ((lambda (tmp1668) (if tmp1668 (apply (lambda (_1669 e1670) (syntax-violation (quote unquote-splicing) "expression not valid outside of quasiquote" x1666)) tmp1668) (syntax-violation #f "source expression failed to match any pattern" tmp1667))) ($sc-dispatch tmp1667 (quote (any any))))) x1666)))) +(define case (make-extended-syncase-macro (module-ref (current-module) (quote case)) (quote macro) (lambda (x1671) ((lambda (tmp1672) ((lambda (tmp1673) (if tmp1673 (apply (lambda (_1674 e1675 m11676 m21677) ((lambda (tmp1678) ((lambda (body1679) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1675)) body1679)) tmp1678)) (letrec ((f1680 (lambda (clause1681 clauses1682) (if (null? clauses1682) ((lambda (tmp1684) ((lambda (tmp1685) (if tmp1685 (apply (lambda (e11686 e21687) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11686 e21687))) tmp1685) ((lambda (tmp1689) (if tmp1689 (apply (lambda (k1690 e11691 e21692) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1690)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11691 e21692)))) tmp1689) ((lambda (_1695) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1684))) ($sc-dispatch tmp1684 (quote (each-any any . each-any)))))) ($sc-dispatch tmp1684 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) any . each-any))))) clause1681) ((lambda (tmp1696) ((lambda (rest1697) ((lambda (tmp1698) ((lambda (tmp1699) (if tmp1699 (apply (lambda (k1700 e11701 e21702) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) k1700)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e11701 e21702)) rest1697)) tmp1699) ((lambda (_1705) (syntax-violation (quote case) "bad clause" x1671 clause1681)) tmp1698))) ($sc-dispatch tmp1698 (quote (each-any any . each-any))))) clause1681)) tmp1696)) (f1680 (car clauses1682) (cdr clauses1682))))))) (f1680 m11676 m21677)))) tmp1673) (syntax-violation #f "source expression failed to match any pattern" tmp1672))) ($sc-dispatch tmp1672 (quote (any any any . each-any))))) x1671)))) +(define identifier-syntax (make-syncase-macro (quote macro) (lambda (x1706) ((lambda (tmp1707) ((lambda (tmp1708) (if tmp1708 (apply (lambda (_1709 e1710) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) e1710)) (list (cons _1709 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile))) (cons e1710 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))) (hygiene guile)))))))))) tmp1708) (syntax-violation #f "source expression failed to match any pattern" tmp1707))) ($sc-dispatch tmp1707 (quote (any any))))) x1706)))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index cd2c53224..c2668c0c4 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -22,6 +22,9 @@ ;;; Extracted from Chez Scheme Version 5.9f ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman +;;; Modified by Andy Wingo according to the Git +;;; revision control logs corresponding to this file: 2009. + ;;; Modified by Mikael Djurfeldt according ;;; to the ChangeLog distributed in the same directory as this file: ;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24, @@ -49,7 +52,7 @@ ;;; also documented in the R4RS and draft R5RS. ;;; ;;; bound-identifier=? -;;; datum->syntax-object +;;; datum->syntax ;;; define-syntax ;;; fluid-let-syntax ;;; free-identifier=? @@ -60,7 +63,7 @@ ;;; letrec-syntax ;;; syntax ;;; syntax-case -;;; syntax-object->datum +;;; syntax->datum ;;; syntax-rules ;;; with-syntax ;;; @@ -79,46 +82,14 @@ ;;; conditionally evaluates expr ... at compile-time or run-time ;;; depending upon situations (see the Chez Scheme System Manual, ;;; Revision 3, for a complete description) -;;; (syntax-error object message) +;;; (syntax-violation who message form [subform]) ;;; used to report errors found during expansion -;;; (install-global-transformer symbol value) -;;; used by expanded code to install top-level syntactic abstractions -;;; (syntax-dispatch e p) +;;; ($sc-dispatch e p) ;;; used by expanded code to handle syntax-case matching ;;; The following nonstandard procedures must be provided by the -;;; implementation for this code to run. -;;; -;;; (void) -;;; returns the implementation's cannonical "unspecified value". This -;;; usually works: (define void (lambda () (if #f #f))). -;;; -;;; (andmap proc list1 list2 ...) -;;; returns true if proc returns true when applied to each element of list1 -;;; along with the corresponding elements of list2 .... -;;; The following definition works but does no error checking: -;;; -;;; (define andmap -;;; (lambda (f first . rest) -;;; (or (null? first) -;;; (if (null? rest) -;;; (let andmap ((first first)) -;;; (let ((x (car first)) (first (cdr first))) -;;; (if (null? first) -;;; (f x) -;;; (and (f x) (andmap first))))) -;;; (let andmap ((first first) (rest rest)) -;;; (let ((x (car first)) -;;; (xr (map car rest)) -;;; (first (cdr first)) -;;; (rest (map cdr rest))) -;;; (if (null? first) -;;; (apply f (cons x xr)) -;;; (and (apply f (cons x xr)) (andmap first rest))))))))) -;;; -;;; The following nonstandard procedures must also be provided by the ;;; implementation for this code to run using the standard portable -;;; hooks and output constructors. They are not used by expanded code, +;;; hooks and output constructors. They are not used by expanded code, ;;; and so need be present only at expansion time. ;;; ;;; (eval x) @@ -134,21 +105,8 @@ ;;; by eval, and eval accepts one argument, nothing special must be done ;;; to support the "noexpand" flag, since it is handled by sc-expand. ;;; -;;; (error who format-string why what) -;;; where who is either a symbol or #f, format-string is always "~a ~s", -;;; why is always a string, and what may be any object. error should -;;; signal an error with a message something like -;;; -;;; "error in : " -;;; ;;; (gensym) ;;; returns a unique symbol each time it's called -;;; -;;; (putprop symbol key value) -;;; (getprop symbol key) -;;; key is always the symbol *sc-expander*; value may be any object. -;;; putprop should associate the given value with the given symbol in -;;; some way that it can be retrieved later with getprop. ;;; When porting to a new Scheme implementation, you should define the ;;; procedures listed above, load the expanded version of psyntax.ss @@ -209,7 +167,7 @@ ;;; Objects with no standard print syntax, including objects containing ;;; cycles and syntax object, are allowed in quoted data as long as they -;;; are contained within a syntax form or produced by datum->syntax-object. +;;; are contained within a syntax form or produced by datum->syntax. ;;; Such objects are never copied. ;;; All identifiers that don't have macro definitions and are not bound @@ -233,19 +191,6 @@ ;;; The implementation of generate-temporaries assumes that it is possible ;;; to generate globally unique symbols (gensyms). -;;; The input to sc-expand may contain "annotations" describing, e.g., the -;;; source file and character position from where each object was read if -;;; it was read from a file. These annotations are handled properly by -;;; sc-expand only if the annotation? hook (see hooks below) is implemented -;;; properly and the operators make-annotation, annotation-expression, -;;; annotation-source, annotation-stripped, and set-annotation-stripped! -;;; are supplied. If annotations are supplied, the proper annotation -;;; source is passed to the various output constructors, allowing -;;; implementations to accurately correlate source and expanded code. -;;; Contact one of the authors for details if you wish to make use of -;;; this feature. - - ;;; Bootstrapping: @@ -256,23 +201,45 @@ +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + (let () +;;; Private version of and-map that handles multiple lists. +(define and-map* + (lambda (f first . rest) + (or (null? first) + (if (null? rest) + (let andmap ((first first)) + (let ((x (car first)) (first (cdr first))) + (if (null? first) + (f x) + (and (f x) (andmap first))))) + (let andmap ((first first) (rest rest)) + (let ((x (car first)) + (xr (map car rest)) + (first (cdr first)) + (rest (map cdr rest))) + (if (null? first) + (apply f (cons x xr)) + (and (apply f (cons x xr)) (andmap first rest))))))))) + (define-syntax define-structure (lambda (x) (define construct-name (lambda (template-identifier . args) - (datum->syntax-object + (datum->syntax template-identifier (string->symbol (apply string-append (map (lambda (x) (if (string? x) x - (symbol->string (syntax-object->datum x)))) + (symbol->string (syntax->datum x)))) args)))))) (syntax-case x () ((_ (name id1 ...)) - (andmap identifier? (syntax (name id1 ...))) + (and-map identifier? (syntax (name id1 ...))) (with-syntax ((constructor (construct-name (syntax name) "make-" (syntax name))) (predicate (construct-name (syntax name) (syntax name) "?")) @@ -310,6 +277,7 @@ (let () (define noexpand "noexpand") +(define *mode* (make-fluid)) ;;; hooks to nonportable run-time helpers (begin @@ -320,170 +288,255 @@ (define top-level-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) (define local-eval-hook (lambda (x mod) - (eval `(,noexpand ,x) (if mod (resolve-module mod) - (interaction-environment))))) - -(define error-hook - (lambda (who why what) - (error who "~a ~s" why what))) + (primitive-eval + `(,noexpand + ,(case (fluid-ref *mode*) + ((c) ((@ (language tree-il) tree-il->scheme) x)) + (else x)))))) (define-syntax gensym-hook (syntax-rules () ((_) (gensym)))) (define put-global-definition-hook - (lambda (symbol binding module) - (let* ((module (if module - (resolve-module module) - (warn "wha" symbol (current-module)))) - (v (or (module-variable module symbol) - (let ((v (make-variable sc-macro))) - (module-add! module symbol v) - v)))) - ;; Don't destroy Guile macros corresponding to primitive syntax - ;; when syncase boots. - (if (not (and (symbol-property symbol 'primitive-syntax) - (eq? module the-syncase-module))) - (variable-set! v sc-macro)) - ;; Properties are tied to variable objects - (set-object-property! v '*sc-expander* binding)))) + (lambda (symbol type val) + (let ((existing (let ((v (module-variable (current-module) symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (not (syncase-macro-type val)) + val)))))) + (module-define! (current-module) + symbol + (if existing + (make-extended-syncase-macro existing type val) + (make-syncase-macro type val)))))) (define get-global-definition-hook (lambda (symbol module) - (let* ((module (if module - (resolve-module module) - (warn "wha" symbol (current-module)))) - (v (module-variable module symbol))) - (and v - (or (object-property v '*sc-expander*) - (and (variable-bound? v) - (macro? (variable-ref v)) - (macro-transformer (variable-ref v)) ;non-primitive - guile-macro)))))) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (let ((v (module-variable (if module + (resolve-module (cdr module)) + (current-module)) + symbol))) + (and v (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) (syncase-macro-type val) + (cons (syncase-macro-type val) + (syncase-macro-binding val)))))))) + ) ;;; output constructors -(define (build-annotated src exp) - (if (and src (not (annotation? exp))) - (make-annotation exp src #t) - exp)) +(define build-void + (lambda (source) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-void) source)) + (else '(if #f #f))))) -(define-syntax build-application - (syntax-rules () - ((_ source fun-exp arg-exps) - (build-annotated source `(,fun-exp . ,arg-exps))))) +(define build-application + (lambda (source fun-exp arg-exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-application) source fun-exp arg-exps)) + (else `(,fun-exp . ,arg-exps))))) -(define-syntax build-conditional - (syntax-rules () - ((_ source test-exp then-exp else-exp) - (build-annotated source `(if ,test-exp ,then-exp ,else-exp))))) +(define build-conditional + (lambda (source test-exp then-exp else-exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-conditional) + source test-exp then-exp else-exp)) + (else (if (equal? else-exp '(if #f #f)) + `(if ,test-exp ,then-exp) + `(if ,test-exp ,then-exp ,else-exp)))))) -(define-syntax build-lexical-reference - (syntax-rules () - ((_ type source var) - (build-annotated source var)))) +(define build-lexical-reference + (lambda (type source name var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-ref) source name var)) + (else var)))) -(define-syntax build-lexical-assignment - (syntax-rules () - ((_ source var exp) - (build-annotated source `(set! ,var ,exp))))) +(define build-lexical-assignment + (lambda (source name var exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lexical-set) source name var exp)) + (else `(set! ,var ,exp))))) -(define-syntax build-global-reference - (syntax-rules () - ((_ source var mod) - (build-annotated source - (make-module-ref mod var #f))))) +;; Before modules are booted, we can't expand into data structures from +;; (language tree-il) -- we need to give the evaluator the +;; s-expressions that it understands natively. Actually the real truth +;; of the matter is that the evaluator doesn't understand tree-il +;; structures at all. So until we fix the evaluator, if ever, the +;; conflation that we should use tree-il iff we are compiling +;; holds true. +;; +(define (analyze-variable mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) + (mod (cdr mod))) + (case kind + ((public) (modref-cont mod var #t)) + ((private) (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((bare) (bare-cont var)) + ((hygiene) (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + (else (syntax-violation #f "bad module kind" var mod)))))) -(define-syntax build-global-assignment - (syntax-rules () - ((_ source var exp mod) - (build-annotated source - `(set! ,(make-module-ref mod var #f) ,exp))))) +(define build-global-reference + (lambda (source var mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) source mod var public?)) + (else (list (if public? '@ '@@) mod var)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) source var)) + (else var)))))) -(define-syntax build-global-definition - (syntax-rules () - ((_ source var exp mod) - (build-annotated source `(define ,var ,exp))))) +(define build-global-assignment + (lambda (source var exp mod) + (analyze-variable + mod var + (lambda (mod var public?) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-set) source mod var public? exp)) + (else `(set! ,(list (if public? '@ '@@) mod var) ,exp)))) + (lambda (var) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-set) source var exp)) + (else `(set! ,var ,exp))))))) -(define-syntax build-lambda - (syntax-rules () - ((_ src vars exp) - (build-annotated src `(lambda ,vars ,exp))))) +;; FIXME: there is a bug that prevents (set! ((@ (foo) bar) baz) quz) +;; from working. Hack around it. +(define (maybe-name-value! name val) + (cond + (((@ (language tree-il) lambda?) val) + (let ((meta ((@ (language tree-il) lambda-meta) val))) + (if (not (assq 'name meta)) + ((setter (@ (language tree-il) lambda-meta)) + val + (acons 'name name meta))))))) -;; FIXME: wingo: add modules here somehow? -(define-syntax build-primref - (syntax-rules () - ((_ src name) (build-annotated src name)) - ((_ src level name) (build-annotated src name)))) +(define build-global-definition + (lambda (source var exp) + (case (fluid-ref *mode*) + ((c) + (maybe-name-value! var exp) + ((@ (language tree-il) make-toplevel-define) source var exp)) + (else `(define ,var ,exp))))) + +(define build-lambda + (lambda (src ids vars docstring exp) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-lambda) src ids vars + (if docstring `((documentation . ,docstring)) '()) + exp)) + (else `(lambda ,vars ,@(if docstring (list docstring) '()) + ,exp))))) + +(define build-primref + (lambda (src name) + (if (equal? (module-name (current-module)) '(guile)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-toplevel-ref) src name)) + (else name)) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-module-ref) src '(guile) name #f)) + (else `(@@ (guile) ,name)))))) (define (build-data src exp) - (if (and (self-evaluating? exp) - (not (vector? exp))) - (build-annotated src exp) - (build-annotated src (list 'quote exp)))) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-const) src exp)) + (else (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))))) (define build-sequence (lambda (src exps) (if (null? (cdr exps)) - (build-annotated src (car exps)) - (build-annotated src `(begin ,@exps))))) + (car exps) + (case (fluid-ref *mode*) + ((c) ((@ (language tree-il) make-sequence) src exps)) + (else `(begin ,@exps)))))) (define build-let - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src `(let ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-let) src ids vars val-exps body-exp)) + (else `(let ,(map list vars val-exps) ,body-exp)))))) (define build-named-let - (lambda (src vars val-exps body-exp) - (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(let ,(car vars) - ,(map list (cdr vars) val-exps) ,body-exp))))) + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) + (f-name (car ids)) + (vars (cdr vars)) + (ids (cdr ids))) + (case (fluid-ref *mode*) + ((c) + (let ((proc (build-lambda src ids vars #f body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src + (list f-name) (list f) (list proc) + (build-application src (build-lexical-reference 'fun src f-name f) + val-exps)))) + (else `(let ,f ,(map list vars val-exps) ,body-exp)))))) (define build-letrec - (lambda (src vars val-exps body-exp) + (lambda (src ids vars val-exps body-exp) (if (null? vars) - (build-annotated src body-exp) - (build-annotated src - `(letrec ,(map list vars val-exps) ,body-exp))))) + body-exp + (case (fluid-ref *mode*) + ((c) + (for-each maybe-name-value! ids val-exps) + ((@ (language tree-il) make-letrec) src ids vars val-exps body-exp)) + (else `(letrec ,(map list vars val-exps) ,body-exp)))))) -;; FIXME: wingo: use make-lexical +;; FIXME: wingo: use make-lexical ? (define-syntax build-lexical-var (syntax-rules () - ((_ src id) (build-annotated src (gensym (symbol->string id)))))) + ((_ src id) (gensym (symbol->string id))))) (define-structure (syntax-object expression wrap module)) -(define-syntax unannotate - (syntax-rules () - ((_ x) - (let ((e x)) - (if (annotation? e) - (annotation-expression e) - e))))) - (define-syntax no-source (identifier-syntax #f)) (define source-annotation (lambda (x) (cond - ((annotation? x) (annotation-source x)) - ((syntax-object? x) (source-annotation (syntax-object-expression x))) - (else no-source)))) + ((syntax-object? x) + (source-annotation (syntax-object-expression x))) + ((pair? x) (let ((props (source-properties x))) + (if (pair? props) + props + #f))) + (else #f)))) (define-syntax arg-check (syntax-rules () ((_ pred? e who) (let ((x e)) - (if (not (pred? x)) (error-hook who "invalid argument" x)))))) + (if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) ;;; compile-time environments @@ -593,8 +646,7 @@ (define global-extend (lambda (type sym val) - (put-global-definition-hook sym (make-binding type val) - (module-name (current-module))))) + (put-global-definition-hook sym type val))) ;;; Conceptually, identifiers are always syntax objects. Internally, @@ -605,29 +657,30 @@ (define nonsymbol-id? (lambda (x) (and (syntax-object? x) - (symbol? (unannotate (syntax-object-expression x)))))) + (symbol? (syntax-object-expression x))))) (define id? (lambda (x) (cond ((symbol? x) #t) - ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x)))) - ((annotation? x) (symbol? (annotation-expression x))) + ((syntax-object? x) (symbol? (syntax-object-expression x))) (else #f)))) (define-syntax id-sym-name (syntax-rules () ((_ e) (let ((x e)) - (unannotate (if (syntax-object? x) (syntax-object-expression x) x)))))) + (if (syntax-object? x) + (syntax-object-expression x) + x))))) (define id-sym-name&marks (lambda (x w) (if (syntax-object? x) (values - (unannotate (syntax-object-expression x)) - (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) - (values (unannotate x) (wrap-marks w))))) + (syntax-object-expression x) + (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) + (values x (wrap-marks w))))) ;;; syntax object wraps @@ -693,7 +746,7 @@ ; must receive ids with complete wraps (lambda (ribcage id label) (set-ribcage-symnames! ribcage - (cons (unannotate (syntax-object-expression id)) + (cons (syntax-object-expression id) (ribcage-symnames ribcage))) (set-ribcage-marks! ribcage (cons (wrap-marks (syntax-object-wrap id)) @@ -793,7 +846,7 @@ ((symbol? id) (or (first (search id (wrap-subst w) (wrap-marks w))) id)) ((syntax-object? id) - (let ((id (unannotate (syntax-object-expression id))) + (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (call-with-values (lambda () (search id (wrap-subst w) marks)) @@ -801,10 +854,7 @@ (or new-id (first (search id (wrap-subst w1) marks)) id)))))) - ((annotation? id) - (let ((id (unannotate id))) - (or (first (search id (wrap-subst w) (wrap-marks w))) id))) - (else (error-hook 'id-var-name "invalid id" id))))) + (else (syntax-violation 'id-var-name "invalid id" id))))) ;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. @@ -821,11 +871,11 @@ (define bound-id=? (lambda (i j) (if (and (syntax-object? i) (syntax-object? j)) - (and (eq? (unannotate (syntax-object-expression i)) - (unannotate (syntax-object-expression j))) + (and (eq? (syntax-object-expression i) + (syntax-object-expression j)) (same-marks? (wrap-marks (syntax-object-wrap i)) (wrap-marks (syntax-object-wrap j)))) - (eq? (unannotate i) (unannotate j))))) + (eq? i j)))) ;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. ;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids @@ -875,7 +925,9 @@ (define source-wrap (lambda (x w s defmod) - (wrap (if s (make-annotation x s #f) x) w defmod))) + (if (and s (pair? x)) + (set-source-properties! x s)) + (wrap x w defmod))) ;;; expanding @@ -897,12 +949,33 @@ (let ((first (chi-top (car body) r w m esew mod))) (cons first (dobody (cdr body) r w m esew mod)))))))) -;; FIXME: module? (define chi-install-global (lambda (name e) - (build-application no-source - (build-primref no-source 'install-global-transformer) - (list (build-data no-source name) e)))) + (build-global-definition + no-source + name + ;; FIXME: seems nasty to call current-module here + (if (let ((v (module-variable (current-module) name))) + ;; FIXME use primitive-macro? + (and v (variable-bound? v) (macro? (variable-ref v)) + (not (eq? (macro-type (variable-ref v)) 'syncase-macro)))) + (build-application + no-source + (build-primref no-source 'make-extended-syncase-macro) + (list (build-application + no-source + (build-primref no-source 'module-ref) + (list (build-application + no-source + (build-primref no-source 'current-module) + '()) + (build-data no-source name))) + (build-data no-source 'macro) + e)) + (build-application + no-source + (build-primref no-source 'make-syncase-macro) + (list (build-data no-source 'macro) e)))))) (define chi-when-list (lambda (e when-list w) @@ -916,8 +989,9 @@ ((free-id=? x (syntax compile)) 'compile) ((free-id=? x (syntax load)) 'load) ((free-id=? x (syntax eval)) 'eval) - (else (syntax-error (wrap x w #f) - "invalid eval-when situation")))) + (else (syntax-violation 'eval-when + "invalid situation" + e (wrap x w #f))))) situations)))))) ;;; syntax-type returns six values: type, value, e, w, s, and mod. The @@ -1009,7 +1083,7 @@ ((_ name) (id? (syntax name)) (values 'define-form (wrap (syntax name) w mod) - (syntax (void)) + (syntax (if #f #f)) empty-wrap s mod)))) ((define-syntax) (syntax-case e () @@ -1021,13 +1095,10 @@ (values 'call #f e w s mod)))) (values 'call #f e w s mod)))) ((syntax-object? e) - ;; s can't be valid source if we've unwrapped (syntax-type (syntax-object-expression e) r (join-wraps w (syntax-object-wrap e)) - no-source rib (or (syntax-object-module e) mod))) - ((annotation? e) - (syntax-type (annotation-expression e) r w (annotation-source e) rib mod)) + s rib (or (syntax-object-module e) mod))) ((self-evaluating? e) (values 'constant #f e w s mod)) (else (values 'other #f e w s mod))))) @@ -1040,7 +1111,7 @@ (if (eq? m 'c&e) (top-level-eval-hook x mod)) x)))) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (case type ((begin-form) @@ -1101,25 +1172,22 @@ (let* ((n (id-var-name value w)) (type (binding-type (lookup n r mod)))) (case type - ((global) + ((global core macro module-ref) (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) + (build-global-definition s n (chi e r w mod)) mod)) ((displaced-lexical) - (syntax-error (wrap value w mod) "identifier out of context")) + (syntax-violation #f "identifier out of context" + e (wrap value w mod))) (else - (if (eq? type 'external-macro) - (eval-if-c&e m - (build-global-definition s n (chi e r w mod) mod) - mod) - (syntax-error (wrap value w mod) - "cannot define keyword at top level")))))) + (syntax-violation #f "cannot define keyword at top level" + e (wrap value w mod)))))) (else (eval-if-c&e m (chi-expr type value e r w s mod) mod))))))) (define chi (lambda (e r w mod) (call-with-values - (lambda () (syntax-type e r w no-source #f mod)) + (lambda () (syntax-type e r w (source-annotation e) #f mod)) (lambda (type value e w s mod) (chi-expr type value e r w s mod))))) @@ -1127,7 +1195,7 @@ (lambda (type value e r w s mod) (case type ((lexical) - (build-lexical-reference 'value s value)) + (build-lexical-reference 'value s e value)) ((core external-macro) ;; apply transformer (value e r w s mod)) @@ -1137,7 +1205,8 @@ (lambda (id mod) (build-global-reference s id mod)))) ((lexical-call) (chi-application - (build-lexical-reference 'fun (source-annotation (car e)) value) + (build-lexical-reference 'fun (source-annotation (car e)) + (car e) value) e r w s mod)) ((global-call) (chi-application @@ -1162,14 +1231,16 @@ (chi-sequence (syntax (e1 e2 ...)) r w s mod) (chi-void)))))) ((define-form define-syntax-form) - (syntax-error (wrap value w mod) "invalid context for definition of")) + (syntax-violation #f "definition in expression context" + e (wrap value w mod))) ((syntax) - (syntax-error (source-wrap e w s mod) - "reference to pattern variable outside syntax form")) + (syntax-violation #f "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) ((displaced-lexical) - (syntax-error (source-wrap e w s mod) - "reference to identifier outside its scope")) - (else (syntax-error (source-wrap e w s mod)))))) + (syntax-violation #f "reference to identifier outside its scope" + (source-wrap e w s mod))) + (else (syntax-violation #f "unexpected syntax" + (source-wrap e w s mod)))))) (define chi-application (lambda (x e r w s mod) @@ -1201,7 +1272,14 @@ (if rib (cons rib (cons 'shift s)) (cons 'shift s))) - (module-name (procedure-module p))))))) ;; hither the hygiene + (let ((pmod (procedure-module p))) + (if pmod + ;; hither the hygiene + (cons 'hygiene (module-name pmod)) + ;; but it's possible for the proc to have + ;; no mod, if it was made before modules + ;; were booted + '(hygiene guile)))))))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -1209,7 +1287,8 @@ (vector-set! v i (rebuild-macro-output (vector-ref x i) m))))) ((symbol? x) - (syntax-error x "encountered raw symbol in macro output")) + (syntax-violation #f "encountered raw symbol in macro output" + (source-wrap e w s mod) x)) (else x)))) (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark)))) @@ -1257,12 +1336,13 @@ (ribcage (make-empty-ribcage)) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w))))) (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) (labels '()) (vars '()) (vals '()) (bindings '())) + (ids '()) (labels '()) + (var-ids '()) (vars '()) (vals '()) (bindings '())) (if (null? body) - (syntax-error outer-form "no expressions in body") + (syntax-violation #f "no expressions in body" outer-form) (let ((e (cdar body)) (er (caar body))) (call-with-values - (lambda () (syntax-type e er empty-wrap no-source ribcage mod)) + (lambda () (syntax-type e er empty-wrap (source-annotation er) ribcage mod)) (lambda (type value e w s mod) (case type ((define-form) @@ -1271,6 +1351,7 @@ (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) + (cons id var-ids) (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (make-binding 'lexical var) bindings))))) ((define-syntax-form) @@ -1278,7 +1359,7 @@ (extend-ribcage! ribcage id label) (parse (cdr body) (cons id ids) (cons label labels) - vars vals + var-ids vars vals (cons (make-binding 'macro (cons er (wrap e w mod))) bindings)))) ((begin-form) @@ -1289,7 +1370,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) ((local-syntax-form) (chi-local-syntax value e er w s mod (lambda (forms er w s mod) @@ -1298,7 +1379,7 @@ (cdr body) (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids labels vars vals bindings)))) + ids labels var-ids vars vals bindings)))) (else ; found a non-definition (if (null? ids) (build-sequence no-source @@ -1308,8 +1389,9 @@ (cdr body)))) (begin (if (not (valid-bound-ids? ids)) - (syntax-error outer-form - "invalid or duplicate identifier in definition")) + (syntax-violation + #f "invalid or duplicate identifier in definition" + outer-form)) (let loop ((bs bindings) (er-cache #f) (r-cache #f)) (if (not (null? bs)) (let* ((b (car bs))) @@ -1327,6 +1409,7 @@ (loop (cdr bs) er-cache r-cache))))) (set-cdr! r (extend-env labels bindings (cdr r))) (build-letrec no-source + (map syntax->datum var-ids) vars (map (lambda (x) (chi (cdr x) (car x) empty-wrap mod)) @@ -1338,15 +1421,20 @@ (cdr body))))))))))))))))) (define chi-lambda-clause - (lambda (e c r w mod k) + (lambda (e docstring c r w mod k) (syntax-case c () + ((args doc e1 e2 ...) + (and (string? (syntax->datum (syntax doc))) (not docstring)) + (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k)) (((id ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (k new-vars + (k (map syntax->datum ids) + new-vars + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) @@ -1355,19 +1443,24 @@ ((ids e1 e2 ...) (let ((old-ids (lambda-var-list (syntax ids)))) (if (not (valid-bound-ids? old-ids)) - (syntax-error e "invalid parameter list in") + (syntax-violation 'lambda "invalid parameter list" e) (let ((labels (gen-labels old-ids)) (new-vars (map gen-var old-ids))) - (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) + (k (let f ((ls1 (cdr old-ids)) (ls2 (car old-ids))) + (if (null? ls1) + (syntax->datum ls2) + (f (cdr ls1) (cons (syntax->datum (car ls1)) ls2)))) + (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars))) (if (null? ls1) ls2 (f (cdr ls1) (cons (car ls1) ls2)))) + (and docstring (syntax->datum docstring)) (chi-body (syntax (e1 e2 ...)) e (extend-var-env labels new-vars r) (make-binding-wrap old-ids labels w) mod)))))) - (_ (syntax-error e))))) + (_ (syntax-violation 'lambda "bad lambda" e))))) (define chi-local-syntax (lambda (rec? e r w s mod k) @@ -1375,7 +1468,7 @@ ((_ ((id val) ...) e1 e2 ...) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound keyword in") + (syntax-violation #f "duplicate bound keyword" e) (let ((labels (gen-labels ids))) (let ((new-w (make-binding-wrap ids labels w))) (k (syntax (e1 e2 ...)) @@ -1393,18 +1486,19 @@ new-w s mod)))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation #f "bad local syntax definition" + (source-wrap e w s mod)))))) (define eval-local-transformer (lambda (expanded mod) (let ((p (local-eval-hook expanded mod))) (if (procedure? p) p - (syntax-error p "nonprocedure transformer"))))) + (syntax-violation #f "nonprocedure transformer" p))))) (define chi-void (lambda () - (build-application no-source (build-primref no-source 'void) '()))) + (build-void no-source))) (define ellipsis? (lambda (x) @@ -1413,32 +1507,8 @@ ;;; data -;;; strips all annotations from potentially circular reader output - -(define strip-annotation - (lambda (x parent) - (cond - ((pair? x) - (let ((new (cons #f #f))) - (if parent (set-annotation-stripped! parent new)) - (set-car! new (strip-annotation (car x) #f)) - (set-cdr! new (strip-annotation (cdr x) #f)) - new)) - ((annotation? x) - (or (annotation-stripped x) - (strip-annotation (annotation-expression x) x))) - ((vector? x) - (let ((new (make-vector (vector-length x)))) - (if parent (set-annotation-stripped! parent new)) - (let loop ((i (- (vector-length x) 1))) - (unless (fx< i 0) - (vector-set! new i (strip-annotation (vector-ref x i) #f)) - (loop (fx- i 1)))) - new)) - (else x)))) - -;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly -;;; on an annotation, strips the annotation as well. +;;; strips syntax-objects down to top-wrap +;;; ;;; since only the head of a list is annotated by the reader, not each pair ;;; in the spine, we also check for pairs whose cars are annotated in case ;;; we've been passed the cdr of an annotated list @@ -1446,32 +1516,28 @@ (define strip (lambda (x w) (if (top-marked? w) - (if (or (annotation? x) (and (pair? x) (annotation? (car x)))) - (strip-annotation x #f) - x) + x (let f ((x x)) (cond - ((syntax-object? x) - (strip (syntax-object-expression x) (syntax-object-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) - x - (cons a d)))) - ((vector? x) - (let ((old (vector->list x))) - (let ((new (map f old))) - (if (andmap eq? old new) x (list->vector new))))) - (else x)))))) + ((syntax-object? x) + (strip (syntax-object-expression x) (syntax-object-wrap x))) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) + x + (cons a d)))) + ((vector? x) + (let ((old (vector->list x))) + (let ((new (map f old))) + (if (and-map* eq? old new) x (list->vector new))))) + (else x)))))) ;;; lexical variables (define gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (if (annotation? id) - (build-lexical-var (annotation-source id) (annotation-expression id)) - (build-lexical-var no-source id))))) + (build-lexical-var no-source id)))) (define lambda-var-list (lambda (vars) @@ -1484,8 +1550,6 @@ (lvl (syntax-object-expression vars) ls (join-wraps w (syntax-object-wrap vars)))) - ((annotation? vars) - (lvl (annotation-expression vars) ls w)) ; include anything else to be caught by subsequent error ; checking (else (cons vars ls)))))) @@ -1505,8 +1569,10 @@ (lambda (id n) (case (binding-type (lookup n r mod)) ((displaced-lexical) - (syntax-error (source-wrap id w s mod) - "identifier out of context")))) + (syntax-violation 'fluid-let-syntax + "identifier out of context" + e + (source-wrap id w s mod))))) (syntax (var ...)) names) (chi-body @@ -1523,13 +1589,15 @@ r) w mod))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'fluid-let-syntax "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'quote (lambda (e r w s mod) (syntax-case e () ((_ e) (build-data s (strip (syntax e) w))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'quote "bad syntax" + (source-wrap e w s mod)))))) (global-extend 'core 'syntax (let () @@ -1545,7 +1613,7 @@ (gen-ref src (car var.lev) (cdr var.lev) maps))) (lambda (var maps) (values `(ref ,var) maps))) (if (ellipsis? e) - (syntax-error src "misplaced ellipsis in syntax form") + (syntax-violation 'syntax "misplaced ellipsis" src) (values `(quote ,e) maps))))) (syntax-case e () ((dots e) @@ -1563,8 +1631,8 @@ (cons '() maps) ellipsis? mod)) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" + src) (values (gen-map x (car maps)) (cdr maps)))))))) (syntax-case y () @@ -1576,8 +1644,7 @@ (lambda () (k (cons '() maps))) (lambda (x maps) (if (null? (car maps)) - (syntax-error src - "extra ellipsis in syntax form") + (syntax-violation 'syntax "extra ellipsis" src) (values (gen-mappend x (car maps)) (cdr maps)))))))) (_ (call-with-values @@ -1606,7 +1673,7 @@ (if (fx= level 0) (values var maps) (if (null? maps) - (syntax-error src "missing ellipsis in syntax form") + (syntax-violation 'syntax "missing ellipsis" src) (call-with-values (lambda () (gen-ref src var (fx- level 1) (cdr maps))) (lambda (outer-var outer-maps) @@ -1632,7 +1699,7 @@ ; identity map equivalence: ; (map (lambda (x) x) y) == y (car actuals)) - ((andmap + ((and-map (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (cdr e)) ; eta map equivalence: @@ -1672,17 +1739,10 @@ (define regen (lambda (x) (case (car x) - ((ref) (build-lexical-reference 'value no-source (cadr 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) (build-lambda no-source (cadr x) (regen (caddr x)))) - ((map) (let ((ls (map regen (cdr x)))) - (build-application no-source - (if (fx= (length ls) 2) - (build-primref no-source 'map) - ; really need to do our own checking here - (build-primref no-source 2 'map)) ; require error check - ls))) + ((lambda) (build-lambda no-source (cadr x) (cadr x) #f (regen (caddr x)))) (else (build-application no-source (build-primref no-source (car x)) (map regen (cdr x))))))) @@ -1694,27 +1754,29 @@ (call-with-values (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod)) (lambda (e maps) (regen e)))) - (_ (syntax-error e))))))) + (_ (syntax-violation 'syntax "bad `syntax' form" e))))))) (global-extend 'core 'lambda (lambda (e r w s mod) (syntax-case e () ((_ . c) - (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod - (lambda (vars body) (build-lambda s vars body))))))) + (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod + (lambda (names vars docstring body) + (build-lambda s names vars docstring body))))))) (global-extend 'core 'let (let () (define (chi-let e r w s mod constructor ids vals exps) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (syntax-violation 'let "duplicate bound variable" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((nw (make-binding-wrap ids labels w)) (nr (extend-var-env labels new-vars r))) (constructor s + (map syntax->datum ids) new-vars (map (lambda (x) (chi x r w mod)) vals) (chi-body exps (source-wrap e nw s mod) @@ -1722,38 +1784,41 @@ (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (chi-let e r w s mod build-let (syntax (id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) ((_ f ((id val) ...) e1 e2 ...) - (id? (syntax f)) + (and (id? (syntax f)) (and-map id? (syntax (id ...)))) (chi-let e r w s mod build-named-let (syntax (f id ...)) (syntax (val ...)) (syntax (e1 e2 ...)))) - (_ (syntax-error (source-wrap e w s mod))))))) + (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) (global-extend 'core 'letrec (lambda (e r w s mod) (syntax-case e () ((_ ((id val) ...) e1 e2 ...) + (and-map id? (syntax (id ...))) (let ((ids (syntax (id ...)))) (if (not (valid-bound-ids? ids)) - (syntax-error e "duplicate bound variable in") + (syntax-violation 'letrec "duplicate bound variable" e) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((w (make-binding-wrap ids labels w)) (r (extend-var-env labels new-vars r))) (build-letrec s + (map syntax->datum ids) new-vars (map (lambda (x) (chi x r w mod)) (syntax (val ...))) (chi-body (syntax (e1 e2 ...)) (source-wrap e w s mod) r w mod))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (global-extend 'core 'set! @@ -1766,45 +1831,66 @@ (let ((b (lookup n r mod))) (case (binding-type b) ((lexical) - (build-lexical-assignment s (binding-value b) val)) + (build-lexical-assignment s + (syntax->datum (syntax id)) + (binding-value b) + val)) ((global) (build-global-assignment s n val mod)) ((displaced-lexical) - (syntax-error (wrap (syntax id) w mod) - "identifier out of context")) - (else (syntax-error (source-wrap e w s mod))))))) + (syntax-violation 'set! "identifier out of context" + (wrap (syntax id) w mod))) + (else (syntax-violation 'set! "bad set!" + (source-wrap e w s mod))))))) ((_ (head tail ...) val) (call-with-values (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod)) (lambda (type value ee ww ss modmod) (case type ((module-ref) - (call-with-values (lambda () (value (syntax (head tail ...)))) - (lambda (id mod) - (build-global-assignment s id (syntax val) mod)))) + (let ((val (chi (syntax val) r w mod))) + (call-with-values (lambda () (value (syntax (head tail ...)))) + (lambda (id mod) + (build-global-assignment s id val mod))))) (else (build-application s (chi (syntax (setter head)) r w mod) (map (lambda (e) (chi e r w mod)) (syntax (tail ... val))))))))) - (_ (syntax-error (source-wrap e w s mod)))))) + (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (global-extend 'module-ref '@ (lambda (e) - (syntax-case e (%module-public-interface) + (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum - (syntax (mod ... %module-public-interface)))))))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax->datum (syntax id)) + (syntax->datum + (syntax (public mod ...)))))))) (global-extend 'module-ref '@@ (lambda (e) (syntax-case e () ((_ (mod ...) id) - (and (andmap id? (syntax (mod ...))) (id? (syntax id))) - (values (syntax-object->datum (syntax id)) - (syntax-object->datum - (syntax (mod ...)))))))) + (and (and-map id? (syntax (mod ...))) (id? (syntax id))) + (values (syntax->datum (syntax id)) + (syntax->datum + (syntax (private mod ...)))))))) + +(global-extend 'core 'if + (lambda (e r w s mod) + (syntax-case e () + ((_ test then) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (build-void no-source))) + ((_ test then else) + (build-conditional + s + (chi (syntax test) r w mod) + (chi (syntax then) r w mod) + (chi (syntax else) r w mod)))))) (global-extend 'begin 'begin '()) @@ -1818,7 +1904,7 @@ (let () (define convert-pattern ; accepts pattern & keys - ; returns syntax-dispatch pattern & ids + ; returns $sc-dispatch pattern & ids (lambda (pattern keys) (let cvt ((p pattern) (n 0) (ids '())) (if (id? p) @@ -1854,7 +1940,7 @@ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (build-application no-source (build-primref no-source 'apply) - (list (build-lambda no-source new-vars + (list (build-lambda no-source (map syntax->datum ids) new-vars #f (chi exp (extend-env labels @@ -1874,17 +1960,16 @@ (lambda (p pvars) (cond ((not (distinct-bound-ids? (map car pvars))) - (syntax-error pat - "duplicate pattern variable in syntax-case pattern")) - ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) - (syntax-error pat - "misplaced ellipsis in syntax-case pattern")) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) (else (let ((y (gen-var 'tmp))) ; fat finger binding and references to temp variable y (build-application no-source - (build-lambda no-source (list y) - (let ((y (build-lexical-reference 'value no-source y))) + (build-lambda no-source (list 'tmp) (list y) #f + (let ((y (build-lexical-reference 'value no-source + 'tmp y))) (build-conditional no-source (syntax-case fender () (#t y) @@ -1899,24 +1984,29 @@ (build-primref no-source 'list) (list x)) (build-application no-source - (build-primref no-source 'syntax-dispatch) + (build-primref 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-error) - (list x)) + (build-primref 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? (syntax pat)) - (andmap (lambda (x) (not (free-id=? (syntax pat) x))) - (cons (syntax (... ...)) keys))) + (and-map (lambda (x) (not (free-id=? (syntax pat) x))) + (cons (syntax (... ...)) keys))) (let ((labels (list (gen-label))) (var (gen-var (syntax pat)))) (build-application no-source - (build-lambda no-source (list var) + (build-lambda no-source + (list (syntax->datum (syntax pat))) (list var) + #f (chi (syntax exp) (extend-env labels (list (make-binding 'syntax `(,var . 0))) @@ -1930,24 +2020,26 @@ ((pat fender exp) (gen-clause x keys (cdr clauses) r (syntax pat) (syntax fender) (syntax exp) mod)) - (_ (syntax-error (car clauses) "invalid syntax-case clause")))))) + (_ (syntax-violation 'syntax-case "invalid clause" + (car clauses))))))) (lambda (e r w s mod) (let ((e (source-wrap e w s mod))) (syntax-case e () ((_ val (key ...) m ...) - (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) - (syntax (key ...))) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) + (syntax (key ...))) (let ((x (gen-var 'tmp))) ; fat finger binding and references to temp variable x (build-application s - (build-lambda no-source (list x) - (gen-syntax-case (build-lexical-reference 'value no-source x) + (build-lambda no-source (list 'tmp) (list x) #f + (gen-syntax-case (build-lexical-reference 'value no-source + 'tmp x) (syntax (key ...)) (syntax (m ...)) r mod)) (list (chi (syntax val) r empty-wrap mod)))) - (syntax-error e "invalid literals list in")))))))) + (syntax-violation 'syntax-case "invalid literals list" e)))))))) ;;; The portable sc-expand seeds chi-top's mode m with 'e (for ;;; evaluating) and esew (which stands for "eval syntax expanders @@ -1959,36 +2051,27 @@ ;;; expanded, and the expanded definitions are also residualized into ;;; the object file if we are compiling a file. (set! sc-expand - (let ((m 'e) (esew '(eval))) - (lambda (x) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x null-env top-wrap m esew - (module-name (current-module))))))) - -(set! sc-expand3 - (let ((m 'e) (esew '(eval))) - (lambda (x . rest) - (if (and (pair? x) (equal? (car x) noexpand)) - (cadr x) - (chi-top x - null-env - top-wrap - (if (null? rest) m (car rest)) - (if (or (null? rest) (null? (cdr rest))) - esew - (cadr rest)) - (module-name (current-module))))))) + (lambda (x . rest) + (if (and (pair? x) (equal? (car x) noexpand)) + (cadr x) + (let ((m (if (null? rest) 'e (car rest))) + (esew (if (or (null? rest) (null? (cdr rest))) + '(eval) + (cadr rest)))) + (with-fluid* *mode* m + (lambda () + (chi-top x null-env top-wrap m esew + (cons 'hygiene (module-name (current-module)))))))))) (set! identifier? (lambda (x) (nonsymbol-id? x))) -(set! datum->syntax-object +(set! datum->syntax (lambda (id datum) (make-syntax-object datum (syntax-object-wrap id) #f))) -(set! syntax-object->datum +(set! syntax->datum ; accepts any object, since syntax objects may consist partially ; or entirely of unwrapped, nonsymbolic data (lambda (x) @@ -2011,21 +2094,23 @@ (arg-check nonsymbol-id? y 'bound-identifier=?) (bound-id=? x y))) -(set! syntax-error - (lambda (object . messages) - (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages) - (let ((message (if (null? messages) - "invalid syntax" - (apply string-append messages)))) - (error-hook #f message (strip object empty-wrap))))) +(set! syntax-violation + (lambda (who message form . subform) + (arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) + who 'syntax-violation) + (arg-check string? message 'syntax-violation) + (scm-error 'syntax-error 'sc-expand + (string-append + (if who "~a: " "") + "~a " + (if (null? subform) "in ~a" "in subform `~s' of `~s'")) + (let ((tail (cons message + (map (lambda (x) (strip x empty-wrap)) + (append subform (list form)))))) + (if who (cons who tail) tail)) + #f))) -(set! install-global-transformer - (lambda (sym v) - (arg-check symbol? sym 'define-syntax) - (arg-check procedure? v 'define-syntax) - (global-extend 'macro sym v))) - -;;; syntax-dispatch expects an expression and a pattern. If the expression +;;; $sc-dispatch expects an expression and a pattern. If the expression ;;; matches the pattern a list of the matching expressions for each ;;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;;; not work on r4rs implementations that violate the ieee requirement @@ -2052,35 +2137,31 @@ (define match-each (lambda (e p w mod) (cond - ((annotation? e) - (match-each (annotation-expression e) p w mod)) - ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first - (let ((rest (match-each (cdr e) p w mod))) - (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax-object? e) - (match-each (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) - (syntax-object-module e))) - (else #f)))) + ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first + (let ((rest (match-each (cdr e) p w mod))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax-object? e) + (match-each (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) + (else #f)))) (define match-each-any (lambda (e w mod) (cond - ((annotation? e) - (match-each-any (annotation-expression e) w mod)) - ((pair? e) - (let ((l (match-each-any (cdr e) w mod))) - (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) - ((syntax-object? e) - (match-each-any (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)) - mod)) - (else #f)))) + ((pair? e) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax-object? e) + (match-each-any (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)) + mod)) + (else #f)))) (define match-empty (lambda (p r) @@ -2129,23 +2210,22 @@ ((eq? p 'any) (cons (wrap e w mod) r)) ((syntax-object? e) (match* - (unannotate (syntax-object-expression e)) - p - (join-wraps w (syntax-object-wrap e)) - r - (syntax-object-module e))) - (else (match* (unannotate e) p w r mod))))) + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + r + (syntax-object-module e))) + (else (match* e p w r mod))))) -(set! syntax-dispatch +(set! $sc-dispatch (lambda (e p) (cond ((eq? p 'any) (list e)) ((syntax-object? e) - (match* (unannotate (syntax-object-expression e)) - p (syntax-object-wrap e) '() (syntax-object-module e))) - (else (match* (unannotate e) p empty-wrap '() #f))))) + (match* (syntax-object-expression e) + p (syntax-object-wrap e) '() (syntax-object-module e))) + (else (match* e p empty-wrap '() #f))))) -(set! sc-chi chi) )) ) @@ -2173,7 +2253,7 @@ (lambda (x) (syntax-case x () ((let* ((x v) ...) e1 e2 ...) - (andmap identifier? (syntax (x ...))) + (and-map identifier? (syntax (x ...))) (let f ((bindings (syntax ((x v) ...)))) (if (null? bindings) (syntax (let () e1 e2 ...)) @@ -2190,7 +2270,9 @@ (syntax-case s () (() v) ((e) (syntax e)) - (_ (syntax-error orig-x)))) + (_ (syntax-violation + 'do "bad step expression" + orig-x s)))) (syntax (var ...)) (syntax (step ...))))) (syntax-case (syntax (e1 ...)) () @@ -2238,12 +2320,22 @@ (syntax p) (quasicons (syntax (quote unquote)) (quasi (syntax (p)) (- lev 1))))) + ((unquote . args) + (= lev 0) + (syntax-violation 'unquote + "unquote takes exactly one argument" + p (syntax (unquote . args)))) (((unquote-splicing p) . q) (if (= lev 0) (quasiappend (syntax p) (quasi (syntax q) lev)) (quasicons (quasicons (syntax (quote unquote-splicing)) (quasi (syntax (p)) (- lev 1))) (quasi (syntax q) lev)))) + (((unquote-splicing . args) . q) + (= lev 0) + (syntax-violation 'unquote-splicing + "unquote-splicing takes exactly one argument" + p (syntax (unquote-splicing . args)))) ((quasiquote p) (quasicons (syntax (quote quasiquote)) (quasi (syntax (p)) (+ lev 1)))) @@ -2263,29 +2355,29 @@ (let f ((x (read p))) (if (eof-object? x) (begin (close-input-port p) '()) - (cons (datum->syntax-object k x) + (cons (datum->syntax k x) (f (read p)))))))) (syntax-case x () ((k filename) - (let ((fn (syntax-object->datum (syntax filename)))) + (let ((fn (syntax->datum (syntax filename)))) (with-syntax (((exp ...) (read-file fn (syntax k)))) (syntax (begin exp ...)))))))) (define-syntax unquote - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote - "expression ,~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote + "expression not valid outside of quasiquote" + x))))) (define-syntax unquote-splicing - (lambda (x) - (syntax-case x () - ((_ e) - (error 'unquote-splicing - "expression ,@~s not valid outside of quasiquote" - (syntax-object->datum (syntax e))))))) + (lambda (x) + (syntax-case x () + ((_ e) + (syntax-violation 'unquote-splicing + "expression not valid outside of quasiquote" + x))))) (define-syntax case (lambda (x) @@ -2298,14 +2390,15 @@ ((else e1 e2 ...) (syntax (begin e1 e2 ...))) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...)))) - (_ (syntax-error x))) + (_ (syntax-violation 'case "bad clause" x clause))) (with-syntax ((rest (f (car clauses) (cdr clauses)))) (syntax-case clause (else) (((k ...) e1 e2 ...) (syntax (if (memv t '(k ...)) (begin e1 e2 ...) rest))) - (_ (syntax-error x)))))))) + (_ (syntax-violation 'case "bad clause" x + clause)))))))) (syntax (let ((t e)) body))))))) (define-syntax identifier-syntax diff --git a/module/ice-9/r4rs.scm b/module/ice-9/r4rs.scm index de2aeb2de..7b1c11cc1 100644 --- a/module/ice-9/r4rs.scm +++ b/module/ice-9/r4rs.scm @@ -17,6 +17,9 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +(eval-when (compile) + (set-current-module (resolve-module '(guile)))) + ;;;; apply and call-with-current-continuation @@ -186,28 +189,3 @@ procedures, their behavior is implementation dependent." (lambda (p) (with-error-to-port p thunk)))) (define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - -;;;; Loading - -(if (not (defined? '%load-verbosely)) - (define %load-verbosely #f)) -(define (assert-load-verbosity v) (set! %load-verbosely v)) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display "loading ") - (display file) - (newline) - (force-output))))) - -(set! %load-hook %load-announce) - -(define (load name . reader) - (with-fluid* current-reader (and (pair? reader) (car reader)) - (lambda () - (start-stack 'load-stack - (primitive-load name))))) diff --git a/module/ice-9/stack-catch.scm b/module/ice-9/stack-catch.scm index 2f4b3d145..a54267617 100644 --- a/module/ice-9/stack-catch.scm +++ b/module/ice-9/stack-catch.scm @@ -40,4 +40,4 @@ this call to @code{catch}." (catch key thunk handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) diff --git a/module/ice-9/syncase.scm b/module/ice-9/syncase.scm index d8fdeb4c9..22391a8c8 100644 --- a/module/ice-9/syncase.scm +++ b/module/ice-9/syncase.scm @@ -17,197 +17,15 @@ (define-module (ice-9 syncase) - :use-module (ice-9 expand-support) - :use-module (ice-9 debug) - :use-module (ice-9 threads) - :export-syntax (sc-macro define-syntax define-syntax-public - fluid-let-syntax - identifier-syntax let-syntax - letrec-syntax syntax syntax-case syntax-rules - with-syntax - include) - :export (sc-expand sc-expand3 install-global-transformer - syntax-dispatch syntax-error bound-identifier=? - datum->syntax-object free-identifier=? - generate-temporaries identifier? syntax-object->datum - void syncase) - :replace (eval eval-when)) + ) - - -(define (annotation? x) #f) - -(define sc-macro - (procedure->memoizing-macro - (lambda (exp env) - (save-module-excursion - (lambda () - ;; Because memoization happens lazily, env's module isn't - ;; necessarily the current module. - (set-current-module (eval-closure-module (car (last-pair env)))) - (strip-expansion-structures (sc-expand exp))))))) - -;;; Exported variables - -(define sc-expand #f) -(define sc-expand3 #f) -(define sc-chi #f) -(define install-global-transformer #f) -(define syntax-dispatch #f) -(define syntax-error #f) - -(define bound-identifier=? #f) -(define datum->syntax-object #f) -(define free-identifier=? #f) -(define generate-temporaries #f) -(define identifier? #f) -(define syntax-object->datum #f) - -(define primitive-syntax '(quote lambda letrec if set! begin define or - and let let* cond do quasiquote unquote - unquote-splicing case @ @@)) - -(for-each (lambda (symbol) - (set-symbol-property! symbol 'primitive-syntax #t)) - primitive-syntax) - -;;; Hooks needed by the syntax-case macro package - -(define (void) *unspecified*) - -(define andmap - (lambda (f first . rest) - (or (null? first) - (if (null? rest) - (let andmap ((first first)) - (let ((x (car first)) (first (cdr first))) - (if (null? first) - (f x) - (and (f x) (andmap first))))) - (let andmap ((first first) (rest rest)) - (let ((x (car first)) - (xr (map car rest)) - (first (cdr first)) - (rest (map cdr rest))) - (if (null? first) - (apply f (cons x xr)) - (and (apply f (cons x xr)) (andmap first rest))))))))) - -(define (error who format-string why what) - (start-stack 'syncase-stack - (scm-error 'misc-error - who - "~A ~S" - (list why what) - '()))) - -(define the-syncase-module (current-module)) - -(define guile-macro - (cons 'external-macro - (lambda (e r w s mod) - (let ((e (syntax-object->datum e))) - (if (symbol? e) - ;; pass the expression through - e - (let* ((mod (resolve-module mod)) - (m (module-ref mod (car e)))) - (if (eq? (macro-type m) 'syntax) - ;; pass the expression through - e - ;; perform Guile macro transform - (let ((e ((macro-transformer m) - (strip-expansion-structures e) - (append r (list (module-eval-closure mod)))))) - (if (variable? e) - e - (if (null? r) - (sc-expand e) - (sc-chi e r w (module-name mod)))))))))))) - -(define generated-symbols (make-weak-key-hash-table 1019)) - -;; We define our own gensym here because the Guile built-in one will -;; eventually produce uninterned and unreadable symbols (as needed for -;; safe macro expansions) and will the be inappropriate for dumping to -;; pssyntax.pp. -;; -;; syncase is supposed to only require that gensym produce unique -;; readable symbols, and they only need be unique with respect to -;; multiple calls to gensym, not globally unique. -;; -(define gensym - (let ((counter 0)) - - (define next-id - (if (provided? 'threads) - (let ((symlock (make-mutex))) - (lambda () - (let ((result #f)) - (with-mutex symlock - (set! result counter) - (set! counter (+ counter 1))) - result))) - ;; faster, non-threaded case. - (lambda () - (let ((result counter)) - (set! counter (+ counter 1)) - result)))) - - ;; actual gensym body code. - (lambda (. rest) - (let* ((next-val (next-id)) - (valstr (number->string next-val))) - (cond - ((null? rest) - (string->symbol (string-append "syntmp-" valstr))) - ((null? (cdr rest)) - (string->symbol (string-append "syntmp-" (car rest) "-" valstr))) - (else - (error - (string-append - "syncase's gensym expected 0 or 1 arguments, got " - (length rest))))))))) - -;;; Load the preprocessed code - -(let ((old-debug #f) - (old-read #f)) - (dynamic-wind (lambda () - (set! old-debug (debug-options)) - (set! old-read (read-options))) - (lambda () - (debug-disable 'debug 'procnames) - (read-disable 'positions) - (load-from-path "ice-9/psyntax-pp")) - (lambda () - (debug-options old-debug) - (read-options old-read)))) - -(define internal-eval (nested-ref the-scm-module '(%app modules guile eval))) - -(define (eval x environment) - (internal-eval (if (and (pair? x) - (equal? (car x) "noexpand")) - (strip-expansion-structures (cadr x)) - (strip-expansion-structures (sc-expand x))) - environment)) +(issue-deprecation-warning + "Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.") ;;; Hack to make syncase macros work in the slib module -(let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) - (if m - (set-object-property! (module-local-variable m 'define) - '*sc-expander* - '(define)))) - -(define (syncase exp) - (strip-expansion-structures (sc-expand exp))) - -(set-module-transformer! the-syncase-module syncase) - -(define-syntax define-syntax-public - (syntax-rules () - ((_ name rules ...) - (begin - ;(eval-case ((load-toplevel) (export-syntax name))) - (define-syntax name rules ...))))) +;; FIXME wingo is this still necessary? +;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib)))) +;; (if m +;; (set-object-property! (module-local-variable m 'define) +;; '*sc-expander* +;; '(define)))) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index bd0f7b745..e07d766eb 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -32,21 +32,71 @@ ;;; Code: (define-module (ice-9 threads) - :export (par-map + :export (begin-thread + parallel + letpar + make-thread + with-mutex + monitor + + par-map par-for-each n-par-map n-par-for-each n-for-each-par-map - %thread-handler) - :export-syntax (begin-thread - parallel - letpar - make-thread - with-mutex - monitor)) + %thread-handler)) +;;; Macros first, so that the procedures expand correctly. + +(define-syntax begin-thread + (syntax-rules () + ((_ e0 e1 ...) + (call-with-new-thread + (lambda () e0 e1 ...) + %thread-handler)))) + +(define-syntax parallel + (lambda (x) + (syntax-case x () + ((_ e0 ...) + (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) + (syntax + (let ((tmp0 (begin-thread e0)) + ...) + (values (join-thread tmp0) ...)))))))) + +(define-syntax letpar + (syntax-rules () + ((_ ((v e) ...) b0 b1 ...) + (call-with-values + (lambda () (parallel e ...)) + (lambda (v ...) + b0 b1 ...))))) + +(define-syntax make-thread + (syntax-rules () + ((_ proc arg ...) + (call-with-new-thread + (lambda () (proc arg ...)) + %thread-handler)))) + +(define-syntax with-mutex + (syntax-rules () + ((_ m e0 e1 ...) + (let ((x m)) + (dynamic-wind + (lambda () (lock-mutex x)) + (lambda () (begin e0 e1 ...)) + (lambda () (unlock-mutex x))))))) + +(define-syntax monitor + (syntax-rules () + ((_ first rest ...) + (with-mutex (make-mutex) + first rest ...)))) + (define (par-mapper mapper) (lambda (proc . arglists) (mapper join-thread @@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS." ;;; Set system thread handler (define %thread-handler thread-handler) -; --- MACROS ------------------------------------------------------- - -(define-macro (begin-thread . forms) - (if (null? forms) - '(begin) - `(call-with-new-thread - (lambda () - ,@forms) - %thread-handler))) - -(define-macro (parallel . forms) - (cond ((null? forms) '(values)) - ((null? (cdr forms)) (car forms)) - (else - (let ((vars (map (lambda (f) - (make-symbol "f")) - forms))) - `((lambda ,vars - (values ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (form) `(begin-thread ,form)) forms)))))) - -(define-macro (letpar bindings . body) - (cond ((or (null? bindings) (null? (cdr bindings))) - `(let ,bindings ,@body)) - (else - (let ((vars (map car bindings))) - `((lambda ,vars - ((lambda ,vars ,@body) - ,@(map (lambda (v) `(join-thread ,v)) vars))) - ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings)))))) - -(define-macro (make-thread proc . args) - `(call-with-new-thread - (lambda () - (,proc ,@args)) - %thread-handler)) - -(define-macro (with-mutex m . body) - `(dynamic-wind - (lambda () (lock-mutex ,m)) - (lambda () (begin ,@body)) - (lambda () (unlock-mutex ,m)))) - -(define-macro (monitor first . rest) - `(with-mutex ,(make-mutex) - (begin - ,first ,@rest))) - ;;; threads.scm ends here diff --git a/module/ice-9/time.scm b/module/ice-9/time.scm index a7045969f..86ebcbff1 100644 --- a/module/ice-9/time.scm +++ b/module/ice-9/time.scm @@ -53,6 +53,6 @@ result)) (define-macro (time exp) - `(,time-proc (lambda () ,exp))) + `((@@ (ice-9 time) time-proc) (lambda () ,exp))) ;;; time.scm ends here diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm index 2752934f9..df6199977 100644 --- a/module/language/assembly/disassemble.scm +++ b/module/language/assembly/disassemble.scm @@ -82,7 +82,7 @@ (if (program? x) (begin (display "----------------------------------------\n") (disassemble x)))) - (cddr (vector->list objs)))))) + (cdr (vector->list objs)))))) (else (error "bad load-program form" asm)))) diff --git a/module/language/ecmascript/spec.scm b/module/language/ecmascript/spec.scm index 550a0b734..0112af5a4 100644 --- a/module/language/ecmascript/spec.scm +++ b/module/language/ecmascript/spec.scm @@ -33,7 +33,6 @@ #:title "Guile ECMAScript" #:version "3.0" #:reader (lambda () (read-ecmascript/1 (current-input-port))) - #:read-file read-ecmascript #:compilers `((ghil . ,compile-ghil)) ;; a pretty-printer would be interesting. #:printer write diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm index c813319d6..02187be05 100644 --- a/module/language/ghil/compile-glil.scm +++ b/module/language/ghil/compile-glil.scm @@ -187,7 +187,7 @@ (define (make-glil-var op env var) (case (ghil-var-kind var) ((argument) - (make-glil-argument op (ghil-var-index var))) + (make-glil-local op (ghil-var-index var))) ((local) (make-glil-local op (ghil-var-index var))) ((external) @@ -217,7 +217,9 @@ (set! stack (cons code stack)) (if loc (set! stack (cons (make-glil-source loc) stack)))) (define (var->binding var) - (list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var))) + (list (ghil-var-name var) (let ((kind (ghil-var-kind var))) + (case kind ((argument) 'local) (else kind))) + (ghil-var-index var))) (define (push-bindings! loc vars) (if (not (null? vars)) (push-code! loc (make-glil-bind (map var->binding vars))))) @@ -496,7 +498,7 @@ (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars)) (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)) (nargs (allocate-indices-linearly! vars)) - (nlocs (allocate-locals! locs body)) + (nlocs (allocate-locals! locs body nargs)) (nexts (allocate-indices-linearly! exts))) ;; meta bindings (push-bindings! #f vars) @@ -509,7 +511,7 @@ (let ((v (car l))) (case (ghil-var-kind v) ((external) - (push-code! #f (make-glil-argument 'ref n)) + (push-code! #f (make-glil-local 'ref n)) (push-code! #f (make-glil-external 'set 0 (ghil-var-index v))))))) ;; compile body (comp body #t #f) @@ -523,8 +525,8 @@ ((null? l) n) (let ((v (car l))) (set! (ghil-var-index v) n)))) -(define (allocate-locals! vars body) - (let ((free '()) (nlocs 0)) +(define (allocate-locals! vars body nargs) + (let ((free '()) (nlocs nargs)) (define (allocate! var) (cond ((pair? free) diff --git a/module/language/glil.scm b/module/language/glil.scm index 01b680194..625760eaa 100644 --- a/module/language/glil.scm +++ b/module/language/glil.scm @@ -44,9 +44,6 @@ make-glil-const glil-const? glil-const-obj - make-glil-argument glil-argument? - glil-argument-op glil-argument-index - make-glil-local glil-local? glil-local-op glil-local-index @@ -87,7 +84,6 @@ () ( obj) ;; Variables - ( op index) ( op index) ( op depth index) ( op name) @@ -125,13 +121,12 @@ ((source ,props) (make-glil-source props)) ((void) (make-glil-void)) ((const ,obj) (make-glil-const obj)) - ((argument ,op ,index) (make-glil-argument op index)) ((local ,op ,index) (make-glil-local op index)) ((external ,op ,depth ,index) (make-glil-external op depth index)) ((toplevel ,op ,name) (make-glil-toplevel op name)) ((module public ,op ,mod ,name) (make-glil-module op mod name #t)) ((module private ,op ,mod ,name) (make-glil-module op mod name #f)) - ((label ,label) (make-label ,label)) + ((label ,label) (make-label label)) ((branch ,inst ,label) (make-glil-branch inst label)) ((call ,inst ,nargs) (make-glil-call inst nargs)) ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra)) @@ -150,8 +145,6 @@ (() `(void)) (( obj) `(const ,obj)) ;; variables - (( op index) - `(argument ,op ,index)) (( op index) `(local ,op ,index)) (( op depth index) diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm index ffac9dbfb..4c92e0f5a 100644 --- a/module/language/glil/compile-assembly.scm +++ b/module/language/glil/compile-assembly.scm @@ -83,16 +83,15 @@ (define (make-closed-binding open-binding start end) (make-binding (car open-binding) (cadr open-binding) (caddr open-binding) start end)) -(define (open-binding bindings vars nargs start) +(define (open-binding bindings vars start) (cons (acons start (map (lambda (v) (pmatch v - ((,name argument ,i) (make-open-binding name #f i)) - ((,name local ,i) (make-open-binding name #f (+ nargs i))) + ((,name local ,i) (make-open-binding name #f i)) ((,name external ,i) (make-open-binding name #t i)) - (else (error "unknown binding type" name type)))) + (else (error "unknown binding type" v)))) vars) (car bindings)) (cdr bindings))) @@ -129,13 +128,13 @@ (define (compile-assembly glil) (receive (code . _) - (glil->assembly glil 0 '() '(()) '() '() #f -1) + (glil->assembly glil '() '(()) '() '() #f -1) (car code))) (define (make-object-table objects) (and (not (null? objects)) (list->vector (cons #f objects)))) -(define (glil->assembly glil nargs nexts-stack bindings +(define (glil->assembly glil nexts-stack bindings source-alist label-alist object-alist addr) (define (emit-code x) (values (map assembly-pack x) bindings source-alist label-alist object-alist)) @@ -159,7 +158,7 @@ addr)) (else (receive (subcode bindings source-alist label-alist object-alist) - (glil->assembly (car body) nargs nexts-stack bindings + (glil->assembly (car body) nexts-stack bindings source-alist label-alist object-alist addr) (lp (cdr body) (append (reverse subcode) code) bindings source-alist label-alist object-alist @@ -196,14 +195,14 @@ (( vars) (values '() - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) (( vars rest) (values `((truncate-values ,(length vars) ,(if rest 1 0))) - (open-binding bindings vars nargs addr) + (open-binding bindings vars addr) source-alist label-alist object-alist)) @@ -238,16 +237,11 @@ (emit-code/object `((object-ref ,i)) object-alist))))) - (( op index) + (( op index) (emit-code (if (eq? op 'ref) `((local-ref ,index)) `((local-set ,index))))) - (( op index) - (emit-code (if (eq? op 'ref) - `((local-ref ,(+ nargs index))) - `((local-set ,(+ nargs index)))))) - (( op depth index) (emit-code (let lp ((d depth) (n 0) (stack nexts-stack)) (if (> d 0) @@ -318,7 +312,12 @@ (error "Unknown instruction:" inst)) (let ((pops (instruction-pops inst))) (cond ((< pops 0) - (emit-code `((,inst ,nargs)))) + (case (instruction-length inst) + ((1) (emit-code `((,inst ,nargs)))) + ((2) (emit-code `((,inst ,(quotient nargs 256) + ,(modulo nargs 256))))) + (else (error "Unknown length for variable-arg instruction:" + inst (instruction-length inst))))) ((= pops nargs) (emit-code `((,inst)))) (else diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm index a98c39975..a47bd80b2 100644 --- a/module/language/glil/decompile-assembly.scm +++ b/module/language/glil/decompile-assembly.scm @@ -175,15 +175,11 @@ (1+ pos))) ((local-ref ,n) (lp (cdr in) (cons *placeholder* stack) - (cons (if (< n nargs) - (make-glil-argument 'ref n) - (make-glil-local 'ref (- n nargs))) + (cons (make-glil-local 'ref n) out) (+ pos 2))) ((local-set ,n) (lp (cdr in) (cdr stack) - (cons (if (< n nargs) - (make-glil-argument 'set n) - (make-glil-local 'set (- n nargs))) + (cons (make-glil-local 'set n) (emit-constants (list-head stack 1) out)) (+ pos 2))) ((br-if-not ,l) diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm deleted file mode 100644 index 4ac973620..000000000 --- a/module/language/scheme/amatch.scm +++ /dev/null @@ -1,37 +0,0 @@ -(define-module (language scheme amatch) - #:use-module (ice-9 syncase) - #:export (amatch apat)) -;; FIXME: shouldn't have to export apat... - -;; This is exactly the same as pmatch except that it unpacks annotations -;; as needed. - -(define-syntax amatch - (syntax-rules (else guard) - ((_ (op arg ...) cs ...) - (let ((v (op arg ...))) - (amatch v cs ...))) - ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) - ((_ v (pat (guard g ...) e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat - (if (and g ...) (begin e0 e ...) (fk)) - (fk)))) - ((_ v (pat e0 e ...) cs ...) - (let ((fk (lambda () (amatch v cs ...)))) - (apat v pat (begin e0 e ...) (fk)))))) - -(define-syntax apat - (syntax-rules (_ quote unquote) - ((_ v _ kt kf) kt) - ((_ v () kt kf) (if (null? v) kt kf)) - ((_ v (quote lit) kt kf) - (if (equal? v (quote lit)) kt kf)) - ((_ v (unquote var) kt kf) (let ((var v)) kt)) - ((_ v (x . y) kt kf) - (if (apair? v) - (let ((vx (acar v)) (vy (acdr v))) - (apat vx x (apat vy y kt kf) kf)) - kf)) - ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf)))) diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index 86234059e..8d8332c34 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -27,13 +27,11 @@ #:use-module (system vm objcode) #:use-module (ice-9 receive) #:use-module (ice-9 optargs) - #:use-module (ice-9 expand-support) - #:use-module ((ice-9 syncase) #:select (sc-macro)) + #:use-module (language tree-il) #:use-module ((system base compile) #:select (syntax-error)) #:export (compile-ghil translate-1 *translate-table* define-scheme-translator)) - ;;; environment := #f ;;; | MODULE ;;; | COMPILE-ENV @@ -70,12 +68,14 @@ (and=> (cenv-module e) set-current-module) (call-with-ghil-environment (cenv-ghil-env e) '() (lambda (env vars) - (let ((x (make-ghil-lambda env #f vars #f '() - (translate-1 env #f x))) - (cenv (make-cenv (current-module) - (ghil-env-parent env) - (if e (cenv-externals e) '())))) - (values x cenv cenv))))))) + (let ((x (tree-il->scheme + (sc-expand x 'c '(compile load eval))))) + (let ((x (make-ghil-lambda env #f vars #f '() + (translate-1 env #f x))) + (cenv (make-cenv (current-module) + (ghil-env-parent env) + (if e (cenv-externals e) '())))) + (values x cenv cenv)))))))) ;;; @@ -104,9 +104,6 @@ (let* ((mod (current-module)) (val (cond ((symbol? head) (module-ref/safe mod head)) - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((macro? head) head) ((pmatch head ((@ ,modname ,sym) (module-ref/safe (resolve-interface modname) sym)) @@ -117,21 +114,6 @@ (cond ((hashq-ref *translate-table* val)) - ((defmacro? val) - (lambda (env loc exp) - (retrans (apply (defmacro-transformer val) (cdr exp))))) - - ((eq? val sc-macro) - ;; syncase! - (let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (lambda (env loc exp) - (retrans - (strip-expansion-structures - (sc-expand3 exp 'c '(compile load eval))))))) - - ((primitive-macro? val) - (syntax-error #f "unhandled primitive macro" head)) - ((macro? val) (syntax-error #f "unknown kind of macro" head)) @@ -180,7 +162,7 @@ (define-macro (define-scheme-translator sym . clauses) `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) - ,sym + (module-ref (current-module) ',sym) (lambda (e l exp) (define (retrans x) ((@ (language scheme compile-ghil) translate-1) @@ -432,16 +414,6 @@ (,args (-> (values (map retrans args))))) -(define-scheme-translator compile-time-environment - ;; (compile-time-environment) - ;; => (MODULE LEXICALS . EXTERNALS) - (() - (-> (inline 'cons - (list (retrans '(current-module)) - (-> (inline 'cons - (list (-> (reified-env)) - (-> (inline 'externals '())))))))))) - (define (lookup-apply-transformer proc) (cond ((eq? proc values) (lambda (e l args) diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm new file mode 100644 index 000000000..4635abc8a --- /dev/null +++ b/module/language/scheme/compile-tree-il.scm @@ -0,0 +1,64 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme compile-tree-il) + #:use-module (language tree-il) + #:export (compile-tree-il)) + +;;; environment := #f +;;; | MODULE +;;; | COMPILE-ENV +;;; compile-env := (MODULE LEXICALS . EXTERNALS) +(define (cenv-module env) + (cond ((not env) #f) + ((module? env) env) + ((and (pair? env) (module? (car env))) (car env)) + (else (error "bad environment" env)))) + +(define (cenv-lexicals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cadr env)) + (else (error "bad environment" env)))) + +(define (cenv-externals env) + (cond ((not env) '()) + ((module? env) '()) + ((pair? env) (cddr env)) + (else (error "bad environment" env)))) + +(define (make-cenv module lexicals externals) + (cons module (cons lexicals externals))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + props)))) + +(define (compile-tree-il x e opts) + (save-module-excursion + (lambda () + (and=> (cenv-module e) set-current-module) + (let* ((x (sc-expand x 'c '(compile load eval))) + (cenv (make-cenv (current-module) + (cenv-lexicals e) (cenv-externals e)))) + (values x cenv cenv))))) diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm new file mode 100644 index 000000000..c4903d87f --- /dev/null +++ b/module/language/scheme/decompile-tree-il.scm @@ -0,0 +1,27 @@ +;;; Guile VM code converters + +;; Copyright (C) 2001,2009 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme decompile-tree-il) + #:use-module (language tree-il) + #:export (decompile-tree-il)) + +(define (decompile-tree-il x env opts) + (values (tree-il->scheme x) env)) diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm deleted file mode 100644 index 2ffefb318..000000000 --- a/module/language/scheme/expand.scm +++ /dev/null @@ -1,307 +0,0 @@ -;;; Guile Scheme specification - -;; Copyright (C) 2001 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 -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program 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 General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(define-module (language scheme expand) - #:use-module (language scheme amatch) - #:use-module (ice-9 expand-support) - #:use-module (ice-9 optargs) - #:use-module ((ice-9 syncase) #:select (sc-macro)) - #:use-module ((system base compile) #:select (syntax-error)) - #:export (expand *expand-table* define-scheme-expander)) - -(define (aref x) (if (annotation? x) (annotation-expression x) x)) -(define (apair? x) (pair? (aref x))) -(define (acar x) (car (aref x))) -(define (acdr x) (cdr (aref x))) -(define (acaar x) (acar (acar x))) -(define (acdar x) (acdr (acar x))) -(define (acadr x) (acar (acdr x))) -(define (acddr x) (acdr (acdr x))) -(define (aloc x) (and (annotation? x) (annotation-source x))) -(define (re-annotate x y) - (if (and (annotation? x) (not (annotation? y))) - (make-annotation y (annotation-source x)) - y)) -(define-macro (-> exp) `(re-annotate x ,exp)) - -(define* (expand x #:optional (mod (current-module)) (once? #f)) - (define re-expand - (if once? - (lambda (x) x) - (lambda (x) (expand x mod once?)))) - (let ((exp (if (annotation? x) (annotation-expression x) x))) - (cond - ((pair? exp) - (let ((head (car exp)) (tail (cdr exp))) - (cond - ;; allow macros to be unquoted into the output of a macro - ;; expansion - ((or (symbol? head) (macro? head)) - (let ((val (cond - ((macro? head) head) - ((module-variable mod head) - => (lambda (var) - ;; unbound vars can happen if the module - ;; definition forward-declared them - (and (variable-bound? var) (variable-ref var)))) - (else #f)))) - (cond - ((hashq-ref *expand-table* val) - => (lambda (expand1) (expand1 x re-expand))) - - ((defmacro? val) - (re-expand (-> (apply (defmacro-transformer val) - (deannotate tail))))) - - ((eq? val sc-macro) - ;; syncase! - (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure)) - (sc-expand3 (@@ (ice-9 syncase) sc-expand3))) - (re-expand - (with-fluids ((eec (module-eval-closure mod))) - ;; fixme -- use ewes fluid? - (sc-expand3 exp 'c '(compile load eval)))))) - - ((primitive-macro? val) - (syntax-error (aloc x) "unhandled primitive macro" head)) - - ((macro? val) - (syntax-error (aloc x) "unknown kind of macro" head)) - - (else - (-> (cons head (map re-expand tail))))))) - - (else - (-> (map re-expand exp)))))) - - (else x)))) - - -(define *expand-table* (make-hash-table)) - -(define-macro (define-scheme-expander sym . clauses) - `(hashq-set! (@ (language scheme expand) *expand-table*) - ,sym - (lambda (x re-expand) - (define syntax-error (@ (system base compile) syntax-error)) - (amatch (acdr x) - ,@clauses - ,@(if (assq 'else clauses) '() - `((else - (syntax-error (aloc x) (format #f "bad ~A" ',sym) x)))))))) - -(define-scheme-expander quote - ;; (quote OBJ) - ((,obj) x)) - -(define-scheme-expander quasiquote - ;; (quasiquote OBJ) - ((,obj) - (-> `(,'quasiquote - ,(let lp ((x obj) (level 0)) - (cond ((not (apair? x)) x) - ;; FIXME: hygiene regarding imported , / ,@ rebinding - ((memq (acar x) '(unquote unquote-splicing)) - (amatch (acdr x) - ((,obj) - (cond - ((zero? level) - (-> `(,(acar x) ,(re-expand obj)))) - (else - (-> `(,(acar x) ,(lp obj (1- level))))))) - (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x)))) - ((eq? (acar x) 'quasiquote) - (amatch (acdr x) - ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level))))) - (else (syntax-error (aloc x) "bad quasiquote" x)))) - (else (-> (cons (lp (acar x) level) (lp (acdr x) level)))))))))) - -(define-scheme-expander define - ;; (define NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(define ,name ,(re-expand val)))) - ;; (define (NAME FORMALS...) BODY...) - (((,name . ,formals) . ,body) (guard (symbol? name)) - ;; -> (define NAME (lambda FORMALS BODY...)) - (re-expand (-> `(define ,name (lambda ,formals . ,body)))))) - -(define-scheme-expander set! - ;; (set! (NAME ARGS...) VAL) - (((,name . ,args) ,val) (guard (symbol? name) - (not (eq? name '@)) (not (eq? name '@@))) - ;; -> ((setter NAME) ARGS... VAL) - (re-expand (-> `((setter ,name) ,@args ,val)))) - - ;; (set! NAME VAL) - ((,name ,val) (guard (symbol? name)) - (-> `(set! ,name ,(re-expand val))))) - -(define-scheme-expander if - ;; (if TEST THEN [ELSE]) - ((,test ,then) - (-> `(if ,(re-expand test) ,(re-expand then)))) - ((,test ,then ,else) - (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else))))) - -(define-scheme-expander and - ;; (and EXPS...) - (,tail - (-> `(and . ,(map re-expand tail))))) - -(define-scheme-expander or - ;; (or EXPS...) - (,tail - (-> `(or . ,(map re-expand tail))))) - -(define-scheme-expander begin - ;; (begin EXPS...) - ((,single-exp) - (-> (re-expand single-exp))) - (,tail - (-> `(begin . ,(map re-expand tail))))) - -(define (valid-bindings? bindings . it-is-for-do) - (define (valid-binding? b) - (amatch b - ((,sym ,var) (guard (symbol? sym)) #t) - ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) - (else #f))) - (and (list? (aref bindings)) - (and-map valid-binding? (aref bindings)))) - -(define-scheme-expander let - ;; (let NAME ((SYM VAL) ...) BODY...) - ((,name ,bindings . ,body) (guard (symbol? name) - (valid-bindings? bindings)) - ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) - (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings)) - . ,body))) - (,name . ,(map acadr (aref bindings))))))) - - ((() . ,body) - (re-expand (expand-internal-defines body))) - - ;; (let ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(let ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander let* - ;; (let* ((SYM VAL) ...) BODY...) - ((() . ,body) - (re-expand (-> `(let () . ,body)))) - ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) - (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body)))))) - -(define-scheme-expander letrec - ;; (letrec ((SYM VAL) ...) BODY...) - ((,bindings . ,body) (guard (valid-bindings? bindings)) - (-> `(letrec ,(map (lambda (x) - ;; nb, relies on -> non-hygiene - (-> `(,(acar x) ,(re-expand (acadr x))))) - (aref bindings)) - ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander cond - ;; (cond (CLAUSE BODY...) ...) - (() (-> '(begin))) - (((else . ,body)) (re-expand (-> `(begin ,@body)))) - (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest))))) - (((,test => ,proc) . ,rest) - ;; FIXME hygiene! - (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))) - (((,test . ,body) . ,rest) - (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest)))))) - -(define-scheme-expander case - ;; (case EXP ((KEY...) BODY...) ...) - ((,exp . ,clauses) - ;; FIXME hygiene! - (re-expand - (->`(let ((_t ,exp)) - ,(let loop ((ls clauses)) - (cond ((null? ls) '(begin)) - ((eq? (acaar ls) 'else) `(begin ,@(acdar ls))) - (else `(if (memv _t ',(acaar ls)) - (begin ,@(acdar ls)) - ,(loop (acdr ls))))))))))) - -(define-scheme-expander do - ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) - ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t)) - (let ((sym (map acar (aref bindings))) - (val (map acadr (aref bindings))) - (update (map acddr (aref bindings)))) - (define (next s x) (if (pair? x) (car x) s)) - (re-expand - ;; FIXME hygiene! - (-> `(letrec ((_l (lambda ,sym - (if ,test - (begin ,@result) - (begin ,@body - (_l ,@(map next sym update))))))) - (_l ,@val))))))) - -(define-scheme-expander lambda - ;; (lambda FORMALS BODY...) - ((,formals ,docstring ,body1 . ,body) (guard (string? docstring)) - (-> `(lambda ,formals ,docstring ,(expand-internal-defines - (map re-expand (cons body1 body)))))) - ((,formals . ,body) - (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body)))))) - -(define-scheme-expander delay - ;; FIXME not hygienic - ((,expr) - (re-expand `(make-promise (lambda () ,expr))))) - -(define-scheme-expander @ - ((,modname ,sym) - x)) - -(define-scheme-expander @@ - ((,modname ,sym) - x)) - -(define-scheme-expander eval-when - ((,when . ,body) (guard (list? when) (and-map symbol? when)) - (if (memq 'compile when) - (primitive-eval `(begin . ,body))) - (if (memq 'load when) - (-> `(begin . ,body)) - (-> `(begin))))) - -;;; Hum, I don't think this takes imported modifications to `define' -;;; properly into account. (Lexical bindings are OK because of alpha -;;; renaming.) -(define (expand-internal-defines body) - (let loop ((ls body) (ds '())) - (amatch ls - (() (syntax-error l "bad body" body)) - (((define ,name ,val) . _) - (loop (acdr ls) (cons (list name val) ds))) - (else - (if (null? ds) - (if (null? (cdr ls)) (car ls) `(begin ,@ls)) - `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls)))))))) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index 8f958eb63..cec2693aa 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -22,6 +22,8 @@ (define-module (language scheme spec) #:use-module (system base language) #:use-module (language scheme compile-ghil) + #:use-module (language scheme compile-tree-il) + #:use-module (language scheme decompile-tree-il) #:export (scheme)) ;;; @@ -30,12 +32,6 @@ (read-enable 'positions) -(define (read-file port) - (do ((x (read port) (read port)) - (l '() (cons x l))) - ((eof-object? x) - (cons 'begin (reverse! l))))) - ;;; ;;; Language definition ;;; @@ -44,8 +40,9 @@ #:title "Guile Scheme" #:version "0.5" #:reader read - #:read-file read-file - #:compilers `((ghil . ,compile-ghil)) + #:compilers `((tree-il . ,compile-tree-il) + (ghil . ,compile-ghil)) + #:decompilers `((tree-il . ,decompile-tree-il)) #:evaluator (lambda (x module) (primitive-eval x)) #:printer write ) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm new file mode 100644 index 000000000..335031182 --- /dev/null +++ b/module/language/tree-il.scm @@ -0,0 +1,359 @@ +;;;; Copyright (C) 2009 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 2.1 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 (language tree-il) + #:use-module (system base pmatch) + #:use-module (system base syntax) + #:export (tree-il-src + + void? make-void void-src + const? make-const const-src const-exp + primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name + lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym + lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp + module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? + module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp + toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name + toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp + toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp + conditional? make-conditional conditional-src conditional-test conditional-then conditional-else + application? make-application application-src application-proc application-args + sequence? make-sequence sequence-src sequence-exps + lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body + let? make-let let-src let-names let-vars let-vals let-exp + letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp + + parse-tree-il + unparse-tree-il + tree-il->scheme + + post-order! + pre-order!)) + +(define-type ( #:common-slots (src)) + () + ( exp) + ( name) + ( name gensym) + ( name gensym exp) + ( mod name public?) + ( mod name public? exp) + ( name) + ( name exp) + ( name exp) + ( test then else) + ( proc args) + ( exps) + ( names vars meta body) + ( names vars vals exp) + ( names vars vals exp)) + + + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (pair? props) props)))) + +(define (parse-tree-il exp) + (let ((loc (location exp)) + (retrans (lambda (x) (parse-tree-il x)))) + (pmatch exp + ((void) + (make-void loc)) + + ((apply ,proc . ,args) + (make-application loc (retrans proc) (map retrans args))) + + ((if ,test ,then ,else) + (make-conditional loc (retrans test) (retrans then) (retrans else))) + + ((primitive ,name) (guard (symbol? name)) + (make-primitive-ref loc name)) + + ((lexical ,name) (guard (symbol? name)) + (make-lexical-ref loc name name)) + + ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) + (make-lexical-ref loc name sym)) + + ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) + (make-lexical-set loc name sym (retrans exp))) + + ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #t)) + + ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #t (retrans exp))) + + ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) + (make-module-ref loc mod name #f)) + + ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) + (make-module-set loc mod name #f (retrans exp))) + + ((toplevel ,name) (guard (symbol? name)) + (make-toplevel-ref loc name)) + + ((set! (toplevel ,name) ,exp) (guard (symbol? name)) + (make-toplevel-set loc name (retrans exp))) + + ((define ,name ,exp) (guard (symbol? name)) + (make-toplevel-define loc name (retrans exp))) + + ((lambda ,names ,vars ,exp) + (make-lambda loc names vars '() (retrans exp))) + + ((lambda ,names ,vars ,meta ,exp) + (make-lambda loc names vars meta (retrans exp))) + + ((const ,exp) + (make-const loc exp)) + + ((begin . ,exps) + (make-sequence loc (map retrans exps))) + + ((let ,names ,vars ,vals ,exp) + (make-let loc names vars (map retrans vals) (retrans exp))) + + ((letrec ,names ,vars ,vals ,exp) + (make-letrec loc names vars (map retrans vals) (retrans exp))) + + (else + (error "unrecognized tree-il" exp))))) + +(define (unparse-tree-il tree-il) + (record-case tree-il + (() + '(void)) + + (( proc args) + `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) + + (( test then else) + `(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else))) + + (( name) + `(primitive ,name)) + + (( name gensym) + `(lexical ,name ,gensym)) + + (( name gensym exp) + `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) + + (( name) + `(toplevel ,name)) + + (( name exp) + `(set! (toplevel ,name) ,(unparse-tree-il exp))) + + (( name exp) + `(define ,name ,(unparse-tree-il exp))) + + (( names vars meta body) + `(lambda ,names ,vars ,meta ,(unparse-tree-il body))) + + (( exp) + `(const ,exp)) + + (( exps) + `(begin ,@(map unparse-tree-il exps))) + + (( names vars vals exp) + `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))) + + (( names vars vals exp) + `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp))))) + +(define (tree-il->scheme e) + (cond ((list? e) + (map tree-il->scheme e)) + ((pair? e) + (cons (tree-il->scheme (car e)) + (tree-il->scheme (cdr e)))) + ((record? e) + (record-case e + (() + '(if #f #f)) + + (( proc args) + `(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) + + (( test then else) + (if (void? else) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then)) + `(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else)))) + + (( name) + name) + + (( name gensym) + gensym) + + (( name gensym exp) + `(set! ,gensym ,(tree-il->scheme exp))) + + (( mod name public?) + `(,(if public? '@ '@@) ,mod ,name)) + + (( mod name public? exp) + `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp))) + + (( name) + name) + + (( name exp) + `(set! ,name ,(tree-il->scheme exp))) + + (( name exp) + `(define ,name ,(tree-il->scheme exp))) + + (( vars meta body) + `(lambda ,vars + ,@(cond ((assq-ref meta 'documentation) => list) (else '())) + ,(tree-il->scheme body))) + + (( exp) + (if (and (self-evaluating? exp) (not (vector? exp))) + exp + (list 'quote exp))) + + (( exps) + `(begin ,@(map tree-il->scheme exps))) + + (( vars vals exp) + `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))) + + (( vars vals exp) + `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp))))) + (else e))) + +(define (post-order! f x) + (let lp ((x x)) + (record-case x + (() + (or (f x) x)) + + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args)) + (or (f x) x)) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name gensym) + (or (f x) x)) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp)) + (or (f x) x)) + + (( mod name public?) + (or (f x) x)) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp)) + (or (f x) x)) + + (( name) + (or (f x) x)) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp)) + (or (f x) x)) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp)) + (or (f x) x)) + + (( vars meta body) + (set! (lambda-body x) (lp body)) + (or (f x) x)) + + (( exp) + (or (f x) x)) + + (( exps) + (set! (sequence-exps x) (map lp exps)) + (or (f x) x)) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp)) + (or (f x) x)) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp)) + (or (f x) x))))) + +(define (pre-order! f x) + (let lp ((x x)) + (let ((x (or (f x) x))) + (record-case x + (( proc args) + (set! (application-proc x) (lp proc)) + (set! (application-args x) (map lp args))) + + (( test then else) + (set! (conditional-test x) (lp test)) + (set! (conditional-then x) (lp then)) + (set! (conditional-else x) (lp else))) + + (( name gensym exp) + (set! (lexical-set-exp x) (lp exp))) + + (( mod name public? exp) + (set! (module-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-set-exp x) (lp exp))) + + (( name exp) + (set! (toplevel-define-exp x) (lp exp))) + + (( vars meta body) + (set! (lambda-body x) (lp body))) + + (( exps) + (set! (sequence-exps x) (map lp exps))) + + (( vars vals exp) + (set! (let-vals x) (map lp vals)) + (set! (let-exp x) (lp exp))) + + (( vars vals exp) + (set! (letrec-vals x) (map lp vals)) + (set! (letrec-exp x) (lp exp))) + + (else #f)) + x))) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm new file mode 100644 index 000000000..477f1fc2d --- /dev/null +++ b/module/language/tree-il/analyze.scm @@ -0,0 +1,235 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il analyze) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:export (analyze-lexicals)) + +;; allocation: the process of assigning a type and index to each var +;; a var is external if it is heaps; assigning index is easy +;; args are assigned in order +;; locals are indexed as their linear position in the binding path +;; (let (0 1) +;; (let (2 3) ...) +;; (let (2) ...)) +;; (let (2 3 4) ...)) +;; etc. +;; +;; This algorithm has the problem that variables are only allocated +;; indices at the end of the binding path. If variables bound early in +;; the path are not used in later portions of the path, their indices +;; will not be recycled. This problem is particularly egregious in the +;; expansion of `or': +;; +;; (or x y z) +;; -> (let ((a x)) (if a a (let ((b y)) (if b b z)))) +;; +;; As you can see, the `a' binding is only used in the ephemeral `then' +;; clause of the first `if', but its index would be reserved for the +;; whole of the `or' expansion. So we have a hack for this specific +;; case. A proper solution would be some sort of liveness analysis, and +;; not our linear allocation algorithm. +;; +;; allocation: +;; sym -> (local . index) | (heap level . index) +;; lambda -> (nlocs . nexts) + +(define (analyze-lexicals x) + ;; parents: lambda -> parent + ;; useful when we see a closed-over var, so we can calculate its + ;; coordinates (depth and index). + ;; bindings: lambda -> (sym ...) + ;; useful for two reasons: one, so we know how much space to allocate + ;; when we go into a lambda; and two, so that we know when to stop, + ;; when looking for closed-over vars. + ;; heaps: sym -> lambda + ;; allows us to heapify vars in an O(1) fashion + ;; refcounts: sym -> count + ;; allows us to detect the or-expansion an O(1) time + + (define (find-heap sym parent) + ;; fixme: check displaced lexicals here? + (if (memq sym (hashq-ref bindings parent)) + parent + (find-heap sym (hashq-ref parents parent)))) + + (define (analyze! x parent level) + (define (step y) (analyze! y parent level)) + (define (recur x parent) (analyze! x parent (1+ level))) + (record-case x + (( proc args) + (step proc) (for-each step args)) + + (( test then else) + (step test) (step then) (step else)) + + (( name gensym) + (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0))) + (if (and (not (memq gensym (hashq-ref bindings parent))) + (not (hashq-ref heaps gensym))) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( name gensym exp) + (step exp) + (if (not (hashq-ref heaps gensym)) + (hashq-set! heaps gensym (find-heap gensym parent)))) + + (( mod name public? exp) + (step exp)) + + (( name exp) + (step exp)) + + (( name exp) + (step exp)) + + (( exps) + (for-each step exps)) + + (( vars meta body) + (hashq-set! parents x parent) + (hashq-set! bindings x + (let rev* ((vars vars) (out '())) + (cond ((null? vars) out) + ((pair? vars) (rev* (cdr vars) + (cons (car vars) out))) + (else (cons vars out))))) + (recur body x) + (hashq-set! bindings x (reverse! (hashq-ref bindings x)))) + + (( vars vals exp) + (for-each step vals) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (step exp)) + + (( vars vals exp) + (hashq-set! bindings parent + (append (reverse vars) (hashq-ref bindings parent))) + (for-each step vals) + (step exp)) + + (else #f))) + + (define (allocate-heap! binder) + (hashq-set! heap-indexes binder + (1+ (hashq-ref heap-indexes binder -1)))) + + (define (allocate! x level n) + (define (recur y) (allocate! y level n)) + (record-case x + (( proc args) + (apply max (recur proc) (map recur args))) + + (( test then else) + (max (recur test) (recur then) (recur else))) + + (( name gensym exp) + (recur exp)) + + (( mod name public? exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( name exp) + (recur exp)) + + (( exps) + (apply max (map recur exps))) + + (( vars meta body) + (let lp ((vars vars) (n 0)) + (if (null? vars) + (hashq-set! allocation x + (let ((nlocs (- (allocate! body (1+ level) n) n))) + (cons nlocs (1+ (hashq-ref heap-indexes x -1))))) + (let ((v (if (pair? vars) (car vars) vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap (1+ level) (allocate-heap! binder)) + (cons 'stack n)))) + (lp (if (pair? vars) (cdr vars) '()) (1+ n))))) + n) + + (( vars vals exp) + (let ((nmax (apply max (map recur vals)))) + (cond + ;; the `or' hack + ((and (conditional? exp) + (= (length vars) 1) + (let ((v (car vars))) + (and (not (hashq-ref heaps v)) + (= (hashq-ref refcounts v 0) 2) + (lexical-ref? (conditional-test exp)) + (eq? (lexical-ref-gensym (conditional-test exp)) v) + (lexical-ref? (conditional-then exp)) + (eq? (lexical-ref-gensym (conditional-then exp)) v)))) + (hashq-set! allocation (car vars) (cons 'stack n)) + ;; the 1+ for this var + (max nmax (1+ n) (allocate! (conditional-else exp) level n))) + (else + (let lp ((vars vars) (n n)) + (if (null? vars) + (max nmax (allocate! exp level n)) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n))))))))))) + + (( vars vals exp) + (let lp ((vars vars) (n n)) + (if (null? vars) + (let ((nmax (apply max + (map (lambda (x) + (allocate! x level n)) + vals)))) + (max nmax (allocate! exp level n))) + (let ((v (car vars))) + (let ((binder (hashq-ref heaps v))) + (hashq-set! + allocation v + (if binder + (cons* 'heap level (allocate-heap! binder)) + (cons 'stack n))) + (lp (cdr vars) (if binder n (1+ n)))))))) + + (else n))) + + (define parents (make-hash-table)) + (define bindings (make-hash-table)) + (define heaps (make-hash-table)) + (define refcounts (make-hash-table)) + (define allocation (make-hash-table)) + (define heap-indexes (make-hash-table)) + + (analyze! x #f -1) + (allocate! x -1 0) + + allocation) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm new file mode 100644 index 000000000..94ace7e53 --- /dev/null +++ b/module/language/tree-il/compile-glil.scm @@ -0,0 +1,448 @@ +;;; TREE-IL -> GLIL compiler + +;; Copyright (C) 2001,2008,2009 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il compile-glil) + #:use-module (system base syntax) + #:use-module (ice-9 receive) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il optimize) + #:use-module (language tree-il analyze) + #:export (compile-glil)) + +;;; TODO: +;; +;; call-with-values -> mv-bind +;; basic degenerate-case reduction + +;; allocation: +;; sym -> (local . index) | (heap level . index) +;; lambda -> (nlocs . nexts) + +(define *comp-module* (make-fluid)) + +(define (compile-glil x e opts) + (let* ((x (make-lambda (tree-il-src x) '() '() '() x)) + (x (optimize! x e opts)) + (allocation (analyze-lexicals x))) + (with-fluid* *comp-module* (or (and e (car e)) (current-module)) + (lambda () + (values (flatten-lambda x -1 allocation) + (and e (cons (car e) (cddr e))) + e))))) + + + +(define *primcall-ops* (make-hash-table)) +(for-each + (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x))) + '(((eq? . 2) . eq?) + ((eqv? . 2) . eqv?) + ((equal? . 2) . equal?) + ((= . 2) . ee?) + ((< . 2) . lt?) + ((> . 2) . gt?) + ((<= . 2) . le?) + ((>= . 2) . ge?) + ((+ . 2) . add) + ((- . 2) . sub) + ((* . 2) . mul) + ((/ . 2) . div) + ((quotient . 2) . quo) + ((remainder . 2) . rem) + ((modulo . 2) . mod) + ((not . 1) . not) + ((pair? . 1) . pair?) + ((cons . 2) . cons) + ((car . 1) . car) + ((cdr . 1) . cdr) + ((set-car! . 2) . set-car!) + ((set-cdr! . 2) . set-cdr!) + ((null? . 1) . null?) + ((list? . 1) . list?) + (list . list) + (vector . vector) + ((@slot-ref . 2) . slot-ref) + ((@slot-set! . 3) . slot-set))) + +(define (make-label) (gensym ":L")) + +(define (vars->bind-list ids vars allocation) + (map (lambda (id v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) (list id 'local (cdr loc))) + ((heap) (list id 'external (cddr loc))) + (else (error "badness" id v loc))))) + ids + vars)) + +(define (emit-bindings src ids vars allocation emit-code) + (if (pair? vars) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation))))) + +(define (with-output-to-code proc) + (let ((out '())) + (define (emit-code src x) + (set! out (cons x out)) + (if src + (set! out (cons (make-glil-source src) out)))) + (proc emit-code) + (reverse out))) + +(define (flatten-lambda x level allocation) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) + (let ((nlocs (car (hashq-ref allocation x))) + (nexts (cdr (hashq-ref allocation x)))) + (make-glil-program + nargs nrest nlocs nexts (lambda-meta x) + (with-output-to-code + (lambda (emit-code) + ;; write bindings and source debugging info + (emit-bindings #f ids vars allocation emit-code) + (if (lambda-src x) + (emit-code #f (make-glil-source (lambda-src x)))) + + ;; copy args to the heap if necessary + (let lp ((in vars) (n 0)) + (if (not (null? in)) + (let ((loc (hashq-ref allocation (car in)))) + (case (car loc) + ((heap) + (emit-code #f (make-glil-local 'ref n)) + (emit-code #f (make-glil-external 'set 0 (cddr loc))))) + (lp (cdr in) (1+ n))))) + + ;; and here, here, dear reader: we compile. + (flatten (lambda-body x) (1+ level) allocation emit-code))))))) + +(define (flatten x level allocation emit-code) + (define (emit-label label) + (emit-code #f (make-glil-label label))) + (define (emit-branch src inst label) + (emit-code src (make-glil-branch inst label))) + + (let comp ((x x) (context 'tail)) + (define (comp-tail tree) (comp tree context)) + (define (comp-push tree) (comp tree 'push)) + (define (comp-drop tree) (comp tree 'drop)) + + (record-case x + (() + (case context + ((push) (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src exp) + (case context + ((push) (emit-code src (make-glil-const exp))) + ((tail) + (emit-code src (make-glil-const exp)) + (emit-code #f (make-glil-call 'return 1))))) + + ;; FIXME: should represent sequence as exps tail + (( src exps) + (let lp ((exps exps)) + (if (null? (cdr exps)) + (comp-tail (car exps)) + (begin + (comp-drop (car exps)) + (lp (cdr exps)))))) + + (( src proc args) + ;; FIXME: need a better pattern-matcher here + (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))) + ;; 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)) + ((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 'goto/apply (1+ (length args))))) + ((push) + (comp-push proc) + (for-each comp-push args) + (emit-code src (make-glil-call 'apply (1+ (length args))))) + ((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))))))))) + + ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) + (not (eq? context 'push))) + ;; tail: (lambda () (values '(1 2))) + ;; drop: (lambda () (values '(1 2)) 3) + ;; push: (lambda () (list (values '(10 12)) 1)) + (case context + ((drop) (for-each comp-drop args)) + ((tail) + (for-each comp-push args) + (emit-code src (make-glil-call 'return/values (length args)))))) + ((and (primitive-ref? proc) + (eq? (primitive-ref-name proc) '@call-with-values) + (= (length args) 2)) + ;; CONSUMER + ;; PRODUCER + ;; (mv-call MV) + ;; ([tail]-call 1) + ;; goto POST + ;; MV: [tail-]call/nargs + ;; POST: (maybe-drop) + (let ((MV (make-label)) (POST (make-label)) + (producer (car args)) (consumer (cadr args))) + (comp-push consumer) + (comp-push producer) + (emit-code src (make-glil-mv-call 0 MV)) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args 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 'goto/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))))))) + + ((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 'goto/cc 1))) + ((push) + (comp-push (car args)) + (emit-code src (make-glil-call 'call/cc 1))) + ((drop) + ;; Crap. Just like `apply' in drop context. + (comp-drop + (make-application + src (make-primitive-ref #f 'call-with-current-continuation) + args))))) + + ((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 context + ((tail) (emit-code #f (make-glil-call 'return 1))) + ((drop) (emit-code #f (make-glil-call 'drop 1)))))) + (else + (comp-push proc) + (for-each comp-push args) + (let ((len (length args))) + (case context + ((tail) (emit-code src (make-glil-call 'goto/args len))) + ((push) (emit-code src (make-glil-call 'call len))) + ((drop) + (let ((MV (make-label)) (POST (make-label))) + (emit-code src (make-glil-mv-call len MV)) + (emit-code #f (make-glil-call 'drop 1)) + (emit-branch #f 'br POST) + (emit-label MV) + (emit-code #f (make-glil-mv-bind '() #f)) + (emit-code #f (make-glil-unbind)) + (emit-label POST)))))))) + + (( src test then else) + ;; TEST + ;; (br-if-not L1) + ;; THEN + ;; (br L2) + ;; L1: ELSE + ;; L2: + (let ((L1 (make-label)) (L2 (make-label))) + (comp-push test) + (emit-branch src 'br-if-not L1) + (comp-tail then) + (if (not (eq? context 'tail)) + (emit-branch #f 'br L2)) + (emit-label L1) + (comp-tail else) + (if (not (eq? context 'tail)) + (emit-label L2)))) + + (( src name) + (cond + ((eq? (module-variable (fluid-ref *comp-module*) name) + (module-variable the-root-module name)) + (case context + ((push) + (emit-code src (make-glil-toplevel 'ref name))) + ((tail) + (emit-code src (make-glil-toplevel 'ref name)) + (emit-code #f (make-glil-call 'return 1))))) + (else + (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*)) + (case context + ((push) + (emit-code src (make-glil-module 'ref '(guile) name #f))) + ((tail) + (emit-code src (make-glil-module 'ref '(guile) name #f)) + (emit-code #f (make-glil-call 'return 1))))))) + + (( src name gensym) + (case context + ((push tail) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'ref (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'ref (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc))) + (if (eq? context 'tail) + (emit-code #f (make-glil-call 'return 1))))))) + + (( src name gensym exp) + (comp-push exp) + (let ((loc (hashq-ref allocation gensym))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external + 'set (- level (cadr loc)) (cddr loc)))) + (else (error "badness" x loc)))) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public?) + (emit-code src (make-glil-module 'ref mod name public?)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src mod name public? exp) + (comp-push exp) + (emit-code src (make-glil-module 'set mod name public?)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name) + (emit-code src (make-glil-toplevel 'ref name)) + (case context + ((drop) (emit-code #f (make-glil-call 'drop 1))) + ((tail) (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'set name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src name exp) + (comp-push exp) + (emit-code src (make-glil-toplevel 'define name)) + (case context + ((push) + (emit-code #f (make-glil-void))) + ((tail) + (emit-code #f (make-glil-void)) + (emit-code #f (make-glil-call 'return 1))))) + + (() + (case context + ((push) + (emit-code #f (flatten-lambda x level allocation))) + ((tail) + (emit-code #f (flatten-lambda x level allocation)) + (emit-code #f (make-glil-call 'return 1))))) + + (( src names vars vals exp) + (for-each comp-push vals) + (emit-bindings src names vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind))) + + (( src names vars vals exp) + (for-each comp-push vals) + (emit-bindings src names vars allocation emit-code) + (for-each (lambda (v) + (let ((loc (hashq-ref allocation v))) + (case (car loc) + ((stack) + (emit-code src (make-glil-local 'set (cdr loc)))) + ((heap) + (emit-code src (make-glil-external 'set 0 (cddr loc)))) + (else (error "badness" x loc))))) + (reverse vars)) + (comp-tail exp) + (emit-code #f (make-glil-unbind)))))) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm new file mode 100644 index 000000000..3a02e021e --- /dev/null +++ b/module/language/tree-il/optimize.scm @@ -0,0 +1,42 @@ +;;; Tree-il optimizer + +;; Copyright (C) 2009 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il optimize) + #:use-module (language tree-il) + #:use-module (language tree-il primitives) + #:export (optimize!)) + +(define (env-module e) + (if e (car e) (current-module))) + +(define (optimize! x env opts) + (expand-primitives! (resolve-primitives! x (env-module env)))) + +;; Possible optimizations: +;; * constant folding, propagation +;; * procedure inlining +;; * always when single call site +;; * always for "trivial" procs +;; * otherwise who knows +;; * dead code elimination +;; * degenerate case optimizations +;; * "fixing letrec" + diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm new file mode 100644 index 000000000..51bbfeae9 --- /dev/null +++ b/module/language/tree-il/primitives.scm @@ -0,0 +1,206 @@ +;;; GHIL macros + +;; Copyright (C) 2001 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il primitives) + #:use-module (system base syntax) + #:use-module (language tree-il) + #:use-module (srfi srfi-16) + #:export (resolve-primitives! add-interesting-primitive! + expand-primitives!)) + +(define *interesting-primitive-names* + '(apply @apply + call-with-values @call-with-values + call-with-current-continuation @call-with-current-continuation + call/cc + values + eq? eqv? equal? + = < > <= >= zero? + + * - / 1- 1+ quotient remainder modulo + not + pair? null? list? acons cons cons* + + list vector + + car cdr + set-car! set-cdr! + + caar cadr cdar cddr + + caaar caadr cadar caddr cdaar cdadr cddar cdddr + + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)) + +(define (add-interesting-primitive! name) + (hashq-set! *interesting-primitive-vars* + (module-variable (current-module) name) name)) + +(define *interesting-primitive-vars* (make-hash-table)) + +(for-each add-interesting-primitive! *interesting-primitive-names*) + +(define (resolve-primitives! x mod) + (post-order! + (lambda (x) + (record-case x + (( src name) + (and (hashq-ref *interesting-primitive-vars* + (module-variable mod name)) + (make-primitive-ref src name))) + (( src mod name public?) + ;; for the moment, we're disabling primitive resolution for + ;; public refs because resolve-interface can raise errors. + (let ((m (and (not public?) (resolve-module mod)))) + (and m (hashq-ref *interesting-primitive-vars* + (module-variable m name)) + (make-primitive-ref src name)))) + (else #f))) + x)) + + + +(define *primitive-expand-table* (make-hash-table)) + +(define (expand-primitives! x) + (pre-order! + (lambda (x) + (record-case x + (( src proc args) + (and (primitive-ref? proc) + (let ((expand (hashq-ref *primitive-expand-table* + (primitive-ref-name proc)))) + (and expand (apply expand src args))))) + (else #f))) + x)) + +;;; I actually did spend about 10 minutes trying to redo this with +;;; syntax-rules. Patches appreciated. +;;; +(define-macro (define-primitive-expander sym . clauses) + (define (inline-args args) + (let lp ((in args) (out '())) + (cond ((null? in) `(list ,@(reverse out))) + ((symbol? in) `(cons* ,@(reverse out) ,in)) + ((pair? (car in)) + (lp (cdr in) + (cons `(make-application src (make-primitive-ref src ',(caar in)) + ,(inline-args (cdar in))) + out))) + ((symbol? (car in)) + ;; assume it's locally bound + (lp (cdr in) (cons (car in) out))) + ((number? (car in)) + (lp (cdr in) (cons `(make-const src ,(car in)) out))) + (else + (error "what what" (car in)))))) + (define (consequent exp) + (cond + ((pair? exp) + `(make-application src (make-primitive-ref src ',(car exp)) + ,(inline-args (cdr exp)))) + ((symbol? exp) + ;; assume locally bound + exp) + ((number? exp) + `(make-const src ,exp)) + (else (error "bad consequent yall" exp)))) + `(hashq-set! *primitive-expand-table* + ',sym + (case-lambda + ,@(let lp ((in clauses) (out '())) + (if (null? in) + (reverse (cons '(else #f) out)) + (lp (cddr in) + (cons `((src . ,(car in)) + ,(consequent (cadr in))) out))))))) + +(define-primitive-expander + + () 0 + (x) x + (x y z . rest) (+ x (+ y z . rest))) + +(define-primitive-expander * + () 1 + (x) x + (x y z . rest) (* x (* y z . rest))) + +(define-primitive-expander - + (x) (- 0 x) + (x y z . rest) (- x (+ y z . rest))) + +(define-primitive-expander 1- + (x) (- x 1)) + +(define-primitive-expander / + (x) (/ 1 x) + (x y z . rest) (/ x (* y z . rest))) + +(define-primitive-expander caar (x) (car (car x))) +(define-primitive-expander cadr (x) (car (cdr x))) +(define-primitive-expander cdar (x) (cdr (car x))) +(define-primitive-expander cddr (x) (cdr (cdr x))) +(define-primitive-expander caaar (x) (car (car (car x)))) +(define-primitive-expander caadr (x) (car (car (cdr x)))) +(define-primitive-expander cadar (x) (car (cdr (car x)))) +(define-primitive-expander caddr (x) (car (cdr (cdr x)))) +(define-primitive-expander cdaar (x) (cdr (car (car x)))) +(define-primitive-expander cdadr (x) (cdr (car (cdr x)))) +(define-primitive-expander cddar (x) (cdr (cdr (car x)))) +(define-primitive-expander cdddr (x) (cdr (cdr (cdr x)))) +(define-primitive-expander caaaar (x) (car (car (car (car x))))) +(define-primitive-expander caaadr (x) (car (car (car (cdr x))))) +(define-primitive-expander caadar (x) (car (car (cdr (car x))))) +(define-primitive-expander caaddr (x) (car (car (cdr (cdr x))))) +(define-primitive-expander cadaar (x) (car (cdr (car (car x))))) +(define-primitive-expander cadadr (x) (car (cdr (car (cdr x))))) +(define-primitive-expander caddar (x) (car (cdr (cdr (car x))))) +(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x))))) +(define-primitive-expander cdaaar (x) (cdr (car (car (car x))))) +(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x))))) +(define-primitive-expander cdadar (x) (cdr (car (cdr (car x))))) +(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x))))) +(define-primitive-expander cddaar (x) (cdr (cdr (car (car x))))) +(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x))))) +(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x))))) +(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x))))) + +(define-primitive-expander cons* + (x) x + (x y) (cons x y) + (x y . rest) (cons x (cons* y . rest))) + +(define-primitive-expander acons (x y z) + (cons (cons x y) z)) + +(define-primitive-expander apply (f . args) + (@apply f . args)) + +(define-primitive-expander call-with-values (producer consumer) + (@call-with-values producer consumer)) + +(define-primitive-expander call-with-current-continuation (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander call/cc (proc) + (@call-with-current-continuation proc)) + +(define-primitive-expander values (x) x) diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm new file mode 100644 index 000000000..c1f098230 --- /dev/null +++ b/module/language/tree-il/spec.scm @@ -0,0 +1,43 @@ +;;; Tree Intermediate Language + +;; Copyright (C) 2009 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 +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program 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 General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language tree-il spec) + #:use-module (system base language) + #:use-module (language glil) + #:use-module (language tree-il) + #:use-module (language tree-il compile-glil) + #:export (tree-il)) + +(define (write-tree-il exp . port) + (apply write (unparse-tree-il exp) port)) + +(define (join exps env) + (make-sequence #f exps)) + +(define-language tree-il + #:title "Tree Intermediate Language" + #:version "1.0" + #:reader read + #:printer write-tree-il + #:parser parse-tree-il + #:joiner join + #:compilers `((glil . ,compile-glil)) + ) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 2254f93e5..6e3b15009 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -154,17 +154,6 @@ ;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) ;;; OPTION ::= KEYWORD VALUE ;;; -(define (define-class-pre-definition kw val) - (case kw - ((#:getter #:setter) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-generic ,val))) - ((#:accessor) - `(if (or (not (defined? ',val)) - (not (is-a? ,val ))) - (define-accessor ,val))) - (else #f))) (define (kw-do-map mapper f kwargs) (define (keywords l) @@ -180,69 +169,6 @@ (a (args kwargs))) (mapper f k a))) -;;; This code should be implemented in C. -;;; -(define-macro (define-class name supers . slots) - ;; Some slot options require extra definitions to be made. In - ;; particular, we want to make sure that the generic function objects - ;; which represent accessors exist before `make-class' tries to add - ;; methods to them. - ;; - ;; Postpone some error handling to class macro. - ;; - `(begin - ;; define accessors - ,@(append-map (lambda (slot) - (kw-do-map filter-map - define-class-pre-definition - (if (pair? slot) (cdr slot) '()))) - (take-while (lambda (x) (not (keyword? x))) slots)) - (if (and (defined? ',name) - (is-a? ,name ) - (memq (class-precedence-list ,name))) - (class-redefinition ,name - (class ,supers ,@slots #:name ',name)) - (define ,name (class ,supers ,@slots #:name ',name))))) - -(define standard-define-class define-class) - -;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) -;;; -;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) -;;; OPTION ::= KEYWORD VALUE -;;; -(define-macro (class supers . slots) - (define (make-slot-definition-forms slots) - (map - (lambda (def) - (cond - ((pair? def) - `(list ',(car def) - ,@(kw-do-map append-map - (lambda (kw arg) - (case kw - ((#:init-form) - `(#:init-form ',arg - #:init-thunk (lambda () ,arg))) - (else (list kw arg)))) - (cdr def)))) - (else - `(list ',def)))) - slots)) - - (if (not (list? supers)) - (goops-error "malformed superclass list: ~S" supers)) - (let ((slot-defs (cons #f '())) - (slots (take-while (lambda (x) (not (keyword? x))) slots)) - (options (or (find-tail keyword? slots) '()))) - `(make-class - ;; evaluate super class variables - (list ,@supers) - ;; evaluate slot definitions, except the slot name! - (list ,@(make-slot-definition-forms slots)) - ;; evaluate class options - ,@options))) - (define (make-class supers slots . options) (let ((env (or (get-keyword #:environment options #f) (top-level-env)))) @@ -275,6 +201,108 @@ #:environment env options)))) +;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...) +;;; +;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...) +;;; OPTION ::= KEYWORD VALUE +;;; +(define-macro (class supers . slots) + (define (make-slot-definition-forms slots) + (map + (lambda (def) + (cond + ((pair? def) + `(list ',(car def) + ,@(kw-do-map append-map + (lambda (kw arg) + (case kw + ((#:init-form) + `(#:init-form ',arg + #:init-thunk (lambda () ,arg))) + (else (list kw arg)))) + (cdr def)))) + (else + `(list ',def)))) + slots)) + (if (not (list? supers)) + (goops-error "malformed superclass list: ~S" supers)) + (let ((slot-defs (cons #f '())) + (slots (take-while (lambda (x) (not (keyword? x))) slots)) + (options (or (find-tail keyword? slots) '()))) + `(make-class + ;; evaluate super class variables + (list ,@supers) + ;; evaluate slot definitions, except the slot name! + (list ,@(make-slot-definition-forms slots)) + ;; evaluate class options + ,@options))) + +(define-syntax define-class-pre-definition + (lambda (x) + (syntax-case x () + ((_ (k arg rest ...) out ...) + (keyword? (syntax->datum (syntax k))) + (case (syntax->datum (syntax k)) + ((#:getter #:setter) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))) + ((#:accessor) + (syntax + (define-class-pre-definition (rest ...) + out ... + (if (or (not (defined? 'arg)) + (not (is-a? arg ))) + (toplevel-define! + 'arg + (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))) + (else + (syntax + (define-class-pre-definition (rest ...) out ...))))) + ((_ () out ...) + (syntax (begin out ...)))))) + +;; Some slot options require extra definitions to be made. In +;; particular, we want to make sure that the generic function objects +;; which represent accessors exist before `make-class' tries to add +;; methods to them. +(define-syntax define-class-pre-definitions + (lambda (x) + (syntax-case x () + ((_ () out ...) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (keyword? (syntax->datum (syntax slot))) + (syntax (begin out ...))) + ((_ (slot rest ...) out ...) + (identifier? (syntax slot)) + (syntax (define-class-pre-definitions (rest ...) + out ...))) + ((_ ((slotname slotopt ...) rest ...) out ...) + (syntax (define-class-pre-definitions (rest ...) + out ... (define-class-pre-definition (slotopt ...)))))))) + +(define-syntax define-class + (syntax-rules () + ((_ name supers slot ...) + (begin + (define-class-pre-definitions (slot ...)) + (if (and (defined? 'name) + (is-a? name ) + (memq (class-precedence-list name))) + (class-redefinition name + (class supers slot ... #:name 'name)) + (toplevel-define! 'name (class supers slot ... #:name 'name))))))) + +(define-syntax standard-define-class + (syntax-rules () + ((_ arg ...) (define-class arg ...)))) + ;;; ;;; {Generic functions and accessors} ;;; @@ -363,13 +391,13 @@ (else (make #:name name))))) ;; same semantics as -(define-macro (define-accessor name) - (if (not (symbol? name)) - (goops-error "bad accessor name: ~S" name)) - `(define ,name - (if (and (defined? ',name) (is-a? ,name )) - (make #:name ',name) - (ensure-accessor (if (defined? ',name) ,name #f) ',name)))) +(define-syntax define-accessor + (syntax-rules () + ((_ name) + (define name + (cond ((not (defined? 'name)) (ensure-accessor #f 'name)) + ((is-a? name ) (make #:name 'name)) + (else (ensure-accessor name 'name))))))) (define (make-setter-name name) (string->symbol (string-append "setter:" (symbol->string name)))) @@ -424,78 +452,132 @@ ;;; {Methods} ;;; -(define-macro (define-method head . body) - (if (not (pair? head)) - (goops-error "bad method head: ~S" head)) - (let ((gf (car head))) - (cond ((and (pair? gf) - (eq? (car gf) 'setter) - (pair? (cdr gf)) - (symbol? (cadr gf)) - (null? (cddr gf))) - ;; named setter method - (let ((name (cadr gf))) - (cond ((not (symbol? name)) - `(add-method! (setter ,name) - (method ,(cdr head) ,@body))) - (else - `(begin - (if (or (not (defined? ',name)) - (not (is-a? ,name ))) - (define-accessor ,name)) - (add-method! (setter ,name) - (method ,(cdr head) ,@body))))))) - ((not (symbol? gf)) - `(add-method! ,gf (method ,(cdr head) ,@body))) - (else - `(begin - ;; FIXME: this code is how it always was, but it's quite - ;; cracky: it will only define the generic function if it - ;; was undefined before (ok), or *was defined to #f*. The - ;; latter is crack. But there are bootstrap issues about - ;; fixing this -- change it to (is-a? ,gf ) and - ;; see. - (if (or (not (defined? ',gf)) - (not ,gf)) - (define-generic ,gf)) - (add-method! ,gf - (method ,(cdr head) ,@body))))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define-macro (method args . body) - (letrec ((specializers - (lambda (ls) - (cond ((null? ls) (list (list 'quote '()))) - ((pair? ls) (cons (if (pair? (car ls)) - (cadar ls) - ') - (specializers (cdr ls)))) - (else '())))) - (formals - (lambda (ls) - (if (pair? ls) - (cons (if (pair? (car ls)) (caar ls) (car ls)) - (formals (cdr ls))) - ls)))) - (let ((make-proc (compile-make-procedure (formals args) - (specializers args) - body))) - `(make - #:specializers (cons* ,@(specializers args)) - #:formals ',(formals args) - #:body ',body - #:make-procedure ,make-proc - #:procedure ,(and (not make-proc) - ;; that is to say: we set #:procedure if - ;; `compile-make-procedure' returned `#f', - ;; which is the case if `body' does not - ;; contain a call to `next-method' - `(lambda ,(formals args) - ,@(if (null? body) - ;; This used to be '((begin)), but - ;; guile's memoizer doesn't like - ;; (lambda args (begin)). - '((if #f #f)) - body))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ ((setter name) . args) body ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method args body ...)))) + ((_ (name . args) body ...) + (begin + ;; FIXME: this code is how it always was, but it's quite cracky: + ;; it will only define the generic function if it was undefined + ;; before (ok), or *was defined to #f*. The latter is crack. But + ;; there are bootstrap issues about fixing this -- change it to + ;; (is-a? name ) and see. + (if (or (not (defined? 'name)) + (not name)) + (toplevel-define! 'name (make #:name 'name))) + (add-method! name (method args body ...)))))) + +(define-syntax method + (lambda (x) + (define (parse-args args) + (let lp ((ls args) (formals '()) (specializers '())) + (syntax-case ls () + (((f s) . rest) + (and (identifier? (syntax f)) (identifier? (syntax s))) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax s) specializers))) + ((f . rest) + (identifier? (syntax f)) + (lp (syntax rest) + (cons (syntax f) formals) + (cons (syntax ) specializers))) + (() + (list (reverse formals) + (reverse (cons (syntax '()) specializers)))) + (tail + (identifier? (syntax tail)) + (list (append (reverse formals) (syntax tail)) + (reverse (cons (syntax ) specializers))))))) + + (define (find-free-id exp referent) + (syntax-case exp () + ((x . y) + (or (find-free-id (syntax x) referent) + (find-free-id (syntax y) referent))) + (x + (identifier? (syntax x)) + (let ((id (datum->syntax (syntax x) referent))) + (and (free-identifier=? (syntax x) id) id))) + (_ #f))) + + (define (compute-procedure formals body) + (syntax-case body () + ((body0 ...) + (with-syntax ((formals formals)) + (syntax (lambda formals body0 ...)))))) + + (define (->proper args) + (let lp ((ls args) (out '())) + (syntax-case ls () + ((x . xs) (lp (syntax xs) (cons (syntax x) out))) + (() (reverse out)) + (tail (reverse (cons (syntax tail) out)))))) + + (define (compute-make-procedure formals body next-method) + (syntax-case body () + ((body ...) + (with-syntax ((next-method next-method)) + (syntax-case formals () + ((formal ...) + (syntax + (lambda (real-next-method) + (lambda (formal ...) + (let ((next-method (lambda args + (if (null? args) + (real-next-method formal ...) + (apply real-next-method args))))) + body ...))))) + (formals + (with-syntax (((formal ...) (->proper (syntax formals)))) + (syntax + (lambda (real-next-method) + (lambda formals + (let ((next-method (lambda args + (if (null? args) + (apply real-next-method formal ...) + (apply real-next-method args))))) + body ...))))))))))) + + (define (compute-procedures formals body) + ;; So, our use of this is broken, because it operates on the + ;; pre-expansion source code. It's equivalent to just searching + ;; for referent in the datums. Ah well. + (let ((id (find-free-id body 'next-method))) + (if id + ;; return a make-procedure + (values (syntax #f) + (compute-make-procedure formals body id)) + (values (compute-procedure formals body) + (syntax #f))))) + + (syntax-case x () + ((_ args) (syntax (method args (if #f #f)))) + ((_ args body0 body1 ...) + (with-syntax (((formals (specializer ...)) (parse-args (syntax args)))) + (call-with-values + (lambda () + (compute-procedures (syntax formals) (syntax (body0 body1 ...)))) + (lambda (procedure make-procedure) + (with-syntax ((procedure procedure) + (make-procedure make-procedure)) + (syntax + (make + #:specializers (cons* specializer ...) + #:formals 'formals + #:body '(body0 body1 ...) + #:make-procedure make-procedure + #:procedure procedure)))))))))) ;;; ;;; {add-method!} @@ -1046,27 +1128,9 @@ ;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes. (eval-when (compile) - (use-modules ((language scheme compile-ghil) :select (define-scheme-translator)) - ((language ghil) :select (make-ghil-inline make-ghil-call)) - (system base pmatch)) - - ;; unfortunately, can't use define-inline because these are primitive - ;; syntaxen. - (define-scheme-translator @slot-ref - ((,obj ,index) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-ref - (list (retrans obj) (retrans index)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))) - - (define-scheme-translator @slot-set! - ((,obj ,index ,val) (guard (integer? index) - (>= index 0) (< index max-fixnum)) - (make-ghil-inline #f #f 'slot-set - (list (retrans obj) (retrans index) (retrans val)))) - (else - (make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))) + (use-modules ((language tree-il primitives) :select (add-interesting-primitive!))) + (add-interesting-primitive! '@slot-ref) + (add-interesting-primitive! '@slot-set!)) (eval-when (eval load compile) (define num-standard-pre-cache 20)) diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index 3962be4bc..e6b13c416 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -24,7 +24,7 @@ (define-module (oop goops compile) :use-module (oop goops) :use-module (oop goops util) - :export (compute-cmethod compile-make-procedure) + :export (compute-cmethod) :no-backtrace ) @@ -60,9 +60,7 @@ ;;; So, for the reader: there basic idea is that, given that the ;;; semantics of `next-method' depend on the concrete types being ;;; dispatched, why not compile a specific procedure to handle each type -;;; combination that we see at runtime. There are two compilation -;;; strategies implemented: one for the memoizer, and one for the VM -;;; compiler. +;;; combination that we see at runtime. ;;; ;;; In theory we can do much better than a bytecode compilation, because ;;; we know the *exact* types of the arguments. It's ideal for native @@ -71,32 +69,6 @@ ;;; I think this whole generic application mess would benefit from a ;;; strict MOP. -;;; Temporary solution---return #f if x doesn't refer to `next-method'. -(define (next-method? x) - (and (pair? x) - (or (eq? (car x) 'next-method) - (next-method? (car x)) - (next-method? (cdr x))))) - -;; Called by the `method' macro in goops.scm. -(define (compile-make-procedure formals specializers body) - (and (next-method? body) - (let ((next-method-sym (gensym " next-method")) - (args-sym (gensym))) - `(lambda (,next-method-sym) - (lambda ,formals - (let ((next-method (lambda ,args-sym - (if (null? ,args-sym) - ,(if (list? formals) - `(,next-method-sym ,@formals) - `(apply - ,next-method-sym - ,@(improper->proper formals))) - (apply ,next-method-sym ,args-sym))))) - ,@(if (null? body) - '((begin)) - body))))))) - (define (compile-method methods types) (let ((make-procedure (slot-ref (car methods) 'make-procedure))) (if make-procedure diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index a54044729..ed9f3077e 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -209,9 +209,8 @@ ;;; ;; Backward compatibility -(if (not (defined? 'lookup-create-cmethod)) - (define (lookup-create-cmethod gf args) - (no-applicable-method (car args) (cadr args)))) +(define (lookup-create-cmethod gf args) + (no-applicable-method (car args) (cadr args))) (define (memoize-method! gf args exp) (if (not (slot-ref gf 'used-by)) diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 4d64da8bb..2aedd7698 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -110,9 +110,7 @@ ;;; Readables ;;; -(if (or (not (defined? 'readables)) - (not readables)) - (define readables (make-weak-key-hash-table 61))) +(define readables (make-weak-key-hash-table 61)) (define-macro (readable exp) `(make-readable ,exp ',(copy-tree exp))) diff --git a/module/oop/goops/simple.scm b/module/oop/goops/simple.scm index 48e76f312..c0cb76fbb 100644 --- a/module/oop/goops/simple.scm +++ b/module/oop/goops/simple.scm @@ -23,6 +23,9 @@ :export (define-class) :no-backtrace) -(define define-class define-class-with-accessors-keywords) +(define-syntax define-class + (syntax-rules () + ((_ arg ...) + (define-class-with-accessors-keywords arg ...)))) (module-use! %module-public-interface (resolve-interface '(oop goops))) diff --git a/module/oop/goops/stklos.scm b/module/oop/goops/stklos.scm index 60ab293c3..ef943cf96 100644 --- a/module/oop/goops/stklos.scm +++ b/module/oop/goops/stklos.scm @@ -47,51 +47,30 @@ ;;; Enable keyword support (*fixme*---currently this has global effect) (read-set! keywords 'prefix) -(define standard-define-class-transformer - (macro-transformer standard-define-class)) +(define-syntax define-class + (syntax-rules () + ((_ name supers (slot ...) rest ...) + (standard-define-class name supers slot ... rest ...)))) -(define define-class - ;; Syntax - (let ((name cadr) - (supers caddr) - (slots cadddr) - (rest cddddr)) - (procedure->memoizing-macro - (lambda (exp env) - (standard-define-class-transformer - `(define-class ,(name exp) ,(supers exp) ,@(slots exp) - ,@(rest exp)) - env))))) +(define (toplevel-define! name val) + (module-define! (current-module) name val)) -(define define-method - (procedure->memoizing-macro - (lambda (exp env) - (let ((name (cadr exp))) - (if (and (pair? name) - (eq? (car name) 'setter) - (pair? (cdr name)) - (null? (cddr name))) - (let ((name (cadr name))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (is-a? ,name )) - (define-accessor ,name)) - (add-method! (setter ,name) (method ,@(cddr exp))))) - (else - `(begin - (define-accessor ,name) - (add-method! (setter ,name) (method ,@(cddr exp))))))) - (cond ((not (symbol? name)) - (goops-error "bad method name: ~S" name)) - ((defined? name env) - `(begin - (if (not (or (is-a? ,name ) - (is-a? ,name ))) - (define-generic ,name)) - (add-method! ,name (method ,@(cddr exp))))) - (else - `(begin - (define-generic ,name) - (add-method! ,name (method ,@(cddr exp))))))))))) +(define-syntax define-method + (syntax-rules (setter) + ((_ (setter name) rest ...) + (begin + (if (or (not (defined? 'name)) + (not (is-a? name ))) + (toplevel-define! 'name + (ensure-accessor + (if (defined? 'name) name #f) 'name))) + (add-method! (setter name) (method rest ...)))) + ((_ name rest ...) + (begin + (if (or (not (defined? 'name)) + (not (or (is-a? name ) + (is-a? name )))) + (toplevel-define! 'name + (ensure-generic + (if (defined? 'name) name #f) 'name))) + (add-method! name (method rest ...)))))) diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm index 9e17d6632..afa1730f1 100644 --- a/module/srfi/srfi-11.scm +++ b/module/srfi/srfi-11.scm @@ -37,7 +37,6 @@ ;;; Code: (define-module (srfi srfi-11) - :use-module (ice-9 syncase) :export-syntax (let-values let*-values)) (cond-expand-provide (current-module) '(srfi-11)) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 925ecb304..dd92079be 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -151,8 +151,10 @@ (hashq-set! thread-exception-handlers ct hl) (handler obj)) (lambda () - (let ((r (thunk))) - (hashq-set! thread-exception-handlers ct hl) r)))))) + (call-with-values thunk + (lambda res + (hashq-set! thread-exception-handlers ct hl) + (apply values res)))))))) (define (current-exception-handler) (car (current-handler-stack))) @@ -249,8 +251,8 @@ (define (wrap thunk) (lambda (continuation) (with-exception-handler (lambda (obj) - (apply (current-exception-handler) (list obj)) - (apply continuation (list))) + ((current-exception-handler) obj) + (continuation)) thunk))) ;; A pass-thru to cancel-thread that first installs a handler that throws diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm index 086751170..87154d6df 100644 --- a/module/srfi/srfi-39.scm +++ b/module/srfi/srfi-39.scm @@ -35,7 +35,6 @@ ;;; Code: (define-module (srfi srfi-39) - #:use-module (ice-9 syncase) #:use-module (srfi srfi-16) #:export (make-parameter) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 7d54947e3..f6522f735 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -29,7 +29,7 @@ #:export (syntax-error *current-language* compiled-file-name compile-file compile-and-load - compile compile-time-environment + compile decompile) #:export-syntax (call-with-compile-error-catch)) @@ -107,9 +107,9 @@ port))) comp)) -(define* (compile-and-load file #:key (to 'value) (opts '())) - (read-and-compile (open-input-port file) - #:from lang #:to to #:opts opts)) +(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '())) + (read-and-compile (open-input-file file) + #:from from #:to to #:opts opts)) (define (compiled-file-name file) (let ((base (basename file)) @@ -135,11 +135,6 @@ ;;; Compiler interface ;;; -(define (read-file-in file lang) - (call-with-input-file file - (or (language-read-file lang) - (error "language has no #:read-file" lang)))) - (define (compile-passes from to opts) (map cdr (or (lookup-compilation-order from to) @@ -152,13 +147,6 @@ (receive (x e new-cenv) ((car passes) x e opts) (lp (cdr passes) x e (if first? new-cenv cenv) #f))))) -(define (compile-time-environment) - "A special function known to the compiler that, when compiled, will -return a representation of the lexical environment in place at compile -time. Useful for supporting some forms of dynamic compilation. Returns -#f if called from the interpreter." - #f) - (define (find-language-joint from to) (let lp ((in (reverse (or (lookup-compilation-order from to) (error "no way to compile" from "to" to)))) diff --git a/module/system/base/language.scm b/module/system/base/language.scm index 649137c4d..8ae4d9667 100644 --- a/module/system/base/language.scm +++ b/module/system/base/language.scm @@ -23,7 +23,7 @@ #:use-module (system base syntax) #:export (define-language language? lookup-language make-language language-name language-title language-version language-reader - language-printer language-parser language-read-file + language-printer language-parser language-compilers language-decompilers language-evaluator language-joiner @@ -42,7 +42,6 @@ reader printer (parser #f) - (read-file #f) (compilers '()) (decompilers '()) (evaluator #f) diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm index 902fc49a5..4777431e5 100644 --- a/module/system/base/pmatch.scm +++ b/module/system/base/pmatch.scm @@ -1,5 +1,4 @@ (define-module (system base pmatch) - #:use-module (ice-9 syncase) #:export (pmatch)) ;; FIXME: shouldn't have to export ppat... @@ -17,15 +16,15 @@ (let ((v (op arg ...))) (pmatch v cs ...))) ((_ v) (if #f #f)) - ((_ v (else e0 e ...)) (begin e0 e ...)) + ((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (pat (guard g ...) e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) (ppat v pat - (if (and g ...) (begin e0 e ...) (fk)) + (if (and g ...) (let () e0 e ...) (fk)) (fk)))) ((_ v (pat e0 e ...) cs ...) (let ((fk (lambda () (pmatch v cs ...)))) - (ppat v pat (begin e0 e ...) (fk)))))) + (ppat v pat (let () e0 e ...) (fk)))))) (define-syntax ppat (syntax-rules (_ quote unquote) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index ebf2b93d4..0a06e3dd0 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -89,7 +89,7 @@ (catch #t (lambda () (%start-stack #t thunk)) default-catch-handler - pre-unwind-handler-dispatch)) + default-pre-unwind-handler)) (define-macro (with-backtrace form) `(call-with-backtrace (lambda () ,form))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0b986d4a2..8ac209339 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -95,6 +95,7 @@ SCM_TESTS = tests/alist.test \ tests/syntax.test \ tests/threads.test \ tests/time.test \ + tests/tree-il.test \ tests/unif.test \ tests/version.test \ tests/weaks.test diff --git a/test-suite/lib.scm b/test-suite/lib.scm index c4ddf9e7c..3f09ce48a 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -317,20 +317,24 @@ (set! run-test local-run-test)) ;;; A short form for tests that are expected to pass, taken from Greg. -(defmacro pass-if (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (pass-if (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #t (lambda () ,name)) - `(run-test ,name #t (lambda () ,@rest)))) +(define-syntax pass-if + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (pass-if (even? 2)) + ;; where the body should also be the name. + (run-test 'name #t (lambda () name))) + ((_ name rest ...) + (run-test name #t (lambda () rest ...))))) ;;; A short form for tests that are expected to fail, taken from Greg. -(defmacro expect-fail (name . rest) - (if (and (null? rest) (pair? name)) - ;; presume this is a simple test, i.e. (expect-fail (even? 2)) - ;; where the body should also be the name. - `(run-test ',name #f (lambda () ,name)) - `(run-test ,name #f (lambda () ,@rest)))) +(define-syntax expect-fail + (syntax-rules () + ((_ name) + ;; presume this is a simple test, i.e. (expect-fail (even? 2)) + ;; where the body should also be the name. + (run-test 'name #f (lambda () name))) + ((_ name rest ...) + (run-test name #f (lambda () rest ...))))) ;;; A helper function to implement the macros that test for exceptions. (define (run-test-exception name exception expect-pass thunk) @@ -362,12 +366,16 @@ (apply throw key proc message rest)))))))) ;;; A short form for tests that expect a certain exception to be thrown. -(defmacro pass-if-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) +(define-syntax pass-if-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #t (lambda () body rest ...))))) ;;; A short form for tests expected to fail to throw a certain exception. -(defmacro expect-fail-exception (name exception body . rest) - `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) +(define-syntax expect-fail-exception + (syntax-rules () + ((_ name exception body rest ...) + (run-test-exception name exception #f (lambda () body rest ...))))) ;;;; TEST NAMES diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index d83167f34..7324d7795 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -18,45 +18,10 @@ (define-module (test-suite tests compiler) :use-module (test-suite lib) :use-module (test-suite guile-test) - :use-module (system vm program)) + :use-module (system base compile)) -(with-test-prefix "environments" +(with-test-prefix "basic" - (pass-if "compile-time-environment in evaluator" - (eq? (primitive-eval '(compile-time-environment)) #f)) - - (pass-if "compile-time-environment in compiler" - (equal? (compile '(compile-time-environment)) - (cons (current-module) - (cons '() '())))) - - (let ((env (compile - '(let ((x 0)) (set! x 1) (compile-time-environment))))) - (pass-if "compile-time-environment in compiler, heap-allocated var" - (equal? env - (cons (current-module) - (cons '((x . 0)) '(1))))) - - ;; fixme: compiling with #t or module - (pass-if "recompiling with environment" - (equal? ((compile '(lambda () x) #:env env)) - 1)) - - (pass-if "recompiling with environment/2" - (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env)) - 2)) - - (pass-if "recompiling with environment/3" - (equal? ((compile '(lambda () x) #:env env)) - 2)) - ) - - (pass-if "compile environment is #f" - (equal? ((compile '(lambda () 10))) - 10)) - - (pass-if "compile environment is a module" - (equal? ((compile '(lambda () 10) #:env (current-module))) - 10)) - ) \ No newline at end of file + (pass-if "compile to value" + (equal? (compile 1) 1))) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 7a22f0dff..e5ef34bb0 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -24,6 +24,9 @@ (define exception:bad-expression (cons 'syntax-error "Bad expression")) +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + ;;; ;;; miscellaneous @@ -85,17 +88,19 @@ ;; Macros are accepted as function parameters. ;; Functions that 'apply' macros are rewritten!!! - (expect-fail-exception "macro as argument" - exception:wrong-type-arg - (let ((f (lambda (p a b) (p a b)))) - (f and #t #t))) + (pass-if-exception "macro as argument" + exception:failed-match + (primitive-eval + '(let ((f (lambda (p a b) (p a b)))) + (f and #t #t)))) - (expect-fail-exception "passing macro as parameter" - exception:wrong-type-arg - (let* ((f (lambda (p a b) (p a b))) - (foo (procedure-source f))) - (f and #t #t) - (equal? (procedure-source f) foo))) + (pass-if-exception "passing macro as parameter" + exception:failed-match + (primitive-eval + '(let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo)))) )) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 0b6f9a468..bd34e4db0 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -35,6 +35,8 @@ (cons 'read-error "end of file in string constant$")) (define exception:illegal-escape (cons 'read-error "illegal character in escape sequence: .*$")) +(define exception:missing-expression + (cons 'read-error "no expression after #;")) (define (read-string s) @@ -194,3 +196,36 @@ (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0))))) +(with-test-prefix "#;" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#;foo 10". 10) + ("#;(10 20 30) foo" . foo) + ("#; (10 20 30) foo" . foo) + ("#;\n10\n20" . 20))) + + (pass-if "#;foo" + (eof-object? (with-input-from-string "#;foo" read))) + + (pass-if-exception "#;" + exception:missing-expression + (with-input-from-string "#;" read)) + (pass-if-exception "#;(" + exception:eof + (with-input-from-string "#;(" read))) + +(with-test-prefix "#'" + (for-each + (lambda (pair) + (pass-if (car pair) + (equal? (with-input-from-string (car pair) read) (cdr pair)))) + + '(("#'foo". (syntax foo)) + ("#`foo" . (quasisyntax foo)) + ("#,foo" . (unsyntax foo)) + ("#,@foo" . (unsyntax-splicing foo))))) + + diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index fbacb15a3..4841f2ef1 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -50,6 +50,9 @@ (define %some-variable #f) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) + (with-test-prefix "set!" (with-test-prefix "target is not procedure with setter" @@ -59,7 +62,7 @@ (set! (symbol->string 'x) 1)) (pass-if-exception "(set! '#f 1)" - exception:bad-variable + exception:bad-quote (eval '(set! '#f 1) (interaction-environment)))) (with-test-prefix "target uses macro" @@ -72,7 +75,7 @@ ;; The `(quote x)' below used to be memoized as an infinite list before ;; Guile 1.8.3. (pass-if-exception "(set! 'x 1)" - exception:bad-variable + exception:bad-quote (eval '(set! 'x 1) (interaction-environment))))) ;; diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index fa309e6ce..3c7090643 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -21,8 +21,13 @@ (define-module (test-suite test-srfi-18) #:use-module (test-suite lib)) -(and (provided? 'threads) - (use-modules (srfi srfi-18)) +;; two expressions so that the srfi-18 import is in effect for expansion +;; of the rest +(if (provided? 'threads) + (use-modules (srfi srfi-18))) + +(and + (provided? 'threads) (with-test-prefix "current-thread" diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index bd6977333..b23d3e20f 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -23,7 +23,7 @@ (with-test-prefix "rec special form" (pass-if-exception "bogus variable" '(misc-error . ".*") - (rec #:foo)) + (sc-expand '(rec #:foo))) (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 1277e5204..aa2e05127 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -21,6 +21,11 @@ :use-module (test-suite lib)) +(define exception:generic-syncase-error + (cons 'syntax-error "source expression failed to match")) +(define exception:unexpected-syntax + (cons 'syntax-error "unexpected syntax")) + (define exception:bad-expression (cons 'syntax-error "Bad expression")) @@ -29,22 +34,32 @@ (define exception:missing-expr (cons 'syntax-error "Missing expression")) (define exception:missing-body-expr - (cons 'syntax-error "Missing body expression")) + (cons 'syntax-error "no expressions in body")) (define exception:extra-expr (cons 'syntax-error "Extra expression")) (define exception:illegal-empty-combination (cons 'syntax-error "Illegal empty combination")) +(define exception:bad-lambda + '(syntax-error . "bad lambda")) +(define exception:bad-let + '(syntax-error . "bad let ")) +(define exception:bad-letrec + '(syntax-error . "bad letrec ")) +(define exception:bad-set! + '(syntax-error . "bad set!")) +(define exception:bad-quote + '(syntax-error . "quote: bad syntax")) (define exception:bad-bindings (cons 'syntax-error "Bad bindings")) (define exception:bad-binding (cons 'syntax-error "Bad binding")) (define exception:duplicate-binding - (cons 'syntax-error "Duplicate binding")) + (cons 'syntax-error "duplicate bound variable")) (define exception:bad-body (cons 'misc-error "^bad body")) (define exception:bad-formals - (cons 'syntax-error "Bad formals")) + '(syntax-error . "invalid parameter list")) (define exception:bad-formal (cons 'syntax-error "Bad formal")) (define exception:duplicate-formal @@ -67,13 +82,13 @@ (with-test-prefix "Bad argument list" (pass-if-exception "improper argument list of length 1" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo . 1)) (interaction-environment))) (pass-if-exception "improper argument list of length 2" - exception:wrong-num-args + exception:generic-syncase-error (eval '(let ((foo (lambda (x y) #t))) (foo 1 . 2)) (interaction-environment)))) @@ -88,7 +103,7 @@ ;; Fixed on 2001-3-3 (pass-if-exception "empty parentheses \"()\"" - exception:illegal-empty-combination + exception:unexpected-syntax (eval '() (interaction-environment))))) @@ -106,28 +121,32 @@ (with-test-prefix "unquote-splicing" (pass-if-exception "extra arguments" - exception:missing/extra-expr - (quasiquote ((unquote-splicing (list 1 2) (list 3 4))))))) + '(syntax-error . "unquote-splicing takes exactly one argument") + (eval '(quasiquote ((unquote-splicing (list 1 2) (list 3 4)))) + (interaction-environment))))) (with-test-prefix "begin" (pass-if "legal (begin)" - (begin) - #t) + (eval '(begin (begin) #t) (interaction-environment))) (with-test-prefix "unmemoization" + ;; FIXME. I have no idea why, but the expander is filling in (if #f + ;; #f) as the second arm of the if, if the second arm is missing. I + ;; thought I made it not do that. But in the meantime, let's adapt, + ;; since that's not what we're testing. + (pass-if "normal begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))) - (foo) ; make sure, memoization has been performed + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f)))) (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)) #f))))) (pass-if "redundant nested begin" - (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))) + (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))) + '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))) #f))))) (pass-if "redundant begin at start of body" (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized @@ -135,10 +154,20 @@ (equal? (procedure-source foo) '(lambda () (begin (+ 1) (+ 2))))))) - (expect-fail-exception "illegal (begin)" - exception:bad-body - (if #t (begin)) - #t)) + (pass-if-exception "illegal (begin)" + exception:generic-syncase-error + (eval '(begin (if #t (begin)) #t) (interaction-environment)))) + +(define-syntax matches? + (syntax-rules (_) + ((_ (op arg ...) pat) (let ((x (op arg ...))) + (matches? x pat))) + ((_ x ()) (null? x)) + ((_ x (a . b)) (and (pair? x) + (matches? (car x) a) + (matches? (cdr x) b))) + ((_ x _) #t) + ((_ x pat) (equal? x 'pat)))) (with-test-prefix "lambda" @@ -146,30 +175,28 @@ (pass-if "normal lambda" (let ((foo (lambda () (lambda (x y) (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) (+ _ _)))))) (pass-if "lambda with documentation" (let ((foo (lambda () (lambda (x y) "docstring" (+ x y))))) - ((foo) 1 2) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (lambda (x y) "docstring" (+ x y))))))) + (matches? (procedure-source foo) + (lambda () (lambda (_ _) "docstring" (+ _ _))))))) (with-test-prefix "bad formals" (pass-if-exception "(lambda)" - exception:missing-expr + exception:bad-lambda (eval '(lambda) (interaction-environment))) (pass-if-exception "(lambda . \"foo\")" - exception:bad-expression + exception:bad-lambda (eval '(lambda . "foo") (interaction-environment))) (pass-if-exception "(lambda \"foo\")" - exception:missing-expr + exception:bad-lambda (eval '(lambda "foo") (interaction-environment))) @@ -179,22 +206,22 @@ (interaction-environment))) (pass-if-exception "(lambda (x 1) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x 1) 2) (interaction-environment))) (pass-if-exception "(lambda (1 x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (1 x) 2) (interaction-environment))) (pass-if-exception "(lambda (x \"a\") 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda (x "a") 2) (interaction-environment))) (pass-if-exception "(lambda (\"a\" x) 2)" - exception:bad-formal + exception:bad-formals (eval '(lambda ("a" x) 2) (interaction-environment)))) @@ -202,20 +229,20 @@ ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x) 1) (interaction-environment))) ;; Fixed on 2001-3-3 (pass-if-exception "(lambda (x x x) 1)" - exception:duplicate-formal + exception:bad-formals (eval '(lambda (x x x) 1) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(lambda ())" - exception:missing-expr + exception:bad-lambda (eval '(lambda ()) (interaction-environment))))) @@ -225,9 +252,8 @@ (pass-if "normal let" (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -238,42 +264,42 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let)" - exception:missing-expr + exception:bad-let (eval '(let) (interaction-environment))) (pass-if-exception "(let 1)" - exception:missing-expr + exception:bad-let (eval '(let 1) (interaction-environment))) (pass-if-exception "(let (x))" - exception:missing-expr + exception:bad-let (eval '(let (x)) (interaction-environment))) (pass-if-exception "(let ((x)))" - exception:missing-expr + exception:bad-let (eval '(let ((x))) (interaction-environment))) (pass-if-exception "(let (x) 1)" - exception:bad-binding + exception:bad-let (eval '(let (x) 1) (interaction-environment))) (pass-if-exception "(let ((x)) 3)" - exception:bad-binding + exception:bad-let (eval '(let ((x)) 3) (interaction-environment))) (pass-if-exception "(let ((x 1) y) x)" - exception:bad-binding + exception:bad-let (eval '(let ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let ((1 2)) 3)" - exception:bad-variable + exception:bad-let (eval '(let ((1 2)) 3) (interaction-environment)))) @@ -287,12 +313,12 @@ (with-test-prefix "bad body" (pass-if-exception "(let ())" - exception:missing-expr + exception:bad-let (eval '(let ()) (interaction-environment))) (pass-if-exception "(let ((x 1)))" - exception:missing-expr + exception:bad-let (eval '(let ((x 1))) (interaction-environment))))) @@ -307,19 +333,19 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let x (y))" - exception:missing-expr + exception:bad-let (eval '(let x (y)) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let x ())" - exception:missing-expr + exception:bad-let (eval '(let x ()) (interaction-environment))) (pass-if-exception "(let x ((y 1)))" - exception:missing-expr + exception:bad-let (eval '(let x ((y 1))) (interaction-environment))))) @@ -329,19 +355,16 @@ (pass-if "normal let*" (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let* ((x 1) (y 2)) (+ x y)))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1)) (let ((_ 2)) (+ _ _))))))) (pass-if "let* without bindings" (let ((foo (lambda () (let ((x 1) (y 2)) (let* () (and (= x 1) (= y 2))))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (let ((x 1) (y 2)) - (let* () - (and (= x 1) (= y 2))))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ 1) (_ 2)) + (if (= _ 1) (= _ 2) #f))))))) (with-test-prefix "bindings" @@ -361,59 +384,59 @@ (with-test-prefix "bad bindings" (pass-if-exception "(let*)" - exception:missing-expr + exception:generic-syncase-error (eval '(let*) (interaction-environment))) (pass-if-exception "(let* 1)" - exception:missing-expr + exception:generic-syncase-error (eval '(let* 1) (interaction-environment))) (pass-if-exception "(let* (x))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* (x)) (interaction-environment))) (pass-if-exception "(let* (x) 1)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* (x) 1) (interaction-environment))) (pass-if-exception "(let* ((x)) 3)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x)) 3) (interaction-environment))) (pass-if-exception "(let* ((x 1) y) x)" - exception:bad-binding + exception:generic-syncase-error (eval '(let* ((x 1) y) x) (interaction-environment))) (pass-if-exception "(let* x ())" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x ()) (interaction-environment))) (pass-if-exception "(let* x (y))" - exception:bad-bindings + exception:generic-syncase-error (eval '(let* x (y)) (interaction-environment))) (pass-if-exception "(let* ((1 2)) 3)" - exception:bad-variable + exception:generic-syncase-error (eval '(let* ((1 2)) 3) (interaction-environment)))) (with-test-prefix "bad body" (pass-if-exception "(let* ())" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ()) (interaction-environment))) (pass-if-exception "(let* ((x 1)))" - exception:missing-expr + exception:generic-syncase-error (eval '(let* ((x 1))) (interaction-environment))))) @@ -423,9 +446,8 @@ (pass-if "normal letrec" (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (letrec ((i 1) (j 2)) (+ i j))))))) + (matches? (procedure-source foo) + (lambda () (letrec ((_ 1) (_ 2)) (+ _ _))))))) (with-test-prefix "bindings" @@ -437,47 +459,47 @@ (with-test-prefix "bad bindings" (pass-if-exception "(letrec)" - exception:missing-expr + exception:bad-letrec (eval '(letrec) (interaction-environment))) (pass-if-exception "(letrec 1)" - exception:missing-expr + exception:bad-letrec (eval '(letrec 1) (interaction-environment))) (pass-if-exception "(letrec (x))" - exception:missing-expr + exception:bad-letrec (eval '(letrec (x)) (interaction-environment))) (pass-if-exception "(letrec (x) 1)" - exception:bad-binding + exception:bad-letrec (eval '(letrec (x) 1) (interaction-environment))) (pass-if-exception "(letrec ((x)) 3)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x)) 3) (interaction-environment))) (pass-if-exception "(letrec ((x 1) y) x)" - exception:bad-binding + exception:bad-letrec (eval '(letrec ((x 1) y) x) (interaction-environment))) (pass-if-exception "(letrec x ())" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x ()) (interaction-environment))) (pass-if-exception "(letrec x (y))" - exception:bad-bindings + exception:bad-letrec (eval '(letrec x (y)) (interaction-environment))) (pass-if-exception "(letrec ((1 2)) 3)" - exception:bad-variable + exception:bad-letrec (eval '(letrec ((1 2)) 3) (interaction-environment)))) @@ -491,12 +513,12 @@ (with-test-prefix "bad body" (pass-if-exception "(letrec ())" - exception:missing-expr + exception:bad-letrec (eval '(letrec ()) (interaction-environment))) (pass-if-exception "(letrec ((x 1)))" - exception:missing-expr + exception:bad-letrec (eval '(letrec ((x 1))) (interaction-environment))))) @@ -508,17 +530,17 @@ (let ((foo (lambda (x) (if x (+ 1) (+ 2))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (if x (+ 1) (+ 2)))))) + (matches? (procedure-source foo) + (lambda (_) (if _ (+ 1) (+ 2)))))) - (pass-if "if without else" + (expect-fail "if without else" (let ((foo (lambda (x) (if x (+ 1))))) (foo #t) ; make sure, memoization has been performed (foo #f) ; make sure, memoization has been performed (equal? (procedure-source foo) '(lambda (x) (if x (+ 1)))))) - (pass-if "if #f without else" + (expect-fail "if #f without else" (let ((foo (lambda () (if #f #f)))) (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) @@ -527,12 +549,12 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(if)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if) (interaction-environment))) (pass-if-exception "(if 1 2 3 4)" - exception:missing/extra-expr + exception:generic-syncase-error (eval '(if 1 2 3 4) (interaction-environment))))) @@ -594,78 +616,77 @@ (eq? 'ok (cond (#t identity =>) (else #f))))) (pass-if-exception "missing recipient" - '(syntax-error . "Missing recipient") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity =>))) (pass-if-exception "extra recipient" - '(syntax-error . "Extra expression") + '(syntax-error . "cond: wrong number of receiver expressions") (cond (#t identity => identity identity)))) (with-test-prefix "unmemoization" + ;; FIXME: the (if #f #f) is a hack! (pass-if "normal clauses" - (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed + (let ((foo (lambda () (cond ((= x 1) 'bar) ((= x 2) 'baz))))) (equal? (procedure-source foo) - '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))) + '(lambda () (if (= x 1) 'bar (if (= x 2) 'baz (if #f #f))))))) (pass-if "else" (let ((foo (lambda () (cond (else 'bar))))) - (foo) ; make sure, memoization has been performed (equal? (procedure-source foo) - '(lambda () (cond (else 'bar)))))) + '(lambda () 'bar)))) + ;; FIXME: the (if #f #f) is a hack! (pass-if "=>" (let ((foo (lambda () (cond (#t => identity))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (cond (#t => identity))))))) + (matches? (procedure-source foo) + (lambda () (let ((_ #t)) + (if _ (identity _) (if #f #f)))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(cond)" - exception:missing-clauses + exception:generic-syncase-error (eval '(cond) (interaction-environment))) (pass-if-exception "(cond #t)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond #t) (interaction-environment))) (pass-if-exception "(cond 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1) (interaction-environment))) (pass-if-exception "(cond 1 2)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2) (interaction-environment))) (pass-if-exception "(cond 1 2 3)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3) (interaction-environment))) (pass-if-exception "(cond 1 2 3 4)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond 1 2 3 4) (interaction-environment))) (pass-if-exception "(cond ())" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond ()) (interaction-environment))) (pass-if-exception "(cond () 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond () 1) (interaction-environment))) (pass-if-exception "(cond (1) 1)" - exception:bad-cond-clause + exception:generic-syncase-error (eval '(cond (1) 1) (interaction-environment)))) @@ -683,7 +704,7 @@ (with-test-prefix "case is hygienic" (pass-if-exception "bound 'else is handled correctly" - exception:bad-case-labels + exception:generic-syncase-error (eval '(let ((else #f)) (case 1 (else #f))) (interaction-environment)))) @@ -691,79 +712,83 @@ (pass-if "normal clauses" (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '(2)) + 'baz + 'foobar)))))) (pass-if "empty labels" (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))) - (foo 1) ; make sure, memoization has been performed - (foo 2) ; make sure, memoization has been performed - (foo 3) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar))))))) + (matches? (procedure-source foo) + (lambda (_) + (if ((@@ (guile) memv) _ '(1)) + 'bar + (if ((@@ (guile) memv) _ '()) + 'baz + 'foobar))))))) (with-test-prefix "bad or missing clauses" (pass-if-exception "(case)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case) (interaction-environment))) (pass-if-exception "(case . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case . "foo") (interaction-environment))) (pass-if-exception "(case 1)" - exception:missing-clauses + exception:generic-syncase-error (eval '(case 1) (interaction-environment))) (pass-if-exception "(case 1 . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 . "foo") (interaction-environment))) (pass-if-exception "(case 1 \"foo\")" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 "foo") (interaction-environment))) (pass-if-exception "(case 1 ())" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ()) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\"))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ("foo")) (interaction-environment))) (pass-if-exception "(case 1 (\"foo\" \"bar\"))" - exception:bad-case-labels + exception:generic-syncase-error (eval '(case 1 ("foo" "bar")) (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 ((2) "bar") . "foo") (interaction-environment))) (pass-if-exception "(case 1 ((2) \"bar\") (else))" - exception:bad-case-clause + exception:generic-syncase-error (eval '(case 1 ((2) "bar") (else)) (interaction-environment))) (pass-if-exception "(case 1 (else #f) . \"foo\")" - exception:bad-expression + exception:generic-syncase-error (eval '(case 1 (else #f) . "foo") (interaction-environment))) (pass-if-exception "(case 1 (else #f) ((1) #t))" - exception:misplaced-else-clause + exception:generic-syncase-error (eval '(case 1 (else #f) ((1) #t)) (interaction-environment))))) @@ -780,14 +805,6 @@ (eval '(define round round) m) (eq? (module-ref m 'round) round))) - (with-test-prefix "currying" - - (pass-if "(define ((foo)) #f)" - (eval '(begin - (define ((foo)) #t) - ((foo))) - (interaction-environment)))) - (with-test-prefix "unmemoization" (pass-if "definition unmemoized without prior execution" @@ -809,7 +826,7 @@ (with-test-prefix "missing or extra expressions" (pass-if-exception "(define)" - exception:missing-expr + exception:generic-syncase-error (eval '(define) (interaction-environment))))) @@ -886,34 +903,10 @@ 'ok) (bar)) (foo) - (equal? + (matches? (procedure-source foo) - '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar))))) - (interaction-environment)))) - -(with-test-prefix "do" - - (with-test-prefix "unmemoization" - - (pass-if "normal case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) - ((> i 9) (+ i j)) - (identity i)))))) - - (pass-if "reduced case" - (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j - ((> i 9) (+ i j)) - (identity i))))) - (foo) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here - ((> i 9) (+ i j)) - (identity i)))))))) + (lambda () (letrec ((_ (lambda () (quote ok)))) (_))))) + (current-module)))) (with-test-prefix "set!" @@ -922,50 +915,50 @@ (pass-if "normal set!" (let ((foo (lambda (x) (set! x (+ 1 x))))) (foo 1) ; make sure, memoization has been performed - (equal? (procedure-source foo) - '(lambda (x) (set! x (+ 1 x))))))) + (matches? (procedure-source foo) + (lambda (_) (set! _ (+ 1 _))))))) (with-test-prefix "missing or extra expressions" (pass-if-exception "(set!)" - exception:missing/extra-expr + exception:bad-set! (eval '(set!) (interaction-environment))) (pass-if-exception "(set! 1)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1) (interaction-environment))) (pass-if-exception "(set! 1 2 3)" - exception:missing/extra-expr + exception:bad-set! (eval '(set! 1 2 3) (interaction-environment)))) (with-test-prefix "bad variable" (pass-if-exception "(set! \"\" #t)" - exception:bad-variable + exception:bad-set! (eval '(set! "" #t) (interaction-environment))) (pass-if-exception "(set! 1 #t)" - exception:bad-variable + exception:bad-set! (eval '(set! 1 #t) (interaction-environment))) (pass-if-exception "(set! #t #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #t #f) (interaction-environment))) (pass-if-exception "(set! #f #t)" - exception:bad-variable + exception:bad-set! (eval '(set! #f #t) (interaction-environment))) (pass-if-exception "(set! #\\space #f)" - exception:bad-variable + exception:bad-set! (eval '(set! #\space #f) (interaction-environment))))) @@ -974,12 +967,12 @@ (with-test-prefix "missing or extra expression" (pass-if-exception "(quote)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote) (interaction-environment))) (pass-if-exception "(quote a b)" - exception:missing/extra-expr + exception:bad-quote (eval '(quote a b) (interaction-environment))))) @@ -1010,46 +1003,27 @@ (do ((n 0 (1+ n))) ((> n 5)) (pass-if n - (let ((cond (make-iterations-cond n))) - (while (cond))) - #t))) + (eval `(letrec ((make-iterations-cond + (lambda (n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))))) + (let ((cond (make-iterations-cond ,n))) + (while (cond)) + #t)) + (interaction-environment))))) (pass-if "initially false" (while #f (unreachable)) #t) - (with-test-prefix "in empty environment" - - ;; an environment with no bindings at all - (define empty-environment - (make-module 1)) - - ;; these tests are 'unresolved because to work with ice-9 syncase it was - ;; necessary to drop the unquote from `do' in the implementation, and - ;; unfortunately that makes `while' depend on its evaluation environment - - (pass-if "empty body" - (throw 'unresolved) - (eval `(,while #f) - empty-environment) - #t) - - (pass-if "initially false" - (throw 'unresolved) - (eval `(,while #f - #f) - empty-environment) - #t) - - (pass-if "iterating" - (throw 'unresolved) - (let ((cond (make-iterations-cond 3))) - (eval `(,while (,cond) - 123 456) - empty-environment)) - #t)) - (with-test-prefix "iterations" (do ((n 0 (1+ n))) ((> n 5)) @@ -1063,8 +1037,9 @@ (with-test-prefix "break" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (break 1))) + (eval '(while #t + (break 1)) + (interaction-environment))) (with-test-prefix "from cond" (pass-if "first" @@ -1135,8 +1110,9 @@ (with-test-prefix "continue" (pass-if-exception "too many args" exception:wrong-num-args - (while #t - (continue 1))) + (eval '(while #t + (continue 1)) + (interaction-environment))) (with-test-prefix "from cond" (do ((n 0 (1+ n))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test new file mode 100644 index 000000000..18b67d6c8 --- /dev/null +++ b/test-suite/tests/tree-il.test @@ -0,0 +1,467 @@ +;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- +;;;; Andy Wingo --- May 2009 +;;;; +;;;; Copyright (C) 2009 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 2.1 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 (test-suite tree-il) + #:use-module (test-suite lib) + #:use-module (system base compile) + #:use-module (system base pmatch) + #:use-module (language tree-il) + #:use-module (language glil)) + +;; Of course, the GLIL that is emitted depends on the source info of the +;; input. Here we're not concerned about that, so we strip source +;; information from the incoming tree-il. + +(define (strip-source x) + (post-order! (lambda (x) (set! (tree-il-src x) #f)) + x)) + +(define-syntax assert-scheme->glil + (syntax-rules () + ((_ in out) + (let ((tree-il (strip-source + (compile 'in #:from 'scheme #:to 'tree-il)))) + (pass-if 'in + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil + (syntax-rules () + ((_ in out) + (pass-if 'in + (let ((tree-il (strip-source (parse-tree-il 'in)))) + (equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil)) + 'out)))))) + +(define-syntax assert-tree-il->glil/pmatch + (syntax-rules () + ((_ in pat test ...) + (let ((exp 'in)) + (pass-if 'in + (let ((glil (unparse-glil + (compile (strip-source (parse-tree-il exp)) + #:from 'tree-il #:to 'glil)))) + (pmatch glil + (pat (guard test ...) #t) + (else #f)))))))) + +(with-test-prefix "void" + (assert-tree-il->glil + (void) + (program 0 0 0 0 () (void) (call return 1))) + (assert-tree-il->glil + (begin (void) (const 1)) + (program 0 0 0 0 () (const 1) (call return 1))) + (assert-tree-il->glil + (apply (primitive +) (void) (const 1)) + (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1)))) + +(with-test-prefix "application" + (assert-tree-il->glil + (apply (toplevel foo) (const 1)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1))) + (assert-tree-il->glil/pmatch + (begin (apply (toplevel foo) (const 1)) (void)) + (program 0 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) + (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (void) (call return 1)) + (and (eq? l1 l3) (eq? l2 l4))) + (assert-tree-il->glil + (apply (toplevel foo) (apply (toplevel bar))) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0) + (call goto/args 1)))) + +(with-test-prefix "conditional" + (assert-tree-il->glil/pmatch + (if (const #t) (const 1) (const 2)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (call return 1) + (label ,l2) (const 2) (call return 1)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (begin (if (const #t) (const 1) (const 2)) (const #f)) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2) + (label ,l3) (label ,l4) (const #f) (call return 1)) + (eq? l1 l3) (eq? l2 l4)) + + (assert-tree-il->glil/pmatch + (apply (primitive null?) (if (const #t) (const 1) (const 2))) + (program 0 0 0 0 () (const #t) (branch br-if-not ,l1) + (const 1) (branch br ,l2) + (label ,l3) (const 2) (label ,l4) + (call null? 1) (call return 1)) + (eq? l1 l3) (eq? l2 l4))) + +(with-test-prefix "primitive-ref" + (assert-tree-il->glil + (primitive +) + (program 0 0 0 0 () (toplevel ref +) (call return 1))) + + (assert-tree-il->glil + (begin (primitive +) (const #f)) + (program 0 0 0 0 () (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (primitive +)) + (program 0 0 0 0 () (toplevel ref +) (call null? 1) + (call return 1)))) + +(with-test-prefix "lexical refs" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (lexical x y)) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "lexical sets" + (assert-tree-il->glil + (let (x) (y) ((const 1)) (set! (lexical x y) (const 2))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (const #f) (call return 1) + (unbind))) + + (assert-tree-il->glil + (let (x) (y) ((const 1)) + (apply (primitive null?) (set! (lexical x y) (const 2)))) + (program 0 0 0 1 () + (const 1) (bind (x external 0)) (external set 0 0) + (const 2) (external set 0 0) (void) (call null? 1) (call return 1) + (unbind)))) + +(with-test-prefix "module refs" + (assert-tree-il->glil + (@ (foo) bar) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module public ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@ (foo) bar)) + (program 0 0 0 0 () + (module public ref (foo) bar) + (call null? 1) (call return 1))) + + (assert-tree-il->glil + (@@ (foo) bar) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call return 1))) + + (assert-tree-il->glil + (begin (@@ (foo) bar) (const #f)) + (program 0 0 0 0 () + (module private ref (foo) bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (@@ (foo) bar)) + (program 0 0 0 0 () + (module private ref (foo) bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "module sets" + (assert-tree-il->glil + (set! (@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module public set (foo) bar) + (void) (call null? 1) (call return 1))) + + (assert-tree-il->glil + (set! (@@ (foo) bar) (const 2)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (@@ (foo) bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (program 0 0 0 0 () + (const 2) (module private set (foo) bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel refs" + (assert-tree-il->glil + (toplevel bar) + (program 0 0 0 0 () + (toplevel ref bar) + (call return 1))) + + (assert-tree-il->glil + (begin (toplevel bar) (const #f)) + (program 0 0 0 0 () + (toplevel ref bar) (call drop 1) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (toplevel bar)) + (program 0 0 0 0 () + (toplevel ref bar) + (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel sets" + (assert-tree-il->glil + (set! (toplevel bar) (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (set! (toplevel bar) (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (set! (toplevel bar) (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel set bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "toplevel defines" + (assert-tree-il->glil + (define bar (const 2)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call return 1))) + + (assert-tree-il->glil + (begin (define bar (const 2)) (const #f)) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (define bar (const 2))) + (program 0 0 0 0 () + (const 2) (toplevel define bar) + (void) (call null? 1) (call return 1)))) + +(with-test-prefix "constants" + (assert-tree-il->glil + (const 2) + (program 0 0 0 0 () + (const 2) (call return 1))) + + (assert-tree-il->glil + (begin (const 2) (const #f)) + (program 0 0 0 0 () + (const #f) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (const 2)) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +(with-test-prefix "lambda" + (assert-tree-il->glil + (lambda (x) (y) () (const 2)) + (program 0 0 0 0 () + (program 1 0 0 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x x1) (y y1) () (const 2)) + (program 0 0 0 0 () + (program 2 0 0 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda x y () (const 2)) + (program 0 0 0 0 () + (program 1 1 0 0 () + (bind (x local 0)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (const 2)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (const 2) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x y)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (local ref 0) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x . x1) (y . y1) () (lexical x1 y1)) + (program 0 0 0 0 () + (program 2 1 0 0 () + (bind (x local 0) (x1 local 1)) + (local ref 1) (call return 1)) + (call return 1))) + + (assert-tree-il->glil + (lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1))) + (program 0 0 0 0 () + (program 1 0 0 1 () + (bind (x external 0)) + (local ref 0) (external set 0 0) + (program 1 0 0 0 () + (bind (y local 0)) + (external ref 1 0) (call return 1)) + (call return 1)) + (call return 1)))) + +(with-test-prefix "sequence" + (assert-tree-il->glil + (begin (begin (const 2) (const #f)) (const #t)) + (program 0 0 0 0 () + (const #t) (call return 1))) + + (assert-tree-il->glil + (apply (primitive null?) (begin (const #f) (const 2))) + (program 0 0 0 0 () + (const 2) (call null? 1) (call return 1)))) + +;; FIXME: binding info for or-hacked locals might bork the disassembler, +;; and could be tightened in any case +(with-test-prefix "the or hack" + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical a b)))) + (program 0 0 1 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 0)) (local set 0) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2)) + + (assert-tree-il->glil/pmatch + (let (x) (y) ((const 1)) + (if (lexical x y) + (lexical x y) + (let (a) (b) ((const 2)) + (lexical x y)))) + (program 0 0 2 0 () + (const 1) (bind (x local 0)) (local set 0) + (local ref 0) (branch br-if-not ,l1) + (local ref 0) (call return 1) + (label ,l2) + (const 2) (bind (a local 1)) (local set 1) + (local ref 0) (call return 1) + (unbind) + (unbind)) + (eq? l1 l2))) + +(with-test-prefix "apply" + (assert-tree-il->glil + (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (program 0 0 0 0 () + (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (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))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (toplevel ref baz) (call apply 2) + (call goto/args 1)))) + +(with-test-prefix "call/cc" + (assert-tree-il->glil + (apply (primitive @call-with-current-continuation) (toplevel foo)) + (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1))) + (assert-tree-il->glil/pmatch + (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (program 0 0 0 0 () + (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) + (call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind) + (label ,l4) + (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))) + (program 0 0 0 0 () + (toplevel ref foo) + (toplevel ref bar) (call call/cc 1) + (call goto/args 1)))) + diff --git a/testsuite/t-match.scm b/testsuite/t-match.scm index 4b85f30d3..ed56ae7ef 100644 --- a/testsuite/t-match.scm +++ b/testsuite/t-match.scm @@ -12,7 +12,7 @@ (define (matches? obj) ; (format #t "matches? ~a~%" obj) (match obj - (($ stuff) => #t) + (($ stuff) #t) ; (blurps #t) ("hello" #t) (else #f)))