mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 11:34:09 +02:00
Code Activity

rename <application> to <call>

Browse source 
* doc/ref/compiler.texi (The Scheme Compiler): Update docs.

* libguile/expand.h:
* libguile/expand.c:
* module/language/tree-il.scm: Rename <application> to <call>.  Change
  the external representation from (apply proc arg ...) to (call proc
  arg ...).

* libguile/memoize.c:
* module/ice-9/psyntax-pp.scm:
* module/ice-9/psyntax.scm:
* module/language/brainfuck/compile-tree-il.scm:
* module/language/ecmascript/compile-tree-il.scm:
* module/language/elisp/compile-tree-il.scm:
* module/language/tree-il/analyze.scm:
* module/language/tree-il/compile-glil.scm:
* module/language/tree-il/fix-letrec.scm:
* module/language/tree-il/inline.scm:
* module/language/tree-il/primitives.scm:
* test-suite/tests/tree-il.test: Update all callers.
This commit is contained in:
Andy Wingo 2011-06-02 13:42:55 +02:00
parent d31d703fd4
commit 7081d4f981
16 changed files with 447 additions and 447 deletions
Download patch file Download diff file Expand all files Collapse all files

33
doc/ref/compiler.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2008, 2009, 2010 @c Copyright (C) 2008, 2009, 2010, 2011
@c Free Software Foundation, Inc. @c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@ -158,12 +158,11 @@ different worlds indefinitely, as shown by the following quine:
@node The Scheme Compiler @node The Scheme Compiler
@subsection The Scheme Compiler @subsection The Scheme Compiler
The job of the Scheme compiler is to expand all macros and all of The job of the Scheme compiler is to expand all macros and all of Scheme
Scheme to its most primitive expressions. The definition of to its most primitive expressions. The definition of ``primitive'' is
``primitive'' is given by the inventory of constructs provided by given by the inventory of constructs provided by Tree-IL, the target
Tree-IL, the target language of the Scheme compiler: procedure language of the Scheme compiler: procedure calls, conditionals, lexical
applications, conditionals, lexical references, etc. This is described references, etc. This is described more fully in the next section.
more fully in the next section.
The tricky and amusing thing about the Scheme-to-Tree-IL compiler is The tricky and amusing thing about the Scheme-to-Tree-IL compiler is
that it is completely implemented by the macro expander. Since the that it is completely implemented by the macro expander. Since the
@ -181,10 +180,10 @@ The Scheme-to-Tree-IL expander may be invoked using the generic
@lisp @lisp
(compile '(+ 1 2) #:from 'scheme #:to 'tree-il) (compile '(+ 1 2) #:from 'scheme #:to 'tree-il)
@result{} @result{}
#<<application> src: #f #<<call> src: #f
proc: #<<toplevel-ref> src: #f name: +> proc: #<<toplevel-ref> src: #f name: +>
args: (#<<const> src: #f exp: 1> args: (#<<const> src: #f exp: 1>
#<<const> src: #f exp: 2>)> #<<const> src: #f exp: 2>)>
@end lisp @end lisp
Or, since Tree-IL is so close to Scheme, it is often useful to expand Or, since Tree-IL is so close to Scheme, it is often useful to expand
@ -339,9 +338,9 @@ instruction.
Compilation of Tree-IL usually begins with a pass that resolves some Compilation of Tree-IL usually begins with a pass that resolves some
@code{<module-ref>} and @code{<toplevel-ref>} expressions to @code{<module-ref>} and @code{<toplevel-ref>} expressions to
@code{<primitive-ref>} expressions. The actual compilation pass @code{<primitive-ref>} expressions. The actual compilation pass has
has special cases for applications of certain primitives, like special cases for calls to certain primitives, like @code{apply} or
@code{apply} or @code{cons}. @code{cons}.
@end deftp @end deftp
@deftp {Scheme Variable} <lexical-ref> src name gensym @deftp {Scheme Variable} <lexical-ref> src name gensym
@deftpx {External Representation} (lexical @var{name} @var{gensym}) @deftpx {External Representation} (lexical @var{name} @var{gensym})
@ -385,8 +384,8 @@ Defines a new top-level variable in the current procedure's module.
@deftpx {External Representation} (if @var{test} @var{then} @var{else}) @deftpx {External Representation} (if @var{test} @var{then} @var{else})
A conditional. Note that @var{else} is not optional. A conditional. Note that @var{else} is not optional.
@end deftp @end deftp
@deftp {Scheme Variable} <application> src proc args @deftp {Scheme Variable} <call> src proc args
@deftpx {External Representation} (apply @var{proc} . @var{args}) @deftpx {External Representation} (call @var{proc} . @var{args})
A procedure call. A procedure call.
@end deftp @end deftp
@deftp {Scheme Variable} <sequence> src exps @deftp {Scheme Variable} <sequence> src exps
@ -506,7 +505,7 @@ Like Scheme's @code{receive} -- binds the values returned by
evaluating @code{exp} to the @code{lambda}-like bindings described by evaluating @code{exp} to the @code{lambda}-like bindings described by
@var{gensyms}. That is to say, @var{gensyms} may be an improper list. @var{gensyms}. That is to say, @var{gensyms} may be an improper list.
@code{<let-values>} is an optimization of @code{<application>} of the @code{<let-values>} is an optimization of a @code{<call>} to the
primitive, @code{call-with-values}. primitive, @code{call-with-values}.
@end deftp @end deftp
@deftp {Scheme Variable} <fix> src names gensyms vals body @deftp {Scheme Variable} <fix> src names gensyms vals body

28
libguile/expand.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
* Free Software Foundation, Inc. * Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
@ -71,8 +71,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \ #define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define APPLICATION(src, proc, exps) \ #define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps) SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQUENCE(src, exps) \ #define SEQUENCE(src, exps) \
SCM_MAKE_EXPANDED_SEQUENCE(src, exps) SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
#define LAMBDA(src, meta, body) \ #define LAMBDA(src, meta, body) \
@ -359,9 +359,9 @@ expand (SCM exp, SCM env)
arg_exps = CDR (arg_exps)) arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args); args = scm_cons (expand (CAR (arg_exps), env), args);
if (scm_is_null (arg_exps)) if (scm_is_null (arg_exps))
return APPLICATION (scm_source_properties (exp), return CALL (scm_source_properties (exp),
expand (proc, env), expand (proc, env),
scm_reverse_x (args, SCM_UNDEFINED)); scm_reverse_x (args, SCM_UNDEFINED));
else else
syntax_error ("expected a proper list", exp, SCM_UNDEFINED); syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
} }
@ -487,10 +487,10 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
scm_list_1 (expand (test, env)), scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F, CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
APPLICATION (SCM_BOOL_F, CALL (SCM_BOOL_F,
expand (CADDR (clause), new_env), expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F, scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))), tmp, tmp))),
rest)); rest));
} }
/* FIXME length == 1 case */ /* FIXME length == 1 case */
@ -993,9 +993,9 @@ expand_named_let (const SCM expr, SCM env)
SCM_BOOL_F, SCM_BOOL_F, var_syms, SCM_BOOL_F, SCM_BOOL_F, var_syms,
expand_sequence (CDDDR (expr), inner_env), expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))), SCM_BOOL_F))),
APPLICATION (SCM_BOOL_F, CALL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, name, name_sym), LEXICAL_REF (SCM_BOOL_F, name, name_sym),
expand_exprs (inits, env))); expand_exprs (inits, env)));
} }
static SCM static SCM
@ -1243,7 +1243,7 @@ scm_init_expand ()
DEFINE_NAMES (TOPLEVEL_SET); DEFINE_NAMES (TOPLEVEL_SET);
DEFINE_NAMES (TOPLEVEL_DEFINE); DEFINE_NAMES (TOPLEVEL_DEFINE);
DEFINE_NAMES (CONDITIONAL); DEFINE_NAMES (CONDITIONAL);
DEFINE_NAMES (APPLICATION); DEFINE_NAMES (CALL);
DEFINE_NAMES (SEQUENCE); DEFINE_NAMES (SEQUENCE);
DEFINE_NAMES (LAMBDA); DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE); DEFINE_NAMES (LAMBDA_CASE);

18
libguile/expand.h
View file

@ -47,7 +47,7 @@ typedef enum
SCM_EXPANDED_TOPLEVEL_SET, SCM_EXPANDED_TOPLEVEL_SET,
SCM_EXPANDED_TOPLEVEL_DEFINE, SCM_EXPANDED_TOPLEVEL_DEFINE,
SCM_EXPANDED_CONDITIONAL, SCM_EXPANDED_CONDITIONAL,
SCM_EXPANDED_APPLICATION, SCM_EXPANDED_CALL,
SCM_EXPANDED_SEQUENCE, SCM_EXPANDED_SEQUENCE,
SCM_EXPANDED_LAMBDA, SCM_EXPANDED_LAMBDA,
SCM_EXPANDED_LAMBDA_CASE, SCM_EXPANDED_LAMBDA_CASE,
@ -228,18 +228,18 @@ enum
#define SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) \ #define SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONDITIONAL], 0, SCM_NUM_EXPANDED_CONDITIONAL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (test), SCM_UNPACK (consequent), SCM_UNPACK (alternate)) scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONDITIONAL], 0, SCM_NUM_EXPANDED_CONDITIONAL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (test), SCM_UNPACK (consequent), SCM_UNPACK (alternate))
#define SCM_EXPANDED_APPLICATION_TYPE_NAME "application" #define SCM_EXPANDED_CALL_TYPE_NAME "call"
#define SCM_EXPANDED_APPLICATION_FIELD_NAMES \ #define SCM_EXPANDED_CALL_FIELD_NAMES \
{ "src", "proc", "args", } { "src", "proc", "args", }
enum enum
{ {
SCM_EXPANDED_APPLICATION_SRC, SCM_EXPANDED_CALL_SRC,
SCM_EXPANDED_APPLICATION_PROC, SCM_EXPANDED_CALL_PROC,
SCM_EXPANDED_APPLICATION_ARGS, SCM_EXPANDED_CALL_ARGS,
SCM_NUM_EXPANDED_APPLICATION_FIELDS, SCM_NUM_EXPANDED_CALL_FIELDS,
}; };
#define SCM_MAKE_EXPANDED_APPLICATION(src, proc, args) \ #define SCM_MAKE_EXPANDED_CALL(src, proc, args) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_APPLICATION], 0, SCM_NUM_EXPANDED_APPLICATION_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args)) scm_c_make_struct (exp_vtables[SCM_EXPANDED_CALL], 0, SCM_NUM_EXPANDED_CALL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (args))
#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence" #define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \ #define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \

6
libguile/memoize.c
View file

@ -241,12 +241,12 @@ memoize (SCM exp, SCM env)
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
case SCM_EXPANDED_APPLICATION: case SCM_EXPANDED_CALL:
{ {
SCM proc, args; SCM proc, args;
proc = REF (exp, APPLICATION, PROC); proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, APPLICATION, ARGS), env); args = memoize_exps (REF (exp, CALL, ARGS), env);
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF) if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
{ {

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

@ -86,7 +86,7 @@
#{test 820}# #{test 820}#
#{consequent 821}# #{consequent 821}#
#{alternate 822}#))) #{alternate 822}#)))
(#{make-application 225}# (#{make-call 225}#
(lambda (#{src 827}# #{proc 828}# #{args 829}#) (lambda (#{src 827}# #{proc 828}# #{args 829}#)
(make-struct/no-tail (make-struct/no-tail
(vector-ref %expanded-vtables 11) (vector-ref %expanded-vtables 11)
@ -234,9 +234,9 @@
(#{build-void 263}# (#{build-void 263}#
(lambda (#{source 943}#) (lambda (#{source 943}#)
(#{make-void 203}# #{source 943}#))) (#{make-void 203}# #{source 943}#)))
(#{build-application 265}# (#{build-call 265}#
(lambda (#{source 945}# #{fun-exp 946}# #{arg-exps 947}#) (lambda (#{source 945}# #{fun-exp 946}# #{arg-exps 947}#)
(#{make-application 225}# (#{make-call 225}#
#{source 945}# #{source 945}#
#{fun-exp 946}# #{fun-exp 946}#
#{arg-exps 947}#))) #{arg-exps 947}#)))
@ -487,7 +487,7 @@
(list #{f-name 1111}#) (list #{f-name 1111}#)
(list #{f 1110}#) (list #{f 1110}#)
(list #{proc 1115}#) (list #{proc 1115}#)
(#{build-application 265}# (#{build-call 265}#
#{src 1096}# #{src 1096}#
(#{build-lexical-reference 271}# (#{build-lexical-reference 271}#
'fun 'fun
@ -1479,7 +1479,7 @@
(#{build-global-definition 281}# (#{build-global-definition 281}#
#f #f
#{name 1713}# #{name 1713}#
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# (#{build-primref 289}#
#f #f
@ -1531,7 +1531,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -1620,7 +1620,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -1642,7 +1642,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -1967,7 +1967,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -2056,7 +2056,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -2078,7 +2078,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -2403,7 +2403,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -2492,7 +2492,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -2514,7 +2514,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -2839,7 +2839,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -2928,7 +2928,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -2950,7 +2950,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -3581,7 +3581,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -3670,7 +3670,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -3692,7 +3692,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -4108,7 +4108,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -4197,7 +4197,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -4219,7 +4219,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -4604,7 +4604,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -4693,7 +4693,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -4715,7 +4715,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -5100,7 +5100,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -5189,7 +5189,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -5211,7 +5211,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -5646,7 +5646,7 @@
#{w 1915}# #{w 1915}#
#{mod 1917}#))) #{mod 1917}#)))
(if (eqv? #{type 1896}# 'lexical-call) (if (eqv? #{type 1896}# 'lexical-call)
(#{chi-application 423}# (#{chi-call 423}#
(begin (begin
(let ((#{id 1925}# (car #{e 1898}#))) (let ((#{id 1925}# (car #{e 1898}#)))
(#{build-lexical-reference 271}# (#{build-lexical-reference 271}#
@ -5662,7 +5662,7 @@
#{s 1901}# #{s 1901}#
#{mod 1902}#) #{mod 1902}#)
(if (eqv? #{type 1896}# 'global-call) (if (eqv? #{type 1896}# 'global-call)
(#{chi-application 423}# (#{chi-call 423}#
(#{build-global-reference 277}# (#{build-global-reference 277}#
(#{source-annotation 320}# (car #{e 1898}#)) (#{source-annotation 320}# (car #{e 1898}#))
(if (#{syntax-object? 305}# #{value 1897}#) (if (#{syntax-object? 305}# #{value 1897}#)
@ -5692,7 +5692,7 @@
#{value 1897}# #{value 1897}#
#{mod 1902}#) #{mod 1902}#)
(if (eqv? #{type 1896}# 'call) (if (eqv? #{type 1896}# 'call)
(#{chi-application 423}# (#{chi-call 423}#
(#{chi 419}# (#{chi 419}#
(car #{e 1898}#) (car #{e 1898}#)
#{r 1899}# #{r 1899}#
@ -5799,7 +5799,7 @@
#{w 1900}# #{w 1900}#
#{s 1901}# #{s 1901}#
#{mod 1902}#)))))))))))))))))) #{mod 1902}#))))))))))))))))))
(#{chi-application 423}# (#{chi-call 423}#
(lambda (#{x 1957}# (lambda (#{x 1957}#
#{e 1958}# #{e 1958}#
#{r 1959}# #{r 1959}#
@ -5812,7 +5812,7 @@
(if #{tmp 1970}# (if #{tmp 1970}#
(@apply (@apply
(lambda (#{e0 1973}# #{e1 1974}#) (lambda (#{e0 1973}# #{e1 1974}#)
(#{build-application 265}# (#{build-call 265}#
#{s 1961}# #{s 1961}#
#{x 1957}# #{x 1957}#
(map (lambda (#{e 1975}#) (map (lambda (#{e 1975}#)
@ -6332,7 +6332,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -6421,7 +6421,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -6443,7 +6443,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -7008,7 +7008,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -7097,7 +7097,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -7119,7 +7119,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -7578,7 +7578,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -7667,7 +7667,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -7689,7 +7689,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -9166,7 +9166,7 @@
'() '()
(#{regen 2903}# (car (cdr (cdr #{x 3099}#))))) (#{regen 2903}# (car (cdr (cdr #{x 3099}#)))))
(error "how did we get here" #{x 3099}#)) (error "how did we get here" #{x 3099}#))
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# #f (car #{x 3099}#)) (#{build-primref 289}# #f (car #{x 3099}#))
(map #{regen 2903}# (cdr #{x 3099}#)))))))))))) (map #{regen 2903}# (cdr #{x 3099}#))))))))))))
@ -9908,7 +9908,7 @@
#f #f
"source expression failed to match any pattern" "source expression failed to match any pattern"
#{tmp 3555}#)))))))) #{tmp 3555}#))))))))
(#{build-application 265}# (#{build-call 265}#
#{s 3483}# #{s 3483}#
(#{chi 419}# (#{chi 419}#
(list '#(syntax-object (list '#(syntax-object
@ -9957,7 +9957,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -10046,7 +10046,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -10068,7 +10068,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -10431,7 +10431,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -10520,7 +10520,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -10542,7 +10542,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -10927,7 +10927,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -11016,7 +11016,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -11038,7 +11038,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -11529,7 +11529,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -11618,7 +11618,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -11640,7 +11640,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -12076,7 +12076,7 @@
(#{gen-labels 354}# #{ids 3800}#)) (#{gen-labels 354}# #{ids 3800}#))
(#{new-vars 3805}# (#{new-vars 3805}#
(map #{gen-var 447}# #{ids 3800}#))) (map #{gen-var 447}# #{ids 3800}#)))
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# #f 'apply) (#{build-primref 289}# #f 'apply)
(list (#{build-simple-lambda 283}# (list (#{build-simple-lambda 283}#
@ -12133,7 +12133,7 @@
#{pat 3820}#) #{pat 3820}#)
(begin (begin
(let ((#{y 3844}# (#{gen-var 447}# 'tmp))) (let ((#{y 3844}# (#{gen-var 447}# 'tmp)))
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-simple-lambda 283}# (#{build-simple-lambda 283}#
#f #f
@ -12183,11 +12183,11 @@
#{r 3819}# #{r 3819}#
#{mod 3823}#))))) #{mod 3823}#)))))
(list (if (eq? #{p 3832}# 'any) (list (if (eq? #{p 3832}# 'any)
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# #f 'list) (#{build-primref 289}# #f 'list)
(list #{x 3816}#)) (list #{x 3816}#))
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# #f '$sc-dispatch) (#{build-primref 289}# #f '$sc-dispatch)
(list #{x 3816}# (list #{x 3816}#
@ -12201,7 +12201,7 @@
#{r 3865}# #{r 3865}#
#{mod 3866}#) #{mod 3866}#)
(if (null? #{clauses 3864}#) (if (null? #{clauses 3864}#)
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-primref 289}# #f 'syntax-violation) (#{build-primref 289}# #f 'syntax-violation)
(list (#{build-data 291}# #f #f) (list (#{build-data 291}# #f #f)
@ -12261,7 +12261,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -12350,7 +12350,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -12372,7 +12372,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -12703,7 +12703,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -12792,7 +12792,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -12814,7 +12814,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -13142,7 +13142,7 @@
chi-local-syntax chi-local-syntax
chi-body chi-body
chi-macro chi-macro
chi-application chi-call
chi-expr chi-expr
chi chi
syntax-type syntax-type
@ -13231,7 +13231,7 @@
build-lexical-reference build-lexical-reference
build-dynlet build-dynlet
build-conditional build-conditional
build-application build-call
build-void build-void
maybe-name-value! maybe-name-value!
decorate-source decorate-source
@ -13253,7 +13253,7 @@
make-lambda-case make-lambda-case
make-lambda make-lambda
make-sequence make-sequence
make-application make-call
make-conditional make-conditional
make-toplevel-define make-toplevel-define
make-toplevel-set make-toplevel-set
@ -13554,7 +13554,7 @@
(list (#{gen-label 352}#))) (list (#{gen-label 352}#)))
(#{var 3890}# (#{var 3890}#
(#{gen-var 447}# #{pat 3880}#))) (#{gen-var 447}# #{pat 3880}#)))
(#{build-application 265}# (#{build-call 265}#
#f #f
(#{build-simple-lambda 283}# (#{build-simple-lambda 283}#
#f #f
@ -13636,7 +13636,7 @@
#{key 3923}#) #{key 3923}#)
(begin (begin
(let ((#{x 3931}# (#{gen-var 447}# 'tmp))) (let ((#{x 3931}# (#{gen-var 447}# 'tmp)))
(#{build-application 265}# (#{build-call 265}#
#{s 3908}# #{s 3908}#
(#{build-simple-lambda 283}# (#{build-simple-lambda 283}#
#f #f

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

@ -313,9 +313,9 @@
(lambda (source) (lambda (source)
(make-void source))) (make-void source)))
(define build-application (define build-call
(lambda (source fun-exp arg-exps) (lambda (source fun-exp arg-exps)
(make-application source fun-exp arg-exps))) (make-call source fun-exp arg-exps)))
(define build-conditional (define build-conditional
(lambda (source test-exp then-exp else-exp) (lambda (source test-exp then-exp else-exp)
@ -436,8 +436,8 @@
(make-letrec (make-letrec
src #f src #f
(list f-name) (list f) (list proc) (list f-name) (list f) (list proc)
(build-application src (build-lexical-reference 'fun src f-name f) (build-call src (build-lexical-reference 'fun src f-name f)
val-exps)))))) val-exps))))))
(define build-letrec (define build-letrec
(lambda (src in-order? ids vars val-exps body-exp) (lambda (src in-order? ids vars val-exps body-exp)
@ -1038,7 +1038,7 @@
(build-global-definition (build-global-definition
no-source no-source
name name
(build-application (build-call
no-source no-source
(build-primref no-source 'make-syntax-transformer) (build-primref no-source 'make-syntax-transformer)
(list (build-data no-source name) (list (build-data no-source name)
@ -1200,7 +1200,7 @@
(lambda (e r w s mod) (lambda (e r w s mod)
(chi e r w mod)))) (chi e r w mod))))
((lexical-call) ((lexical-call)
(chi-application (chi-call
(let ((id (car e))) (let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id) (build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id) (if (syntax-object? id)
@ -1209,7 +1209,7 @@
value)) value))
e r w s mod)) e r w s mod))
((global-call) ((global-call)
(chi-application (chi-call
(build-global-reference (source-annotation (car e)) (build-global-reference (source-annotation (car e))
(if (syntax-object? value) (if (syntax-object? value)
(syntax-object-expression value) (syntax-object-expression value)
@ -1220,7 +1220,7 @@
e r w s mod)) e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod)) ((global) (build-global-reference s value mod))
((call) (chi-application (chi (car e) r w mod) e r w s mod)) ((call) (chi-call (chi (car e) r w mod) e r w s mod))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod)))) ((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
@ -1245,12 +1245,12 @@
(else (syntax-violation #f "unexpected syntax" (else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
(define chi-application (define chi-call
(lambda (x e r w s mod) (lambda (x e r w s mod)
(syntax-case e () (syntax-case e ()
((e0 e1 ...) ((e0 e1 ...)
(build-application s x (build-call s x
(map (lambda (e) (chi e r w mod)) #'(e1 ...))))))) (map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy) ;; (What follows is my interpretation of what's going on here -- Andy)
;; ;;
@ -1954,9 +1954,9 @@
(if (list? (cadr x)) (if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x))) (build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x))) (error "how did we get here" x)))
(else (build-application no-source (else (build-call no-source
(build-primref no-source (car x)) (build-primref no-source (car x))
(map regen (cdr x))))))) (map regen (cdr x)))))))
(lambda (e r w s mod) (lambda (e r w s mod)
(let ((e (source-wrap e w s mod))) (let ((e (source-wrap e w s mod)))
@ -2147,10 +2147,10 @@
(build-global-assignment s (syntax->datum #'e) (build-global-assignment s (syntax->datum #'e)
val mod))))))) val mod)))))))
(else (else
(build-application s (build-call s
(chi #'(setter head) r w mod) (chi #'(setter head) r w mod)
(map (lambda (e) (chi e r w mod)) (map (lambda (e) (chi e r w mod))
#'(tail ... val)))))))) #'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@ (global-extend 'module-ref '@
@ -2288,20 +2288,20 @@
(lambda (pvars exp y r mod) (lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source (build-call no-source
(build-primref no-source 'apply) (build-primref no-source 'apply)
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp (chi exp
(extend-env (extend-env
labels labels
(map (lambda (var level) (map (lambda (var level)
(make-binding 'syntax `(,var . ,level))) (make-binding 'syntax `(,var . ,level)))
new-vars new-vars
(map cdr pvars)) (map cdr pvars))
r) r)
(make-binding-wrap ids labels empty-wrap) (make-binding-wrap ids labels empty-wrap)
mod)) mod))
y)))))) y))))))
(define gen-clause (define gen-clause
(lambda (x keys clauses r pat fender exp mod) (lambda (x keys clauses r pat fender exp mod)
@ -2316,36 +2316,36 @@
(else (else
(let ((y (gen-var 'tmp))) (let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y ;; fat finger binding and references to temp variable y
(build-application no-source (build-call no-source
(build-simple-lambda no-source (list 'tmp) #f (list y) '() (build-simple-lambda no-source (list 'tmp) #f (list y) '()
(let ((y (build-lexical-reference 'value no-source (let ((y (build-lexical-reference 'value no-source
'tmp y))) 'tmp y)))
(build-conditional no-source (build-conditional no-source
(syntax-case fender () (syntax-case fender ()
(#t y) (#t y)
(_ (build-conditional no-source (_ (build-conditional no-source
y y
(build-dispatch-call pvars fender y r mod) (build-dispatch-call pvars fender y r mod)
(build-data no-source #f)))) (build-data no-source #f))))
(build-dispatch-call pvars exp y r mod) (build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod)))) (gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any) (list (if (eq? p 'any)
(build-application no-source (build-call no-source
(build-primref no-source 'list) (build-primref no-source 'list)
(list x)) (list x))
(build-application no-source (build-call no-source
(build-primref no-source '$sc-dispatch) (build-primref no-source '$sc-dispatch)
(list x (build-data no-source p))))))))))))) (list x (build-data no-source p)))))))))))))
(define gen-syntax-case (define gen-syntax-case
(lambda (x keys clauses r mod) (lambda (x keys clauses r mod)
(if (null? clauses) (if (null? clauses)
(build-application no-source (build-call no-source
(build-primref no-source 'syntax-violation) (build-primref no-source 'syntax-violation)
(list (build-data no-source #f) (list (build-data no-source #f)
(build-data no-source (build-data no-source
"source expression failed to match any pattern") "source expression failed to match any pattern")
x)) x))
(syntax-case (car clauses) () (syntax-case (car clauses) ()
((pat exp) ((pat exp)
(if (and (id? #'pat) (if (and (id? #'pat)
@ -2355,18 +2355,18 @@
(chi #'exp r empty-wrap mod) (chi #'exp r empty-wrap mod)
(let ((labels (list (gen-label))) (let ((labels (list (gen-label)))
(var (gen-var #'pat))) (var (gen-var #'pat)))
(build-application no-source (build-call no-source
(build-simple-lambda (build-simple-lambda
no-source (list (syntax->datum #'pat)) #f (list var) no-source (list (syntax->datum #'pat)) #f (list var)
'() '()
(chi #'exp (chi #'exp
(extend-env labels (extend-env labels
(list (make-binding 'syntax `(,var . 0))) (list (make-binding 'syntax `(,var . 0)))
r) r)
(make-binding-wrap #'(pat) (make-binding-wrap #'(pat)
labels empty-wrap) labels empty-wrap)
mod)) mod))
(list x)))) (list x))))
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod))) #'pat #t #'exp mod)))
((pat fender exp) ((pat fender exp)
@ -2383,14 +2383,14 @@
#'(key ...)) #'(key ...))
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
;; fat finger binding and references to temp variable x ;; fat finger binding and references to temp variable x
(build-application s (build-call s
(build-simple-lambda no-source (list 'tmp) #f (list x) '() (build-simple-lambda no-source (list 'tmp) #f (list x) '()
(gen-syntax-case (build-lexical-reference 'value no-source (gen-syntax-case (build-lexical-reference 'value no-source
'tmp x) 'tmp x)
#'(key ...) #'(m ...) #'(key ...) #'(m ...)
r r
mod)) mod))
(list (chi #'val r empty-wrap mod)))) (list (chi #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e)))))))) (syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds chi-top's mode m with 'e (for ;; The portable macroexpand seeds chi-top's mode m with 'e (for

54
module/language/brainfuck/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Brainfuck for GNU Guile ;;; Brainfuck for GNU Guile
;; Copyright (C) 2009 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -94,7 +94,7 @@
(parse-tree-il (parse-tree-il
`(let (pointer tape) (pointer tape) `(let (pointer tape) (pointer tape)
((const 0) ((const 0)
(apply (primitive make-vector) (const ,tape-size) (const 0))) (call (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp))) ,(compile-body exp)))
env env
env)) env))
@ -109,11 +109,11 @@
(cond (cond
((null? in) ((null? in)
;; No more input, build our output. ;; No more input, build our output.
(cond (cond
((null? out) '(void)) ; no output ((null? out) '(void)) ; no output
((null? (cdr out)) (car out)) ; single expression ((null? (cdr out)) (car out)) ; single expression
(else `(begin ,@(reverse out)))) ; sequence (else `(begin ,@(reverse out)))) ; sequence
) )
(else (else
(pmatch (car in) (pmatch (car in)
@ -121,34 +121,34 @@
;; (set! pointer (+ pointer +-1)) ;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir) ((<bf-move> ,dir)
(emit `(set! (lexical pointer) (emit `(set! (lexical pointer)
(apply (primitive +) (lexical pointer) (const ,dir))))) (call (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as: ;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1)) ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc) ((<bf-increment> ,inc)
(emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer) (emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
(apply (primitive +) (call (primitive +)
(apply (primitive vector-ref) (call (primitive vector-ref)
(lexical tape) (lexical pointer)) (lexical tape) (lexical pointer))
(const ,inc))))) (const ,inc)))))
;; Output . is done by converting the cell's integer value to a ;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character: ;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer))) ;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>) ((<bf-print>)
(emit `(apply (primitive write-char) (emit `(call (primitive write-char)
(apply (primitive integer->char) (call (primitive integer->char)
(apply (primitive vector-ref) (call (primitive vector-ref)
(lexical tape) (lexical pointer)))))) (lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII ;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell: ;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char))) ;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>) ((<bf-read>)
(emit `(apply (primitive vector-set!) (emit `(call (primitive vector-set!)
(lexical tape) (lexical pointer) (lexical tape) (lexical pointer)
(apply (primitive char->integer) (call (primitive char->integer)
(apply (primitive read-char)))))) (call (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until ;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call ;; the current cell gets zero. The body is compiled via a recursive call
@ -171,14 +171,14 @@
((lambda () ((lambda ()
(lambda-case (lambda-case
((() #f #f #f () ()) ((() #f #f #f () ())
(if (apply (primitive =) (if (call (primitive =)
(apply (primitive vector-ref) (call (primitive vector-ref)
(lexical tape) (lexical pointer)) (lexical tape) (lexical pointer))
(const 0)) (const 0))
(void) (void)
(begin ,(compile-body body) (begin ,(compile-body body)
(apply (lexical ,iterate))))) (call (lexical ,iterate)))))
#f))) #f)))
(apply (lexical ,iterate)))))) (call (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in)))))))) (else (error "unknown brainfuck instruction" (car in))))))))

172
module/language/ecmascript/compile-tree-il.scm
View file

@ -38,7 +38,7 @@
(define-syntax @impl (define-syntax @impl
(syntax-rules () (syntax-rules ()
((_ sym arg ...) ((_ sym arg ...)
(-> (apply (@implv sym) arg ...))))) (-> (call (@implv sym) arg ...)))))
(define (empty-lexical-environment) (define (empty-lexical-environment)
'()) '())
@ -103,23 +103,23 @@
(this (this
(@impl get-this)) (@impl get-this))
((+ ,a) ((+ ,a)
(-> (apply (-> (primitive '+)) (-> (call (-> (primitive '+))
(@impl ->number (comp a e)) (@impl ->number (comp a e))
(-> (const 0))))) (-> (const 0)))))
((- ,a) ((- ,a)
(-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e)))) (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a) ((~ ,a)
(@impl bitwise-not (comp a e))) (@impl bitwise-not (comp a e)))
((! ,a) ((! ,a)
(@impl logical-not (comp a e))) (@impl logical-not (comp a e)))
((+ ,a ,b) ((+ ,a ,b)
(-> (apply (-> (primitive '+)) (comp a e) (comp b e)))) (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b) ((- ,a ,b)
(-> (apply (-> (primitive '-)) (comp a e) (comp b e)))) (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b) ((/ ,a ,b)
(-> (apply (-> (primitive '/)) (comp a e) (comp b e)))) (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b) ((* ,a ,b)
(-> (apply (-> (primitive '*)) (comp a e) (comp b e)))) (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b) ((% ,a ,b)
(@impl mod (comp a e) (comp b e))) (@impl mod (comp a e) (comp b e)))
((<< ,a ,b) ((<< ,a ,b)
@ -127,27 +127,27 @@
((>> ,a ,b) ((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e))) (@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b) ((< ,a ,b)
(-> (apply (-> (primitive '<)) (comp a e) (comp b e)))) (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b) ((<= ,a ,b)
(-> (apply (-> (primitive '<=)) (comp a e) (comp b e)))) (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b) ((> ,a ,b)
(-> (apply (-> (primitive '>)) (comp a e) (comp b e)))) (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b) ((>= ,a ,b)
(-> (apply (-> (primitive '>=)) (comp a e) (comp b e)))) (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b) ((in ,a ,b)
(@impl has-property? (comp a e) (comp b e))) (@impl has-property? (comp a e) (comp b e)))
((== ,a ,b) ((== ,a ,b)
(-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e)))) (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b) ((!= ,a ,b)
(-> (apply (-> (primitive 'not)) (-> (call (-> (primitive 'not))
(-> (apply (-> (primitive 'equal?)) (-> (call (-> (primitive 'equal?))
(comp a e) (comp b e)))))) (comp a e) (comp b e))))))
((=== ,a ,b) ((=== ,a ,b)
(-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e)))) (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b) ((!== ,a ,b)
(-> (apply (-> (primitive 'not)) (-> (call (-> (primitive 'not))
(-> (apply (-> (primitive 'eqv?)) (-> (call (-> (primitive 'eqv?))
(comp a e) (comp b e)))))) (comp a e) (comp b e))))))
((& ,a ,b) ((& ,a ,b)
(@impl band (comp a e) (comp b e))) (@impl band (comp a e) (comp b e)))
((^ ,a ,b) ((^ ,a ,b)
@ -176,9 +176,9 @@
(begin1 (comp `(ref ,foo) e) (begin1 (comp `(ref ,foo) e)
(lambda (var) (lambda (var)
(-> (set! (lookup foo e) (-> (set! (lookup foo e)
(-> (apply (-> (primitive '+)) (-> (call (-> (primitive '+))
(-> (lexical var var)) (-> (lexical var var))
(-> (const 1))))))))) (-> (const 1)))))))))
((postinc (pref ,obj ,prop)) ((postinc (pref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
@ -189,9 +189,9 @@
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (const prop)) (-> (const prop))
(-> (apply (-> (primitive '+)) (-> (call (-> (primitive '+))
(-> (lexical tmpvar tmpvar)) (-> (lexical tmpvar tmpvar))
(-> (const 1)))))))))) (-> (const 1))))))))))
((postinc (aref ,obj ,prop)) ((postinc (aref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
@ -204,16 +204,16 @@
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (lexical propvar propvar)) (-> (lexical propvar propvar))
(-> (apply (-> (primitive '+)) (-> (call (-> (primitive '+))
(-> (lexical tmpvar tmpvar)) (-> (lexical tmpvar tmpvar))
(-> (const 1)))))))))))) (-> (const 1))))))))))))
((postdec (ref ,foo)) ((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e) (begin1 (comp `(ref ,foo) e)
(lambda (var) (lambda (var)
(-> (set (lookup foo e) (-> (set (lookup foo e)
(-> (apply (-> (primitive '-)) (-> (call (-> (primitive '-))
(-> (lexical var var)) (-> (lexical var var))
(-> (const 1))))))))) (-> (const 1)))))))))
((postdec (pref ,obj ,prop)) ((postdec (pref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
@ -224,9 +224,9 @@
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (const prop)) (-> (const prop))
(-> (apply (-> (primitive '-)) (-> (call (-> (primitive '-))
(-> (lexical tmpvar tmpvar)) (-> (lexical tmpvar tmpvar))
(-> (const 1)))))))))) (-> (const 1))))))))))
((postdec (aref ,obj ,prop)) ((postdec (aref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
@ -246,18 +246,18 @@
(let ((v (lookup foo e))) (let ((v (lookup foo e)))
(-> (begin (-> (begin
(-> (set! v (-> (set! v
(-> (apply (-> (primitive '+)) (-> (call (-> (primitive '+))
v v
(-> (const 1)))))) (-> (const 1))))))
v)))) v))))
((preinc (pref ,obj ,prop)) ((preinc (pref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
(begin1 (-> (apply (-> (primitive '+)) (begin1 (-> (call (-> (primitive '+))
(@impl pget (@impl pget
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (const prop))) (-> (const prop)))
(-> (const 1)))) (-> (const 1))))
(lambda (tmpvar) (lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar)) (@impl pput (-> (lexical objvar objvar))
(-> (const prop)) (-> (const prop))
@ -267,11 +267,11 @@
(lambda (objvar) (lambda (objvar)
(let1 (comp prop e) (let1 (comp prop e)
(lambda (propvar) (lambda (propvar)
(begin1 (-> (apply (-> (primitive '+)) (begin1 (-> (call (-> (primitive '+))
(@impl pget (@impl pget
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (lexical propvar propvar))) (-> (lexical propvar propvar)))
(-> (const 1)))) (-> (const 1))))
(lambda (tmpvar) (lambda (tmpvar)
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
@ -281,18 +281,18 @@
(let ((v (lookup foo e))) (let ((v (lookup foo e)))
(-> (begin (-> (begin
(-> (set! v (-> (set! v
(-> (apply (-> (primitive '-)) (-> (call (-> (primitive '-))
v v
(-> (const 1)))))) (-> (const 1))))))
v)))) v))))
((predec (pref ,obj ,prop)) ((predec (pref ,obj ,prop))
(let1 (comp obj e) (let1 (comp obj e)
(lambda (objvar) (lambda (objvar)
(begin1 (-> (apply (-> (primitive '-)) (begin1 (-> (call (-> (primitive '-))
(@impl pget (@impl pget
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (const prop))) (-> (const prop)))
(-> (const 1)))) (-> (const 1))))
(lambda (tmpvar) (lambda (tmpvar)
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
@ -303,11 +303,11 @@
(lambda (objvar) (lambda (objvar)
(let1 (comp prop e) (let1 (comp prop e)
(lambda (propvar) (lambda (propvar)
(begin1 (-> (apply (-> (primitive '-)) (begin1 (-> (call (-> (primitive '-))
(@impl pget (@impl pget
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
(-> (lexical propvar propvar))) (-> (lexical propvar propvar)))
(-> (const 1)))) (-> (const 1))))
(lambda (tmpvar) (lambda (tmpvar)
(@impl pput (@impl pput
(-> (lexical objvar objvar)) (-> (lexical objvar objvar))
@ -345,7 +345,7 @@
(-> (lambda '() (-> (lambda '()
`(lambda-case `(lambda-case
((() #f #f #f () ()) ((() #f #f #f () ())
(apply ,(@impl pget obj prop) ,@args))))))) (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args) ((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e) (comp `(call/this ,(comp obj e)
,(-> (const prop)) ,(-> (const prop))
@ -357,25 +357,25 @@
,@(map (lambda (x) (comp x e)) args)) ,@(map (lambda (x) (comp x e)) args))
e)) e))
((call ,proc ,args) ((call ,proc ,args)
`(apply ,(comp proc e) `(call ,(comp proc e)
,@(map (lambda (x) (comp x e)) args))) ,@(map (lambda (x) (comp x e)) args)))
((return ,expr) ((return ,expr)
(-> (apply (-> (primitive 'return)) (-> (call (-> (primitive 'return))
(comp expr e)))) (comp expr e))))
((array . ,args) ((array . ,args)
`(apply ,(@implv new-array) `(call ,(@implv new-array)
,@(map (lambda (x) (comp x e)) args))) ,@(map (lambda (x) (comp x e)) args)))
((object . ,args) ((object . ,args)
`(apply ,(@implv new-object) `(call ,(@implv new-object)
,@(map (lambda (x) ,@(map (lambda (x)
(pmatch x (pmatch x
((,prop ,val) ((,prop ,val)
(-> (apply (-> (primitive 'cons)) (-> (call (-> (primitive 'cons))
(-> (const prop)) (-> (const prop))
(comp val e)))) (comp val e))))
(else (else
(error "bad prop-val pair" x)))) (error "bad prop-val pair" x))))
args))) args)))
((pref ,obj ,prop) ((pref ,obj ,prop)
(@impl pget (@impl pget
(comp obj e) (comp obj e)
@ -450,14 +450,14 @@
`((() #f #f #f () ()) `((() #f #f #f () ())
,(-> (begin ,(-> (begin
(comp statement e) (comp statement e)
(-> (apply (-> (lexical '%continue %continue))))))))))) (-> (call (-> (lexical '%continue %continue)))))))))))
(-> (lambda '() (-> (lambda '()
(-> (lambda-case (-> (lambda-case
`((() #f #f #f () ()) `((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e)) ,(-> (if (@impl ->boolean (comp test e))
(-> (apply (-> (lexical '%loop %loop)))) (-> (call (-> (lexical '%loop %loop))))
(@implv *undefined*))))))))) (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%loop %loop))))))))) (-> (call (-> (lexical '%loop %loop)))))))))
((while ,test ,statement) ((while ,test ,statement)
(let ((%continue (gensym "%continue "))) (let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e))) (let ((e (econs '%continue %continue e)))
@ -467,9 +467,9 @@
`((() #f #f #f () ()) `((() #f #f #f () ())
,(-> (if (@impl ->boolean (comp test e)) ,(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e) (-> (begin (comp statement e)
(-> (apply (-> (lexical '%continue %continue)))))) (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))))) (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue))))))))) (-> (call (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement) ((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue "))) (let ((%continue (gensym "%continue ")))
@ -483,10 +483,10 @@
(comp 'true e)) (comp 'true e))
(-> (begin (comp statement e) (-> (begin (comp statement e)
(comp (or inc '(begin)) e) (comp (or inc '(begin)) e)
(-> (apply (-> (lexical '%continue %continue)))))) (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))))) (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e) (-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue %continue))))))))))) (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement) ((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum ")) (let ((%enum (gensym "%enum "))
@ -506,9 +506,9 @@
,(-> (const 'pop)))) ,(-> (const 'pop))))
e) e)
(comp statement e) (comp statement e)
(-> (apply (-> (lexical '%continue %continue)))))) (-> (call (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))))) (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue))))))))) (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x) ((block ,x)
(comp x e)) (comp x e))

58
module/language/elisp/compile-tree-il.scm
View file

@ -1,6 +1,6 @@
;;; Guile Emacs Lisp ;;; Guile Emacs Lisp
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify ;; 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 ;; it under the terms of the GNU General Public License as published by
@ -109,7 +109,7 @@
;;; Build a call to a primitive procedure nicely. ;;; Build a call to a primitive procedure nicely.
(define (call-primitive loc sym . args) (define (call-primitive loc sym . args)
(make-application loc (make-primitive-ref loc sym) args)) (make-call loc (make-primitive-ref loc sym) args))
;;; Error reporting routine for syntax/compilation problems or build ;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output. ;;; code for a runtime-error output.
@ -118,9 +118,9 @@
(apply error args)) (apply error args))
(define (runtime-error loc msg . args) (define (runtime-error loc msg . args)
(make-application loc (make-call loc
(make-primitive-ref loc 'error) (make-primitive-ref loc 'error)
(cons (make-const loc msg) args))) (cons (make-const loc msg) args)))
;;; Generate code to ensure a global symbol is there for further use of ;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol. In general during the compilation, those needed are ;;; a given symbol. In general during the compilation, those needed are
@ -129,10 +129,10 @@
;;; this routine. ;;; this routine.
(define (generate-ensure-global loc sym module) (define (generate-ensure-global loc sym module)
(make-application loc (make-call loc
(make-module-ref loc runtime 'ensure-fluid! #t) (make-module-ref loc runtime 'ensure-fluid! #t)
(list (make-const loc module) (list (make-const loc module)
(make-const loc sym)))) (make-const loc sym))))
(define (ensuring-globals loc bindings body) (define (ensuring-globals loc bindings body)
(make-sequence (make-sequence
@ -151,12 +151,12 @@
(call-primitive (call-primitive
loc loc
'with-fluids* 'with-fluids*
(make-application loc (make-call loc
(make-primitive-ref loc 'list) (make-primitive-ref loc 'list)
(map (lambda (sym) (map (lambda (sym)
(make-module-ref loc module sym #t)) (make-module-ref loc module sym #t))
syms)) syms))
(make-application loc (make-primitive-ref loc 'list) vals) (make-call loc (make-primitive-ref loc 'list) vals)
(make-lambda loc (make-lambda loc
'() '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))) (make-lambda-case #f '() #f #f #f '() '() body #f))))
@ -204,7 +204,7 @@
sym sym
module module
(lambda () (lambda ()
(make-application (make-call
loc loc
(make-module-ref loc runtime 'set-variable! #t) (make-module-ref loc runtime 'set-variable! #t)
(list (make-const loc module) (make-const loc sym) value))) (list (make-const loc module) (make-const loc sym) value)))
@ -779,11 +779,11 @@
((,condition . ,body) ((,condition . ,body)
(let* ((itersym (gensym)) (let* ((itersym (gensym))
(compiled-body (map compile-expr body)) (compiled-body (map compile-expr body))
(iter-call (make-application loc (iter-call (make-call loc
(make-lexical-ref loc (make-lexical-ref loc
'iterate 'iterate
itersym) itersym)
(list))) (list)))
(full-body (make-sequence loc (full-body (make-sequence loc
`(,@compiled-body ,iter-call))) `(,@compiled-body ,iter-call)))
(lambda-body (make-conditional loc (lambda-body (make-conditional loc
@ -828,7 +828,7 @@
loc loc
name name
function-slot function-slot
(make-application (make-call
loc loc
(make-module-ref loc '(guile) 'cons #t) (make-module-ref loc '(guile) 'cons #t)
(list (make-const loc 'macro) (list (make-const loc 'macro)
@ -876,13 +876,13 @@
=> (lambda (macro-function) => (lambda (macro-function)
(compile-expr (apply macro-function arguments)))) (compile-expr (apply macro-function arguments))))
(else (else
(make-application loc (make-call loc
(if (symbol? operator) (if (symbol? operator)
(reference-variable loc (reference-variable loc
operator operator
function-slot) function-slot)
(compile-expr operator)) (compile-expr operator))
(map compile-expr arguments)))))) (map compile-expr arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe ;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil. ;;; some special value like nil.

35
module/language/tree-il.scm
View file

@ -34,7 +34,7 @@
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp <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 <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
<application> application? make-application application-src application-proc application-args <call> call? make-call call-src call-proc call-args
<sequence> sequence? make-sequence sequence-src sequence-exps <sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src <lambda-case> lambda-case? make-lambda-case lambda-case-src
@ -118,7 +118,7 @@
;; (<toplevel-set> name exp) ;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp) ;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate) ;; (<conditional> test consequent alternate)
;; (<application> proc args) ;; (<call> proc args)
;; (<sequence> exps) ;; (<sequence> exps)
;; (<lambda> meta body) ;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate) ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
@ -149,8 +149,8 @@
((void) ((void)
(make-void loc)) (make-void loc))
((apply ,proc . ,args) ((call ,proc . ,args)
(make-application loc (retrans proc) (map retrans args))) (make-call loc (retrans proc) (map retrans args)))
((if ,test ,consequent ,alternate) ((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@ -253,8 +253,8 @@
((<void>) ((<void>)
'(void)) '(void))
((<application> proc args) ((<call> proc args)
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate))) `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@ -336,7 +336,7 @@
((<void>) ((<void>)
'(if #f #f)) '(if #f #f))
((<application> proc args) ((<call> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args))) `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
@ -478,7 +478,8 @@
((<abort> tag args tail) ((<abort> tag args tail)
`(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args) `(apply abort-to-prompt
,(tree-il->scheme tag) ,@(map tree-il->scheme args)
,(tree-il->scheme tail))))) ,(tree-il->scheme tail)))))
@ -489,7 +490,7 @@ invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
and SEED is the current result, intially seeded with SEED. and SEED is the current result, intially seeded with SEED.
This is an implementation of `foldts' as described by Andy Wingo in This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''." ``Calls of fold to XML transformation''."
(let loop ((tree tree) (let loop ((tree tree)
(result seed)) (result seed))
(if (or (null? tree) (pair? tree)) (if (or (null? tree) (pair? tree))
@ -507,7 +508,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop alternate (up tree (loop alternate
(loop consequent (loop consequent
(loop test (down tree result)))))) (loop test (down tree result))))))
((<application> proc args) ((<call> proc args)
(up tree (loop (cons proc args) (down tree result)))) (up tree (loop (cons proc args) (down tree result))))
((<sequence> exps) ((<sequence> exps)
(up tree (loop exps (down tree result)))) (up tree (loop exps (down tree result))))
@ -580,7 +581,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (foldts test seed ...)) (let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...))) ((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...))) (foldts alternate seed ...)))
((<application> proc args) ((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...))) (let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...))) (fold-values foldts args seed ...)))
((<sequence> exps) ((<sequence> exps)
@ -633,9 +634,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order! f x) (define (post-order! f x)
(let lp ((x x)) (let lp ((x x))
(record-case x (record-case x
((<application> proc args) ((<call> proc args)
(set! (application-proc x) (lp proc)) (set! (call-proc x) (lp proc))
(set! (application-args x) (map lp args))) (set! (call-args x) (map lp args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test)) (set! (conditional-test x) (lp test))
@ -717,9 +718,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let lp ((x x)) (let lp ((x x))
(let ((x (or (f x) x))) (let ((x (or (f x) x)))
(record-case x (record-case x
((<application> proc args) ((<call> proc args)
(set! (application-proc x) (lp proc)) (set! (call-proc x) (lp proc))
(set! (application-args x) (map lp args))) (set! (call-args x) (map lp args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
(set! (conditional-test x) (lp test)) (set! (conditional-test x) (lp test))

32
module/language/tree-il/analyze.scm
View file

@ -178,7 +178,7 @@
(analyze! x new-proc (append labels labels-in-proc) #t #f)) (analyze! x new-proc (append labels labels-in-proc) #t #f))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x (record-case x
((<application> proc args) ((<call> proc args)
(apply lset-union eq? (step-tail-call proc args) (apply lset-union eq? (step-tail-call proc args)
(map step args))) (map step args)))
@ -364,7 +364,7 @@
(define (allocate! x proc n) (define (allocate! x proc n)
(define (recur y) (allocate! y proc n)) (define (recur y) (allocate! y proc n))
(record-case x (record-case x
((<application> proc args) ((<call> proc args)
(apply max (recur proc) (map recur args))) (apply max (recur proc) (map recur args)))
((<conditional> test consequent alternate) ((<conditional> test consequent alternate)
@ -863,7 +863,7 @@ accurate information is missing from a given `tree-il' element."
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...) (defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env) (define (goops-toplevel-definition proc args env)
;; If application of PROC to ARGS is a GOOPS top-level definition, return ;; If call of PROC to ARGS is a GOOPS top-level definition, return
;; the name of the variable being defined; otherwise return #f. This ;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al. ;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args) (define (toplevel-define-arg args)
@ -929,7 +929,7 @@ accurate information is missing from a given `tree-il' element."
(make-toplevel-info (vhash-delq name refs) (make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs))) (vhash-consq name #t defs)))
((<application> proc args) ((<call> proc args)
;; Check for a dynamic top-level definition, as is ;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros. ;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args (let ((name (goops-toplevel-definition proc args
@ -967,12 +967,12 @@ accurate information is missing from a given `tree-il' element."
(define-record-type <arity-info> (define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas) (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info? arity-info?
(toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...) (toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...) (lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...) (toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
(define (validate-arity proc application lexical?) (define (validate-arity proc call lexical?)
;; Validate the argument count of APPLICATION, a tree-il application of ;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch. ;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args) (define (filter-keyword-args keywords allow-other-keys? args)
@ -1032,8 +1032,8 @@ accurate information is missing from a given `tree-il' element."
(else (else
(values #f #f)))))))) (values #f #f))))))))
(let ((args (application-args application)) (let ((args (call-args call))
(src (tree-il-src application))) (src (tree-il-src call)))
(call-with-values (lambda () (arities proc)) (call-with-values (lambda () (arities proc))
(lambda (name arities) (lambda (name arities)
(define matches? (define matches?
@ -1120,7 +1120,7 @@ accurate information is missing from a given `tree-il' element."
((<fix> gensyms vals) ((<fix> gensyms vals)
(fold extend info gensyms vals)) (fold extend info gensyms vals))
((<application> proc args src) ((<call> proc args src)
(record-case proc (record-case proc
((<lambda> body) ((<lambda> body)
(validate-arity proc x #t) (validate-arity proc x #t)
@ -1180,9 +1180,9 @@ accurate information is missing from a given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls result)) (let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result))) (toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each (vlist-for-each
(lambda (name+application) (lambda (name+call)
(let* ((name (car name+application)) (let* ((name (car name+call))
(application (cdr name+application)) (call (cdr name+call))
(proc (proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr) (or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env) (and (module? env)
@ -1197,7 +1197,7 @@ accurate information is missing from a given `tree-il' element."
(module-ref env name)))) (module-ref env name))))
proc))) proc)))
(if (or (lambda? proc*) (procedure? proc*)) (if (or (lambda? proc*) (procedure? proc*))
(validate-arity proc* application (lambda? proc*))))) (validate-arity proc* call (lambda? proc*)))))
toplevel-calls))) toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null))) (make-arity-info vlist-null vlist-null vlist-null)))
@ -1348,7 +1348,7 @@ accurate information is missing from a given `tree-il' element."
(record-case x (record-case x
((<const> exp) ((<const> exp)
exp) exp)
((<application> proc args) ((<call> proc args)
;; Gettexted literals, like `(_ "foo")'. ;; Gettexted literals, like `(_ "foo")'.
(and (record-case proc (and (record-case proc
((<toplevel-ref> name) (eq? name '_)) ((<toplevel-ref> name) (eq? name '_))
@ -1412,7 +1412,7 @@ accurate information is missing from a given `tree-il' element."
(false-if-exception (module-ref env name)))) (false-if-exception (module-ref env name))))
(record-case x (record-case x
((<application> proc args src) ((<call> proc args src)
(let ((loc src)) (let ((loc src))
(record-case proc (record-case proc
((<toplevel-ref> name src) ((<toplevel-ref> name src)

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

@ -255,7 +255,7 @@
(comp-drop (car exps)) (comp-drop (car exps))
(lp (cdr exps)))))) (lp (cdr exps))))))
((<application> src proc args) ((<call> src proc args)
;; FIXME: need a better pattern-matcher here ;; FIXME: need a better pattern-matcher here
(cond (cond
((and (primitive-ref? proc) ((and (primitive-ref? proc)
@ -289,8 +289,8 @@
(maybe-emit-return)) (maybe-emit-return))
((vals) ((vals)
(comp-vals (comp-vals
(make-application src (make-primitive-ref #f 'apply) (make-call src (make-primitive-ref #f 'apply)
(cons proc args)) (cons proc args))
MVRA) MVRA)
(maybe-emit-return)) (maybe-emit-return))
((drop) ((drop)
@ -299,8 +299,8 @@
;; yet apply does not create a MV continuation. So we ;; yet apply does not create a MV continuation. So we
;; mv-call out to our trampoline instead. ;; mv-call out to our trampoline instead.
(comp-drop (comp-drop
(make-application src (make-primitive-ref #f 'apply) (make-call src (make-primitive-ref #f 'apply)
(cons proc args))) (cons proc args)))
(maybe-emit-return))))))) (maybe-emit-return)))))))
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values) ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
@ -333,8 +333,8 @@
((vals) ((vals)
;; Fall back. ;; Fall back.
(comp-vals (comp-vals
(make-application src (make-primitive-ref #f 'call-with-values) (make-call src (make-primitive-ref #f 'call-with-values)
args) args)
MVRA) MVRA)
(maybe-emit-return)) (maybe-emit-return))
(else (else
@ -368,7 +368,7 @@
(emit-code src (make-glil-call 'tail-call/cc 1))) (emit-code src (make-glil-call 'tail-call/cc 1)))
((vals) ((vals)
(comp-vals (comp-vals
(make-application (make-call
src (make-primitive-ref #f 'call-with-current-continuation) src (make-primitive-ref #f 'call-with-current-continuation)
args) args)
MVRA) MVRA)
@ -380,7 +380,7 @@
((drop) ((drop)
;; Crap. Just like `apply' in drop context. ;; Crap. Just like `apply' in drop context.
(comp-drop (comp-drop
(make-application (make-call
src (make-primitive-ref #f 'call-with-current-continuation) src (make-primitive-ref #f 'call-with-current-continuation)
args)) args))
(maybe-emit-return)))) (maybe-emit-return))))
@ -528,7 +528,7 @@
(let ((L1 (make-label)) (L2 (make-label))) (let ((L1 (make-label)) (L2 (make-label)))
;; need a pattern matcher ;; need a pattern matcher
(record-case test (record-case test
((<application> proc args) ((<call> proc args)
(record-case proc (record-case proc
((<primitive-ref> name) ((<primitive-ref> name)
(let ((len (length args))) (let ((len (length args)))
@ -546,7 +546,7 @@
((and (eq? name 'not) (= len 1)) ((and (eq? name 'not) (= len 1))
(let ((app (car args))) (let ((app (car args)))
(record-case app (record-case app
((<application> proc args) ((<call> proc args)
(let ((len (length args))) (let ((len (length args)))
(record-case proc (record-case proc
((<primitive-ref> name) ((<primitive-ref> name)
@ -948,7 +948,7 @@
((<dynwind> src body winder unwinder) ((<dynwind> src body winder unwinder)
(comp-push winder) (comp-push winder)
(comp-push unwinder) (comp-push unwinder)
(comp-drop (make-application src winder '())) (comp-drop (make-call src winder '()))
(emit-code #f (make-glil-call 'wind 2)) (emit-code #f (make-glil-call 'wind 2))
(case context (case context
@ -957,14 +957,14 @@
(comp-vals body MV) (comp-vals body MV)
;; one value: unwind... ;; one value: unwind...
(emit-code #f (make-glil-call 'unwind 0)) (emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '())) (comp-drop (make-call src unwinder '()))
;; ...and return the val ;; ...and return the val
(emit-code #f (make-glil-call 'return 1)) (emit-code #f (make-glil-call 'return 1))
(emit-label MV) (emit-label MV)
;; multiple values: unwind... ;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0)) (emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '())) (comp-drop (make-call src unwinder '()))
;; and return the values. ;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1)))) (emit-code #f (make-glil-call 'return/nvalues 1))))
@ -973,7 +973,7 @@
(comp-push body) (comp-push body)
;; and unwind, leaving the val on the stack ;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0)) (emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '()))) (comp-drop (make-call src unwinder '())))
((vals) ((vals)
(let ((MV (make-label))) (let ((MV (make-label)))
@ -984,7 +984,7 @@
(emit-label MV) (emit-label MV)
;; multiple values: unwind... ;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0)) (emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '())) (comp-drop (make-call src unwinder '()))
;; and goto the MVRA. ;; and goto the MVRA.
(emit-branch #f 'br MVRA))) (emit-branch #f 'br MVRA)))
@ -992,7 +992,7 @@
;; compile body, discarding values. then unwind... ;; compile body, discarding values. then unwind...
(comp-drop body) (comp-drop body)
(emit-code #f (make-glil-call 'unwind 0)) (emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '())) (comp-drop (make-call src unwinder '()))
;; and fall through, or goto RA if there is one. ;; and fall through, or goto RA if there is one.
(if RA (if RA
(emit-branch #f 'br RA))))) (emit-branch #f 'br RA)))))

2
module/language/tree-il/fix-letrec.scm
View file

@ -44,7 +44,7 @@
((<sequence> exps) ((<sequence> exps)
(and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?)) (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps)) exps))
((<application> proc args) ((<call> proc args)
(and (primitive-ref? proc) (and (primitive-ref? proc)
(simple-primitive? (primitive-ref-name proc)) (simple-primitive? (primitive-ref-name proc))
;; FIXME: check arity? ;; FIXME: check arity?

20
module/language/tree-il/inline.scm
View file

@ -47,7 +47,7 @@
(else x))) (else x)))
(else x))) (else x)))
((<application> src proc args) ((<call> src proc args)
(record-case proc (record-case proc
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<primitive-ref> name) ((<primitive-ref> name)
@ -66,7 +66,7 @@
(const-exp k) (const-exp l))))) (const-exp k) (const-exp l)))))
(else (else
(let lp ((elts (const-exp l))) (let lp ((elts (const-exp l)))
(let ((test (make-application (let ((test (make-call
#f #f
(make-primitive-ref #f (case name (make-primitive-ref #f (case name
((memq) 'eq?) ((memq) 'eq?)
@ -101,7 +101,7 @@
(define (inline! x) (define (inline! x)
(define (inline1 x) (define (inline1 x)
(record-case x (record-case x
((<application> src proc args) ((<call> src proc args)
(record-case proc (record-case proc
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x) ;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<lambda> body) ((<lambda> body)
@ -133,7 +133,7 @@
(not (lambda-case-alternate (lambda-body consumer)))) (not (lambda-case-alternate (lambda-body consumer))))
(make-let-values (make-let-values
src src
(let ((x (make-application src producer '()))) (let ((x (make-call src producer '())))
(or (inline1 x) x)) (or (inline1 x) x))
(lambda-body consumer))) (lambda-body consumer)))
(else #f))) (else #f)))
@ -178,7 +178,7 @@
(and (not opt) (not kw) rest (not alternate) (and (not opt) (not kw) rest (not alternate)
(record-case body (record-case body
((<application> proc args) ((<call> proc args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...) ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(and (primitive-ref? proc) (and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@apply) (eq? (primitive-ref-name proc) '@apply)
@ -189,7 +189,7 @@
(else #f)))) (else #f))))
;; Actually the opposite of inlining -- if the prompt cannot be proven to ;; Actually the opposite of inlining -- if the prompt cannot be proven to
;; be escape-only, ensure that its body is the application of a thunk. ;; be escape-only, ensure that its body is the call of a thunk.
((<prompt> src tag body handler) ((<prompt> src tag body handler)
(define (escape-only? handler) (define (escape-only? handler)
(and (pair? (lambda-case-req handler)) (and (pair? (lambda-case-req handler))
@ -206,13 +206,13 @@
(define (make-thunk body) (define (make-thunk body)
(make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f))) (make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
(if (or (and (application? body) (if (or (and (call? body)
(lambda? (application-proc body)) (lambda? (call-proc body))
(null? (application-args body))) (null? (call-args body)))
(escape-only? handler)) (escape-only? handler))
x x
(make-prompt src tag (make-prompt src tag
(make-application #f (make-thunk body) '()) (make-call #f (make-thunk body) '())
handler))) handler)))
(else #f))) (else #f)))

30
module/language/tree-il/primitives.scm
View file

@ -1,6 +1,6 @@
;;; open-coding primitive procedures ;;; open-coding primitive procedures
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -183,7 +183,7 @@
(pre-order! (pre-order!
(lambda (x) (lambda (x)
(record-case x (record-case x
((<application> src proc args) ((<call> src proc args)
(and (primitive-ref? proc) (and (primitive-ref? proc)
(let ((expand (hashq-ref *primitive-expand-table* (let ((expand (hashq-ref *primitive-expand-table*
(primitive-ref-name proc)))) (primitive-ref-name proc))))
@ -203,8 +203,8 @@
(lp (cdr in) (lp (cdr in)
(cons (if (eq? (caar in) 'quote) (cons (if (eq? (caar in) 'quote)
`(make-const src ,@(cdar in)) `(make-const src ,@(cdar in))
`(make-application src (make-primitive-ref src ',(caar in)) `(make-call src (make-primitive-ref src ',(caar in))
,(inline-args (cdar in)))) ,(inline-args (cdar in))))
out))) out)))
((symbol? (car in)) ((symbol? (car in))
;; assume it's locally bound ;; assume it's locally bound
@ -222,8 +222,8 @@
,(consequent then) ,(consequent then)
,(consequent else))) ,(consequent else)))
(else (else
`(make-application src (make-primitive-ref src ',(car exp)) `(make-call src (make-primitive-ref src ',(car exp))
,(inline-args (cdr exp)))))) ,(inline-args (cdr exp))))))
((symbol? exp) ((symbol? exp)
;; assume locally bound ;; assume locally bound
exp) exp)
@ -412,7 +412,7 @@
(make-dynwind (make-dynwind
src src
(make-lexical-ref #f 'pre PRE) (make-lexical-ref #f 'pre PRE)
(make-application #f thunk '()) (make-call #f thunk '())
(make-lexical-ref #f 'post POST))))) (make-lexical-ref #f 'post POST)))))
(else (else
(let ((PRE (gensym " pre")) (let ((PRE (gensym " pre"))
@ -426,7 +426,7 @@
(make-dynwind (make-dynwind
src src
(make-lexical-ref #f 'pre PRE) (make-lexical-ref #f 'pre PRE)
(make-application #f (make-lexical-ref #f 'thunk THUNK) '()) (make-call #f (make-lexical-ref #f 'thunk THUNK) '())
(make-lexical-ref #f 'post POST))))))) (make-lexical-ref #f 'post POST)))))))
(else #f))) (else #f)))
@ -470,9 +470,9 @@
;; trickery here. ;; trickery here.
(make-lambda-case (make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-application #f (make-primitive-ref #f 'apply) (make-call #f (make-primitive-ref #f 'apply)
(list handler (list handler
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f))))
(else #f))) (else #f)))
@ -486,14 +486,14 @@
((lambda? handler) ((lambda? handler)
(let ((args-sym (gensym))) (let ((args-sym (gensym)))
(make-prompt (make-prompt
src tag (make-application #f thunk '()) src tag (make-call #f thunk '())
;; If handler itself is a lambda, the inliner can do some ;; If handler itself is a lambda, the inliner can do some
;; trickery here. ;; trickery here.
(make-lambda-case (make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-application #f (make-primitive-ref #f 'apply) (make-call #f (make-primitive-ref #f 'apply)
(list handler (list handler
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f))))
(else #f))) (else #f)))
(else #f))) (else #f)))

70
test-suite/tests/tree-il.test
View file

@ -63,15 +63,15 @@
(begin (void) (const 1)) (begin (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive +) (void) (const 1)) (call (primitive +) (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application" (with-test-prefix "application"
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (const 1)) (call (toplevel foo) (const 1))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (apply (toplevel foo) (const 1)) (void)) (begin (call (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (call drop 1) (branch br ,l2)
(label ,l3) (mv-bind 0 #f) (label ,l3) (mv-bind 0 #f)
@ -79,7 +79,7 @@
(void) (call return 1)) (void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel bar))) (call (toplevel foo) (call (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call tail-call 1)))) (call tail-call 1))))
@ -98,7 +98,7 @@
(eq? l1 l3) (eq? l2 l4)) (eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (if (toplevel foo) (const 1) (const 2))) (call (primitive null?) (if (toplevel foo) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
(const 1) (branch br ,l2) (const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4) (label ,l3) (const 2) (label ,l4)
@ -115,7 +115,7 @@
(program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (primitive +)) (call (primitive null?) (primitive +))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1)))) (call return 1))))
@ -135,7 +135,7 @@
(unbind))) (unbind)))
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) (let (x) (y) ((const 1)) (call (primitive null?) (lexical x y)))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0) (const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1) (lexical #t #f ref 0) (call null? 1) (call return 1)
@ -145,7 +145,7 @@
(assert-tree-il->glil (assert-tree-il->glil
;; unreferenced sets may be optimized away -- make sure they are ref'd ;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))) (set! (lexical x y) (call (primitive 1+) (lexical x y))))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@ -154,7 +154,7 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) (begin (set! (lexical x y) (call (primitive 1+) (lexical x y)))
(lexical x y))) (lexical x y)))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
@ -164,8 +164,8 @@
(assert-tree-il->glil (assert-tree-il->glil
(let (x) (y) ((const 1)) (let (x) (y) ((const 1))
(apply (primitive null?) (call (primitive null?)
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))) (set! (lexical x y) (call (primitive 1+) (lexical x y)))))
(program () (std-prelude 0 1 #f) (label _) (program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0) (const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@ -186,7 +186,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@ (foo) bar)) (call (primitive null?) (@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar) (module public ref (foo) bar)
(call null? 1) (call return 1))) (call null? 1) (call return 1)))
@ -204,7 +204,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (@@ (foo) bar)) (call (primitive null?) (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar) (module private ref (foo) bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
@ -223,7 +223,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@ (foo) bar) (const 2))) (call (primitive null?) (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar) (const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1))) (void) (call null? 1) (call return 1)))
@ -241,7 +241,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (@@ (foo) bar) (const 2))) (call (primitive null?) (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar) (const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -260,7 +260,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (toplevel bar)) (call (primitive null?) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (toplevel ref bar)
(call null? 1) (call return 1)))) (call null? 1) (call return 1))))
@ -279,7 +279,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (set! (toplevel bar) (const 2))) (call (primitive null?) (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar) (const 2) (toplevel set bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -298,7 +298,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (define bar (const 2))) (call (primitive null?) (define bar (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar) (const 2) (toplevel define bar)
(void) (call null? 1) (call return 1)))) (void) (call null? 1) (call return 1))))
@ -315,7 +315,7 @@
(const #f) (call return 1))) (const #f) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (const 2)) (call (primitive null?) (const 2))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
@ -323,7 +323,7 @@
;; simple bindings -> let ;; simple bindings -> let
(assert-tree-il->glil (assert-tree-il->glil
(letrec (x y) (x1 y1) ((const 10) (const 20)) (letrec (x y) (x1 y1) ((const 10) (const 20))
(apply (toplevel foo) (lexical x x1) (lexical y y1))) (call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _) (program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20) (const 10) (const 20)
(bind (x #f 0) (y #f 1)) (bind (x #f 0) (y #f 1))
@ -335,8 +335,8 @@
;; complex bindings -> box and set! within let ;; complex bindings -> box and set! within let
(assert-tree-il->glil (assert-tree-il->glil
(letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1))) (call (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _) (program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these? (void) (void) ;; what are these?
(bind (x #t 0) (y #t 1)) (bind (x #t 0) (y #t 1))
@ -351,8 +351,8 @@
;; complex bindings in letrec* -> box and set! in order ;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil (assert-tree-il->glil
(letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(apply (primitive +) (lexical x x1) (lexical y y1))) (call (primitive +) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _) (program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these? (void) (void) ;; what are these?
(bind (x #t 0) (y #t 1)) (bind (x #t 0) (y #t 1))
@ -470,7 +470,7 @@
(const #t) (call return 1))) (const #t) (call return 1)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2))) (call (primitive null?) (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1)))) (const 2) (call null? 1) (call return 1))))
@ -512,10 +512,10 @@
(with-test-prefix "apply" (with-test-prefix "apply"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @apply) (toplevel foo) (toplevel bar)) (call (primitive @apply) (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) (begin (call (primitive @apply) (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@ -523,7 +523,7 @@
(void) (call return 1)) (void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo) (toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
@ -531,10 +531,10 @@
(with-test-prefix "call/cc" (with-test-prefix "call/cc"
(assert-tree-il->glil (assert-tree-il->glil
(apply (primitive @call-with-current-continuation) (toplevel foo)) (call (primitive @call-with-current-continuation) (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
(assert-tree-il->glil (assert-tree-il->glil
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) (begin (call (primitive @call-with-current-continuation) (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@ -542,8 +542,8 @@
(void) (call return 1)) (void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4))) (and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil (assert-tree-il->glil
(apply (toplevel foo) (call (toplevel foo)
(apply (toplevel @call-with-current-continuation) (toplevel bar))) (call (toplevel @call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo) (toplevel ref foo)
(toplevel ref bar) (call call/cc 1) (toplevel ref bar) (call call/cc 1)
@ -580,9 +580,9 @@
'(lambda () '(lambda ()
(lambda-case (lambda-case
(((x y) #f #f #f () (x1 y1)) (((x y) #f #f #f () (x1 y1))
(apply (toplevel +) (call (toplevel +)
(lexical x x1) (lexical x x1)
(lexical y y1))) (lexical y y1)))
#f)))))) #f))))))
(and (equal? (map strip-source leaves) (and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1) (list (make-lexical-ref #f 'y 'y1)