[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-149-g8470b3f

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8470b3f45b48bf627642e8f41938492be4eacf2c

The branch, master has been updated
       via  8470b3f45b48bf627642e8f41938492be4eacf2c (commit)
      from  7aec4ce019555b0c7113c585fda4a7ef18b84b5a (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 8470b3f45b48bf627642e8f41938492be4eacf2c
Author: Andy Wingo <address@hidden>
Date:   Tue Jan 12 22:50:10 2010 +0100

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/session.scm      |    4 +-
 module/system/vm/frame.scm    |  105 ++++++++++++++++++++++++----------------
 module/system/vm/program.scm  |   34 ++++++++------
 module/texinfo/reflection.scm |   52 ++++++++++-----------
 4 files changed, 110 insertions(+), 85 deletions(-)

diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index f6cad46..e168d3e 100644
--- 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 ea012fa..ff002b2 100644
--- 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)))
+
+
+
+;;;
+;;; 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))))))
-
-
-;;;
-;;; 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))))))))
 
 
 
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 28d453a..1afc3e0 100644
--- 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 d88bd37..5a76c28 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)


hooks/post-receive
-- 
GNU Guile