mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge branch 'syncase-in-boot-9'

Browse source 
Conflicts:
	module/Makefile.am
This commit is contained in:
Andy Wingo 2009-05-29 16:01:43 +02:00
commit 938d46a35d
92 changed files with 4522 additions and 3330 deletions
Download patch file Download diff file Expand all files Collapse all files

28
doc/ref/api-procedures.texi
View file

@ -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

703
doc/ref/compiler.texi
View file

@ -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{#<language>} 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{}
#<<application> src: #f
proc: #<<toplevel-ref> src: #f name: +>
args: (#<<const> src: #f exp: 1>
#<<const> 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{#<primitive-builtin-macro!
if>}.
@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{<ghil-quote>}, 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{<const>}, 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} <ghil-toplevel-env> [table='()]
A toplevel environment. The @var{table} holds all toplevel variables
that have been resolved in this environment.
@end deftp
@deftp {Scheme Variable} <ghil-env> 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} <ghil-var> 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{<ghil-quote>} 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{<ghil-quote>}
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{#<const src: #f exp: 3>} 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{<ghil-@var{foo}> 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} <ghil-void> env loc
The unspecified value.
@deftp {Scheme Variable} <void> src
@deftpx {External Representation} (void)
An empty expression. In practice, equivalent to Scheme's @code{(if #f
#f)}.
@end deftp
@deftp {Scheme Variable} <ghil-quote> env loc exp
A quoted expression.
@deftp {Scheme Variable} <const> src exp
@deftpx {External Representation} (const @var{exp})
A constant.
@end deftp
@deftp {Scheme Variable} <primitive-ref> 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{<module-ref>} and @code{<toplevel-ref>} expressions to
@code{<primitive-ref>} expressions. The actual compilation pass
has special cases for applications of certain primitives, like
@code{apply} or @code{cons}.
@end deftp
@deftp {Scheme Variable} <ghil-quasiquote> 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} <lexical-ref> 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} <ghil-unquote> env loc exp
Like Scheme's @code{unquote}; only valid within a quasiquote.
@deftp {Scheme Variable} <lexical-set> 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} <ghil-unquote-splicing> env loc exp
Like Scheme's @code{unquote-splicing}; only valid within a quasiquote.
@deftp {Scheme Variable} <module-ref> 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} <ghil-ref> 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} <module-set> 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} <ghil-set> env loc var val
A variable mutation. @var{var} is serialized as a symbol.
@deftp {Scheme Variable} <toplevel-ref> src name
@deftpx {External Representation} (toplevel @var{name})
References a variable from the current procedure's module.
@end deftp
@deftp {Scheme Variable} <ghil-define> env loc var val
A toplevel variable definition. See @code{ghil-var-define!}.
@deftp {Scheme Variable} <toplevel-set> 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} <ghil-if> env loc test then else
@deftp {Scheme Variable} <toplevel-define> 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} <conditional> 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} <ghil-and> env loc . exps
Like Scheme's @code{and}.
@end deftp
@deftp {Scheme Variable} <ghil-or> env loc . exps
Like Scheme's @code{or}.
@end deftp
@deftp {Scheme Variable} <ghil-begin> env loc . body
Like Scheme's @code{begin}.
@end deftp
@deftp {Scheme Variable} <ghil-bind> 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{<ghil-bind>} has @code{let} or @code{letrec}
semantics, and thus only serializes @code{<ghil-bind>} as @code{bind}.
@end deftp
@deftp {Scheme Variable} <ghil-mv-bind> 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} <ghil-lambda> 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} <ghil-call> env loc proc . args
@deftp {Scheme Variable} <application> src proc args
@deftpx {External Representation} (apply @var{proc} . @var{args})
A procedure call.
@end deftp
@deftp {Scheme Variable} <ghil-mv-call> env loc producer consumer
Like Scheme's @code{call-with-values}.
@deftp {Scheme Variable} <sequence> src exps
@deftpx {External Representation} (begin . @var{exps})
Like Scheme's @code{begin}.
@end deftp
@deftp {Scheme Variable} <ghil-inline> 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} <lambda> 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} <ghil-values> env loc . values
Like Scheme's @code{values}.
@deftp {Scheme Variable} <let> 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} <ghil-values*> env loc . values
@var{values} are as in the Scheme expression, @code{(apply values .
@var{vals})}.
@end deftp
@deftp {Scheme Variable} <ghil-reified-env> 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} <letrec> src names vars vals exp
@deftpx {External Representation} (letrec @var{names} @var{vars} @var{vals} @var{exp})
A version of @code{<let>} 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} <ghil-mv-bind> 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{<ghil-lambda>}. @var{body} is a list of GLIL
expressions.
properties, as in Tree IL's @code{<lambda>}. @var{body} is a list of
GLIL expressions.
@end deftp
@deftp {Scheme Variable} <glil-bind> . 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} <glil-source> 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} <glil-void>
Pushes the unspecified value on the stack.
@end deftp
@deftp {Scheme Variable} <glil-const> 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} <glil-argument> 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} <glil-local> op index
Like @code{<glil-argument>}, 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} <glil-external> 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} <glil-module> 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{<module-ref>}, for more information.
@end deftp
@deftp {Scheme Variable} <glil-label> 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{<glil-local>} 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.

164
doc/ref/vm.texi
View file

@ -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 #<program foo (a)>:
Bytecode:
0 (local-ref 0) ;; `a' (arg)
2 (external-set 0) ;; `a' (arg)
4 (object-ref 0) ;; #<program #(0 28 #f) (b)>
6 (make-closure) at (unknown file):0:16
4 (object-ref 1) ;; #<program b70d2910 at <unknown port>:0:16 (b)>
6 (make-closure)
7 (return)
----------------------------------------
Disassembly of #<program #(0 28 #f) (b)>:
Disassembly of #<program b70d2910 at <unknown port>: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.

32
guile-readline/ice-9/readline.scm
View file

@ -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}."

1
lang/Makefile.am
View file

@ -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 \

4
lang/elisp/expand.scm Normal file
View file

@ -0,0 +1,4 @@
(define-module (lang elisp expand)
#:export (expand))
(define (expand x) x)

45
lang/elisp/interface.scm
View file

@ -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.

1
lang/elisp/internals/lambda.scm
View file

@ -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

3
lang/elisp/primitives/fns.scm
View file

@ -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)

1
lang/elisp/primitives/syntax.scm
View file

@ -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)

39
lang/elisp/transform.scm
View file

@ -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)

19
libguile/eval.c
View file

@ -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.

2
libguile/eval.h
View file

@ -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);

49
libguile/frames.c
View file

@ -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 <config.h>
@ -45,6 +21,7 @@
#include <stdlib.h>
#include <string.h>
#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"

80
libguile/frames.h
View file

@ -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_ */

50
libguile/instructions.c
View file

@ -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 <config.h>
#endif
#include <string.h>
#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"

66
libguile/instructions.h
View file

@ -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_ */

113
libguile/macros.c
View file

@ -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 ("#<primitive-", port);
else
scm_puts ("#<", port);
scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@ -63,6 +66,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port);
if (SCM_MACRO_TYPE (macro) == 4)
scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
@ -77,12 +82,30 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_iprin1 (src, port, pstate);
}
if (SCM_MACRO_IS_EXTENDED (macro))
{
scm_putc (' ', port);
scm_write (SCM_SMOB_OBJECT_2 (macro), port);
scm_putc (' ', port);
scm_write (SCM_SMOB_OBJECT_3 (macro), port);
}
scm_putc ('>', 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"
}

13
libguile/macros.h
View file

@ -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<<SCM_MACRO_TYPE_BITS)-1)
#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
@ -39,10 +45,15 @@ SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
SCM_API SCM scm_syncase_macro_type (SCM m);
SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_API SCM scm_make_synt (const char *name,
SCM (*macroizer) (SCM),
SCM (*fcn) ());

4
libguile/modules.c
View file

@ -412,13 +412,13 @@ SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
register SCM b;
/* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
evaluated. */
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
if (scm_is_false (module))
return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
/* 1. Check module obarray */
b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);

49
libguile/objcodes.c
View file

@ -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 <config.h>
@ -51,6 +27,7 @@
#include <sys/types.h>
#include <assert.h>
#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"

66
libguile/objcodes.h
View file

@ -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_ */

49
libguile/programs.c
View file

@ -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 <config.h>
#endif
#include <string.h>
#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"

86
libguile/programs.h
View file

@ -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_ */

83
libguile/read.c
View file

@ -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))

50
libguile/vm-bootstrap.h
View file

@ -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_ */

48
libguile/vm-engine.c
View file

@ -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 */

52
libguile/vm-engine.h
View file

@ -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

48
libguile/vm-expand.h
View file

@ -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

48
libguile/vm-i-scheme.c
View file

@ -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 */

8
libguile/vm-i-system.c
View file

@ -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

49
libguile/vm.c
View file

@ -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 <config.h>
@ -46,6 +22,7 @@
#include <stdlib.h>
#include <alloca.h>
#include <string.h>
#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"

108
libguile/vm.h
View file

@ -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_ */

46
module/Makefile.am
View file

@ -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

542
module/ice-9/boot-9.scm
View file

@ -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

47
module/ice-9/compile-psyntax.scm
View file

@ -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)))

8
module/ice-9/documentation.scm
View file

@ -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)

169
module/ice-9/expand-support.scm
View file

@ -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> annotation? annotate deannotate make-annotation
annotation-expression annotation-source annotation-stripped
set-annotation-stripped!
deannotate/source-properties
<module-ref> make-module-ref
module-ref-symbol module-ref-modname module-ref-public?
<lexical> make-lexical
lexical-name lexical-gensym
strip-expansion-structures))
(define <annotation>
(make-vtable "prprpw"
(lambda (struct port)
(display "#<annotated " port)
(display (struct-ref struct 0) port)
(display ">" port))))
(define (annotation? x)
(and (struct? x) (eq? (struct-vtable x) <annotation>)))
(define (make-annotation e s . stripped?)
(if (null? stripped?)
(make-struct <annotation> 0 e s #f)
(apply make-struct <annotation> 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 <module-ref>
(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) <module-ref>)))
(define (make-module-ref modname symbol public?)
(make-struct <module-ref> 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 <lexical>
(make-vtable "prpr"
(lambda (struct port)
(display "#<lexical " port)
(display (lexical-name struct) port)
(display "/" port)
(display (lexical-gensym struct) port)
(display ">" port))))
(define (lexical? x)
(and (struct? x) (eq? (struct-vtable x) <lexical>)))
(define (make-lexical name gensym)
(make-struct <lexical> 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)))

4
module/ice-9/match.scm
View file

@ -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)))))

3
module/ice-9/networking.scm
View file

@ -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))

1
module/ice-9/null.scm
View file

@ -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

1
module/ice-9/occam-channel.scm
View file

@ -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

3
module/ice-9/posix.scm
View file

@ -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))

24
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because one or more lines are too long

987
module/ice-9/psyntax.scm
View file

File diff suppressed because it is too large Load diff

28
module/ice-9/r4rs.scm
View file

@ -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)))))

2
module/ice-9/stack-catch.scm
View file

@ -40,4 +40,4 @@ this call to @code{catch}."
(catch key
thunk
handler
pre-unwind-handler-dispatch))
default-pre-unwind-handler))

200
module/ice-9/syncase.scm
View file

@ -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))))

114
module/ice-9/threads.scm
View file

@ -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

2
module/ice-9/time.scm
View file

@ -53,6 +53,6 @@
result))
(define-macro (time exp)
`(,time-proc (lambda () ,exp)))
`((@@ (ice-9 time) time-proc) (lambda () ,exp)))
;;; time.scm ends here

2
module/language/assembly/disassemble.scm
View file

@ -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))))

1
module/language/ecmascript/spec.scm
View file

@ -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

14
module/language/ghil/compile-glil.scm
View file

@ -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)

9
module/language/glil.scm
View file

@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
<glil-argument> make-glil-argument glil-argument?
glil-argument-op glil-argument-index
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
(<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> 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 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
((<glil-argument> op index)
`(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)

31
module/language/glil/compile-assembly.scm
View file

@ -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 @@
((<glil-bind> vars)
(values '()
(open-binding bindings vars nargs addr)
(open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> 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)))))
((<glil-argument> op index)
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,(+ nargs index)))
`((local-set ,(+ nargs index))))))
((<glil-external> 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

8
module/language/glil/decompile-assembly.scm
View file

@ -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)

37
module/language/scheme/amatch.scm
View file

@ -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))))

48
module/language/scheme/compile-ghil.scm
View file

@ -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)

64
module/language/scheme/compile-tree-il.scm Normal file
View file

@ -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)))))

27
module/language/scheme/decompile-tree-il.scm Normal file
View file

@ -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))

307
module/language/scheme/expand.scm
View file

@ -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))))))))

13
module/language/scheme/spec.scm
View file

@ -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
)

359
module/language/tree-il.scm Normal file
View file

@ -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> void? make-void void-src
<const> const? make-const const-src const-exp
<primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
<lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
<lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
<module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
<module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
<toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
<let> let? make-let let-src let-names let-vars let-vals let-exp
<letrec> 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 (<tree-il> #:common-slots (src))
(<void>)
(<const> exp)
(<primitive-ref> name)
(<lexical-ref> name gensym)
(<lexical-set> name gensym exp)
(<module-ref> mod name public?)
(<module-set> mod name public? exp)
(<toplevel-ref> name)
(<toplevel-set> name exp)
(<toplevel-define> name exp)
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
(<lambda> names vars meta body)
(<let> names vars vals exp)
(<letrec> 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>)
'(void))
((<application> proc args)
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<conditional> test then else)
`(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
((<primitive-ref> name)
`(primitive ,name))
((<lexical-ref> name gensym)
`(lexical ,name ,gensym))
((<lexical-set> name gensym exp)
`(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
((<module-ref> mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
((<module-set> mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
((<toplevel-ref> name)
`(toplevel ,name))
((<toplevel-set> name exp)
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
((<lambda> names vars meta body)
`(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
((<const> exp)
`(const ,exp))
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
((<let> names vars vals exp)
`(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
((<letrec> 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
((<void>)
'(if #f #f))
((<application> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<conditional> 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))))
((<primitive-ref> name)
name)
((<lexical-ref> name gensym)
gensym)
((<lexical-set> name gensym exp)
`(set! ,gensym ,(tree-il->scheme exp)))
((<module-ref> mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
((<module-set> mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
((<toplevel-ref> name)
name)
((<toplevel-set> name exp)
`(set! ,name ,(tree-il->scheme exp)))
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
((<lambda> vars meta body)
`(lambda ,vars
,@(cond ((assq-ref meta 'documentation) => list) (else '()))
,(tree-il->scheme body)))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
exp
(list 'quote exp)))
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
((<let> vars vals exp)
`(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
((<letrec> 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
((<void>)
(or (f x) x))
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args))
(or (f x) x))
((<conditional> 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))
((<primitive-ref> name)
(or (f x) x))
((<lexical-ref> name gensym)
(or (f x) x))
((<lexical-set> name gensym exp)
(set! (lexical-set-exp x) (lp exp))
(or (f x) x))
((<module-ref> mod name public?)
(or (f x) x))
((<module-set> mod name public? exp)
(set! (module-set-exp x) (lp exp))
(or (f x) x))
((<toplevel-ref> name)
(or (f x) x))
((<toplevel-set> name exp)
(set! (toplevel-set-exp x) (lp exp))
(or (f x) x))
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp))
(or (f x) x))
((<lambda> vars meta body)
(set! (lambda-body x) (lp body))
(or (f x) x))
((<const> exp)
(or (f x) x))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps))
(or (f x) x))
((<let> vars vals exp)
(set! (let-vals x) (map lp vals))
(set! (let-exp x) (lp exp))
(or (f x) x))
((<letrec> 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
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
((<conditional> test then else)
(set! (conditional-test x) (lp test))
(set! (conditional-then x) (lp then))
(set! (conditional-else x) (lp else)))
((<lexical-set> name gensym exp)
(set! (lexical-set-exp x) (lp exp)))
((<module-set> mod name public? exp)
(set! (module-set-exp x) (lp exp)))
((<toplevel-set> name exp)
(set! (toplevel-set-exp x) (lp exp)))
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> vars meta body)
(set! (lambda-body x) (lp body)))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
((<let> vars vals exp)
(set! (let-vals x) (map lp vals))
(set! (let-exp x) (lp exp)))
((<letrec> vars vals exp)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-exp x) (lp exp)))
(else #f))
x)))

235
module/language/tree-il/analyze.scm Normal file
View file

@ -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
((<application> proc args)
(step proc) (for-each step args))
((<conditional> test then else)
(step test) (step then) (step else))
((<lexical-ref> 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))))
((<lexical-set> name gensym exp)
(step exp)
(if (not (hashq-ref heaps gensym))
(hashq-set! heaps gensym (find-heap gensym parent))))
((<module-set> mod name public? exp)
(step exp))
((<toplevel-set> name exp)
(step exp))
((<toplevel-define> name exp)
(step exp))
((<sequence> exps)
(for-each step exps))
((<lambda> 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))))
((<let> vars vals exp)
(for-each step vals)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(step exp))
((<letrec> 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
((<application> proc args)
(apply max (recur proc) (map recur args)))
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
((<lexical-set> name gensym exp)
(recur exp))
((<module-set> mod name public? exp)
(recur exp))
((<toplevel-set> name exp)
(recur exp))
((<toplevel-define> name exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
((<lambda> 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)
((<let> 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)))))))))))
((<letrec> 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)

448
module/language/tree-il/compile-glil.scm Normal file
View file

@ -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
((<void>)
(case context
((push) (emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<const> 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
((<sequence> src exps)
(let lp ((exps exps))
(if (null? (cdr exps))
(comp-tail (car exps))
(begin
(comp-drop (car exps))
(lp (cdr exps))))))
((<application> src proc args)
;; FIXME: need a better pattern-matcher here
(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))))))))
((<conditional> 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))))
((<primitive-ref> 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)))))))
((<lexical-ref> 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)))))))
((<lexical-set> 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)))))
((<module-ref> 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)))))
((<module-set> 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)))))
((<toplevel-ref> 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)))))
((<toplevel-set> 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)))))
((<toplevel-define> 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)))))
((<lambda>)
(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)))))
((<let> 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)))
((<letrec> 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))))))

42
module/language/tree-il/optimize.scm Normal file
View file

@ -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"

206
module/language/tree-il/primitives.scm Normal file
View file

@ -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
((<toplevel-ref> src name)
(and (hashq-ref *interesting-primitive-vars*
(module-variable mod name))
(make-primitive-ref src name)))
((<module-ref> 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
((<application> src proc args)
(and (primitive-ref? proc)
(let ((expand (hashq-ref *primitive-expand-table*
(primitive-ref-name proc))))
(and expand (apply expand src args)))))
(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)

43
module/language/tree-il/spec.scm Normal file
View file

@ -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))
)

410
module/oop/goops.scm
View file

@ -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 <generic>)))
(define-generic ,val)))
((#:accessor)
`(if (or (not (defined? ',val))
(not (is-a? ,val <accessor>)))
(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 <class>)
(memq <object> (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 <generic>)))
(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 <accessor>)))
(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 <class>)
(memq <object> (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 <generic> #:name name)))))
;; same semantics as <generic>
(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 <accessor>))
(make <accessor> #: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 <accessor>) (make <accessor> #: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 <accessor>)))
(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 <generic>) 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)
'<top>)
(specializers (cdr ls))))
(else '(<top>)))))
(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 <method>
#: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 <accessor>)))
(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 <generic>) and see.
(if (or (not (defined? 'name))
(not name))
(toplevel-define! 'name (make <generic> #: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 <top>) specializers)))
(()
(list (reverse formals)
(reverse (cons (syntax '()) specializers))))
(tail
(identifier? (syntax tail))
(list (append (reverse formals) (syntax tail))
(reverse (cons (syntax <top>) 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 <method>
#: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))

32
module/oop/goops/compile.scm
View file

@ -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

5
module/oop/goops/dispatch.scm
View file

@ -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))

4
module/oop/goops/save.scm
View file

@ -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)))

5
module/oop/goops/simple.scm
View file

@ -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)))

71
module/oop/goops/stklos.scm
View file

@ -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 <generic-with-setter>))
(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 <generic>)
(is-a? ,name <primitive-generic>)))
(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 <generic-with-setter>)))
(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 <generic>)
(is-a? name <primitive-generic>))))
(toplevel-define! 'name
(ensure-generic
(if (defined? 'name) name #f) 'name)))
(add-method! name (method rest ...))))))

1
module/srfi/srfi-11.scm
View file

@ -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))

10
module/srfi/srfi-18.scm
View file

@ -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

1
module/srfi/srfi-39.scm
View file

@ -35,7 +35,6 @@
;;; Code:
(define-module (srfi srfi-39)
#:use-module (ice-9 syncase)
#:use-module (srfi srfi-16)
#:export (make-parameter)

20
module/system/base/compile.scm
View file

@ -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))))

3
module/system/base/language.scm
View file

@ -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)

7
module/system/base/pmatch.scm
View file

@ -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)

2
module/system/repl/repl.scm
View file

@ -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)))

1
test-suite/Makefile.am
View file

@ -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

40
test-suite/lib.scm
View file

@ -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

43
test-suite/tests/compiler.test
View file

@ -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))
)
(pass-if "compile to value"
(equal? (compile 1) 1)))

25
test-suite/tests/eval.test
View file

@ -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))))
))

35
test-suite/tests/reader.test
View file

@ -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)))))

7
test-suite/tests/srfi-17.test
View file

@ -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)))))
;;

9
test-suite/tests/srfi-18.test
View file

@ -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"

2
test-suite/tests/srfi-31.test
View file

@ -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)))))

414
test-suite/tests/syntax.test
View file

@ -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)))

467
test-suite/tests/tree-il.test Normal file
View file

@ -0,0 +1,467 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- 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))))

2
testsuite/t-match.scm
View file

@ -12,7 +12,7 @@
(define (matches? obj)
; (format #t "matches? ~a~%" obj)
(match obj
(($ stuff) => #t)
(($ stuff) #t)
; (blurps #t)
("hello" #t)
(else #f)))