mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

GOOPS cleanup to use SRFI-1 better

Browse source 
* module/oop/goops.scm (class-subclasses, class-methods): Reimplement
  using stock SRFI-1 procedures.
This commit is contained in:
Andy Wingo 2015-01-12 21:16:25 +01:00
parent c2aa5d9bba
commit 0ca4929027
1 changed files with 11 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

46
module/oop/goops.scm
View file

@ -237,6 +237,17 @@
"Return the slot list of the class @var{obj}."
class-index-slots)
(define (class-subclasses c)
(define (all-subclasses c)
(cons c (append-map all-subclasses
(class-direct-subclasses c))))
(delete-duplicates (cdr (all-subclasses c)) eq?))
(define (class-methods c)
(delete-duplicates (append-map class-direct-methods
(cons c (class-subclasses c)))
eq?))
;;
;; is-a?
;;
@ -2657,41 +2668,6 @@ var{initargs}."
no-method
))
;;;
;;; {<composite-metaclass> and <active-metaclass>}
;;;
;(autoload "active-slot" <active-metaclass>)
;(autoload "composite-slot" <composite-metaclass>)
;(export <composite-metaclass> <active-metaclass>)
;;;
;;; {Tools}
;;;
;; list2set
;;
;; duplicate the standard list->set function but using eq instead of
;; eqv which really sucks a lot, uselessly here
;;
(define (list2set l)
(let loop ((l l)
(res '()))
(cond
((null? l) res)
((memq (car l) res) (loop (cdr l) res))
(else (loop (cdr l) (cons (car l) res))))))
(define (class-subclasses c)
(letrec ((allsubs (lambda (c)
(cons c (mapappend allsubs
(class-direct-subclasses c))))))
(list2set (cdr (allsubs c)))))
(define (class-methods c)
(list2set (mapappend class-direct-methods
(cons c (class-subclasses c)))))
;;;
;;; {Final initialization}
;;;