(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)))
((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)))))
(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))
(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)