mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

fix texinfo reflection for procedures

Browse source 
* 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 2010-01-12 22:50:10 +01:00
parent 7aec4ce019
commit 8470b3f45b
4 changed files with 110 additions and 85 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/ice-9/session.scm
View file

@ -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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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) ((procedure-source proc)
=> cadr) => cadr)
(((@ (system vm program) program?) proc) (((@ (system vm program) program?) proc)
((@ (system vm program) program-arguments) proc)) ((@ (system vm program) program-arguments-alist) proc))
(else #f))) (else #f)))

105
module/system/vm/frame.scm
View file

@ -38,7 +38,7 @@
(define (frame-lookup-binding frame var) (define (frame-lookup-binding frame var)
(let lp ((bindings (frame-bindings frame))) (let lp ((bindings (frame-bindings frame)))
(cond ((null? bindings) (cond ((null? bindings)
(error "variable not bound in frame" var frame)) #f)
((eq? (binding:name (car bindings)) var) ((eq? (binding:name (car bindings)) var)
(car bindings)) (car bindings))
(else (else
@ -46,14 +46,34 @@
(define (frame-binding-set! frame var val) (define (frame-binding-set! frame var val)
(frame-local-set! frame (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)) val))
(define (frame-binding-ref frame var) (define (frame-binding-ref frame var)
(frame-local-ref frame (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: ;; Basically there are two cases to deal with here:
;; ;;
;; 1. We've already parsed the arguments, and bound them to local ;; 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 ;; 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 ;; the types don't match. In that case the arguments are all on the
;; stack, and nothing else is on the stack. ;; 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) (define (frame-call-representation frame)
(let ((p (frame-procedure 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))))))))

34
module/system/vm/program.scm
View file

@ -36,7 +36,7 @@
arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? 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-meta
program-objcode program? program-objects program-objcode program? program-objects
@ -129,7 +129,7 @@
(car arities)) (car arities))
(else (lp (cdr arities)))))))) (else (lp (cdr arities))))))))
(define (arglist->arguments arglist) (define (arglist->arguments-alist arglist)
(pmatch arglist (pmatch arglist
((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents) ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents)
`((required . ,req) `((required . ,req)
@ -140,14 +140,19 @@
(extents . ,extents))) (extents . ,extents)))
(else #f))) (else #f)))
(define (arity->arguments prog arity) (define* (arity->arguments-alist prog arity
#:optional
(make-placeholder
(lambda (i) (string->symbol "_"))))
(define var-by-index (define var-by-index
(let ((rbinds (map (lambda (x) (let ((rbinds (map (lambda (x)
(cons (binding:index x) (binding:name x))) (cons (binding:index x) (binding:name x)))
(program-bindings-for-ip prog (program-bindings-for-ip prog
(arity:start arity))))) (arity:start arity)))))
(lambda (i) (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 '()) (let lp ((nreq (arity:nreq arity)) (req '())
(nopt (arity:nopt arity)) (opt '()) (nopt (arity:nopt arity)) (opt '())
@ -172,20 +177,21 @@
(allow-other-keys? . ,(arity:allow-other-keys? arity)) (allow-other-keys? . ,(arity:allow-other-keys? arity))
(rest . ,rest)))))) (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))) (let ((arity (program-arity prog ip)))
(and arity (and arity
(arity->arguments prog arity)))) (arity->arguments-alist prog arity))))
(define* (program-lambda-list prog #:optional ip) (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) (define (arguments-alist->lambda-list arguments-alist)
(let ((req (or (assq-ref arguments 'required) '())) (let ((req (or (assq-ref arguments-alist 'required) '()))
(opt (or (assq-ref arguments 'optional) '())) (opt (or (assq-ref arguments-alist 'optional) '()))
(key (map keyword->symbol (key (map keyword->symbol
(map car (or (assq-ref arguments 'keyword) '())))) (map car (or (assq-ref arguments-alist 'keyword) '()))))
(rest (or (assq-ref arguments 'rest) '()))) (rest (or (assq-ref arguments-alist 'rest) '())))
`(,@req `(,@req
,@(if (pair? opt) (cons #:optional opt) '()) ,@(if (pair? opt) (cons #:optional opt) '())
,@(if (pair? key) (cons #:key key) '()) ,@(if (pair? key) (cons #:key key) '())
@ -208,8 +214,8 @@
(string-append (string-append
" " (string-join (map (lambda (a) " " (string-join (map (lambda (a)
(object->string (object->string
(arguments->lambda-list (arguments-alist->lambda-list
(arity->arguments prog a)))) (arity->arguments-alist prog a))))
arities) arities)
" | ")))))) " | "))))))

52
module/texinfo/reflection.scm
View file

@ -1,6 +1,6 @@
;;;; (texinfo reflection) -- documenting Scheme as stexinfo ;;;; (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> ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -92,37 +92,35 @@
(define (get-proc-args proc) (define (get-proc-args proc)
(cond (cond
((procedure-property proc 'arglist) ((procedure-arguments proc)
=> (lambda (arglist) => (lambda (args)
(let ((required-args (car arglist)) (let ((required-args (assq-ref args 'required))
(optional-args (cadr arglist)) (optional-args (assq-ref args 'optional))
(keyword-args (caddr arglist)) (keyword-args (assq-ref args 'keyword))
(rest-arg (car (cddddr arglist)))) (rest-arg (assq-ref args 'rest)))
(process-args (process-args
(append (append
;; start with the required args... ;; start with the required args...
(map symbol->string required-args) (map symbol->string required-args)
;; add any optional args if needed... ;; add any optional args if needed...
(map (lambda (a) (map (lambda (a)
(if (list? a) (if (list? a)
(format #f "[~a = ~s]" (car a) (cadr a)) (format #f "[~a = ~s]" (car a) (cadr a))
(format #f "[~a]" a))) (format #f "[~a]" a)))
optional-args) optional-args)
;; now the keyword args.. ;; now the keyword args..
(map (lambda (a) (map (lambda (a)
(if (list? a) (if (pair? a)
(format #f "[#:~a = ~s]" (car a) (cadr a)) (format #f "[~a]" (car a))
(format #f "[#:~a]" a))) (format #f "[#:~a]" a)))
keyword-args) keyword-args)
;; now the rest arg... ;; now the rest arg...
(if rest-arg (if rest-arg
(list "." (symbol->string rest-arg)) (list "." (symbol->string rest-arg))
'())))))) '()))))))))
(else
(process-args (and=> (procedure-source proc) cadr)))))
;; like the normal false-if-exception, but doesn't affect the-last-stack ;; like the normal false-if-exception, but doesn't affect the-last-stack
(define-macro (false-if-exception exp) (define-macro (false-if-exception exp)