summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/session.scm4
-rw-r--r--module/system/vm/frame.scm105
-rw-r--r--module/system/vm/program.scm34
-rw-r--r--module/texinfo/reflection.scm54
4 files changed, 111 insertions, 86 deletions
diff --git a/module/ice-9/session.scm b/module/ice-9/session.scm
index f6cad46b0..e168d3e5b 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 ea012fa74..ff002b2ce 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 28d453ab9..1afc3e0f4 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 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)