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

More GOOPS cleanups

Browse source 
* module/oop/goops.scm (build-slots-list): Use `match'.
  (make-standard-class): Formatting fixes.
This commit is contained in:
Andy Wingo 2015-01-14 20:15:53 +01:00
parent bacc8829ba
commit f5c3476793
1 changed files with 26 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

54
module/oop/goops.scm
View file

@ -393,31 +393,30 @@ subclasses of @var{c}."
'() '()))) '() '())))
(define (remove-duplicate-slots slots) (define (remove-duplicate-slots slots)
(let lp ((slots (reverse slots)) (res '()) (seen '())) (let lp ((slots (reverse slots)) (res '()) (seen '()))
(cond (match slots
((null? slots) res) (() res)
((memq (caar slots) seen) (((and slot (name . options)) . slots)
(lp (cdr slots) res seen)) (if (memq name seen)
(else (lp slots res seen)
(lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen)))))) (lp slots (cons slot res) (cons name seen)))))))
(let* ((class-slots (and (memq <class> cpl) (let* ((class-slots (and (memq <class> cpl)
(struct-ref <class> class-index-slots)))) (struct-ref <class> class-index-slots))))
(when class-slots (when class-slots
(check-cpl dslots class-slots)) (check-cpl dslots class-slots))
(let lp ((cpl (cdr cpl)) (res dslots) (class-slots '())) (let lp ((cpl (cdr cpl)) (res dslots) (class-slots '()))
(if (null? cpl) (match cpl
(remove-duplicate-slots (append class-slots res)) (() (remove-duplicate-slots (append class-slots res)))
(let* ((head (car cpl)) ((head . cpl)
(cpl (cdr cpl)) (let ((new-slots (struct-ref head class-index-direct-slots)))
(new-slots (struct-ref head class-index-direct-slots))) (cond
(cond ((not class-slots)
((not class-slots) (lp cpl (append new-slots res) class-slots))
(lp cpl (append new-slots res) class-slots)) ((eq? head <class>)
((eq? head <class>) ;; Move class slots to the head of the list.
;; Move class slots to the head of the list. (lp cpl res new-slots))
(lp cpl res new-slots)) (else
(else (check-cpl new-slots class-slots)
(check-cpl new-slots class-slots) (lp cpl (append new-slots res) class-slots)))))))))
(lp cpl (append new-slots res) class-slots))))))))
(define (%compute-layout slots getters-n-setters nfields is-class?) (define (%compute-layout slots getters-n-setters nfields is-class?)
(define (instance-allocated? g-n-s) (define (instance-allocated? g-n-s)
@ -516,12 +515,12 @@ subclasses of @var{c}."
(struct-set! z class-index-slots slots) (struct-set! z class-index-slots slots)
(struct-set! z class-index-getters-n-setters g-n-s) (struct-set! z class-index-getters-n-setters g-n-s)
(struct-set! z class-index-redefined #f) (struct-set! z class-index-redefined #f)
(for-each (lambda (super) (for-each
(let ((subclasses (lambda (super)
(struct-ref super class-index-direct-subclasses))) (let ((subclasses (struct-ref super class-index-direct-subclasses)))
(struct-set! super class-index-direct-subclasses (struct-set! super class-index-direct-subclasses
(cons z subclasses)))) (cons z subclasses))))
dsupers) dsupers)
(%prep-layout! z) (%prep-layout! z)
z))) z)))
@ -770,8 +769,7 @@ followed by its associated value. If @var{l} does not hold a value for
(slot-set! z slot (get-keyword kw args default)))) (slot-set! z slot (get-keyword kw args default))))
'((#:name name ???) '((#:name name ???)
(#:dsupers direct-supers ()) (#:dsupers direct-supers ())
(#:slots direct-slots ()) (#:slots direct-slots ()))))
)))
(else (else
(error "boot `make' does not support this class" class))) (error "boot `make' does not support this class" class)))
z)))) z))))