[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-84-gde
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-84-gde45d8e |
|
Date: |
Sun, 02 May 2010 12:07:17 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=de45d8eef9dc16c3020219886a7e5fd11a553fbb
The branch, master has been updated
via de45d8eef9dc16c3020219886a7e5fd11a553fbb (commit)
via 384dce46bf2313f9c429984b4e7cefe9d14fbcee (commit)
via ba2d960396c692986ee42274dc7f1d7eb72a9c89 (commit)
via 41e64dd73c687400c3d88a974069d1676b26b6d7 (commit)
via 93f63467e6e9d2f0203fd1c54a98539f5fefeba0 (commit)
via 915aca30baccaf646752d84f11d4e461ca24391a (commit)
via 246ea9e16a173a0ddd8e95b49087e0b0fd27232c (commit)
from acc51c3e653f60459ca1334625966aca89080ce3 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit de45d8eef9dc16c3020219886a7e5fd11a553fbb
Author: Andy Wingo <address@hidden>
Date: Sun May 2 13:41:31 2010 +0200
add assert-nargs-ee/locals instruction
* libguile/vm-i-system.c (assert-nargs-ee/locals): New instruction, a
combination of assert-nargs-ee and reserve-locals in the case in which
nreq and nlocs can both be represented in 8 bits.
* module/language/glil/compile-assembly.scm (glil->assembly): Add
compiler case.
* doc/ref/vm.texi (Function Prologue Instructions): Update docs.
commit 384dce46bf2313f9c429984b4e7cefe9d14fbcee
Author: Andy Wingo <address@hidden>
Date: Sun May 2 13:15:22 2010 +0200
add underflow check in make-array
* libguile/vm-i-scheme.c (make-array): Check for underflow before making
the array.
commit ba2d960396c692986ee42274dc7f1d7eb72a9c89
Author: Andy Wingo <address@hidden>
Date: Sun May 2 13:14:58 2010 +0200
add SCM_UNLIKELY to CHECK_UNDERFLOW
* libguile/vm-engine.h (CHECK_OVERFLOW, CHECK_UNDERFLOW): Add
SCM_UNLIKELY blocks. Fix off-by-one error in CHECK_UNDERFLOW.
(PRE_CHECK_UNDERFLOW): New macro, for checking underflow before
accessing the current sp.
(POP): Use PRE_CHECK_UNDERFLOW.
commit 41e64dd73c687400c3d88a974069d1676b26b6d7
Author: Andy Wingo <address@hidden>
Date: Sun May 2 12:46:50 2010 +0200
update compiler.texi
* doc/ref/compiler.texi (Compiler Tower): Update for removal of version
from <language>, and add joiner and make-default-environment fields.
Update examples.
(The Scheme Compiler): Update for `macroexpand' instead of
`sc-expand', and that the environment must be a module.
(Tree-IL): Update for new Tree-IL, and change from "vars" to
"gensyms".
(GLIL): Update for new GLIL, including preludes and prompts.
(Assembly): Update for current output (which seems quite verbose).
(Bytecode and Objcode): Update for current output, and some procedure
name changes.
commit 93f63467e6e9d2f0203fd1c54a98539f5fefeba0
Author: Andy Wingo <address@hidden>
Date: Sun May 2 11:22:23 2010 +0200
rename `vars' field in tree-il binding constructs to `gensyms'
* module/language/tree-il.scm (<tree-il>): Rename `vars' fields of
<let>, <letrec>, <fix>, and <lambda-case> to `gensyms'. For clarity,
and to match <lexical-ref>.
* module/language/tree-il.scm:
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm: Update all callers.
commit 915aca30baccaf646752d84f11d4e461ca24391a
Author: Andy Wingo <address@hidden>
Date: Sun May 2 11:19:46 2010 +0200
fix a comment about environments and the scheme compiler
* module/language/scheme/compile-tree-il.scm: Fix a comment about the
format of environments.
commit 246ea9e16a173a0ddd8e95b49087e0b0fd27232c
Author: Andy Wingo <address@hidden>
Date: Sun May 2 11:19:13 2010 +0200
remove `version' field from <language>
* module/system/base/language.scm (<language>): Remove the `version'
field from languages. It just wasn't useful.
* module/language/assembly/spec.scm:
* module/language/brainfuck/spec.scm:
* module/language/bytecode/spec.scm:
* module/language/ecmascript/spec.scm:
* module/language/elisp/spec.scm:
* module/language/glil/spec.scm:
* module/language/objcode/spec.scm:
* module/language/scheme/spec.scm:
* module/language/tree-il/spec.scm:
* module/language/value/spec.scm: Remove #:version from all language
definitions. Shorten some language names (e.g. "Guile Scheme" ->
"Scheme").
-----------------------------------------------------------------------
Summary of changes:
doc/ref/compiler.texi | 345 +++++++++++++++++-----------
doc/ref/vm.texi | 8 +
libguile/vm-engine.h | 12 +-
libguile/vm-i-scheme.c | 1 +
libguile/vm-i-system.c | 20 ++
module/language/assembly/spec.scm | 3 +-
module/language/brainfuck/spec.scm | 5 +-
module/language/bytecode/spec.scm | 3 +-
module/language/ecmascript/spec.scm | 5 +-
module/language/elisp/spec.scm | 3 +-
module/language/glil/compile-assembly.scm | 18 +-
module/language/glil/spec.scm | 3 +-
module/language/objcode/spec.scm | 1 -
module/language/scheme/compile-tree-il.scm | 3 +-
module/language/scheme/spec.scm | 5 +-
module/language/tree-il.scm | 74 +++---
module/language/tree-il/analyze.scm | 150 ++++++------
module/language/tree-il/compile-glil.scm | 92 ++++----
module/language/tree-il/fix-letrec.scm | 80 ++++----
module/language/tree-il/inline.scm | 36 ++--
module/language/tree-il/spec.scm | 3 +-
module/language/value/spec.scm | 5 +-
module/system/base/language.scm | 5 +-
23 files changed, 485 insertions(+), 395 deletions(-)
diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi
index 637bc42..eb81abd 100644
--- a/doc/ref/compiler.texi
+++ b/doc/ref/compiler.texi
@@ -53,8 +53,9 @@ Languages are registered in the module, @code{(system base
language)}:
They are registered with the @code{define-language} form.
@deffn {Scheme Syntax} define-language @
-name title version reader printer @
-[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f]
+name title reader printer @
+[parser=#f] [compilers='()] [decompilers='()] [evaluator=#f] @
+[joiner=#f] [make-default-environment=make-fresh-user-module]
Define a language.
This syntax defines a @code{#<language>} object, bound to @var{name}
@@ -64,13 +65,13 @@ for Scheme:
@example
(define-language scheme
- #:title "Guile Scheme"
- #:version "0.5"
- #:reader read
+ #:title "Scheme"
+ #:reader (lambda (port env) ...)
#:compilers `((tree-il . ,compile-tree-il))
#:decompilers `((tree-il . ,decompile-tree-il))
- #:evaluator (lambda (x module) (primitive-eval x))
- #:printer write)
+ #:evaluator (lambda (x module) (primitive-eval x))
+ #:printer write
+ #:make-default-environment (lambda () ...))
@end example
@end deffn
@@ -79,17 +80,11 @@ they present a uniform interface to the read-eval-print
loop. This
allows the user to change the current language of the REPL:
@example
-$ guile
-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 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.
-tree-il@@(guile-user)>
+Happy hacking with Tree Intermediate Language! To switch back, type `,L
scheme'.
+tree-il@@(guile-user)> ,L scheme
+Happy hacking with Scheme! To switch back, type `,L tree-il'.
+scheme@@(guile-user)>
@end example
Languages can be looked up by name, as they were above.
@@ -126,9 +121,9 @@ and target languages.
The normal tower of languages when compiling Scheme goes like this:
@itemize
address@hidden Scheme, which we know and love
address@hidden Scheme
@item Tree Intermediate Language (Tree-IL)
address@hidden Guile Low Intermediate Language (GLIL)
address@hidden Guile Lowlevel Intermediate Language (GLIL)
@item Assembly
@item Bytecode
@item Objcode
@@ -195,14 +190,14 @@ The Scheme-to-Tree-IL expander may be invoked using the
generic
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
address@hidden(sc-expand '(+ 1 2) 'c)}, where the @code{'c} is for
address@hidden(macroexpand '(+ 1 2) 'c)}, where the @code{'c} is for
``compile''. With @code{'e} (the default), the result is translated
back to Scheme:
@lisp
-(sc-expand '(+ 1 2))
+(macroexpand '(+ 1 2))
@result{} (+ 1 2)
-(sc-expand '(let ((x 10)) (* x x)))
+(macroexpand '(let ((x 10)) (* x x)))
@result{} (let ((x84 10)) (* x84 x84))
@end lisp
@@ -214,9 +209,9 @@ lexical binding only has one name. It is for this reason
that the
much information we would lose if we translated to Scheme directly:
lexical variable names, source locations, and module hygiene.
-Note however that @code{sc-expand} does not have the same signature as
address@hidden @code{compile-tree-il} is a small wrapper
-around @code{sc-expand}, to make it conform to the general form of
+Note however that @code{macroexpand} does not have the same signature
+as @code{compile-tree-il}. @code{compile-tree-il} is a small wrapper
+around @code{macroexpand}, to make it conform to the general form of
compiler procedures in Guile's language tower.
Compiler procedures take three arguments: an expression, an
@@ -235,17 +230,10 @@ 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.
-For Scheme, an environment may be one of two things:
-
address@hidden
address@hidden @code{#f}, in which case compilation is performed in the context
-of the current module; or
address@hidden a module, which specifies the context of the compilation.
address@hidden itemize
-
-By default, the @code{compile} and @code{compile-file} procedures
-compile in a fresh module, such that bindings and macros introduced by
-the expression being compiled are isolated:
+For Scheme, an environment is a module. By default, the @code{compile}
+and @code{compile-file} procedures compile in a fresh module, such
+that bindings and macros introduced by the expression being compiled
+are isolated:
@example
(eq? (current-module) (compile '(current-module)))
@@ -289,12 +277,12 @@ expanded, pre-analyzed Scheme.
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{<const>}, which has two fields,
address@hidden and @code{exp}. Instances of this type are records created
-via @code{make-const}, and whose fields are accessed as
address@hidden, and @code{const-exp}. There is also a predicate,
address@hidden @xref{Records}, for more information on records.
+requires a limited set of transformations. For example, the Tree-IL
+type @code{<const>} is a record type with two fields, @code{src} and
address@hidden Instances of this type are created via @code{make-const}.
+Fields of this type are accessed via the @code{const-src} and
address@hidden procedures. There is also a predicate, @code{const?}.
address@hidden, for more information on records.
@c alpha renaming
@@ -318,10 +306,7 @@ Users may program with this format directly at the REPL:
@example
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.
+Happy hacking with Tree Intermediate Language! To switch back, type `,L
scheme'.
tree-il@@(guile-user)> (apply (primitive +) (const 32) (const 10))
@result{} 42
@end example
@@ -408,25 +393,104 @@ A procedure call.
@deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}.
@end deftp
address@hidden {Scheme Variable} <lambda> src names vars meta body
address@hidden {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.
address@hidden deftp
address@hidden {Scheme Variable} <let> src names vars vals exp
address@hidden {External Representation} (let @var{names} @var{vars} @var{vals}
@var{exp})
address@hidden {Scheme Variable} <lambda> src meta body
address@hidden {External Representation} (lambda @var{meta} @var{body})
+A closure. @var{meta} is an association list of properties for the
+procedure. @var{body} is a single Tree-IL expression of type
address@hidden<lambda-case>}. As the @code{<lambda-case>} clause can chain to
+an alternate clause, this makes Tree-IL's @code{<lambda>} have the
+expressiveness of Scheme's @code{case-lambda}.
address@hidden deftp
address@hidden {Scheme Variable} <lambda-case> req opt rest kw inits gensyms
body alternate
address@hidden {External Representation} @
+ (lambda-case ((@var{req} @var{opt} @var{rest} @var{kw} @var{inits}
@var{gensyms})@
+ @var{body})@
+ address@hidden)
+One clause of a @code{case-lambda}. A @code{lambda} expression in
+Scheme is treated as a @code{case-lambda} with one clause.
+
address@hidden is a list of the procedure's required arguments, as symbols.
address@hidden is a list of the optional arguments, or @code{#f} if there
+are no optional arguments. @var{rest} is the name of the rest
+argument, or @code{#f}.
+
address@hidden is a list of the form, @code{(@var{allow-other-keys?}
+(@var{keyword} @var{name} @var{var}) ...)}, where @var{keyword} is the
+keyword corresponding to the argument named @var{name}, and whose
+corresponding gensym is @var{var}. @var{inits} are tree-il expressions
+corresponding to all of the optional and keyword argumens, evaluated
+to bind variables whose value is not supplied by the procedure caller.
+Each @var{init} expression is evaluated in the lexical context of
+previously bound variables, from left to right.
+
address@hidden is a list of gensyms corresponding to all arguments:
+first all of the required arguments, then the optional arguments if
+any, then the rest argument if any, then all of the keyword arguments.
+
address@hidden is the body of the clause. If the procedure is called with
+an appropriate number of arguments, @var{body} is evaluated in tail
+position. Otherwise, if there is a @var{consequent}, it should be a
address@hidden<lambda-case>} expression, representing the next clause to try.
+If there is no @var{consequent}, a wrong-number-of-arguments error is
+signaled.
address@hidden deftp
address@hidden {Scheme Variable} <let> src names gensyms vals exp
address@hidden {External Representation} (let @var{names} @var{gensyms}
@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
+original binding names, @var{gensyms} 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
address@hidden {Scheme Variable} <letrec> src names vars vals exp
address@hidden {External Representation} (letrec @var{names} @var{vars}
@var{vals} @var{exp})
address@hidden {Scheme Variable} <letrec> src names gensyms vals exp
address@hidden {External Representation} (letrec @var{names} @var{gensyms}
@var{vals} @var{exp})
A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}.
@end deftp
address@hidden {Scheme Variable} <dynlet> fluids vals body
address@hidden {External Representation} (dynlet @var{fluids} @var{vals}
@var{body})
+Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
address@hidden should be a list of Tree-IL expressions that will
+evaluate to fluids, and @var{vals} a corresponding list of expressions
+to bind to the fluids during the dynamic extent of the evaluation of
address@hidden
address@hidden deftp
address@hidden {Scheme Variable} <dynref> fluid
address@hidden {External Representation} (dynref @var{fluid})
+A dynamic variable reference. @var{fluid} should be a Tree-IL
+expression evaluating to a fluid.
address@hidden deftp
address@hidden {Scheme Variable} <dynset> fluid exp
address@hidden {External Representation} (dynset @var{fluid} @var{exp})
+A dynamic variable set. @var{fluid}, a Tree-IL expression evaluating
+to a fluid, will be set to the result of evaluating @var{exp}.
address@hidden deftp
address@hidden {Scheme Variable} <dynwind> winder body unwinder
address@hidden {External Representation} (dynwind @var{winder} @var{body}
@var{unwinder})
+A @code{dynamic-wind}. @var{winder} and @var{unwinder} should both
+evaluate to thunks. Ensure that the winder and the unwinder are called
+before entering and after leaving @var{body}. Note that @var{body} is
+an expression, without a thunk wrapper.
address@hidden deftp
address@hidden {Scheme Variable} <prompt> tag body handler
address@hidden {External Representation} (prompt @var{tag} @var{body}
@var{handler})
+A dynamic prompt. Instates a prompt named @var{tag}, an expression,
+during the dynamic extent of the execution of @var{body}, also an
+expression. If an abort occurs to this prompt, control will be passed
+to @var{handler}, a @code{<lambda-case>} expression with no optional
+or keyword arguments, and no alternate. The first argument to the
address@hidden<lambda-case>} will be the captured continuation, and then all
+of the values passed to the abort. @xref{Prompts}, for more
+information.
address@hidden deftp
address@hidden {Scheme Variable} <abort> tag args tail
address@hidden {External Representation} (abort @var{tag} @var{args} @var{tail})
+An abort to the nearest prompt with the name @var{tag}, an expression.
address@hidden should be a list of expressions to pass to the prompt's
+handler, and @var{tail} should be an expression that will evaluate to
+a list of additional arguments. An abort will save the partial
+continuation, which may later be reinstated, resulting in the
address@hidden<abort>} expression evaluating to some number of values.
address@hidden deftp
There are two Tree-IL constructs that are not normally produced by
higher-level compilers, but instead are generated during the
@@ -435,17 +499,17 @@ compiler does. Users should not generate these
expressions directly,
unless they feel very clever, as the default analysis pass will
generate them as necessary.
address@hidden {Scheme Variable} <let-values> src names vars exp body
address@hidden {External Representation} (let-values @var{names} @var{vars}
@var{exp} @var{body})
address@hidden {Scheme Variable} <let-values> src names gensyms exp body
address@hidden {External Representation} (let-values @var{names} @var{gensyms}
@var{exp} @var{body})
Like Scheme's @code{receive} -- binds the values returned by
evaluating @code{exp} to the @code{lambda}-like bindings described by
address@hidden That is to say, @var{vars} may be an improper list.
address@hidden That is to say, @var{gensyms} may be an improper list.
@code{<let-values>} is an optimization of @code{<application>} of the
primitive, @code{call-with-values}.
@end deftp
address@hidden {Scheme Variable} <fix> src names vars vals body
address@hidden {External Representation} (fix @var{names} @var{vars} @var{vals}
@var{body})
address@hidden {Scheme Variable} <fix> src names gensyms vals body
address@hidden {External Representation} (fix @var{names} @var{gensyms}
@var{vals} @var{body})
Like @code{<letrec>}, but only for @var{vals} that are unset
@code{lambda} expressions.
@@ -470,19 +534,38 @@ Interested readers are encouraged to read the
implementation in
@node GLIL
@subsection GLIL
-Guile Low Intermediate Language (GLIL) is a structured intermediate
+Guile Lowlevel Intermediate Language (GLIL) is a structured intermediate
language whose expressions more closely approximate Guile's VM
instruction set. Its expression types are defined in @code{(language
glil)}.
address@hidden {Scheme Variable} <glil-program> nargs nrest nlocs meta . body
address@hidden {Scheme Variable} <glil-program> meta . body
A unit of code that at run-time will correspond to a compiled
-procedure. @var{nargs} @var{nrest} and @var{nlocs} collectively define
-the program's arity; see @ref{Compiled Procedures}, for more
-information. @var{meta} should be an alist of properties, as in
+procedure. @var{meta} should be an alist of properties, as in
Tree-IL's @code{<lambda>}. @var{body} is an ordered list of GLIL
expressions.
@end deftp
address@hidden {Scheme Variable} <glil-std-prelude> nreq nlocs else-label
+A prologue for a function with no optional, keyword, or rest
+arguments. @var{nreq} is the number of required arguments. @var{nlocs}
+the total number of local variables, including the arguments. If the
+procedure was not given exactly @var{nreq} arguments, control will
+jump to @var{else-label}, if given, or otherwise signal an error.
address@hidden deftp
address@hidden {Scheme Variable} <glil-opt-prelude> nreq nopt rest nlocs
else-label
+A prologue for a function with optional or rest arguments. Like
address@hidden<glil-std-prelude>}, with the addition that @var{nopt} is the
+number of optional arguments (possibly zero) and @var{rest} is an
+index of a local variable at which to bind a rest argument, or
address@hidden if there is no rest argument.
address@hidden deftp
address@hidden {Scheme Variable} <glil-kw-prelude> nreq nopt rest kw
allow-other-keys? nlocs else-label
+A prologue for a function with keyword arguments. Like
address@hidden<glil-opt-prelude>}, with the addition that @var{kw} is a list
+of keyword arguments, and @var{allow-other-keys?} is a flag indicating
+whether to allow unknown keys. @xref{Function Prologue Instructions,
address@hidden, for details on the format of @var{kw}.
address@hidden deftp
@deftp {Scheme Variable} <glil-bind> . vars
An advisory expression that notes a liveness extent for a set of
variables. @var{vars} is a list of @code{(@var{name} @var{type}
@@ -529,10 +612,10 @@ list, or a pair or vector of constants.
@end deftp
@deftp {Scheme Variable} <glil-lexical> local? boxed? op index
Accesses a lexically bound variable. If the variable is not
address@hidden it is free. All variables may have @code{ref} and
address@hidden as their @var{op}. Boxed variables may also have the
address@hidden @code{box}, @code{empty-box}, and @code{fix}, which
-correspond in semantics to the VM instructions @code{box},
address@hidden it is free. All variables may have @code{ref},
address@hidden, and @code{bound?} as their @var{op}. Boxed variables may
+also have the @var{op}s @code{box}, @code{empty-box}, and @code{fix},
+which correspond in semantics to the VM instructions @code{box},
@code{empty-box}, and @code{fix-closure}. @xref{Stack Layout}, for
more information.
@end deftp
@@ -565,20 +648,22 @@ corresponding to the multiple-value return address for
the call. See
the notes on @code{mv-call} in @ref{Procedure Call and Return
Instructions}, for more information.
@end deftp
address@hidden {Scheme Variable} <glil-prompt> label escape-only?
+Push a dynamic prompt into the stack, with a handler at @var{label}.
address@hidden is a flag that is propagated to the prompt,
+allowing an abort to avoid capturing a continuation in some cases.
address@hidden, for more information.
address@hidden deftp
Users may enter in GLIL at the REPL as well, though there is a bit
-more bookkeeping to do. Since GLIL needs the set of variables to be
-declared explicitly in a @code{<glil-program>}, GLIL expressions must
-be wrapped in a thunk that declares the arity of the expression:
+more bookkeeping to do:
@example
scheme@@(guile-user)> ,language glil
-Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on
- Guile 1.9.0
-Copyright (C) 2001-2008 Free Software Foundation, Inc.
-
-Enter `,help' for help.
-glil@@(guile-user)> (program 0 0 0 () (const 3) (call return 1))
+Happy hacking with Guile Lowlevel Intermediate Language (GLIL)!
+To switch back, type `,L scheme'.
+glil@@(guile-user)> (program () (std-prelude 0 0 #f)
+ (const 3) (call return 1))
@result{} 3
@end example
@@ -624,44 +709,33 @@ 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
- () ; Labels
- 70 ; Length
- #f ; Metadata
- (make-false)
- (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
+scheme@@(guile-user)> (compile '(+ 32 10) #:to 'assembly)
+(load-program
+ ((:LCASE104 . 6)) ; Labels, unused in this case.
+ 16 ; Length of the thunk that was compiled.
+ (load-program ; Metadata thunk.
()
- 8
- (load-program 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)
- (nop)
- (nop))
- ; Return our new procedure.
- (return))
+ 17
+ #f ; No metadata thunk for the metadata thunk.
+ (make-eol)
+ (make-eol)
+ (make-int8 6)
+ (make-int8 12) ; Liveness extents, source info, and arities,
+ (make-int8:0) ; in a format that Guile knows how to parse.
+ (list 0 3)
+ (list 0 1)
+ (list 0 3)
+ (return))
+ (assert-nargs-ee 0 0) ; Prologue.
+ (reserve-locals 0 0)
+ (make-int8 32) ; Actual code starts here.
+ (make-int8 10)
+ (add)
+ (return)
+ (nop)
+ (nop) ; Padding; the metadata thunk is actually
+ (nop) ; written after the main text.
+ (nop))
@end example
Of course you can switch the REPL to assembly and enter in assembly
@@ -679,11 +753,13 @@ 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)
address@hidden (load-program 0 0 0 () 6 #f
- (make-int8 32) (make-int8 10) (add) (return))
scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
address@hidden #u8(0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 10 32 10 10 120 52)
address@hidden #vu8(16 0 0 0 25 0 0 0 ; Header.
+ 45 0 0 52 0 0 ; Prologue.
+ 10 32 10 10 148 66 ; Actual code.
+ 0 0 0 0 ; Padding.
+ 17 0 0 0 0 0 0 0 9 9 10 6 10 ; Metadata thunk.
+ 12 11 18 0 3 18 0 1 18 0 3 66)
@end example
``Objcode'' is bytecode, but mapped directly to a C structure,
@@ -691,9 +767,6 @@ scheme@@(guile-user)> (compile '(+ 32 10) #:to 'bytecode)
@example
struct scm_objcode @{
- scm_t_uint8 nargs;
- scm_t_uint8 nrest;
- scm_t_uint16 nlocs;
scm_t_uint32 len;
scm_t_uint32 metalen;
scm_t_uint8 base[0];
@@ -701,9 +774,8 @@ struct scm_objcode @{
@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 6 bytes were the program's header.
+bytecode. Also, the @code{len} and @code{metalen} fields are in native
+endianness, which makes objcode (and bytecode) system-dependent.
Objcode also has a couple of important efficiency hacks. First,
objcode may be mapped directly from disk, allowing compiled code to be
@@ -725,7 +797,7 @@ Returns @code{#f} iff @var{obj} is object code, @code{#f}
otherwise.
@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
address@hidden
+bytevector. @xref{Bytevectors}.
@end deffn
@deffn {Scheme Variable} load-objcode file
@@ -739,12 +811,12 @@ prevent accidental loading of arbitrary garbage.
@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.
+Write object code out to a file, prepending the sixteen-byte cookie.
@end deffn
address@hidden {Scheme Variable} objcode->u8vector objcode
address@hidden {C Function} scm_objcode_to_u8vector (objcode)
-Copy object code out to a @code{u8vector} for analysis by Scheme.
address@hidden {Scheme Variable} objcode->bytecode objcode
address@hidden {C Function} scm_objcode_to_bytecode (objcode)
+Copy object code out to a bytevector for analysis by Scheme.
@end deffn
The following procedure is actually in @code{(system vm program)}, but
@@ -766,13 +838,8 @@ Compiling object code to the fake language, @code{value},
is performed
via loading objcode into a program, then executing that thunk with
respect to the compilation environment. Normally the environment
propagates through the compiler transparently, but users may specify
-the compilation environment manually as well:
+the compilation environment manually as well, as a module.
address@hidden {Scheme Procedure} make-objcode-env module free-vars
-Make an object code environment. @var{module} should be a Scheme
-module, and @var{free-vars} should be a vector of free variables.
address@hidden is also a valid object code environment.
address@hidden deffn
@node Writing New High-Level Languages
@subsection Writing New High-Level Languages
diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 0bb6ea4..6a7a0a9 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -827,6 +827,14 @@ operation decrements the stack pointer, any excess values
are dropped.
reserve space for local variables.
@end deffn
address@hidden Instruction assert-nargs-ee/locals n
address@hidden Instruction assert-nargs-ge/locals n
+A combination of @code{assert-nargs-ee} and @code{reserve-locals}. The
+number of arguments is encoded in the lower three bits of @var{n}, a
+one-byte value. The number of additional local variables is take from
+the upper 5 bits of @var{n}.
address@hidden deffn
+
@node Trampoline Instructions
@subsubsection Trampoline Instructions
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 66e03c8..836648c 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -259,17 +259,21 @@
#endif
#define CHECK_OVERFLOW() \
- if (sp >= stack_limit) \
+ if (SCM_UNLIKELY (sp >= stack_limit)) \
goto vm_error_stack_overflow
#define CHECK_UNDERFLOW() \
- if (sp < SCM_FRAME_UPPER_ADDRESS (fp)) \
+ if (SCM_UNLIKELY (sp <= SCM_FRAME_UPPER_ADDRESS (fp))) \
+ goto vm_error_stack_underflow;
+
+#define PRE_CHECK_UNDERFLOW(N) \
+ if (SCM_UNLIKELY (sp - N <= SCM_FRAME_UPPER_ADDRESS (fp))) \
goto vm_error_stack_underflow;
#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
-#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); }
while (0)
-#define POP(x) do { x = *sp; DROP (); } while (0)
+#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while
(0)
+#define POP(x) do { PRE_CHECK_UNDERFLOW (1); x = *sp--; NULLSTACK (1); } while
(0)
/* A fast CONS. This has to be fast since its used, for instance, by
POP_LIST when fetching a function's argument list. Note: `scm_cell' is an
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index d2bd435..fb1af11 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -386,6 +386,7 @@ VM_DEFINE_INSTRUCTION (163, make_array, "make-array", 3,
-1, 1)
len = (len << 8) + FETCH ();
POP (shape);
SYNC_REGISTER ();
+ PRE_CHECK_UNDERFLOW (len);
ret = scm_from_contiguous_array (shape, sp - len + 1, len);
DROPN (len);
PUSH (ret);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index c1d9491..cedd43f 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1622,6 +1622,26 @@ VM_DEFINE_INSTRUCTION (93, fluid_set, "fluid-set", 0, 2,
0)
NEXT;
}
+VM_DEFINE_INSTRUCTION (95, assert_nargs_ee_locals, "assert-nargs-ee/locals",
1, 0, 0)
+{
+ scm_t_ptrdiff n;
+ SCM *old_sp;
+
+ /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */
+ n = FETCH ();
+
+ if (SCM_UNLIKELY (sp - (fp - 1) != (n & 0x7)))
+ goto vm_error_wrong_num_args;
+
+ old_sp = sp;
+ sp += (n >> 3);
+ CHECK_OVERFLOW ();
+ while (old_sp < sp)
+ *++old_sp = SCM_UNDEFINED;
+
+ NEXT;
+}
+
/*
(defun renumber-ops ()
diff --git a/module/language/assembly/spec.scm
b/module/language/assembly/spec.scm
index 9e34c4d..01a55c4 100644
--- a/module/language/assembly/spec.scm
+++ b/module/language/assembly/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Virtual Machine Assembly
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -26,7 +26,6 @@
(define-language assembly
#:title "Guile Virtual Machine Assembly Language"
- #:version "2.0"
#:reader (lambda (port env) (read port))
#:printer write
#:parser read ;; fixme: make a verifier?
diff --git a/module/language/brainfuck/spec.scm
b/module/language/brainfuck/spec.scm
index 9c4d0a8..f7cd901 100644
--- a/module/language/brainfuck/spec.scm
+++ b/module/language/brainfuck/spec.scm
@@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile.
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -35,8 +35,7 @@
; language.
(define-language brainfuck
- #:title "Guile Brainfuck"
- #:version "1.0"
+ #:title "Brainfuck"
#:reader (lambda (port env) (read-brainfuck port))
#:compilers `((tree-il . ,compile-tree-il)
(scheme . ,compile-scheme))
diff --git a/module/language/bytecode/spec.scm
b/module/language/bytecode/spec.scm
index b38b091..57ccd71 100644
--- a/module/language/bytecode/spec.scm
+++ b/module/language/bytecode/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -31,7 +31,6 @@
(define-language bytecode
#:title "Guile Bytecode Vectors"
- #:version "0.3"
#:reader (lambda (port env) (read port))
#:printer write
#:compilers `((objcode . ,compile-objcode))
diff --git a/module/language/ecmascript/spec.scm
b/module/language/ecmascript/spec.scm
index dd4dc3c..9a4bfab 100644
--- a/module/language/ecmascript/spec.scm
+++ b/module/language/ecmascript/spec.scm
@@ -1,6 +1,6 @@
;;; ECMAScript specification for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -29,8 +29,7 @@
;;;
(define-language ecmascript
- #:title "Guile ECMAScript"
- #:version "3.0"
+ #:title "ECMAScript"
#:reader (lambda (port env) (read-ecmascript/1 port))
#:compilers `((tree-il . ,compile-tree-il))
;; a pretty-printer would be interesting.
diff --git a/module/language/elisp/spec.scm b/module/language/elisp/spec.scm
index 072ccb9..d93208e 100644
--- a/module/language/elisp/spec.scm
+++ b/module/language/elisp/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Emac Lisp
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -26,7 +26,6 @@
(define-language elisp
#:title "Emacs Lisp"
- #:version "0.0"
#:reader (lambda (port env) (read-elisp port))
#:printer write
#:compilers `((tree-il . ,compile-tree-il)))
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index bfc0a36..0add22e 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -231,14 +231,16 @@
((<glil-std-prelude> nreq nlocs else-label)
(emit-code/arity
- `(,(if else-label
- `(br-if-nargs-ne ,(quotient nreq 256)
- ,(modulo nreq 256)
- ,else-label)
- `(assert-nargs-ee ,(quotient nreq 256)
- ,(modulo nreq 256)))
- (reserve-locals ,(quotient nlocs 256)
- ,(modulo nlocs 256)))
+ (if (and (< nreq 8) (< nlocs (+ nreq 32)) (not else-label))
+ `((assert-nargs-ee/locals ,(logior nreq (ash (- nlocs nreq) 3))))
+ `(,(if else-label
+ `(br-if-nargs-ne ,(quotient nreq 256)
+ ,(modulo nreq 256)
+ ,else-label)
+ `(assert-nargs-ee ,(quotient nreq 256)
+ ,(modulo nreq 256)))
+ (reserve-locals ,(quotient nlocs 256)
+ ,(modulo nlocs 256))))
nreq #f #f #f))
((<glil-opt-prelude> nreq nopt rest nlocs else-label)
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
index 7733d7b..a8164e5 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -33,7 +33,6 @@
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"
- #:version "0.3"
#:reader (lambda (port env) (read port))
#:printer write-glil
#:parser parse-glil
diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index 707dd1f..a4cb062 100644
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -80,7 +80,6 @@
(define-language objcode
#:title "Guile Object Code"
- #:version "0.3"
#:reader #f
#:printer write-objcode
#:compilers `((value . ,objcode->value))
diff --git a/module/language/scheme/compile-tree-il.scm
b/module/language/scheme/compile-tree-il.scm
index 6db2572..d9d2d7a 100644
--- a/module/language/scheme/compile-tree-il.scm
+++ b/module/language/scheme/compile-tree-il.scm
@@ -22,8 +22,7 @@
#:use-module (language tree-il)
#:export (compile-tree-il))
-;;; environment := #f
-;;; | MODULE
+;;; environment := MODULE
(define (compile-tree-il x e opts)
(save-module-excursion
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 6cfbc42..802a51d 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Scheme specification
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -36,8 +36,7 @@
;;;
(define-language scheme
- #:title "Guile Scheme"
- #:version "0.5"
+ #:title "Scheme"
#:reader (lambda (port env)
;; Use the binding of current-reader from the environment.
;; FIXME: Handle `read-options' as well?
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 8daf49a..bec3bec 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -39,11 +39,11 @@
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
lambda-case-req lambda-case-opt lambda-case-rest
lambda-case-kw
- lambda-case-inits lambda-case-vars
+ lambda-case-inits lambda-case-gensyms
lambda-case-body lambda-case-alternate
- <let> let? make-let let-src let-names let-vars let-vals let-body
- <letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
- <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
+ <let> let? make-let let-src let-names let-gensyms let-vals let-body
+ <letrec> letrec? make-letrec letrec-src letrec-names
letrec-gensyms letrec-vals letrec-body
+ <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-exp let-values-body
<dynwind> dynwind? make-dynwind dynwind-src dynwind-winder
dynwind-body dynwind-unwinder
<dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals
dynlet-body
@@ -76,10 +76,10 @@
(<application> proc args)
(<sequence> exps)
(<lambda> meta body)
- (<lambda-case> req opt rest kw inits vars body alternate)
- (<let> names vars vals body)
- (<letrec> names vars vals body)
- (<fix> names vars vals body)
+ (<lambda-case> req opt rest kw inits gensyms body alternate)
+ (<let> names gensyms vals body)
+ (<letrec> names gensyms vals body)
+ (<fix> names gensyms vals body)
(<let-values> exp body)
(<dynwind> winder body unwinder)
(<dynlet> fluids vals body)
@@ -147,15 +147,15 @@
((lambda ,meta ,body)
(make-lambda loc meta (retrans body)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body) ,alternate)
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
(make-lambda-case loc req opt rest kw
- (map retrans inits) vars
+ (map retrans inits) gensyms
(retrans body)
(and=> alternate retrans)))
- ((lambda-case ((,req ,opt ,rest ,kw ,inits ,vars) ,body))
+ ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
(make-lambda-case loc req opt rest kw
- (map retrans inits) vars
+ (map retrans inits) gensyms
(retrans body)
#f))
@@ -165,14 +165,14 @@
((begin . ,exps)
(make-sequence loc (map retrans exps)))
- ((let ,names ,vars ,vals ,body)
- (make-let loc names vars (map retrans vals) (retrans body)))
+ ((let ,names ,gensyms ,vals ,body)
+ (make-let loc names gensyms (map retrans vals) (retrans body)))
- ((letrec ,names ,vars ,vals ,body)
- (make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((letrec ,names ,gensyms ,vals ,body)
+ (make-letrec loc names gensyms (map retrans vals) (retrans body)))
- ((fix ,names ,vars ,vals ,body)
- (make-fix loc names vars (map retrans vals) (retrans body)))
+ ((fix ,names ,gensyms ,vals ,body)
+ (make-fix loc names gensyms (map retrans vals) (retrans body)))
((let-values ,exp ,body)
(make-let-values loc (retrans exp) (retrans body)))
@@ -236,8 +236,8 @@
((<lambda> meta body)
`(lambda ,meta ,(unparse-tree-il body)))
- ((<lambda-case> req opt rest kw inits vars body alternate)
- `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,vars)
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
,(unparse-tree-il body))
. ,(if alternate (list (unparse-tree-il alternate)) '())))
@@ -247,14 +247,14 @@
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
- ((<let> names vars vals body)
- `(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<let> names gensyms vals body)
+ `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
- ((<letrec> names vars vals body)
- `(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
+ ((<letrec> names gensyms vals body)
+ `(letrec ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
- ((<fix> names vars vals body)
- `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+ ((<fix> names gensyms vals body)
+ `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
((<let-values> exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
@@ -324,9 +324,9 @@
`(lambda ,@(car (tree-il->scheme body)))
`(case-lambda ,@(tree-il->scheme body))))
- ((<lambda-case> req opt rest kw inits vars body alternate)
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
;; FIXME! use parse-lambda-case?
- `((,(if rest (apply cons* vars) vars)
+ `((,(if rest (apply cons* gensyms) gensyms)
,(tree-il->scheme body))
,@(if alternate (tree-il->scheme alternate) '())))
@@ -338,15 +338,15 @@
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
- ((<let> vars vals body)
- `(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+ ((<let> gensyms vals body)
+ `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
- ((<letrec> vars vals body)
- `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+ ((<letrec> gensyms vals body)
+ `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
;; not a typo, we really do translate back to letrec
- `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+ `(letrec ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
((<let-values> exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
@@ -564,15 +564,15 @@ This is an implementation of `foldts' as described by
Andy Wingo in
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(set! (let-vals x) (map lp vals))
(set! (let-body x) (lp body)))
- ((<letrec> vars vals body)
+ ((<letrec> gensyms vals body)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
(set! (fix-vals x) (map lp vals))
(set! (fix-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index bc56a7d..0bf6b9c 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -235,39 +235,39 @@
(hashq-set! free-vars x free)
free))
- ((<lambda-case> opt kw inits vars body alternate)
+ ((<lambda-case> opt kw inits gensyms body alternate)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-union
eq?
(lset-difference eq?
(lset-union eq?
(apply lset-union eq? (map step inits))
(step-tail body))
- vars)
+ gensyms)
(if alternate (step-tail alternate) '())))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
(lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals))
- vars))
+ gensyms))
- ((<letrec> vars vals body)
+ ((<letrec> gensyms vals body)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
- (for-each (lambda (sym) (hashq-set! assigned sym #t)) vars)
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
+ (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
(lset-difference eq?
(apply lset-union eq? (step-tail body) (map step vals))
- vars))
+ gensyms))
- ((<fix> vars vals body)
+ ((<fix> gensyms vals body)
;; Try to allocate these procedures as labels.
(for-each (lambda (sym val) (hashq-set! labels sym val))
- vars vals)
+ gensyms vals)
(hashq-set! bound-vars proc
- (append (reverse vars) (hashq-ref bound-vars proc)))
+ (append (reverse gensyms) (hashq-ref bound-vars proc)))
;; Step into subexpressions.
(let* ((var-refs
(map
@@ -282,13 +282,13 @@
;; just like the closure case, except here we use
;; recur/labels instead of recur
(hashq-set! bound-vars x '())
- (let ((free (recur/labels body x vars)))
+ (let ((free (recur/labels body x gensyms)))
(hashq-set! bound-vars x (reverse! (hashq-ref
bound-vars x)))
(hashq-set! free-vars x free)
free))))
vals))
- (vars-with-refs (map cons vars var-refs))
- (body-refs (recur/labels body proc vars)))
+ (vars-with-refs (map cons gensyms var-refs))
+ (body-refs (recur/labels body proc gensyms)))
(define (delabel-dependents! sym)
(let ((refs (assq-ref vars-with-refs sym)))
(if refs
@@ -314,7 +314,7 @@
(for-each (lambda (sym)
(if (not (hashq-ref labels sym))
(delabel-dependents! sym)))
- vars)
+ gensyms)
;; Now lift bound variables with label-allocated lambdas to the
;; parent procedure.
(for-each
@@ -328,10 +328,10 @@
(hashq-ref bound-vars proc)))
(hashq-remove! bound-vars val)
(hashq-remove! free-vars val))))
- vars vals)
+ gensyms vals)
(lset-difference eq?
(apply lset-union eq? body-refs var-refs)
- vars)))
+ gensyms)))
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
@@ -407,10 +407,10 @@
(hashq-set! allocation x (cons labels free-addresses)))
n)
- ((<lambda-case> opt kw inits vars body alternate)
+ ((<lambda-case> opt kw inits gensyms body alternate)
(max
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(let ((nlocs (apply
max
(allocate! body proc n)
@@ -421,72 +421,72 @@
(hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
nlocs)
(begin
- (hashq-set! allocation (car vars)
+ (hashq-set! allocation (car gensyms)
(make-hashq
- proc `(#t ,(hashq-ref assigned (car vars)) . ,n)))
- (lp (cdr vars) (1+ n)))))
+ proc `(#t ,(hashq-ref assigned (car gensyms)) .
,n)))
+ (lp (cdr gensyms) (1+ n)))))
(if alternate (allocate! alternate proc n) n)))
- ((<let> vars vals body)
+ ((<let> gensyms vals body)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
((and (conditional? body)
- (= (length vars) 1)
- (let ((v (car vars)))
+ (= (length gensyms) 1)
+ (let ((v (car gensyms)))
(and (not (hashq-ref assigned v))
(= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test body))
(eq? (lexical-ref-gensym (conditional-test body)) v)
(lexical-ref? (conditional-consequent body))
(eq? (lexical-ref-gensym (conditional-consequent body))
v))))
- (hashq-set! allocation (car vars)
+ (hashq-set! allocation (car gensyms)
(make-hashq proc `(#t #f . ,n)))
;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
(else
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(max nmax (allocate! body proc n))
- (let ((v (car vars)))
+ (let ((v (car gensyms)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n)))))))))
+ (lp (cdr gensyms) (1+ n)))))))))
- ((<letrec> vars vals body)
- (let lp ((vars vars) (n n))
- (if (null? vars)
+ ((<letrec> gensyms vals body)
+ (let lp ((gensyms gensyms) (n n))
+ (if (null? gensyms)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x proc n))
vals))))
(max nmax (allocate! body proc n)))
- (let ((v (car vars)))
+ (let ((v (car gensyms)))
(hashq-set!
allocation v
(make-hashq proc
`(#t ,(hashq-ref assigned v) . ,n)))
- (lp (cdr vars) (1+ n))))))
+ (lp (cdr gensyms) (1+ n))))))
- ((<fix> vars vals body)
- (let lp ((in vars) (n n))
+ ((<fix> gensyms vals body)
+ (let lp ((in gensyms) (n n))
(if (null? in)
- (let lp ((vars vars) (vals vals) (nmax n))
+ (let lp ((gensyms gensyms) (vals vals) (nmax n))
(cond
- ((null? vars)
+ ((null? gensyms)
(max nmax (allocate! body proc n)))
- ((hashq-ref labels (car vars))
+ ((hashq-ref labels (car gensyms))
;; allocate lambda body inline to proc
- (lp (cdr vars)
+ (lp (cdr gensyms)
(cdr vals)
(record-case (car vals)
((<lambda> body)
(max nmax (allocate! body proc n))))))
(else
;; allocate closure
- (lp (cdr vars)
+ (lp (cdr gensyms)
(cdr vals)
(max nmax (allocate! (car vals) proc n))))))
@@ -519,8 +519,8 @@
((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
- (pair? (lambda-case-vars handler))
- (car (lambda-case-vars handler)))))
+ (pair? (lambda-case-gensyms handler))
+ (car (lambda-case-gensyms handler)))))
(hashq-set! allocation x
(and cont-var (zero? (hashq-ref refcounts cont-var 0))))
(max (recur tag) (recur body) (recur handler))))
@@ -629,18 +629,18 @@ accurate information is missing from a given `tree-il'
element."
(record-case x
((<lexical-set> gensym)
(make-binding-info vars (vhash-consq gensym #t refs)))
- ((<lambda-case> req opt inits rest kw vars)
+ ((<lambda-case> req opt inits rest kw gensyms)
(let ((names `(,@req
,@(or opt '())
,@(if rest (list rest) '())
,@(if kw (map cadr (cdr kw)) '()))))
- (make-binding-info (extend vars names) refs)))
- ((<let> vars names)
- (make-binding-info (extend vars names) refs))
- ((<letrec> vars names)
- (make-binding-info (extend vars names) refs))
- ((<fix> vars names)
- (make-binding-info (extend vars names) refs))
+ (make-binding-info (extend gensyms names) refs)))
+ ((<let> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
+ ((<letrec> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
+ ((<fix> gensyms names)
+ (make-binding-info (extend gensyms names) refs))
(else info))))
(lambda (x info env locs)
@@ -670,14 +670,14 @@ accurate information is missing from a given `tree-il'
element."
;; It doesn't hurt as these are unique names, it just
;; makes REFS unnecessarily fat.
(record-case x
- ((<lambda-case> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<let> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<letrec> vars)
- (make-binding-info (shrink vars refs) refs))
- ((<fix> vars)
- (make-binding-info (shrink vars refs) refs))
+ ((<lambda-case> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<let> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<letrec> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
+ ((<fix> gensyms)
+ (make-binding-info (shrink gensyms refs) refs))
(else info))))
(lambda (result env) #t)
@@ -1106,12 +1106,12 @@ accurate information is missing from a given `tree-il'
element."
exp)
toplevel-lambdas))))
(else info)))
- ((<let> vars vals)
- (fold extend info vars vals))
- ((<letrec> vars vals)
- (fold extend info vars vals))
- ((<fix> vars vals)
- (fold extend info vars vals))
+ ((<let> gensyms vals)
+ (fold extend info gensyms vals))
+ ((<letrec> gensyms vals)
+ (fold extend info gensyms vals))
+ ((<fix> gensyms vals)
+ (fold extend info gensyms vals))
((<application> proc args src)
(record-case proc
@@ -1158,12 +1158,12 @@ accurate information is missing from a given `tree-il'
element."
(lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info)))
(record-case x
- ((<let> vars vals)
- (fold shrink info vars vals))
- ((<letrec> vars vals)
- (fold shrink info vars vals))
- ((<fix> vars vals)
- (fold shrink info vars vals))
+ ((<let> gensyms vals)
+ (fold shrink info gensyms vals))
+ ((<letrec> gensyms vals)
+ (fold shrink info gensyms vals))
+ ((<fix> gensyms vals)
+ (fold shrink info gensyms vals))
(else info))))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index a07ad66..10b06b8 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -428,7 +428,7 @@
;; new box
(emit-code #f (make-glil-lexical #t #t 'box
index)))
(,x (error "what" x))))
- (reverse (lambda-case-vars lcase)))
+ (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
@@ -465,7 +465,7 @@
((#t #t . ,index) ; boxed
(emit-code #f (make-glil-lexical #t #t 'box
index)))
(,x (error "what" x))))
- (reverse (lambda-case-vars lcase)))
+ (reverse (lambda-case-gensyms lcase)))
(emit-branch src 'br (car (hashq-ref allocation lcase))))
((lambda-case? lcase)
;; no match, try next case
@@ -669,15 +669,15 @@
(length free-locs))))))))
(maybe-emit-return))
- ((<lambda-case> src req opt rest kw inits vars alternate body)
+ ((<lambda-case> src req opt rest kw inits gensyms alternate body)
;; o/~ feature on top of feature o/~
;; req := (name ...)
;; opt := (name ...) | #f
;; rest := name | #f
;; kw: (allow-other-keys? (keyword name var) ...) | #f
- ;; vars: (sym ...)
- ;; init: tree-il in context of vars
- ;; vars map to named arguments in the following order:
+ ;; gensyms: (sym ...)
+ ;; init: tree-il in context of gensyms
+ ;; gensyms map to named arguments in the following order:
;; required, optional (positional), rest, keyword.
(let* ((nreq (length req))
(nopt (if opt (length opt) 0))
@@ -687,7 +687,7 @@
(kw-indices (map (lambda (x)
(pmatch x
((,key ,name ,var)
- (cons key (list-index vars var)))
+ (cons key (list-index gensyms var)))
(else (error "bad kwarg" x))))
(if kw (cdr kw) '())))
(nargs (apply max (+ nreq nopt (if rest 1 0))
@@ -695,10 +695,10 @@
(nlocs (cdr (hashq-ref allocation x)))
(alternate-label (and alternate (make-label))))
(or (= nargs
- (length vars)
+ (length gensyms)
(+ nreq (length inits) (if rest 1 0)))
(error "something went wrong"
- req opt rest kw inits vars nreq nopt kw-indices nargs))
+ req opt rest kw inits gensyms nreq nopt kw-indices nargs))
;; the prelude, to check args & reset the stack pointer,
;; allowing room for locals
(emit-code
@@ -718,33 +718,33 @@
((#t #t . ,n)
(emit-code #f (make-glil-lexical #t #f 'ref n))
(emit-code #f (make-glil-lexical #t #t 'box n)))))
- vars)
+ gensyms)
;; write bindings info
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-bindings
#f
(let lp ((kw (if kw (cdr kw) '()))
(names (append (reverse opt-names) (reverse req)))
- (vars (list-tail vars (+ nreq nopt
+ (gensyms (list-tail gensyms (+ nreq nopt
(if rest 1 0)))))
(pmatch kw
(()
- ;; fixme: check that vars is empty
+ ;; fixme: check that gensyms is empty
(reverse (if rest (cons rest names) names)))
(((,key ,name ,var) . ,kw)
- (if (memq var vars)
- (lp kw (cons name names) (delq var vars))
- (lp kw names vars)))
+ (if (memq var gensyms)
+ (lp kw (cons name names) (delq var gensyms))
+ (lp kw names gensyms)))
(,kw (error "bad keywords, yo" kw))))
- vars allocation self emit-code))
+ gensyms allocation self emit-code))
;; init optional/kw args
- (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
+ (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
(cond
((null? inits)) ; done
((and rest-idx (= n rest-idx))
- (lp inits (1+ n) (cdr vars)))
+ (lp inits (1+ n) (cdr gensyms)))
(#t
- (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
+ (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
((#t ,boxed? . ,n*) (guard (= n* n))
(let ((L (make-label)))
(emit-code #f (make-glil-lexical #t boxed? 'bound? n))
@@ -752,21 +752,21 @@
(comp-push (car inits))
(emit-code #f (make-glil-lexical #t boxed? 'set n))
(emit-label L)
- (lp (cdr inits) (1+ n) (cdr vars))))
+ (lp (cdr inits) (1+ n) (cdr gensyms))))
(#t (error "what" inits))))))
;; post-prelude case label for label calls
(emit-label (car (hashq-ref allocation x)))
(comp-tail body)
- (if (not (null? vars))
+ (if (not (null? gensyms))
(emit-code #f (make-glil-unbind)))
(if alternate-label
(begin
(emit-label alternate-label)
(comp-tail alternate)))))
- ((<let> src names vars vals body)
+ ((<let> src names gensyms vals body)
(for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
+ (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
@@ -774,29 +774,29 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<letrec> src names vars vals body)
+ ((<letrec> src names gensyms vals body)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
(,loc (error "badness" x loc))))
- vars)
+ gensyms)
(for-each comp-push vals)
- (emit-bindings src names vars allocation self emit-code)
+ (emit-bindings src names gensyms allocation self emit-code)
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
- ((<fix> src names vars vals body)
+ ((<fix> src names gensyms vals body)
;; The ideal here is to just render the lambda bodies inline, and
;; wire the code together with gotos. We can do that if
;; analyze-lexicals has determined that a given var has "label"
@@ -835,10 +835,10 @@
(let lp ((lcase (lambda-body x)))
(if lcase
(record-case lcase
- ((<lambda-case> src req vars body alternate)
+ ((<lambda-case> src req gensyms body alternate)
(emit-label (car (hashq-ref allocation lcase)))
;; FIXME: opt & kw args in the bindings
- (emit-bindings #f req vars allocation self emit-code)
+ (emit-bindings #f req gensyms allocation self
emit-code)
(if src
(emit-code #f (make-glil-source src)))
(comp-fix body (or RA new-RA))
@@ -846,15 +846,15 @@
(lp alternate)))
(emit-label POST)))))))
vals
- vars)
+ gensyms)
;; Emit bindings metadata for closures
- (let ((binds (let lp ((out '()) (vars vars) (names names))
- (cond ((null? vars) (reverse! out))
- ((assq (car vars) fix-labels)
- (lp out (cdr vars) (cdr names)))
+ (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
+ (cond ((null? gensyms) (reverse! out))
+ ((assq (car gensyms) fix-labels)
+ (lp out (cdr gensyms) (cdr names)))
(else
- (lp (acons (car vars) (car names) out)
- (cdr vars) (cdr names)))))))
+ (lp (acons (car gensyms) (car names) out)
+ (cdr gensyms) (cdr names)))))))
(emit-bindings src (map cdr binds) (map car binds)
allocation self emit-code))
;; Now go back and fix up the bindings for closures.
@@ -878,7 +878,7 @@
(emit-code #f (make-glil-lexical #t #f 'fix n)))
(,loc (error "badness" x loc)))))))
vals
- vars)
+ gensyms)
(comp-tail body)
(if new-RA
(emit-label new-RA))
@@ -886,7 +886,7 @@
((<let-values> src exp body)
(record-case body
- ((<lambda-case> req opt kw rest vars body alternate)
+ ((<lambda-case> req opt kw rest gensyms body alternate)
(if (or opt kw alternate)
(error "unexpected lambda-case in let-values" x))
(let ((MV (make-label)))
@@ -896,7 +896,7 @@
(emit-code src (make-glil-mv-bind
(vars->bind-list
(append req (if rest (list rest) '()))
- vars allocation self)
+ gensyms allocation self)
(and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
@@ -905,7 +905,7 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))
@@ -1086,13 +1086,13 @@
;; then the args to the continuation (pushed separately), and then the
;; number of args, including the continuation.
(record-case handler
- ((<lambda-case> req opt kw rest vars body alternate)
+ ((<lambda-case> req opt kw rest gensyms body alternate)
(if (or opt kw alternate)
(error "unexpected lambda-case in prompt" x))
(emit-code src (make-glil-mv-bind
(vars->bind-list
(append req (if rest (list rest) '()))
- vars allocation self)
+ gensyms allocation self)
(and rest #t)))
(for-each (lambda (v)
(pmatch (hashq-ref (hashq-ref allocation v) self)
@@ -1101,7 +1101,7 @@
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
(,loc (error "badness" x loc))))
- (reverse vars))
+ (reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index bef31ce..e849e69 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -71,15 +71,15 @@
simple
lambda*
complex))
- ((<letrec> vars)
- (values (append vars unref)
+ ((<letrec> gensyms)
+ (values (append gensyms unref)
ref
set
simple
lambda*
complex))
- ((<let> vars)
- (values (append vars unref)
+ ((<let> gensyms)
+ (values (append gensyms unref)
ref
set
simple
@@ -89,65 +89,65 @@
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
(record-case x
- ((<letrec> (orig-vars vars) vals)
- (let lp ((vars orig-vars) (vals vals)
+ ((<letrec> (orig-gensyms gensyms) vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
+ ((null? gensyms)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
+ ((memq (car gensyms) unref)
+ (lp (cdr gensyms) (cdr vals)
s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((lambda? (car vals))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
- ((simple-expression? (car vals) orig-vars)
- (lp (cdr vars) (cdr vals)
- (cons (car vars) s) l c))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
+ ((simple-expression? (car vals) orig-gensyms)
+ (lp (cdr gensyms) (cdr vals)
+ (cons (car gensyms) s) l c))
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
- ((<let> (orig-vars vars) vals)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
+ ((<let> (orig-gensyms gensyms) vals)
;; The point is to compile let-bound lambdas as
;; efficiently as we do letrec-bound lambdas, so
;; we use the same algorithm for analyzing the
- ;; vars. There is no problem recursing into the
+ ;; gensyms. There is no problem recursing into the
;; bindings after the let, because all variables
;; have been renamed.
- (let lp ((vars orig-vars) (vals vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
+ ((null? gensyms)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
+ ((memq (car gensyms) unref)
+ (lp (cdr gensyms) (cdr vals)
s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((and (lambda? (car vals))
- (not (memq (car vars) set)))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
+ (not (memq (car gensyms) set)))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
;; There is no difference between simple and
;; complex, for the purposes of let. Just lump
;; them all into complex.
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
(else
(values unref ref set simple lambda* complex))))
'()
@@ -171,11 +171,11 @@
(make-sequence #f (list exp (make-void #f)))
x))
- ((<letrec> src names vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<letrec> src names gensyms vals body)
+ (let ((binds (map list gensyms names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
- (lset-intersection eq? vars set)))
+ (lset-intersection eq? gensyms set)))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
@@ -216,11 +216,11 @@
;; Finally, the body.
body)))))))))
- ((<let> src names vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<let> src names gensyms vals body)
+ (let ((binds (map list gensyms names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
- (lset-intersection eq? vars set)))
+ (lset-intersection eq? gensyms set)))
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
diff --git a/module/language/tree-il/inline.scm
b/module/language/tree-il/inline.scm
index 8dd7dd3..7060729 100644
--- a/module/language/tree-il/inline.scm
+++ b/module/language/tree-il/inline.scm
@@ -44,9 +44,9 @@
(let lp ((lcase body))
(and lcase
(record-case lcase
- ((<lambda-case> req opt rest kw inits vars body alternate)
- (if (and (= (length vars) (length req) (length args)))
- (let ((x (make-let src req vars args body)))
+ ((<lambda-case> req opt rest kw inits gensyms body
alternate)
+ (if (and (= (length gensyms) (length req) (length args)))
+ (let ((x (make-let src req gensyms args body)))
(or (inline1 x) x))
(lp alternate)))))))
@@ -101,24 +101,24 @@
(else #f)))
- ((<let> vars body)
- (if (null? vars) body x))
+ ((<let> gensyms body)
+ (if (null? gensyms) body x))
- ((<letrec> vars body)
- (if (null? vars) body x))
+ ((<letrec> gensyms body)
+ (if (null? gensyms) body x))
- ((<fix> vars body)
- (if (null? vars) body x))
+ ((<fix> gensyms body)
+ (if (null? gensyms) body x))
- ((<lambda-case> req opt rest kw vars body alternate)
- (define (args-compatible? args vars)
- (let lp ((args args) (vars vars))
+ ((<lambda-case> req opt rest kw gensyms body alternate)
+ (define (args-compatible? args gensyms)
+ (let lp ((args args) (gensyms gensyms))
(cond
- ((null? args) (null? vars))
- ((null? vars) #f)
+ ((null? args) (null? gensyms))
+ ((null? gensyms) #f)
((and (lexical-ref? (car args))
- (eq? (lexical-ref-gensym (car args)) (car vars)))
- (lp (cdr args) (cdr vars)))
+ (eq? (lexical-ref-gensym (car args)) (car gensyms)))
+ (lp (cdr args) (cdr gensyms)))
(else #f))))
(and (not opt) (not kw) rest (not alternate)
@@ -129,7 +129,7 @@
(eq? (primitive-ref-name proc) '@apply)
(pair? args)
(lambda? (car args))
- (args-compatible? (cdr args) vars)
+ (args-compatible? (cdr args) gensyms)
(lambda-body (car args))))
(else #f))))
@@ -138,7 +138,7 @@
((<prompt> src tag body handler)
(define (escape-only? handler)
(and (pair? (lambda-case-req handler))
- (let ((cont (car (lambda-case-vars handler))))
+ (let ((cont (car (lambda-case-gensyms handler))))
(tree-il-fold (lambda (leaf escape-only?)
(and escape-only?
(not
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index b2ebcfc..38e6d31 100644
--- a/module/language/tree-il/spec.scm
+++ b/module/language/tree-il/spec.scm
@@ -1,6 +1,6 @@
;;; Tree Intermediate Language
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 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
@@ -37,7 +37,6 @@
(define-language tree-il
#:title "Tree Intermediate Language"
- #:version "1.0"
#:reader (lambda (port env) (read port))
#:printer write-tree-il
#:parser parse-tree-il
diff --git a/module/language/value/spec.scm b/module/language/value/spec.scm
index aebba8c..6c6cff9 100644
--- a/module/language/value/spec.scm
+++ b/module/language/value/spec.scm
@@ -1,6 +1,6 @@
;;; Guile Lowlevel Intermediate Language
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010 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
@@ -23,8 +23,7 @@
#:export (value))
(define-language value
- #:title "Guile Values"
- #:version "0.3"
+ #:title "Values"
#:reader #f
#:printer write
)
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 046e11d..8d02cd2 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -1,6 +1,6 @@
;;; Multi-language support
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 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
@@ -22,7 +22,7 @@
(define-module (system base language)
#:use-module (system base syntax)
#:export (define-language language? lookup-language make-language
- language-name language-title language-version language-reader
+ language-name language-title language-reader
language-printer language-parser
language-compilers language-decompilers language-evaluator
language-joiner language-make-default-environment
@@ -38,7 +38,6 @@
(define-record/keywords <language>
name
title
- version
reader
printer
(parser #f)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-10-84-gde45d8e,
Andy Wingo <=