fix texinfo reflection for procedures

* module/system/vm/program.scm (program-arguments-alist): Rename from
  program-arguments, a name shadowed by features.c
  (arglist->arguments-alist, arity->arguments-alist)
  (arguments-alist->lambda-list, program-lambda-list, write-program):
  Adapt callers.

* module/system/vm/frame.scm (frame-lookup-binding): Return #f if the
  binding is not found, not an error.
  (frame-binding-set!, frame-binding-ref): Adapt to error appropriately.
  (frame-arguments): Dispatch to frame-call-representation.
  (frame-call-representation): Refactor a bit.

* module/ice-9/session.scm (procedure-arguments): Adapt to
  program-arguments name change.

* module/texinfo/reflection.scm (get-proc-args): Refactor to actually
  work with VM procedures.

diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index f6cad46b0adb6be0717444e191c8de02c2a3e20a..e168d3e5bdc90a02a18f1cf509eb8c57bef12c5a 100644 (file)
--- a/module/ice-9/session.scm
+++ b/module/ice-9/session.scm
@@ -1,4 +1,4 @@
-;;;;   Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;;   Copyright (C) 1997, 2000, 2001, 2003, 2006, 2009, 2010 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -516,7 +516,7 @@ The alist keys that are currently defined are `required', `optional',
    ((procedure-source proc)
     => cadr)
    (((@ (system vm program) program?) proc)
-    ((@ (system vm program) program-arguments) proc))
+    ((@ (system vm program) program-arguments-alist) proc))
    (else #f)))
 
 

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index ea012fa747255f56a8fe2cdf95f94a21beba8921..ff002b2cef9b521438f37e86581a0f088ae84eac 100644 (file)
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -38,7 +38,7 @@
 (define (frame-lookup-binding frame var)
   (let lp ((bindings (frame-bindings frame)))
     (cond ((null? bindings)
-           (error "variable not bound in frame" var frame))
+           #f)
           ((eq? (binding:name (car bindings)) var)
            (car bindings))
           (else
@@ -46,14 +46,34 @@
 
 (define (frame-binding-set! frame var val)
   (frame-local-set! frame
-                    (binding:index (frame-lookup-binding frame var))
+                    (binding:index
+                     (or (frame-lookup-binding frame var)
+                         (error "variable not bound in frame" var frame)))
                     val))
 
 (define (frame-binding-ref frame var)
   (frame-local-ref frame
-                   (binding:index (frame-lookup-binding frame var))))
+                   (binding:index
+                    (or (frame-lookup-binding frame var)
+                        (error "variable not bound in frame" var frame)))))
 
 
+;; This function is always called to get some sort of representation of the
+;; frame to present to the user, so let's do the logical thing and dispatch to
+;; frame-call-representation.
+(define (frame-arguments frame)
+  (cdr (frame-call-representation frame)))
+
+
+\f
+;;;
+;;; Pretty printing
+;;;
+
+(define (frame-source frame)
+  (program-source (frame-procedure frame)
+                  (frame-instruction-pointer frame)))
+
 ;; Basically there are two cases to deal with here:
 ;;
 ;;   1. We've already parsed the arguments, and bound them to local
@@ -68,48 +88,49 @@
 ;;      number of arguments, or perhaps we're doing a typed dispatch and
 ;;      the types don't match. In that case the arguments are all on the
 ;;      stack, and nothing else is on the stack.
-(define (frame-arguments frame)
-  (cond
-   ((program-lambda-list (frame-procedure frame)
-                         (frame-instruction-pointer frame))
-    ;; case 1
-    => (lambda (formals)
-         (let lp ((formals formals) (i 0))
-           (pmatch formals
-             (() '())
-             ((,x . ,rest) (guard (symbol? x))
-              (cons (frame-binding-ref frame x) (lp rest (1+ i))))
-             ((,x . ,rest) (guard (keyword? x))
-              (cons x (lp rest i)))
-             ((,x . ,rest) (guard (not x) (< i (frame-num-locals frame)))
-              ;; an arg, but we don't know the name. ref by index.
-              (cons (frame-local-ref frame i) (lp rest (1+ i))))
-             (,rest (guard (symbol? rest))
-              (frame-binding-ref frame rest))
-             (,rest (guard (not rest) (< i (frame-num-locals frame)))
-              ;; again, no name.
-              (frame-local-ref frame i))
-             ;; let's not error here, as we are called during
-             ;; backtraces...
-             (else '???)))))
-   (else
-    ;; case 2
-    (map (lambda (i)
-           (frame-local-ref frame i))
-         (iota (frame-num-locals frame))))))
-
-\f
-;;;
-;;; Pretty printing
-;;;
-
-(define (frame-source frame)
-  (program-source (frame-procedure frame)
-                  (frame-instruction-pointer frame)))
 
 (define (frame-call-representation frame)
   (let ((p (frame-procedure frame)))
-    (cons (or (procedure-name p) p) (frame-arguments frame))))
+    (cons
+     (or (procedure-name p) p)     
+     (cond
+      ((program-arguments-alist p (frame-instruction-pointer frame))
+       ;; case 1
+       => (lambda (arguments)
+            (define (binding-ref sym i)
+              (cond
+               ((frame-lookup-binding frame sym)
+                => (lambda (b) (frame-local-ref frame (binding:index b))))
+               ((< i (frame-num-locals frame))
+                (frame-local-ref frame i))
+               (else
+                ;; let's not error here, as we are called during backtraces...
+                '???)))
+            (let lp ((req (or (assq-ref arguments 'required) '()))
+                     (opt (or (assq-ref arguments 'optional) '()))
+                     (key (or (assq-ref arguments 'keyword) '()))
+                     (rest (or (assq-ref arguments 'rest) #f))
+                     (i 0))
+              (cond
+               ((pair? req)
+                (cons (binding-ref (car req) i)
+                      (lp (cdr req) opt key rest (1+ i))))
+               ((pair? opt)
+                (cons (binding-ref (car opt) i)
+                      (lp req (cdr opt) key rest (1+ i))))
+               ((pair? key)
+                (cons* (caar key)
+                       (frame-local-ref frame (cdar key))
+                       (lp req opt (cdr key) rest (1+ i))))
+               (rest
+                (binding-ref rest i))
+               (else
+                '())))))
+      (else
+       ;; case 2
+       (map (lambda (i)
+              (frame-local-ref frame i))
+            (iota (frame-num-locals frame))))))))
 
 
 \f

diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 28d453ab927f917fa5165b9519603767817dac63..1afc3e0f43500eb9bf33314bfd6c5aeaaf1f211b 100644 (file)
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -36,7 +36,7 @@
 
             arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
 
-            program-arguments program-lambda-list
+            program-arguments-alist program-lambda-list
             
             program-meta
             program-objcode program? program-objects
@@ -129,7 +129,7 @@
                   (car arities))
                  (else (lp (cdr arities))))))))
 
-(define (arglist->arguments arglist)
+(define (arglist->arguments-alist arglist)
   (pmatch arglist
     ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
      `((required . ,req)
@@ -140,14 +140,19 @@
        (extents . ,extents)))
     (else #f)))
 
-(define (arity->arguments prog arity)
+(define* (arity->arguments-alist prog arity
+                                 #:optional
+                                 (make-placeholder
+                                  (lambda (i) (string->symbol "_"))))
   (define var-by-index
     (let ((rbinds (map (lambda (x)
                          (cons (binding:index x) (binding:name x)))
                        (program-bindings-for-ip prog
                                                 (arity:start arity)))))
       (lambda (i)
-        (assv-ref rbinds i))))
+        (or (assv-ref rbinds i)
+            ;; if we don't know the name, return a placeholder
+            (make-placeholder i)))))
 
   (let lp ((nreq (arity:nreq arity)) (req '())
            (nopt (arity:nopt arity)) (opt '())
@@ -172,20 +177,21 @@
         (allow-other-keys? . ,(arity:allow-other-keys? arity))
         (rest . ,rest))))))
 
-(define* (program-arguments prog #:optional ip)
+;; the name "program-arguments" is taken by features.c...
+(define* (program-arguments-alist prog #:optional ip)
   (let ((arity (program-arity prog ip)))
     (and arity
-        (arity->arguments prog arity))))
+         (arity->arguments-alist prog arity))))
 
 (define* (program-lambda-list prog #:optional ip)
-  (and=> (program-arguments prog ip) arguments->lambda-list))
+  (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
 
-(define (arguments->lambda-list arguments)
-  (let ((req (or (assq-ref arguments 'required) '()))
-        (opt (or (assq-ref arguments 'optional) '()))
+(define (arguments-alist->lambda-list arguments-alist)
+  (let ((req (or (assq-ref arguments-alist 'required) '()))
+        (opt (or (assq-ref arguments-alist 'optional) '()))
         (key (map keyword->symbol
-                  (map car (or (assq-ref arguments 'keyword) '()))))
-        (rest (or (assq-ref arguments 'rest) '())))
+                  (map car (or (assq-ref arguments-alist 'keyword) '()))))
+        (rest (or (assq-ref arguments-alist 'rest) '())))
     `(,@req
       ,@(if (pair? opt) (cons #:optional opt) '())
       ,@(if (pair? key) (cons #:key key) '())
@@ -208,8 +214,8 @@
                 (string-append
                  " " (string-join (map (lambda (a)
                                          (object->string
-                                          (arguments->lambda-list
-                                           (arity->arguments prog a))))
+                                          (arguments-alist->lambda-list
+                                           (arity->arguments-alist prog a))))
                                        arities)
                                   " | "))))))
 

diff --git a/module/texinfo/reflection.scm b/module/texinfo/reflection.scm
index d88bd37c898c5c6bc731aaec70db4ca3c9cfe7f4..5a76c281f6941549fd062c53f801509fcf0369ab 100644 (file)
--- 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)