summaryrefslogtreecommitdiff
path: root/module/texinfo/reflection.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/texinfo/reflection.scm')
-rw-r--r--module/texinfo/reflection.scm54
1 files changed, 26 insertions, 28 deletions
diff --git a/module/texinfo/reflection.scm b/module/texinfo/reflection.scm
index d88bd37c8..5a76c281f 100644
--- a/module/texinfo/reflection.scm
+++ b/module/texinfo/reflection.scm
@@ -1,6 +1,6 @@
;;;; (texinfo reflection) -- documenting Scheme as stexinfo
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -92,37 +92,35 @@
(define (get-proc-args proc)
(cond
- ((procedure-property proc 'arglist)
- => (lambda (arglist)
- (let ((required-args (car arglist))
- (optional-args (cadr arglist))
- (keyword-args (caddr arglist))
- (rest-arg (car (cddddr arglist))))
+ ((procedure-arguments proc)
+ => (lambda (args)
+ (let ((required-args (assq-ref args 'required))
+ (optional-args (assq-ref args 'optional))
+ (keyword-args (assq-ref args 'keyword))
+ (rest-arg (assq-ref args 'rest)))
(process-args
(append
- ;; start with the required args...
- (map symbol->string required-args)
-
- ;; add any optional args if needed...
- (map (lambda (a)
- (if (list? a)
- (format #f "[~a = ~s]" (car a) (cadr a))
- (format #f "[~a]" a)))
- optional-args)
+ ;; start with the required args...
+ (map symbol->string required-args)
+
+ ;; add any optional args if needed...
+ (map (lambda (a)
+ (if (list? a)
+ (format #f "[~a = ~s]" (car a) (cadr a))
+ (format #f "[~a]" a)))
+ optional-args)
- ;; now the keyword args..
- (map (lambda (a)
- (if (list? a)
- (format #f "[#:~a = ~s]" (car a) (cadr a))
- (format #f "[#:~a]" a)))
- keyword-args)
+ ;; now the keyword args..
+ (map (lambda (a)
+ (if (pair? a)
+ (format #f "[~a]" (car a))
+ (format #f "[#:~a]" a)))
+ keyword-args)
- ;; now the rest arg...
- (if rest-arg
- (list "." (symbol->string rest-arg))
- '()))))))
- (else
- (process-args (and=> (procedure-source proc) cadr)))))
+ ;; now the rest arg...
+ (if rest-arg
+ (list "." (symbol->string rest-arg))
+ '()))))))))
;; like the normal false-if-exception, but doesn't affect the-last-stack
(define-macro (false-if-exception exp)