mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 04:30:19 +02:00
Code Activity

add generic method-formals; fixes to method-source

Browse source 
* module/oop/goops.scm (method-source): Don't throw an error if this
  method has no source.
  (method-formals): New generic function, the complement of
  method-specializers for introspection.
This commit is contained in:
Andy Wingo 2009-03-20 12:06:10 +01:00
parent 17dd267a35
commit 4e2f1e9edd
1 changed files with 12 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

19
module/oop/goops.scm
View file

@ -68,7 +68,8 @@
class-direct-methods class-direct-slots class-precedence-list class-direct-methods class-direct-slots class-precedence-list
class-slots class-environment class-slots class-environment
generic-function-name generic-function-name
generic-function-methods method-generic-function method-specializers generic-function-methods method-generic-function
method-specializers method-formals
primitive-generic-generic enable-primitive-generic! primitive-generic-generic enable-primitive-generic!
method-procedure accessor-method-slot-definition method-procedure accessor-method-slot-definition
slot-exists? make find-method get-keyword) slot-exists? make find-method get-keyword)
@ -565,12 +566,16 @@
;;; ;;;
(define-method (method-source (m <method>)) (define-method (method-source (m <method>))
(let* ((spec (map* class-name (slot-ref m 'specializers))) (let* ((spec (map* class-name (slot-ref m 'specializers)))
(proc (procedure-source (slot-ref m 'procedure))) (src (procedure-source (slot-ref m 'procedure))))
(args (cadr proc)) (and src
(body (cddr proc))) (let ((args (cadr src))
(cons 'method (body (cddr src)))
(cons (map* list args spec) (cons 'method
body)))) (cons (map* list args spec)
body))))))
(define-method (method-formals (m <method>))
(slot-ref m 'formals))
;;; ;;;
;;; Slots ;;; Slots