(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)))
+ ((<primcall> args)
+ (apply lset-union eq? (map step args)))
+
((<conditional> test consequent alternate)
(lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))
((<toplevel-define> exp)
(step exp))
- ((<sequence> exps)
- (let lp ((exps exps) (ret '()))
- (cond ((null? exps) '())
- ((null? (cdr exps))
- (lset-union eq? ret (step-tail (car exps))))
- (else
- (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))
+ ((<seq> head tail)
+ (lset-union eq? (step head) (step-tail tail)))
((<lambda> body)
;; order is important here
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynwind> body winder unwinder)
- (lset-union eq? (step body) (step winder) (step unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (lset-union eq? (step winder) (step pre)
+ (step body)
+ (step post) (step unwinder)))
((<dynlet> fluids vals body)
(apply lset-union eq? (step body) (map step (append fluids vals))))
(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)))
+ ((<primcall> args)
+ (apply max n (map recur args)))
+
((<conditional> test consequent alternate)
(max (recur test) (recur consequent) (recur alternate)))
((<toplevel-define> exp)
(recur exp))
- ((<sequence> exps)
- (apply max (map recur exps)))
+ ((<seq> head tail)
+ (max (recur head)
+ (recur tail)))
((<lambda> body)
;; allocate closure vars in order
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynwind> body winder unwinder)
- (max (recur body) (recur winder) (recur unwinder)))
+ ((<dynwind> winder pre body post unwinder)
+ (max (recur winder) (recur pre)
+ (recur body)
+ (recur post) (recur unwinder)))
((<dynlet> fluids vals body)
(apply max (recur body) (map recur (append fluids vals))))
(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)
(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
(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)
(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?
((<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)
(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)
(module-ref env name))))
proc)))
(cond ((lambda? proc*)
- (validate-arity proc* application #t))
+ (validate-arity proc* call #t))
((procedure? proc*)
- (validate-arity proc* application #f)))))
+ (validate-arity proc* call #f)))))
toplevel-calls)))
(make-arity-info vlist-null vlist-null vlist-null)))
(match x
(($ <const> _ (? string? exp))
exp)
- (($ <application> _ (? (cut gettext? <> env))
+ (($ <call> _ (? (cut gettext? <> env))
(($ <const> _ (? string? fmt))))
;; Gettexted literals, like `(_ "foo")'.
fmt)
- (($ <application> _ (? (cut ngettext? <> env))
+ (($ <call> _ (? (cut ngettext? <> env))
(($ <const> _ (? string? fmt)) ($ <const> _ (? string?)) _ ..1))
;; Plural gettextized literals, like `(N_ "singular" "plural" n)'.
(false-if-exception (module-ref env name))))
(match x
- (($ <application> src ($ <toplevel-ref> _ name) args)
+ (($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(if (or (and (eq? proc (@ (guile) simple-format))
(check-simple-format-args args
(or src (find pair? locs))))
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
- (($ <application> src ($ <module-ref> _ '(ice-9 format) 'format) args)
+ (($ <call> src ($ <module-ref> _ '(ice-9 format) 'format) args)
(check-format-args args (or src (find pair? locs))))
- (($ <application> src ($ <module-ref> _ '(guile)
- (or 'format 'simple-format))
+ (($ <call> src ($ <module-ref> _ '(guile)
+ (or 'format 'simple-format))
args)
(and (check-simple-format-args args
(or src (find pair? locs)))
HCoop / bpt / guile.git / blobdiff