mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-18 01:30:27 +02:00
Code Activity

(language tree-il analyze) works better with RTL programs

Browse source 
* module/system/vm/program.scm (program-arguments-alists): Export this
  interface.  Fall back to grovelling through procedure-minimum-arity if
  the program has no arities, as might be the case for continuations.

* module/language/tree-il/analyze.scm (validate-arity): Use
  program-arguments-alists instead of the program-arities interface, to
  cover both stack VM and RTL programs.
This commit is contained in:
Andy Wingo 2013-10-18 18:41:59 +02:00
parent b0ca878cae
commit 8bd261baaa
2 changed files with 18 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -950,13 +950,15 @@ given `tree-il' element."
(or (and (or (null? x) (pair? x)) (or (and (or (null? x) (pair? x))
(length x)) (length x))
0)) 0))
(cond ((program? proc) (cond ((or (program? proc) (rtl-program? proc))
(values (procedure-name proc) (values (procedure-name proc)
(map (lambda (a) (map (lambda (a)
(list (arity:nreq a) (arity:nopt a) (arity:rest? a) (list (length (or (assq-ref a 'required) '()))
(map car (arity:kw a)) (length (or (assq-ref a 'optional) '()))
(arity:allow-other-keys? a))) (and (assq-ref a 'rest) #t)
(program-arities proc)))) (map car (or (assq-ref a 'keyword) '()))
(assq-ref a 'allow-other-keys?)))
(program-arguments-alists proc))))
((procedure? proc) ((procedure? proc)
(if (struct? proc) (if (struct? proc)
;; An applicable struct. ;; An applicable struct.

16
module/system/vm/program.scm
View file

@ -41,7 +41,8 @@
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
program-arguments-alist program-lambda-list program-arguments-alist program-arguments-alists
program-lambda-list
program-meta program-meta
program-objcode program? program-objects program-objcode program? program-objects
@ -340,8 +341,9 @@
0))) 0)))
(define (program-arguments-alists prog) (define (program-arguments-alists prog)
(cond "Returns all arities of the given procedure, as a list of association
((primitive? prog) lists."
(define (fallback)
(match (procedure-minimum-arity prog) (match (procedure-minimum-arity prog)
(#f '()) (#f '())
((nreq nopt rest?) ((nreq nopt rest?)
@ -349,9 +351,13 @@
(arity->arguments-alist (arity->arguments-alist
prog prog
(list 0 0 nreq nopt rest? '(#f . ()))))))) (list 0 0 nreq nopt rest? '(#f . ())))))))
(cond
((primitive? prog) (fallback))
((rtl-program? prog) ((rtl-program? prog)
(map arity-arguments-alist (let ((arities (find-program-arities (rtl-program-code prog))))
(or (find-program-arities (rtl-program-code prog)) '()))) (if arities
(map arity-arguments-alist arities)
(fallback))))
((program? prog) ((program? prog)
(map (lambda (arity) (arity->arguments-alist prog arity)) (map (lambda (arity) (arity->arguments-alist prog arity))
(or (program-arities prog) '()))) (or (program-arities prog) '())))