mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-22 03:30:22 +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

27
doc/ref/compiler.texi
View file

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

14
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.
*
* 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)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
#define APPLICATION(src, proc, exps) \
SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps)
#define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQUENCE(src, exps) \
SCM_MAKE_EXPANDED_SEQUENCE(src, exps)
#define LAMBDA(src, meta, body) \
@ -359,7 +359,7 @@ expand (SCM exp, SCM env)
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
if (scm_is_null (arg_exps))
return APPLICATION (scm_source_properties (exp),
return CALL (scm_source_properties (exp),
expand (proc, env),
scm_reverse_x (args, SCM_UNDEFINED));
else
@ -487,7 +487,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
APPLICATION (SCM_BOOL_F,
CALL (SCM_BOOL_F,
expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))),
@ -993,7 +993,7 @@ expand_named_let (const SCM expr, SCM env)
SCM_BOOL_F, SCM_BOOL_F, var_syms,
expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))),
APPLICATION (SCM_BOOL_F,
CALL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, name, name_sym),
expand_exprs (inits, env)));
}
@ -1243,7 +1243,7 @@ scm_init_expand ()
DEFINE_NAMES (TOPLEVEL_SET);
DEFINE_NAMES (TOPLEVEL_DEFINE);
DEFINE_NAMES (CONDITIONAL);
DEFINE_NAMES (APPLICATION);
DEFINE_NAMES (CALL);
DEFINE_NAMES (SEQUENCE);
DEFINE_NAMES (LAMBDA);
DEFINE_NAMES (LAMBDA_CASE);

18
libguile/expand.h
View file

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

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, ALTERNATE), env));
case SCM_EXPANDED_APPLICATION:
case SCM_EXPANDED_CALL:
{
SCM proc, args;
proc = REF (exp, APPLICATION, PROC);
args = memoize_exps (REF (exp, APPLICATION, ARGS), env);
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
{

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

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

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

@ -313,9 +313,9 @@
(lambda (source)
(make-void source)))
(define build-application
(define build-call
(lambda (source fun-exp arg-exps)
(make-application source fun-exp arg-exps)))
(make-call source fun-exp arg-exps)))
(define build-conditional
(lambda (source test-exp then-exp else-exp)
@ -436,7 +436,7 @@
(make-letrec
src #f
(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))))))
(define build-letrec
@ -1038,7 +1038,7 @@
(build-global-definition
no-source
name
(build-application
(build-call
no-source
(build-primref no-source 'make-syntax-transformer)
(list (build-data no-source name)
@ -1200,7 +1200,7 @@
(lambda (e r w s mod)
(chi e r w mod))))
((lexical-call)
(chi-application
(chi-call
(let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id)
@ -1209,7 +1209,7 @@
value))
e r w s mod))
((global-call)
(chi-application
(chi-call
(build-global-reference (source-annotation (car e))
(if (syntax-object? value)
(syntax-object-expression value)
@ -1220,7 +1220,7 @@
e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod))
((call) (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)
(syntax-case e ()
((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod))))
@ -1245,11 +1245,11 @@
(else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod))))))
(define chi-application
(define chi-call
(lambda (x e r w s mod)
(syntax-case e ()
((e0 e1 ...)
(build-application s x
(build-call s x
(map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy)
@ -1954,7 +1954,7 @@
(if (list? (cadr x))
(build-simple-lambda no-source (cadr x) #f (cadr x) '() (regen (caddr x)))
(error "how did we get here" x)))
(else (build-application no-source
(else (build-call no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
@ -2147,7 +2147,7 @@
(build-global-assignment s (syntax->datum #'e)
val mod)))))))
(else
(build-application s
(build-call s
(chi #'(setter head) r w mod)
(map (lambda (e) (chi e r w mod))
#'(tail ... val))))))))
@ -2288,7 +2288,7 @@
(lambda (pvars exp y r mod)
(let ((ids (map car pvars)) (levels (map cdr pvars)))
(let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
(build-application no-source
(build-call no-source
(build-primref no-source 'apply)
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp
@ -2316,7 +2316,7 @@
(else
(let ((y (gen-var 'tmp)))
;; 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) '()
(let ((y (build-lexical-reference 'value no-source
'tmp y)))
@ -2330,17 +2330,17 @@
(build-dispatch-call pvars exp y r mod)
(gen-syntax-case x keys clauses r mod))))
(list (if (eq? p 'any)
(build-application no-source
(build-call no-source
(build-primref no-source 'list)
(list x))
(build-application no-source
(build-call no-source
(build-primref no-source '$sc-dispatch)
(list x (build-data no-source p)))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mod)
(if (null? clauses)
(build-application no-source
(build-call no-source
(build-primref no-source 'syntax-violation)
(list (build-data no-source #f)
(build-data no-source
@ -2355,7 +2355,7 @@
(chi #'exp r empty-wrap mod)
(let ((labels (list (gen-label)))
(var (gen-var #'pat)))
(build-application no-source
(build-call no-source
(build-simple-lambda
no-source (list (syntax->datum #'pat)) #f (list var)
'()
@ -2383,7 +2383,7 @@
#'(key ...))
(let ((x (gen-var 'tmp)))
;; 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) '()
(gen-syntax-case (build-lexical-reference 'value no-source
'tmp x)

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

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

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

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

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

@ -1,6 +1,6 @@
;;; Guile Emacs Lisp
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@ -109,7 +109,7 @@
;;; Build a call to a primitive procedure nicely.
(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
;;; code for a runtime-error output.
@ -118,7 +118,7 @@
(apply error args))
(define (runtime-error loc msg . args)
(make-application loc
(make-call loc
(make-primitive-ref loc 'error)
(cons (make-const loc msg) args)))
@ -129,7 +129,7 @@
;;; this routine.
(define (generate-ensure-global loc sym module)
(make-application loc
(make-call loc
(make-module-ref loc runtime 'ensure-fluid! #t)
(list (make-const loc module)
(make-const loc sym))))
@ -151,12 +151,12 @@
(call-primitive
loc
'with-fluids*
(make-application loc
(make-call loc
(make-primitive-ref loc 'list)
(map (lambda (sym)
(make-module-ref loc module sym #t))
syms))
(make-application loc (make-primitive-ref loc 'list) vals)
(make-call loc (make-primitive-ref loc 'list) vals)
(make-lambda loc
'()
(make-lambda-case #f '() #f #f #f '() '() body #f))))
@ -204,7 +204,7 @@
sym
module
(lambda ()
(make-application
(make-call
loc
(make-module-ref loc runtime 'set-variable! #t)
(list (make-const loc module) (make-const loc sym) value)))
@ -779,7 +779,7 @@
((,condition . ,body)
(let* ((itersym (gensym))
(compiled-body (map compile-expr body))
(iter-call (make-application loc
(iter-call (make-call loc
(make-lexical-ref loc
'iterate
itersym)
@ -828,7 +828,7 @@
loc
name
function-slot
(make-application
(make-call
loc
(make-module-ref loc '(guile) 'cons #t)
(list (make-const loc 'macro)
@ -876,7 +876,7 @@
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
(else
(make-application loc
(make-call loc
(if (symbol? operator)
(reference-variable loc
operator

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-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate
<application> application? make-application application-src application-proc application-args
<call> call? make-call call-src call-proc call-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
<lambda-case> lambda-case? make-lambda-case lambda-case-src
@ -118,7 +118,7 @@
;; (<toplevel-set> name exp)
;; (<toplevel-define> name exp)
;; (<conditional> test consequent alternate)
;; (<application> proc args)
;; (<call> proc args)
;; (<sequence> exps)
;; (<lambda> meta body)
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
@ -149,8 +149,8 @@
((void)
(make-void loc))
((apply ,proc . ,args)
(make-application loc (retrans proc) (map retrans args)))
((call ,proc . ,args)
(make-call loc (retrans proc) (map retrans args)))
((if ,test ,consequent ,alternate)
(make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
@ -253,8 +253,8 @@
((<void>)
'(void))
((<application> proc args)
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<call> proc args)
`(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<conditional> test consequent alternate)
`(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
@ -336,7 +336,7 @@
((<void>)
'(if #f #f))
((<application> proc args)
((<call> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<conditional> test consequent alternate)
@ -478,7 +478,8 @@
((<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)))))
@ -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.
This is an implementation of `foldts' as described by Andy Wingo in
``Applications of fold to XML transformation''."
``Calls of fold to XML transformation''."
(let loop ((tree tree)
(result seed))
(if (or (null? tree) (pair? tree))
@ -507,7 +508,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(up tree (loop alternate
(loop consequent
(loop test (down tree result))))))
((<application> proc args)
((<call> proc args)
(up tree (loop (cons proc args) (down tree result))))
((<sequence> exps)
(up tree (loop exps (down tree result))))
@ -580,7 +581,7 @@ This is an implementation of `foldts' as described by Andy Wingo in
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
((<application> proc args)
((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<sequence> exps)
@ -633,9 +634,9 @@ This is an implementation of `foldts' as described by Andy Wingo in
(define (post-order! f x)
(let lp ((x x))
(record-case x
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
((<call> proc args)
(set! (call-proc x) (lp proc))
(set! (call-args x) (map lp args)))
((<conditional> test consequent alternate)
(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 ((x (or (f x) x)))
(record-case x
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
((<call> proc args)
(set! (call-proc x) (lp proc))
(set! (call-args x) (map lp args)))
((<conditional> test consequent alternate)
(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))
(define (recur x new-proc) (analyze! x new-proc '() tail? #f))
(record-case x
((<application> proc args)
((<call> proc args)
(apply lset-union eq? (step-tail-call proc args)
(map step args)))
@ -364,7 +364,7 @@
(define (allocate! x proc n)
(define (recur y) (allocate! y proc n))
(record-case x
((<application> proc args)
((<call> proc args)
(apply max (recur proc) (map recur args)))
((<conditional> test consequent alternate)
@ -863,7 +863,7 @@ accurate information is missing from a given `tree-il' element."
(defs toplevel-info-defs)) ;; (VARIABLE-NAME ...)
(define (goops-toplevel-definition proc args env)
;; If application of PROC to ARGS is a GOOPS top-level definition, return
;; If call of PROC to ARGS is a GOOPS top-level definition, return
;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args)
@ -929,7 +929,7 @@ accurate information is missing from a given `tree-il' element."
(make-toplevel-info (vhash-delq name refs)
(vhash-consq name #t defs)))
((<application> proc args)
((<call> proc args)
;; Check for a dynamic top-level definition, as is
;; done by code expanded from GOOPS macros.
(let ((name (goops-toplevel-definition proc args
@ -967,12 +967,12 @@ accurate information is missing from a given `tree-il' element."
(define-record-type <arity-info>
(make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
arity-info?
(toplevel-calls toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
(toplevel-calls toplevel-procedure-calls) ;; ((NAME . CALL) ...)
(lexical-lambdas lexical-lambdas) ;; ((GENSYM . DEFINITION) ...)
(toplevel-lambdas toplevel-lambdas)) ;; ((NAME . DEFINITION) ...)
(define (validate-arity proc application lexical?)
;; Validate the argument count of APPLICATION, a tree-il application of
(define (validate-arity proc call lexical?)
;; Validate the argument count of CALL, a tree-il call of
;; PROC, emitting a warning in case of argument count mismatch.
(define (filter-keyword-args keywords allow-other-keys? args)
@ -1032,8 +1032,8 @@ accurate information is missing from a given `tree-il' element."
(else
(values #f #f))))))))
(let ((args (application-args application))
(src (tree-il-src application)))
(let ((args (call-args call))
(src (tree-il-src call)))
(call-with-values (lambda () (arities proc))
(lambda (name arities)
(define matches?
@ -1120,7 +1120,7 @@ accurate information is missing from a given `tree-il' element."
((<fix> gensyms vals)
(fold extend info gensyms vals))
((<application> proc args src)
((<call> proc args src)
(record-case proc
((<lambda> body)
(validate-arity proc x #t)
@ -1180,9 +1180,9 @@ accurate information is missing from a given `tree-il' element."
(let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result)))
(vlist-for-each
(lambda (name+application)
(let* ((name (car name+application))
(application (cdr name+application))
(lambda (name+call)
(let* ((name (car name+call))
(call (cdr name+call))
(proc
(or (and=> (vhash-assq name toplevel-lambdas) cdr)
(and (module? env)
@ -1197,7 +1197,7 @@ accurate information is missing from a given `tree-il' element."
(module-ref env name))))
proc)))
(if (or (lambda? proc*) (procedure? proc*))
(validate-arity proc* application (lambda? proc*)))))
(validate-arity proc* call (lambda? proc*)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
@ -1348,7 +1348,7 @@ accurate information is missing from a given `tree-il' element."
(record-case x
((<const> exp)
exp)
((<application> proc args)
((<call> proc args)
;; Gettexted literals, like `(_ "foo")'.
(and (record-case proc
((<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))))
(record-case x
((<application> proc args src)
((<call> proc args src)
(let ((loc src))
(record-case proc
((<toplevel-ref> name src)

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

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

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

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

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

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

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

@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@ -183,7 +183,7 @@
(pre-order!
(lambda (x)
(record-case x
((<application> src proc args)
((<call> src proc args)
(and (primitive-ref? proc)
(let ((expand (hashq-ref *primitive-expand-table*
(primitive-ref-name proc))))
@ -203,7 +203,7 @@
(lp (cdr in)
(cons (if (eq? (caar in) 'quote)
`(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))))
out)))
((symbol? (car in))
@ -222,7 +222,7 @@
,(consequent then)
,(consequent else)))
(else
`(make-application src (make-primitive-ref src ',(car exp))
`(make-call src (make-primitive-ref src ',(car exp))
,(inline-args (cdr exp))))))
((symbol? exp)
;; assume locally bound
@ -412,7 +412,7 @@
(make-dynwind
src
(make-lexical-ref #f 'pre PRE)
(make-application #f thunk '())
(make-call #f thunk '())
(make-lexical-ref #f 'post POST)))))
(else
(let ((PRE (gensym " pre"))
@ -426,7 +426,7 @@
(make-dynwind
src
(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)))))))
(else #f)))
@ -470,7 +470,7 @@
;; trickery here.
(make-lambda-case
(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
(make-lexical-ref #f 'args args-sym)))
#f))))
@ -486,12 +486,12 @@
((lambda? handler)
(let ((args-sym (gensym)))
(make-prompt
src tag (make-application #f thunk '())
src tag (make-call #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-application #f (make-primitive-ref #f 'apply)
(make-call #f (make-primitive-ref #f 'apply)
(list handler
(make-lexical-ref #f 'args args-sym)))
#f))))

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

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