mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 15:40:19 +02:00
Code Activity

Port method and generic accessors to Scheme

Browse source 
* libguile/goops.c:
* module/oop/goops.scm (generic-function-methods)
  (method-generic-function, method-specializers, method-procedure): Port
  to Scheme.
This commit is contained in:
Andy Wingo 2015-01-09 22:05:01 +01:00
parent 70dd600070
commit 48c981c9b6
2 changed files with 76 additions and 73 deletions
Download patch file Download diff file Expand all files Collapse all files

45
module/oop/goops.scm
View file

@ -640,6 +640,27 @@
(error "boot `make' does not support this class" class)))
z))))
(define (method-generic-function obj)
"Return the generic function for the method @var{obj}."
(unless (is-a? obj <method>)
(scm-error 'wrong-type-arg #f "Not a method: ~S"
(list obj) #f))
(slot-ref obj 'generic-function))
(define (method-specializers obj)
"Return specializers of the method @var{obj}."
(unless (is-a? obj <method>)
(scm-error 'wrong-type-arg #f "Not a method: ~S"
(list obj) #f))
(slot-ref obj 'specializers))
(define (method-procedure obj)
"Return the procedure of the method @var{obj}."
(unless (is-a? obj <method>)
(scm-error 'wrong-type-arg #f "Not a method: ~S"
(list obj) #f))
(slot-ref obj 'procedure))
(define *dispatch-module* (current-module))
;;;
@ -1319,6 +1340,30 @@
(define (%sort-applicable-methods methods types)
(sort methods (lambda (a b) (%method-more-specific? a b types))))
(define (generic-function-methods obj)
"Return the methods of the generic function @var{obj}."
(define (fold-upward method-lists gf)
(cond
((is-a? gf <extended-generic>)
(let lp ((method-lists method-lists) (gfs (slot-ref gf 'extends)))
(match gfs
(() method-lists)
((gf . gfs)
(lp (fold-upward (cons (slot-ref gf 'methods) method-lists) gf)
gfs)))))
(else method-lists)))
(define (fold-downward method-lists gf)
(let lp ((method-lists (cons (slot-ref gf 'methods) method-lists))
(gfs (slot-ref gf 'extended-by)))
(match gfs
(() method-lists)
((gf . gfs)
(lp (fold-downward method-lists gf) gfs)))))
(unless (is-a? obj <generic>)
(scm-error 'wrong-type-arg #f "Not a generic: ~S"
(list obj) #f))
(concatenate (fold-downward (fold-upward '() obj) obj)))
(define (%compute-applicable-methods gf args)
(define (method-applicable? m types)
(let lp ((specs (method-specializers m)) (types types))