mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-25 20:50:31 +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
|
|
@ -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