mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-23 21:10:29 +02:00
Code Activity

Use vhashes in `arity-analysis'.

Browse source 
* module/language/tree-il/analyze.scm (arity-analysis): Use vhashes
  instead of alists.
This commit is contained in:
Ludovic Courtès 2010-02-03 00:00:05 +01:00
parent 04ea6fb504
commit df685ee46b
1 changed files with 39 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

77
module/language/tree-il/analyze.scm
View file

@ -1054,20 +1054,20 @@ accurate information is missing from a given `tree-il' element."
(record-case val (record-case val
((<lambda> body) ((<lambda> body)
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
(alist-cons lexical-name val (vhash-consq lexical-name val
lexical-lambdas) lexical-lambdas)
toplevel-lambdas)) toplevel-lambdas))
((<lexical-ref> gensym) ((<lexical-ref> gensym)
;; lexical alias ;; lexical alias
(let ((val* (assq gensym lexical-lambdas))) (let ((val* (vhash-assq gensym lexical-lambdas)))
(if (pair? val*) (if (pair? val*)
(extend lexical-name (cdr val*) info) (extend lexical-name (cdr val*) info)
info))) info)))
((<toplevel-ref> name) ((<toplevel-ref> name)
;; top-level alias ;; top-level alias
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
(alist-cons lexical-name val (vhash-consq lexical-name val
lexical-lambdas) lexical-lambdas)
toplevel-lambdas)) toplevel-lambdas))
(else info)))) (else info))))
@ -1081,17 +1081,17 @@ accurate information is missing from a given `tree-il' element."
((<lambda> body) ((<lambda> body)
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
lexical-lambdas lexical-lambdas
(alist-cons name exp toplevel-lambdas))) (vhash-consq name exp toplevel-lambdas)))
((<toplevel-ref> name) ((<toplevel-ref> name)
;; alias for another toplevel ;; alias for another toplevel
(let ((proc (assq name toplevel-lambdas))) (let ((proc (vhash-assq name toplevel-lambdas)))
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
lexical-lambdas lexical-lambdas
(alist-cons (toplevel-define-name x) (vhash-consq (toplevel-define-name x)
(if (pair? proc) (if (pair? proc)
(cdr proc) (cdr proc)
exp) exp)
toplevel-lambdas)))) toplevel-lambdas))))
(else info))) (else info)))
((<let> vars vals) ((<let> vars vals)
(fold extend info vars vals)) (fold extend info vars vals))
@ -1106,16 +1106,16 @@ accurate information is missing from a given `tree-il' element."
(validate-arity proc x #t) (validate-arity proc x #t)
info) info)
((<toplevel-ref> name) ((<toplevel-ref> name)
(make-arity-info (alist-cons name x toplevel-calls) (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas lexical-lambdas
toplevel-lambdas)) toplevel-lambdas))
((<lexical-ref> gensym) ((<lexical-ref> gensym)
(let ((proc (assq gensym lexical-lambdas))) (let ((proc (vhash-assq gensym lexical-lambdas)))
(if (pair? proc) (if (pair? proc)
(record-case (cdr proc) (record-case (cdr proc)
((<toplevel-ref> name) ((<toplevel-ref> name)
;; alias to toplevel ;; alias to toplevel
(make-arity-info (alist-cons name x toplevel-calls) (make-arity-info (vhash-consq name x toplevel-calls)
lexical-lambdas lexical-lambdas
toplevel-lambdas)) toplevel-lambdas))
(else (else
@ -1136,7 +1136,9 @@ accurate information is missing from a given `tree-il' element."
(lexical-lambdas (lexical-lambdas info)) (lexical-lambdas (lexical-lambdas info))
(toplevel-lambdas (toplevel-lambdas info))) (toplevel-lambdas (toplevel-lambdas info)))
(make-arity-info toplevel-calls (make-arity-info toplevel-calls
(alist-delete name lexical-lambdas eq?) (if (vhash-assq name lexical-lambdas)
(vlist-tail lexical-lambdas)
lexical-lambdas)
toplevel-lambdas))) toplevel-lambdas)))
(let ((toplevel-calls (toplevel-procedure-calls info)) (let ((toplevel-calls (toplevel-procedure-calls info))
@ -1157,26 +1159,25 @@ accurate information is missing from a given `tree-il' element."
;; encountered. ;; encountered.
(let ((toplevel-calls (toplevel-procedure-calls result)) (let ((toplevel-calls (toplevel-procedure-calls result))
(toplevel-lambdas (toplevel-lambdas result))) (toplevel-lambdas (toplevel-lambdas result)))
(for-each (lambda (name+application) (vlist-for-each
(let* ((name (car name+application)) (lambda (name+application)
(application (cdr name+application)) (let* ((name (car name+application))
(proc (application (cdr name+application))
(or (assoc-ref toplevel-lambdas name) (proc
(and (module? env) (or (and=> (vhash-assq name toplevel-lambdas) cdr)
(false-if-exception (and (module? env)
(module-ref env name))))) (false-if-exception
(proc* (module-ref env name)))))
;; handle toplevel aliases (proc*
(if (toplevel-ref? proc) ;; handle toplevel aliases
(let ((name (toplevel-ref-name proc))) (if (toplevel-ref? proc)
(and (module? env) (let ((name (toplevel-ref-name proc)))
(false-if-exception (and (module? env)
(module-ref env name)))) (false-if-exception
proc))) (module-ref env name))))
;; (format #t "toplevel-call to ~A (~A) from ~A~%" proc)))
;; name proc* application) (if (or (lambda? proc*) (procedure? proc*))
(if (or (lambda? proc*) (procedure? proc*)) (validate-arity proc* application (lambda? proc*)))))
(validate-arity proc* application (lambda? proc*))))) toplevel-calls)))
toplevel-calls)))
(make-arity-info '() '() '()))) (make-arity-info vlist-null vlist-null vlist-null)))