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 ;;;; ;;;; 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) + ;; 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) + ;; 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)