X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/ceb7f9cc126f50e0cc8956b80ac5d111580b23c8..180ac9d7b0bac97bdead2813a1b0b23d19002c3e:/module/language/tree-il/analyze.scm diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index badce9f77..f5890b25a 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -180,10 +180,13 @@ (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 - (( proc args) + (( proc args) (apply lset-union eq? (step-tail-call proc args) (map step args))) + (( args) + (apply lset-union eq? (map step args))) + (( test consequent alternate) (lset-union eq? (step test) (step-tail consequent) (step-tail alternate))) @@ -222,13 +225,8 @@ (( exp) (step exp)) - (( 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)))))))) + (( head tail) + (lset-union eq? (step head) (step-tail tail))) (( body) ;; order is important here @@ -339,8 +337,10 @@ (( exp body) (lset-union eq? (step exp) (step body))) - (( body winder unwinder) - (lset-union eq? (step body) (step winder) (step unwinder))) + (( winder pre body post unwinder) + (lset-union eq? (step winder) (step pre) + (step body) + (step post) (step unwinder))) (( fluids vals body) (apply lset-union eq? (step body) (map step (append fluids vals)))) @@ -367,9 +367,12 @@ (define (allocate! x proc n) (define (recur y) (allocate! y proc n)) (record-case x - (( proc args) + (( proc args) (apply max (recur proc) (map recur args))) + (( args) + (apply max n (map recur args))) + (( test consequent alternate) (max (recur test) (recur consequent) (recur alternate))) @@ -385,8 +388,9 @@ (( exp) (recur exp)) - (( exps) - (apply max (map recur exps))) + (( head tail) + (max (recur head) + (recur tail))) (( body) ;; allocate closure vars in order @@ -509,8 +513,10 @@ (( exp body) (max (recur exp) (recur body))) - (( body winder unwinder) - (max (recur body) (recur winder) (recur unwinder))) + (( winder pre body post unwinder) + (max (recur winder) (recur pre) + (recur body) + (recur post) (recur unwinder))) (( fluids vals body) (apply max (recur body) (map recur (append fluids vals)))) @@ -866,7 +872,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) @@ -927,7 +933,7 @@ accurate information is missing from a given `tree-il' element." (make-toplevel-info (vhash-delq name refs) (vhash-consq name #t defs))) - (( proc args) + (( 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 @@ -965,12 +971,12 @@ accurate information is missing from a given `tree-il' element." (define-record-type (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) @@ -1034,8 +1040,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? @@ -1122,7 +1128,7 @@ accurate information is missing from a given `tree-il' element." (( gensyms vals) (fold extend info gensyms vals)) - (( proc args src) + (( proc args src) (record-case proc (( body) (validate-arity proc x #t) @@ -1182,9 +1188,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) @@ -1199,9 +1205,9 @@ accurate information is missing from a given `tree-il' element." (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))) @@ -1395,11 +1401,11 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (match x (($ _ (? string? exp)) exp) - (($ _ (? (cut gettext? <> env)) + (($ _ (? (cut gettext? <> env)) (($ _ (? string? fmt)))) ;; Gettexted literals, like `(_ "foo")'. fmt) - (($ _ (? (cut ngettext? <> env)) + (($ _ (? (cut ngettext? <> env)) (($ _ (? string? fmt)) ($ _ (? string?)) _ ..1)) ;; Plural gettextized literals, like `(N_ "singular" "plural" n)'. @@ -1490,17 +1496,17 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME." (false-if-exception (module-ref env name)))) (match x - (($ src ($ _ name) args) + (($ src ($ _ 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)))))) - (($ src ($ _ '(ice-9 format) 'format) args) + (($ src ($ _ '(ice-9 format) 'format) args) (check-format-args args (or src (find pair? locs)))) - (($ src ($ _ '(guile) - (or 'format 'simple-format)) + (($ src ($ _ '(guile) + (or 'format 'simple-format)) args) (and (check-simple-format-args args (or src (find pair? locs)))