mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 20:30:28 +02:00
rename <application> to <call>
* 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
parent
d31d703fd4
commit
7081d4f981
16 changed files with 447 additions and 447 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,8 +436,8 @@
|
|||
(make-letrec
|
||||
src #f
|
||||
(list f-name) (list f) (list proc)
|
||||
(build-application src (build-lexical-reference 'fun src f-name f)
|
||||
val-exps))))))
|
||||
(build-call src (build-lexical-reference 'fun src f-name f)
|
||||
val-exps))))))
|
||||
|
||||
(define build-letrec
|
||||
(lambda (src in-order? ids vars val-exps body-exp)
|
||||
|
|
@ -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,12 +1245,12 @@
|
|||
(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
|
||||
(map (lambda (e) (chi e r w mod)) #'(e1 ...)))))))
|
||||
(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,9 +1954,9 @@
|
|||
(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
|
||||
(build-primref no-source (car x))
|
||||
(map regen (cdr x)))))))
|
||||
(else (build-call no-source
|
||||
(build-primref no-source (car x))
|
||||
(map regen (cdr x)))))))
|
||||
|
||||
(lambda (e r w s mod)
|
||||
(let ((e (source-wrap e w s mod)))
|
||||
|
|
@ -2147,10 +2147,10 @@
|
|||
(build-global-assignment s (syntax->datum #'e)
|
||||
val mod)))))))
|
||||
(else
|
||||
(build-application s
|
||||
(chi #'(setter head) r w mod)
|
||||
(map (lambda (e) (chi e r w mod))
|
||||
#'(tail ... val))))))))
|
||||
(build-call s
|
||||
(chi #'(setter head) r w mod)
|
||||
(map (lambda (e) (chi e r w mod))
|
||||
#'(tail ... val))))))))
|
||||
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
|
||||
|
||||
(global-extend 'module-ref '@
|
||||
|
|
@ -2288,20 +2288,20 @@
|
|||
(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-primref no-source 'apply)
|
||||
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
|
||||
(chi exp
|
||||
(extend-env
|
||||
labels
|
||||
(map (lambda (var level)
|
||||
(make-binding 'syntax `(,var . ,level)))
|
||||
new-vars
|
||||
(map cdr pvars))
|
||||
r)
|
||||
(make-binding-wrap ids labels empty-wrap)
|
||||
mod))
|
||||
y))))))
|
||||
(build-call no-source
|
||||
(build-primref no-source 'apply)
|
||||
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
|
||||
(chi exp
|
||||
(extend-env
|
||||
labels
|
||||
(map (lambda (var level)
|
||||
(make-binding 'syntax `(,var . ,level)))
|
||||
new-vars
|
||||
(map cdr pvars))
|
||||
r)
|
||||
(make-binding-wrap ids labels empty-wrap)
|
||||
mod))
|
||||
y))))))
|
||||
|
||||
(define gen-clause
|
||||
(lambda (x keys clauses r pat fender exp mod)
|
||||
|
|
@ -2316,36 +2316,36 @@
|
|||
(else
|
||||
(let ((y (gen-var 'tmp)))
|
||||
;; fat finger binding and references to temp variable y
|
||||
(build-application no-source
|
||||
(build-simple-lambda no-source (list 'tmp) #f (list y) '()
|
||||
(let ((y (build-lexical-reference 'value no-source
|
||||
'tmp y)))
|
||||
(build-conditional no-source
|
||||
(syntax-case fender ()
|
||||
(#t y)
|
||||
(_ (build-conditional no-source
|
||||
y
|
||||
(build-dispatch-call pvars fender y r mod)
|
||||
(build-data no-source #f))))
|
||||
(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-primref no-source 'list)
|
||||
(list x))
|
||||
(build-application no-source
|
||||
(build-primref no-source '$sc-dispatch)
|
||||
(list x (build-data no-source p)))))))))))))
|
||||
(build-call no-source
|
||||
(build-simple-lambda no-source (list 'tmp) #f (list y) '()
|
||||
(let ((y (build-lexical-reference 'value no-source
|
||||
'tmp y)))
|
||||
(build-conditional no-source
|
||||
(syntax-case fender ()
|
||||
(#t y)
|
||||
(_ (build-conditional no-source
|
||||
y
|
||||
(build-dispatch-call pvars fender y r mod)
|
||||
(build-data no-source #f))))
|
||||
(build-dispatch-call pvars exp y r mod)
|
||||
(gen-syntax-case x keys clauses r mod))))
|
||||
(list (if (eq? p 'any)
|
||||
(build-call no-source
|
||||
(build-primref no-source 'list)
|
||||
(list x))
|
||||
(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-primref no-source 'syntax-violation)
|
||||
(list (build-data no-source #f)
|
||||
(build-data no-source
|
||||
"source expression failed to match any pattern")
|
||||
x))
|
||||
(build-call no-source
|
||||
(build-primref no-source 'syntax-violation)
|
||||
(list (build-data no-source #f)
|
||||
(build-data no-source
|
||||
"source expression failed to match any pattern")
|
||||
x))
|
||||
(syntax-case (car clauses) ()
|
||||
((pat exp)
|
||||
(if (and (id? #'pat)
|
||||
|
|
@ -2355,18 +2355,18 @@
|
|||
(chi #'exp r empty-wrap mod)
|
||||
(let ((labels (list (gen-label)))
|
||||
(var (gen-var #'pat)))
|
||||
(build-application no-source
|
||||
(build-simple-lambda
|
||||
no-source (list (syntax->datum #'pat)) #f (list var)
|
||||
'()
|
||||
(chi #'exp
|
||||
(extend-env labels
|
||||
(list (make-binding 'syntax `(,var . 0)))
|
||||
r)
|
||||
(make-binding-wrap #'(pat)
|
||||
labels empty-wrap)
|
||||
mod))
|
||||
(list x))))
|
||||
(build-call no-source
|
||||
(build-simple-lambda
|
||||
no-source (list (syntax->datum #'pat)) #f (list var)
|
||||
'()
|
||||
(chi #'exp
|
||||
(extend-env labels
|
||||
(list (make-binding 'syntax `(,var . 0)))
|
||||
r)
|
||||
(make-binding-wrap #'(pat)
|
||||
labels empty-wrap)
|
||||
mod))
|
||||
(list x))))
|
||||
(gen-clause x keys (cdr clauses) r
|
||||
#'pat #t #'exp mod)))
|
||||
((pat fender exp)
|
||||
|
|
@ -2383,14 +2383,14 @@
|
|||
#'(key ...))
|
||||
(let ((x (gen-var 'tmp)))
|
||||
;; fat finger binding and references to temp variable x
|
||||
(build-application s
|
||||
(build-simple-lambda no-source (list 'tmp) #f (list x) '()
|
||||
(gen-syntax-case (build-lexical-reference 'value no-source
|
||||
'tmp x)
|
||||
#'(key ...) #'(m ...)
|
||||
r
|
||||
mod))
|
||||
(list (chi #'val r empty-wrap mod))))
|
||||
(build-call s
|
||||
(build-simple-lambda no-source (list 'tmp) #f (list x) '()
|
||||
(gen-syntax-case (build-lexical-reference 'value no-source
|
||||
'tmp x)
|
||||
#'(key ...) #'(m ...)
|
||||
r
|
||||
mod))
|
||||
(list (chi #'val r empty-wrap mod))))
|
||||
(syntax-violation 'syntax-case "invalid literals list" e))))))))
|
||||
|
||||
;; The portable macroexpand seeds chi-top's mode m with 'e (for
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -109,11 +109,11 @@
|
|||
(cond
|
||||
((null? in)
|
||||
;; No more input, build our output.
|
||||
(cond
|
||||
((null? out) '(void)) ; no output
|
||||
((null? (cdr out)) (car out)) ; single expression
|
||||
(else `(begin ,@(reverse out)))) ; sequence
|
||||
)
|
||||
(cond
|
||||
((null? out) '(void)) ; no output
|
||||
((null? (cdr out)) (car out)) ; single expression
|
||||
(else `(begin ,@(reverse out)))) ; sequence
|
||||
)
|
||||
(else
|
||||
(pmatch (car in)
|
||||
|
||||
|
|
@ -121,34 +121,34 @@
|
|||
;; (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)
|
||||
(lexical tape) (lexical pointer))
|
||||
(const ,inc)))))
|
||||
(emit `(call (primitive vector-set!) (lexical tape) (lexical pointer)
|
||||
(call (primitive +)
|
||||
(call (primitive vector-ref)
|
||||
(lexical tape) (lexical pointer))
|
||||
(const ,inc)))))
|
||||
|
||||
;; Output . is done by converting the cell's integer value to a
|
||||
;; 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)
|
||||
(lexical tape) (lexical pointer))))))
|
||||
(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!)
|
||||
(lexical tape) (lexical pointer)
|
||||
(apply (primitive char->integer)
|
||||
(apply (primitive read-char))))))
|
||||
(emit `(call (primitive vector-set!)
|
||||
(lexical tape) (lexical pointer)
|
||||
(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)
|
||||
(lexical tape) (lexical pointer))
|
||||
(const 0))
|
||||
(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))))))))
|
||||
|
|
|
|||
|
|
@ -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 '+))
|
||||
(@impl ->number (comp a e))
|
||||
(-> (const 0)))))
|
||||
(-> (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,27 +127,27 @@
|
|||
((>> ,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?))
|
||||
(comp a e) (comp b e))))))
|
||||
(-> (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?))
|
||||
(comp a e) (comp b e))))))
|
||||
(-> (call (-> (primitive 'not))
|
||||
(-> (call (-> (primitive 'eqv?))
|
||||
(comp a e) (comp b e))))))
|
||||
((& ,a ,b)
|
||||
(@impl band (comp a e) (comp b e)))
|
||||
((^ ,a ,b)
|
||||
|
|
@ -176,9 +176,9 @@
|
|||
(begin1 (comp `(ref ,foo) e)
|
||||
(lambda (var)
|
||||
(-> (set! (lookup foo e)
|
||||
(-> (apply (-> (primitive '+))
|
||||
(-> (lexical var var))
|
||||
(-> (const 1)))))))))
|
||||
(-> (call (-> (primitive '+))
|
||||
(-> (lexical var var))
|
||||
(-> (const 1)))))))))
|
||||
((postinc (pref ,obj ,prop))
|
||||
(let1 (comp obj e)
|
||||
(lambda (objvar)
|
||||
|
|
@ -189,9 +189,9 @@
|
|||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop))
|
||||
(-> (apply (-> (primitive '+))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))
|
||||
(-> (call (-> (primitive '+))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))
|
||||
((postinc (aref ,obj ,prop))
|
||||
(let1 (comp obj e)
|
||||
(lambda (objvar)
|
||||
|
|
@ -204,16 +204,16 @@
|
|||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (lexical propvar propvar))
|
||||
(-> (apply (-> (primitive '+))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))))
|
||||
(-> (call (-> (primitive '+))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))))
|
||||
((postdec (ref ,foo))
|
||||
(begin1 (comp `(ref ,foo) e)
|
||||
(lambda (var)
|
||||
(-> (set (lookup foo e)
|
||||
(-> (apply (-> (primitive '-))
|
||||
(-> (lexical var var))
|
||||
(-> (const 1)))))))))
|
||||
(-> (call (-> (primitive '-))
|
||||
(-> (lexical var var))
|
||||
(-> (const 1)))))))))
|
||||
((postdec (pref ,obj ,prop))
|
||||
(let1 (comp obj e)
|
||||
(lambda (objvar)
|
||||
|
|
@ -224,9 +224,9 @@
|
|||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop))
|
||||
(-> (apply (-> (primitive '-))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))
|
||||
(-> (call (-> (primitive '-))
|
||||
(-> (lexical tmpvar tmpvar))
|
||||
(-> (const 1))))))))))
|
||||
((postdec (aref ,obj ,prop))
|
||||
(let1 (comp obj e)
|
||||
(lambda (objvar)
|
||||
|
|
@ -246,18 +246,18 @@
|
|||
(let ((v (lookup foo e)))
|
||||
(-> (begin
|
||||
(-> (set! v
|
||||
(-> (apply (-> (primitive '+))
|
||||
v
|
||||
(-> (const 1))))))
|
||||
(-> (call (-> (primitive '+))
|
||||
v
|
||||
(-> (const 1))))))
|
||||
v))))
|
||||
((preinc (pref ,obj ,prop))
|
||||
(let1 (comp obj e)
|
||||
(lambda (objvar)
|
||||
(begin1 (-> (apply (-> (primitive '+))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop)))
|
||||
(-> (const 1))))
|
||||
(begin1 (-> (call (-> (primitive '+))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop)))
|
||||
(-> (const 1))))
|
||||
(lambda (tmpvar)
|
||||
(@impl pput (-> (lexical objvar objvar))
|
||||
(-> (const prop))
|
||||
|
|
@ -267,11 +267,11 @@
|
|||
(lambda (objvar)
|
||||
(let1 (comp prop e)
|
||||
(lambda (propvar)
|
||||
(begin1 (-> (apply (-> (primitive '+))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (lexical propvar propvar)))
|
||||
(-> (const 1))))
|
||||
(begin1 (-> (call (-> (primitive '+))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (lexical propvar propvar)))
|
||||
(-> (const 1))))
|
||||
(lambda (tmpvar)
|
||||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
|
|
@ -281,18 +281,18 @@
|
|||
(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 '-))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop)))
|
||||
(-> (const 1))))
|
||||
(begin1 (-> (call (-> (primitive '-))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (const prop)))
|
||||
(-> (const 1))))
|
||||
(lambda (tmpvar)
|
||||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
|
|
@ -303,11 +303,11 @@
|
|||
(lambda (objvar)
|
||||
(let1 (comp prop e)
|
||||
(lambda (propvar)
|
||||
(begin1 (-> (apply (-> (primitive '-))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (lexical propvar propvar)))
|
||||
(-> (const 1))))
|
||||
(begin1 (-> (call (-> (primitive '-))
|
||||
(@impl pget
|
||||
(-> (lexical objvar objvar))
|
||||
(-> (lexical propvar propvar)))
|
||||
(-> (const 1))))
|
||||
(lambda (tmpvar)
|
||||
(@impl pput
|
||||
(-> (lexical objvar objvar))
|
||||
|
|
@ -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,25 +357,25 @@
|
|||
,@(map (lambda (x) (comp x e)) args))
|
||||
e))
|
||||
((call ,proc ,args)
|
||||
`(apply ,(comp proc e)
|
||||
,@(map (lambda (x) (comp x e)) args)))
|
||||
`(call ,(comp proc e)
|
||||
,@(map (lambda (x) (comp x e)) args)))
|
||||
((return ,expr)
|
||||
(-> (apply (-> (primitive 'return))
|
||||
(comp expr e))))
|
||||
(-> (call (-> (primitive 'return))
|
||||
(comp expr e))))
|
||||
((array . ,args)
|
||||
`(apply ,(@implv new-array)
|
||||
,@(map (lambda (x) (comp x e)) args)))
|
||||
`(call ,(@implv new-array)
|
||||
,@(map (lambda (x) (comp x e)) args)))
|
||||
((object . ,args)
|
||||
`(apply ,(@implv new-object)
|
||||
,@(map (lambda (x)
|
||||
(pmatch x
|
||||
((,prop ,val)
|
||||
(-> (apply (-> (primitive 'cons))
|
||||
(-> (const prop))
|
||||
(comp val e))))
|
||||
(else
|
||||
(error "bad prop-val pair" x))))
|
||||
args)))
|
||||
`(call ,(@implv new-object)
|
||||
,@(map (lambda (x)
|
||||
(pmatch x
|
||||
((,prop ,val)
|
||||
(-> (call (-> (primitive 'cons))
|
||||
(-> (const prop))
|
||||
(comp val e))))
|
||||
(else
|
||||
(error "bad prop-val pair" x))))
|
||||
args)))
|
||||
((pref ,obj ,prop)
|
||||
(@impl pget
|
||||
(comp obj e)
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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,9 +118,9 @@
|
|||
(apply error args))
|
||||
|
||||
(define (runtime-error loc msg . args)
|
||||
(make-application loc
|
||||
(make-primitive-ref loc 'error)
|
||||
(cons (make-const loc msg) args)))
|
||||
(make-call loc
|
||||
(make-primitive-ref loc 'error)
|
||||
(cons (make-const loc msg) args)))
|
||||
|
||||
;;; Generate code to ensure a global symbol is there for further use of
|
||||
;;; a given symbol. In general during the compilation, those needed are
|
||||
|
|
@ -129,10 +129,10 @@
|
|||
;;; this routine.
|
||||
|
||||
(define (generate-ensure-global loc sym module)
|
||||
(make-application loc
|
||||
(make-module-ref loc runtime 'ensure-fluid! #t)
|
||||
(list (make-const loc module)
|
||||
(make-const loc sym))))
|
||||
(make-call loc
|
||||
(make-module-ref loc runtime 'ensure-fluid! #t)
|
||||
(list (make-const loc module)
|
||||
(make-const loc sym))))
|
||||
|
||||
(define (ensuring-globals loc bindings body)
|
||||
(make-sequence
|
||||
|
|
@ -151,12 +151,12 @@
|
|||
(call-primitive
|
||||
loc
|
||||
'with-fluids*
|
||||
(make-application 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)
|
||||
(map (lambda (sym)
|
||||
(make-module-ref loc module sym #t))
|
||||
syms))
|
||||
(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,11 +779,11 @@
|
|||
((,condition . ,body)
|
||||
(let* ((itersym (gensym))
|
||||
(compiled-body (map compile-expr body))
|
||||
(iter-call (make-application loc
|
||||
(make-lexical-ref loc
|
||||
'iterate
|
||||
itersym)
|
||||
(list)))
|
||||
(iter-call (make-call loc
|
||||
(make-lexical-ref loc
|
||||
'iterate
|
||||
itersym)
|
||||
(list)))
|
||||
(full-body (make-sequence loc
|
||||
`(,@compiled-body ,iter-call)))
|
||||
(lambda-body (make-conditional loc
|
||||
|
|
@ -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,13 +876,13 @@
|
|||
=> (lambda (macro-function)
|
||||
(compile-expr (apply macro-function arguments))))
|
||||
(else
|
||||
(make-application loc
|
||||
(if (symbol? operator)
|
||||
(reference-variable loc
|
||||
operator
|
||||
function-slot)
|
||||
(compile-expr operator))
|
||||
(map compile-expr arguments))))))
|
||||
(make-call loc
|
||||
(if (symbol? operator)
|
||||
(reference-variable loc
|
||||
operator
|
||||
function-slot)
|
||||
(compile-expr operator))
|
||||
(map compile-expr arguments))))))
|
||||
|
||||
;;; Compile a symbol expression. This is a variable reference or maybe
|
||||
;;; some special value like nil.
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,8 +289,8 @@
|
|||
(maybe-emit-return))
|
||||
((vals)
|
||||
(comp-vals
|
||||
(make-application src (make-primitive-ref #f 'apply)
|
||||
(cons proc args))
|
||||
(make-call src (make-primitive-ref #f 'apply)
|
||||
(cons proc args))
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
((drop)
|
||||
|
|
@ -299,8 +299,8 @@
|
|||
;; yet apply does not create a MV continuation. So we
|
||||
;; mv-call out to our trampoline instead.
|
||||
(comp-drop
|
||||
(make-application src (make-primitive-ref #f 'apply)
|
||||
(cons proc args)))
|
||||
(make-call src (make-primitive-ref #f 'apply)
|
||||
(cons proc args)))
|
||||
(maybe-emit-return)))))))
|
||||
|
||||
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
|
||||
|
|
@ -333,8 +333,8 @@
|
|||
((vals)
|
||||
;; Fall back.
|
||||
(comp-vals
|
||||
(make-application src (make-primitive-ref #f 'call-with-values)
|
||||
args)
|
||||
(make-call src (make-primitive-ref #f 'call-with-values)
|
||||
args)
|
||||
MVRA)
|
||||
(maybe-emit-return))
|
||||
(else
|
||||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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,8 +203,8 @@
|
|||
(lp (cdr in)
|
||||
(cons (if (eq? (caar in) 'quote)
|
||||
`(make-const src ,@(cdar in))
|
||||
`(make-application src (make-primitive-ref src ',(caar in))
|
||||
,(inline-args (cdar in))))
|
||||
`(make-call src (make-primitive-ref src ',(caar in))
|
||||
,(inline-args (cdar in))))
|
||||
out)))
|
||||
((symbol? (car in))
|
||||
;; assume it's locally bound
|
||||
|
|
@ -222,8 +222,8 @@
|
|||
,(consequent then)
|
||||
,(consequent else)))
|
||||
(else
|
||||
`(make-application src (make-primitive-ref src ',(car exp))
|
||||
,(inline-args (cdr exp))))))
|
||||
`(make-call src (make-primitive-ref src ',(car exp))
|
||||
,(inline-args (cdr exp))))))
|
||||
((symbol? exp)
|
||||
;; assume locally bound
|
||||
exp)
|
||||
|
|
@ -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,9 +470,9 @@
|
|||
;; trickery here.
|
||||
(make-lambda-case
|
||||
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
|
||||
(make-application #f (make-primitive-ref #f 'apply)
|
||||
(list handler
|
||||
(make-lexical-ref #f 'args args-sym)))
|
||||
(make-call #f (make-primitive-ref #f 'apply)
|
||||
(list handler
|
||||
(make-lexical-ref #f 'args args-sym)))
|
||||
#f))))
|
||||
(else #f)))
|
||||
|
||||
|
|
@ -486,14 +486,14 @@
|
|||
((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)
|
||||
(list handler
|
||||
(make-lexical-ref #f 'args args-sym)))
|
||||
(make-call #f (make-primitive-ref #f 'apply)
|
||||
(list handler
|
||||
(make-lexical-ref #f 'args args-sym)))
|
||||
#f))))
|
||||
(else #f)))
|
||||
(else #f)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue