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

goops.scm cleanups

Browse source 
* module/oop/goops.scm (make-generic, make-extended-generic):
  (ensure-generic, make-accessor, ensure-accessor): Use optional
  arguments for #:name.  `make-extended-generic' also accepts empty
  extension lists.
This commit is contained in:
Andy Wingo 2011-07-07 12:17:08 +02:00
parent c1e3e9aaff
commit a8c10aa131
1 changed files with 40 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

85
module/oop/goops.scm
View file

@ -336,13 +336,11 @@
names)) names))
(goops-error "no prefixes supplied")))) (goops-error "no prefixes supplied"))))
(define (make-generic . name) (define* (make-generic #:optional name)
(let ((name (and (pair? name) (car name)))) (make <generic> #:name name))
(make <generic> #:name name)))
(define (make-extended-generic gfs . name) (define* (make-extended-generic gfs #:optional name)
(let* ((name (and (pair? name) (car name))) (let* ((gfs (if (list? gfs) gfs (list gfs)))
(gfs (if (pair? gfs) gfs (list gfs)))
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs))) (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
(let ((ans (if gws? (let ((ans (if gws?
(let* ((sname (and name (make-setter-name name))) (let* ((sname (and name (make-setter-name name)))
@ -379,18 +377,17 @@
(delq! eg (slot-ref gf 'extended-by)))) (delq! eg (slot-ref gf 'extended-by))))
gfs)) gfs))
(define (ensure-generic old-definition . name) (define* (ensure-generic old-definition #:optional name)
(let ((name (and (pair? name) (car name)))) (cond ((is-a? old-definition <generic>) old-definition)
(cond ((is-a? old-definition <generic>) old-definition) ((procedure-with-setter? old-definition)
((procedure-with-setter? old-definition) (make <generic-with-setter>
(make <generic-with-setter> #:name name
#:name name #:default (procedure old-definition)
#:default (procedure old-definition) #:setter (setter old-definition)))
#:setter (setter old-definition))) ((procedure? old-definition)
((procedure? old-definition) (if (generic-capability? old-definition) old-definition
(if (generic-capability? old-definition) old-definition (make <generic> #:name name #:default old-definition)))
(make <generic> #:name name #:default old-definition))) (else (make <generic> #:name name))))
(else (make <generic> #:name name)))))
;; same semantics as <generic> ;; same semantics as <generic>
(define-syntax define-accessor (define-syntax define-accessor
@ -404,34 +401,32 @@
(define (make-setter-name name) (define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name)))) (string->symbol (string-append "setter:" (symbol->string name))))
(define (make-accessor . name) (define* (make-accessor #:optional name)
(let ((name (and (pair? name) (car name)))) (make <accessor>
(make <accessor> #:name name
#:name name #:setter (make <generic>
#:setter (make <generic> #:name (and name (make-setter-name name)))))
#:name (and name (make-setter-name name))))))
(define (ensure-accessor proc . name) (define* (ensure-accessor proc #:optional name)
(let ((name (and (pair? name) (car name)))) (cond ((and (is-a? proc <accessor>)
(cond ((and (is-a? proc <accessor>) (is-a? (setter proc) <generic>))
(is-a? (setter proc) <generic>)) proc)
proc) ((is-a? proc <generic-with-setter>)
((is-a? proc <generic-with-setter>) (upgrade-accessor proc (setter proc)))
(upgrade-accessor proc (setter proc))) ((is-a? proc <generic>)
((is-a? proc <generic>) (upgrade-accessor proc (make-generic name)))
(upgrade-accessor proc (make-generic name))) ((procedure-with-setter? proc)
((procedure-with-setter? proc) (make <accessor>
(make <accessor> #:name name
#:name name #:default (procedure proc)
#:default (procedure proc) #:setter (ensure-generic (setter proc) name)))
#:setter (ensure-generic (setter proc) name))) ((procedure? proc)
((procedure? proc) (ensure-accessor (if (generic-capability? proc)
(ensure-accessor (if (generic-capability? proc) (make <generic> #:name name #:default proc)
(make <generic> #:name name #:default proc) (ensure-generic proc name))
(ensure-generic proc name)) name))
name)) (else
(else (make-accessor name))))
(make-accessor name)))))
(define (upgrade-accessor generic setter) (define (upgrade-accessor generic setter)
(let ((methods (slot-ref generic 'methods)) (let ((methods (slot-ref generic 'methods))