mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 13:00:26 +02:00
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.
This commit is contained in:
Andy Wingo
parent
7aec4ce019
commit
8470b3f45b
4 changed files with 110 additions and 85 deletions
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
" | "))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
;; 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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue