[Guile-commits] 12/25: More GOOPS cleanups

[Andy Wingo]

wingo pushed a commit to branch wip-goops-refactor
in repository guile.

commit 422884ba0741bcce8d09091de97ee684feefc3df
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 14 20:15:53 2015 +0100

    More GOOPS cleanups
    
    * module/oop/goops.scm (build-slots-list): Use `match'.
      (make-standard-class): Formatting fixes.
---
 module/oop/goops.scm |   54 ++++++++++++++++++++++++-------------------------
 1 files changed, 26 insertions(+), 28 deletions(-)

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