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

better procedure-arguments for interpreted procs with opt, rest, kwargs

Browse source 
* module/ice-9/session.scm (procedure-arguments): Arrange to interpret
  numbers in the "req" and "opt" positions of an 'arglist as N arguments
  with unknown name.

* module/ice-9/eval.scm (primitive-eval): Set 'arglist on "complex"
  procedures.  Fixes http://bugs.gnu.org/10922.

* test-suite/tests/session.test ("procedure-arguments"): Add a test.
This commit is contained in:
Andy Wingo 2012-07-06 12:19:12 +02:00
parent 5558cdaa30
commit fc835b1b14
3 changed files with 38 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

9
module/ice-9/eval.scm
View file

@ -238,7 +238,14 @@
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
(set-procedure-minimum-arity! proc nreq nopt rest?)
(begin
(set-procedure-property! proc 'arglist
(list nreq
nopt
(if kw (cdr kw) '())
(and kw (car kw))
(and rest? '_)))
(set-procedure-minimum-arity! proc nreq nopt rest?))
(let* ((nreq* (cadr alt))
(rest?* (if (null? (cddr alt)) #f (caddr alt)))
(tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))

8
module/ice-9/session.scm
View file

@ -511,8 +511,12 @@ The alist keys that are currently defined are `required', `optional',
((procedure-property proc 'arglist)
=> (match-lambda
((req opt keyword aok? rest)
`((required . ,req)
(optional . ,opt)
`((required . ,(if (number? req)
(make-list req '_)
req))
(optional . ,(if (number? opt)
(make-list opt '_)
opt))
(keyword . ,keyword)
(allow-other-keys? . ,aok?)
(rest . ,rest)))))

25
test-suite/tests/session.test
View file

@ -20,6 +20,7 @@
(define-module (test-suite session)
#:use-module (test-suite lib)
#:use-module (ice-9 match)
#:use-module (system base compile)
#:use-module (ice-9 session))
@ -94,7 +95,29 @@
(let* ((proc (compile '(lambda (a b) #f) #:to 'value))
(args (procedure-arguments proc)))
(set-procedure-property! proc 'arglist (map cdr args))
(equal? args (procedure-arguments proc)))))
(equal? args (procedure-arguments proc))))
(pass-if "interpreted procedures (simple)"
(match (procedure-arguments
(eval '(lambda (x y) #f) (current-module)))
(((required _ _)
(optional)
(keyword)
(allow-other-keys? . #f)
(rest . #f))
#t)
(_ #f)))
(pass-if "interpreted procedures (complex)"
(match (procedure-arguments
(eval '(lambda* (a b #:optional c #:key d) #f) (current-module)))
(((required _ _)
(optional _)
(keyword (#:d . 3))
(allow-other-keys? . #f)
(rest . #f))
#t)
(_ #f))))
;;; Local Variables:
;;; eval: (put 'pass-if-valid-arguments 'scheme-indent-function 1)