guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 35/87: goops: use computed class slot offsets; untabify


From: Andy Wingo
Subject: [Guile-commits] 35/87: goops: use computed class slot offsets; untabify and fix whitepace
Date: Thu, 22 Jan 2015 17:29:53 +0000

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

commit 8ed7c52706a72b1d2633d4af7a1e7518f781a803
Author: Andy Wingo <address@hidden>
Date:   Fri Jan 9 20:07:06 2015 +0100

    goops: use computed class slot offsets; untabify and fix whitepace
    
    * module/oop/goops.scm: Untabify and remove trailing whitespace.  Change
      slot-ref on classes to struct-ref of fixed offsets.
---
 module/oop/goops.scm |  867 +++++++++++++++++++++++++-------------------------
 1 files changed, 438 insertions(+), 429 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index d00ce67..77c387d 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -97,14 +97,14 @@
             make-extended-generic
             make-accessor ensure-accessor
             add-method!
-            class-slot-ref class-slot-set! slot-unbound slot-missing 
+            class-slot-ref class-slot-set! slot-unbound slot-missing
             slot-definition-name  slot-definition-options
             slot-definition-allocation
 
             slot-definition-getter slot-definition-setter
             slot-definition-accessor
             slot-definition-init-value slot-definition-init-form
-            slot-definition-init-thunk slot-definition-init-keyword 
+            slot-definition-init-thunk slot-definition-init-keyword
             slot-init-function class-slot-definition
             method-source
             compute-cpl compute-std-cpl compute-get-n-set compute-slots
@@ -120,7 +120,7 @@
             class-subclasses class-methods
             goops-error
             min-fixnum max-fixnum
-           
+
 ;;; *fixme* Should go into goops.c
             instance?  slot-ref-using-class
             slot-set-using-class! slot-bound-using-class?
@@ -279,7 +279,8 @@
         (lp (cdr slots) res seen))
        (else
         (lp (cdr slots) (cons (car slots) res) (cons (caar slots) seen))))))
-  (let* ((class-slots (and (memq <class> cpl) (slot-ref <class> 'slots))))
+  (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 '()))
@@ -287,7 +288,7 @@
           (remove-duplicate-slots (append class-slots res))
           (let* ((head (car cpl))
                  (cpl (cdr cpl))
-                 (new-slots (slot-ref head 'direct-slots)))
+                 (new-slots (struct-ref head class-index-direct-slots)))
             (cond
              ((not class-slots)
               (lp cpl (append new-slots res) class-slots))
@@ -351,8 +352,8 @@
          (unless (= n nfields) (error "bad nfields"))
          (unless (null? slots) (error "inconsistent g-n-s/slots"))
          (when is-class?
-           (let ((class-layout (symbol->string (slot-ref <class> 'layout))))
-             (unless (string-prefix? class-layout layout)
+           (let ((class-layout (struct-ref <class> class-index-layout)))
+             (unless (string-prefix? (symbol->string class-layout) layout)
                (error "bad layout for class"))))
          layout)
         ((g-n-s . getters-n-setters)
@@ -375,16 +376,17 @@
               (lp n slots getters-n-setters))))))))))
 
 (define (%prep-layout! class)
-  (let* ((is-class? (and (memq <class> (slot-ref class 'cpl)) #t))
-         (layout (%compute-layout (slot-ref class 'slots)
-                                  (slot-ref class 'getters-n-setters)
-                                  (slot-ref class 'nfields)
-                                  is-class?)))
+  (let* ((is-class? (and (memq <class> (struct-ref class class-index-cpl)) #t))
+         (layout (%compute-layout
+                  (struct-ref class class-index-slots)
+                  (struct-ref class class-index-getters-n-setters)
+                  (struct-ref class class-index-nfields)
+                  is-class?)))
     (%init-layout! class layout)))
 
 (define (make-standard-class class name dsupers dslots)
   (let ((z (make-struct/no-tail class)))
-    (slot-set! z 'direct-supers dsupers)
+    (struct-set! z class-index-direct-supers dsupers)
     (let* ((cpl (compute-cpl z))
            (dslots (map (lambda (slot)
                           (if (pair? slot) slot (list slot)))
@@ -392,18 +394,20 @@
            (slots (build-slots-list dslots cpl))
            (nfields (length slots))
            (g-n-s (%compute-getters-n-setters slots)))
-      (slot-set! z 'name name)
-      (slot-set! z 'direct-slots dslots)
-      (slot-set! z 'direct-subclasses '())
-      (slot-set! z 'direct-methods '())
-      (slot-set! z 'cpl cpl)
-      (slot-set! z 'slots slots)
-      (slot-set! z 'nfields nfields)
-      (slot-set! z 'getters-n-setters g-n-s)
-      (slot-set! z 'redefined #f)
+      (struct-set! z class-index-name name)
+      (struct-set! z class-index-direct-slots dslots)
+      (struct-set! z class-index-direct-subclasses '())
+      (struct-set! z class-index-direct-methods '())
+      (struct-set! z class-index-cpl cpl)
+      (struct-set! z class-index-slots slots)
+      (struct-set! z class-index-nfields nfields)
+      (struct-set! z class-index-getters-n-setters g-n-s)
+      (struct-set! z class-index-redefined #f)
       (for-each (lambda (super)
-                  (let ((subclasses (slot-ref super 'direct-subclasses)))
-                    (slot-set! super 'direct-subclasses (cons z subclasses))))
+                  (let ((subclasses
+                         (struct-ref super class-index-direct-subclasses)))
+                    (struct-set! super class-index-direct-subclasses
+                                 (cons z subclasses))))
                 dsupers)
       (%prep-layout! z)
       (%inherit-magic! z dsupers)
@@ -432,9 +436,9 @@
 
 ;; <top>, <object>, and <class> were partially initialized.  Correct
 ;; them here.
-(slot-set! <object> 'direct-subclasses (list <class>))
-(slot-set! <class> 'direct-supers (list <object>))
-(slot-set! <class> 'cpl (list <class> <object> <top>))
+(struct-set! <object> class-index-direct-subclasses (list <class>))
+(struct-set! <class> class-index-direct-supers (list <object>))
+(struct-set! <class> class-index-cpl (list <class> <object> <top>))
 
 (define-standard-class <foreign-slot> (<top>))
 (define-standard-class <protected-slot> (<foreign-slot>))
@@ -460,10 +464,11 @@
                  (cons (list 'name) tail))
                 ((_ (name class) tail)
                  (cons (list 'name #:class class) tail)))))
-  (let ((dslots (fold-<class>-slots macro-fold-right visit '())))
-    (slot-set! <class> 'direct-slots dslots)
-    (slot-set! <class> 'slots dslots)
-    (slot-set! <class> 'getters-n-setters (%compute-getters-n-setters 
dslots))))
+  (let* ((dslots (fold-<class>-slots macro-fold-right visit '()))
+         (g-n-s (%compute-getters-n-setters dslots)))
+    (struct-set! <class> class-index-direct-slots dslots)
+    (struct-set! <class> class-index-slots dslots)
+    (struct-set! <class> class-index-getters-n-setters g-n-s)))
 
 ;; Applicables and their classes.
 (define-standard-class <procedure-class> (<class>))
@@ -865,13 +870,13 @@
 
 (define (memoize-method! gf args)
   (let ((applicable ((if (eq? gf compute-applicable-methods)
-                        %compute-applicable-methods
-                        compute-applicable-methods)
-                    gf args)))
+                         %compute-applicable-methods
+                         compute-applicable-methods)
+                     gf args)))
     (cond (applicable
            (memoize-effective-method! gf args applicable))
-         (else
-          (no-applicable-method gf args)))))
+          (else
+           (no-applicable-method gf args)))))
 
 (set-procedure-property! memoize-method! 'system-procedure #t)
 
@@ -908,36 +913,36 @@
   (let ((table-of-metas '()))
     (lambda (meta-supers)
       (let ((entry (assoc meta-supers table-of-metas)))
-       (if entry
-           ;; Found a previously created metaclass
-           (cdr entry)
-           ;; Create a new meta-class which inherit from "meta-supers"
-           (let ((new (make <class> #:dsupers meta-supers
-                                    #:slots   '()
-                                    #:name   (gensym "metaclass"))))
-             (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
-             new))))))
+        (if entry
+            ;; Found a previously created metaclass
+            (cdr entry)
+            ;; Create a new meta-class which inherit from "meta-supers"
+            (let ((new (make <class> #:dsupers meta-supers
+                                     #:slots   '()
+                                     #:name   (gensym "metaclass"))))
+              (set! table-of-metas (cons (cons meta-supers new) 
table-of-metas))
+              new))))))
 
 (define (ensure-metaclass supers)
   (if (null? supers)
       <class>
       (let* ((all-metas (map (lambda (x) (class-of x)) supers))
-            (all-cpls  (append-map (lambda (m)
-                                      (cdr (class-precedence-list m))) 
+             (all-cpls  (append-map (lambda (m)
+                                      (cdr (class-precedence-list m)))
                                     all-metas))
-            (needed-metas '()))
-       ;; Find the most specific metaclasses.  The new metaclass will be
-       ;; a subclass of these.
-       (for-each
-        (lambda (meta)
-          (if (and (not (member meta all-cpls))
-                     (not (member meta needed-metas)))
-            (set! needed-metas (append needed-metas (list meta)))))
-        all-metas)
-       ;; Now return a subclass of the metaclasses we found.
-       (if (null? (cdr needed-metas))
-           (car needed-metas)  ; If there's only one, just use it.
-           (ensure-metaclass-with-supers needed-metas)))))
+             (needed-metas '()))
+        ;; Find the most specific metaclasses.  The new metaclass will be
+        ;; a subclass of these.
+        (for-each
+         (lambda (meta)
+           (if (and (not (member meta all-cpls))
+                      (not (member meta needed-metas)))
+             (set! needed-metas (append needed-metas (list meta)))))
+         all-metas)
+        ;; Now return a subclass of the metaclasses we found.
+        (if (null? (cdr needed-metas))
+            (car needed-metas)  ; If there's only one, just use it.
+            (ensure-metaclass-with-supers needed-metas)))))
 
 ;;;
 ;;; {Classes}
@@ -974,7 +979,7 @@
     ;; Everything seems correct, build the class
     (apply make metaclass
            #:dsupers supers
-           #:slots slots 
+           #:slots slots
            #:name name
            options)))
 
@@ -1047,7 +1052,7 @@
           #'(define-class-pre-definition (rest ...) out ...))))
       ((_ () out ...)
        #'(begin out ...)))))
-       
+
 ;; Some slot options require extra definitions to be made. In
 ;; particular, we want to make sure that the generic function objects
 ;; which represent accessors exist before `make-class' tries to add
@@ -1065,7 +1070,7 @@
        #'(define-class-pre-definitions (rest ...)
          out ...))
       ((_ ((slotname slotopt ...) rest ...) out ...)
-       #'(define-class-pre-definitions (rest ...) 
+       #'(define-class-pre-definitions (rest ...)
          out ... (define-class-pre-definition (slotopt ...)))))))
 
 (define-syntax-rule (define-class name supers slot ...)
@@ -1077,7 +1082,7 @@
         (class-redefinition name
                             (class supers slot ... #:name 'name))
         (toplevel-define! 'name (class supers slot ... #:name 'name)))))
-       
+
 (define-syntax-rule (standard-define-class arg ...)
   (define-class arg ...))
 
@@ -1125,42 +1130,42 @@
 
 (define* (make-extended-generic gfs #:optional name)
   (let* ((gfs (if (list? 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* ((sname (and name (make-setter-name name)))
-                         (setters
-                          (append-map (lambda (gf)
-                                        (if (is-a? gf <generic-with-setter>)
-                                            (list (ensure-generic (setter gf)
-                                                                  sname))
-                                            '()))
-                                      gfs))
-                         (es (make <extended-generic-with-setter>
-                               #:name name
-                               #:extends gfs
-                               #:setter (make <extended-generic>
-                                          #:name sname
-                                          #:extends setters))))
-                    (extended-by! setters (setter es))
-                    es)
-                  (make <extended-generic>
-                    #:name name
-                    #:extends gfs))))
+                   (let* ((sname (and name (make-setter-name name)))
+                          (setters
+                           (append-map (lambda (gf)
+                                         (if (is-a? gf <generic-with-setter>)
+                                             (list (ensure-generic (setter gf)
+                                                                   sname))
+                                             '()))
+                                       gfs))
+                          (es (make <extended-generic-with-setter>
+                                #:name name
+                                #:extends gfs
+                                #:setter (make <extended-generic>
+                                           #:name sname
+                                           #:extends setters))))
+                     (extended-by! setters (setter es))
+                     es)
+                   (make <extended-generic>
+                     #:name name
+                     #:extends gfs))))
       (extended-by! gfs ans)
       ans)))
 
 (define (extended-by! gfs eg)
   (for-each (lambda (gf)
-             (slot-set! gf 'extended-by
-                        (cons eg (slot-ref gf 'extended-by))))
-           gfs)
+              (slot-set! gf 'extended-by
+                         (cons eg (slot-ref gf 'extended-by))))
+            gfs)
   (invalidate-method-cache! eg))
 
 (define (not-extended-by! gfs eg)
   (for-each (lambda (gf)
-             (slot-set! gf 'extended-by
-                        (delq! eg (slot-ref gf 'extended-by))))
-           gfs)
+              (slot-set! gf 'extended-by
+                         (delq! eg (slot-ref gf 'extended-by))))
+            gfs)
   (invalidate-method-cache! eg))
 
 (define* (ensure-generic old-definition #:optional name)
@@ -1214,21 +1219,21 @@
 
 (define (upgrade-accessor generic setter)
   (let ((methods (slot-ref generic 'methods))
-       (gws (make (if (is-a? generic <extended-generic>)
-                      <extended-generic-with-setter>
-                      <accessor>)
-                  #:name (generic-function-name generic)
-                  #:extended-by (slot-ref generic 'extended-by)
-                  #:setter setter)))
+        (gws (make (if (is-a? generic <extended-generic>)
+                       <extended-generic-with-setter>
+                       <accessor>)
+                   #:name (generic-function-name generic)
+                   #:extended-by (slot-ref generic 'extended-by)
+                   #:setter setter)))
     (if (is-a? generic <extended-generic>)
-       (let ((gfs (slot-ref generic 'extends)))
-         (not-extended-by! gfs generic)
-         (slot-set! gws 'extends gfs)
-         (extended-by! gfs gws)))
+        (let ((gfs (slot-ref generic 'extends)))
+          (not-extended-by! gfs generic)
+          (slot-set! gws 'extends gfs)
+          (extended-by! gfs gws)))
     ;; Steal old methods
     (for-each (lambda (method)
-               (slot-set! method 'generic-function gws))
-             methods)
+                (slot-set! method 'generic-function gws))
+              methods)
     (slot-set! gws 'methods methods)
     (invalidate-method-cache! gws)
     gws))
@@ -1247,9 +1252,9 @@
 ;;
 ;;   (define-method M (a . l) ....)
 ;;   (define-method M (a) ....)
-;; 
+;;
 ;; we consider that the second method is more specific.
-;; 
+;;
 ;; Precondition: `a' and `b' are methods and are applicable to `types'.
 (define (%method-more-specific? a b types)
   (let lp ((a-specializers (method-specializers a))
@@ -1439,32 +1444,32 @@
 (define (add-method-in-classes! m)
   ;; Add method in all the classes which appears in its specializers list
   (for-each* (lambda (x)
-              (let ((dm (class-direct-methods x)))
-                (if (not (memq m dm))
-                    (slot-set! x 'direct-methods (cons m dm)))))
-            (method-specializers m)))
+               (let ((dm (class-direct-methods x)))
+                 (unless (memq m dm)
+                   (struct-set! x class-index-direct-methods (cons m dm)))))
+             (method-specializers m)))
 
 (define (remove-method-in-classes! m)
   ;; Remove method in all the classes which appears in its specializers list
   (for-each* (lambda (x)
-              (slot-set! x
-                         'direct-methods
-                         (delv! m (class-direct-methods x))))
-            (method-specializers m)))
+               (struct-set! x
+                            class-index-direct-methods
+                            (delv! m (class-direct-methods x))))
+             (method-specializers m)))
 
 (define (compute-new-list-of-methods gf new)
   (let ((new-spec (method-specializers new))
-       (methods  (slot-ref gf 'methods)))
+        (methods  (slot-ref gf 'methods)))
     (let loop ((l methods))
       (if (null? l)
-         (cons new methods)
-         (if (equal? (method-specializers (car l)) new-spec)
-             (begin 
-               ;; This spec. list already exists. Remove old method from 
dependents
-               (remove-method-in-classes! (car l))
-               (set-car! l new) 
-               methods)
-             (loop (cdr l)))))))
+          (cons new methods)
+          (if (equal? (method-specializers (car l)) new-spec)
+              (begin
+                ;; This spec. list already exists. Remove old method from 
dependents
+                (remove-method-in-classes! (car l))
+                (set-car! l new)
+                methods)
+              (loop (cdr l)))))))
 
 (define (method-n-specializers m)
   (length* (slot-ref m 'specializers)))
@@ -1495,8 +1500,8 @@
 (define-method (add-method! (proc <procedure>) (m <method>))
   (if (generic-capability? proc)
       (begin
-       (enable-primitive-generic! proc)
-       (add-method! proc m))
+        (enable-primitive-generic! proc)
+        (add-method! proc m))
       (next-method)))
 
 (define-method (add-method! (pg <primitive-generic>) (m <method>))
@@ -1514,7 +1519,7 @@
 ;;;
 (define-method (method-source (m <method>))
   (let* ((spec (map* class-name (slot-ref m 'specializers)))
-        (src (procedure-source (slot-ref m 'procedure))))
+         (src (procedure-source (slot-ref m 'procedure))))
     (and src
          (let ((args (cadr src))
                (body (cddr src)))
@@ -1561,7 +1566,7 @@
   (assq slot-name (class-slots class)))
 
 (define (slot-init-function class slot-name)
-  (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+  (cadr (assq slot-name (struct-ref class class-index-getters-n-setters))))
 
 (define (accessor-method-slot-definition obj)
   "Return the slot definition of the accessor @var{obj}."
@@ -1582,7 +1587,7 @@
 ;; When this generic gets called, we will have already checked eq? and
 ;; eqv? -- the purpose of this generic is to extend equality. So by
 ;; default, there is no extension, thus the #f return.
-(add-method! g-equal? (method (x y) #f)) 
+(add-method! g-equal? (method (x y) #f))
 (set-primitive-generic! equal? g-equal?)
 
 ;;;
@@ -1590,7 +1595,7 @@
 ;;;
 
 ;     Code for writing objects must test that the slots they use are
-;     bound. Otherwise a slot-unbound method will be called and will 
+;     bound. Otherwise a slot-unbound method will be called and will
 ;     conduct to an infinite loop.
 
 ;; Write
@@ -1607,66 +1612,66 @@
 (define-method (write (o <object>) file)
   (let ((class (class-of o)))
     (if (slot-bound? class 'name)
-       (begin
-         (display "#<" file)
-         (display (class-name class) file)
-         (display #\space file)
-         (display-address o file)
-         (display #\> file))
-       (next-method))))
+        (begin
+          (display "#<" file)
+          (display (class-name class) file)
+          (display #\space file)
+          (display-address o file)
+          (display #\> file))
+        (next-method))))
 
 (define-method (write (class <class>) file)
   (let ((meta (class-of class)))
     (if (and (slot-bound? class 'name)
-            (slot-bound? meta 'name))
-       (begin
-         (display "#<" file)
-         (display (class-name meta) file)
-         (display #\space file)
-         (display (class-name class) file)
-         (display #\space file)
-         (display-address class file)
-         (display #\> file))
-       (next-method))))
+             (slot-bound? meta 'name))
+        (begin
+          (display "#<" file)
+          (display (class-name meta) file)
+          (display #\space file)
+          (display (class-name class) file)
+          (display #\space file)
+          (display-address class file)
+          (display #\> file))
+        (next-method))))
 
 (define-method (write (gf <generic>) file)
   (let ((meta (class-of gf)))
     (if (and (slot-bound? meta 'name)
-            (slot-bound? gf 'methods))
-       (begin
-         (display "#<" file)
-         (display (class-name meta) file)
-         (let ((name (generic-function-name gf)))
-           (if name
-               (begin
-                 (display #\space file)
-                 (display name file))))
-         (display " (" file)
-         (display (length (generic-function-methods gf)) file)
-         (display ")>" file))
-       (next-method))))
+             (slot-bound? gf 'methods))
+        (begin
+          (display "#<" file)
+          (display (class-name meta) file)
+          (let ((name (generic-function-name gf)))
+            (if name
+                (begin
+                  (display #\space file)
+                  (display name file))))
+          (display " (" file)
+          (display (length (generic-function-methods gf)) file)
+          (display ")>" file))
+        (next-method))))
 
 (define-method (write (o <method>) file)
   (let ((meta (class-of o)))
     (if (and (slot-bound? meta 'name)
-            (slot-bound? o 'specializers))
-       (begin
-         (display "#<" file)
-         (display (class-name meta) file)
-         (display #\space file)
-         (display (map* (lambda (spec)
-                          (if (slot-bound? spec 'name)
-                              (slot-ref spec 'name)
-                              spec))
-                        (method-specializers o))
-                  file)
-         (display #\space file)
-         (display-address o file)
-         (display #\> file))
-       (next-method))))
+             (slot-bound? o 'specializers))
+        (begin
+          (display "#<" file)
+          (display (class-name meta) file)
+          (display #\space file)
+          (display (map* (lambda (spec)
+                           (if (slot-bound? spec 'name)
+                               (slot-ref spec 'name)
+                               spec))
+                         (method-specializers o))
+                   file)
+          (display #\space file)
+          (display-address o file)
+          (display #\> file))
+        (next-method))))
 
 ;; Display (do the same thing as write by default)
-(define-method (display o file) 
+(define-method (display o file)
   (write-object o file))
 
 ;;;
@@ -1688,65 +1693,65 @@
 (define <module> (find-subclass <top> '<module>))
 
 (define-method (merge-generics (module <module>)
-                              (name <symbol>)
-                              (int1 <module>)
-                              (val1 <top>)
-                              (int2 <module>)
-                              (val2 <top>)
-                              (var <top>)
-                              (val <top>))
+                               (name <symbol>)
+                               (int1 <module>)
+                               (val1 <top>)
+                               (int2 <module>)
+                               (val2 <top>)
+                               (var <top>)
+                               (val <top>))
   #f)
 
 (define-method (merge-generics (module <module>)
-                              (name <symbol>)
-                              (int1 <module>)
-                              (val1 <generic>)
-                              (int2 <module>)
-                              (val2 <generic>)
-                              (var <top>)
-                              (val <boolean>))
+                               (name <symbol>)
+                               (int1 <module>)
+                               (val1 <generic>)
+                               (int2 <module>)
+                               (val2 <generic>)
+                               (var <top>)
+                               (val <boolean>))
   (and (not (eq? val1 val2))
        (make-variable (make-extended-generic (list val2 val1) name))))
 
 (define-method (merge-generics (module <module>)
-                              (name <symbol>)
-                              (int1 <module>)
-                              (val1 <generic>)
-                              (int2 <module>)
-                              (val2 <generic>)
-                              (var <top>)
-                              (gf <extended-generic>))
+                               (name <symbol>)
+                               (int1 <module>)
+                               (val1 <generic>)
+                               (int2 <module>)
+                               (val2 <generic>)
+                               (var <top>)
+                               (gf <extended-generic>))
   (and (not (memq val2 (slot-ref gf 'extends)))
        (begin
-        (slot-set! gf
-                   'extends
-                   (cons val2 (delq! val2 (slot-ref gf 'extends))))
-        (slot-set! val2
-                   'extended-by
-                   (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (slot-set! gf
+                    'extends
+                    (cons val2 (delq! val2 (slot-ref gf 'extends))))
+         (slot-set! val2
+                    'extended-by
+                    (cons gf (delq! gf (slot-ref val2 'extended-by))))
          (invalidate-method-cache! gf)
-        var)))
+         var)))
 
 (module-define! duplicate-handlers 'merge-generics merge-generics)
 
 (define-method (merge-accessors (module <module>)
-                               (name <symbol>)
-                               (int1 <module>)
-                               (val1 <top>)
-                               (int2 <module>)
-                               (val2 <top>)
-                               (var <top>)
-                               (val <top>))
+                                (name <symbol>)
+                                (int1 <module>)
+                                (val1 <top>)
+                                (int2 <module>)
+                                (val2 <top>)
+                                (var <top>)
+                                (val <top>))
   #f)
 
 (define-method (merge-accessors (module <module>)
-                               (name <symbol>)
-                               (int1 <module>)
-                               (val1 <accessor>)
-                               (int2 <module>)
-                               (val2 <accessor>)
-                               (var <top>)
-                               (val <top>))
+                                (name <symbol>)
+                                (int1 <module>)
+                                (val1 <accessor>)
+                                (int2 <module>)
+                                (val2 <accessor>)
+                                (var <top>)
+                                (val <top>))
   (merge-generics module name int1 val1 int2 val2 var val))
 
 (module-define! duplicate-handlers 'merge-accessors merge-accessors)
@@ -1756,19 +1761,20 @@
 ;;;
 
 (define (class-slot-g-n-s class slot-name)
-  (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
-        (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
-                         (slot-missing class slot-name)))))
+  (let* ((this-slot (assq slot-name (struct-ref class class-index-slots)))
+         (getters-n-setters (struct-ref class class-index-getters-n-setters))
+         (g-n-s (cddr (or (assq slot-name getters-n-setters)
+                          (slot-missing class slot-name)))))
     (if (not (memq (slot-definition-allocation this-slot)
-                  '(#:class #:each-subclass)))
-       (slot-missing class slot-name))
+                   '(#:class #:each-subclass)))
+        (slot-missing class slot-name))
     g-n-s))
 
 (define (class-slot-ref class slot)
   (let ((x ((car (class-slot-g-n-s class slot)) #f)))
     (if (unbound? x)
-       (slot-unbound class slot)
-       x)))
+        (slot-unbound class slot)
+        x)))
 
 (define (class-slot-set! class slot value)
   ((cadr (class-slot-g-n-s class slot)) #f value))
@@ -1784,10 +1790,10 @@
 
 (define-method (slot-missing (c <class>) (o <object>) s)
   (goops-error "No slot with name `~S' in object ~S" s o))
-  
+
 (define-method (slot-missing (c <class>) s)
   (goops-error "No class slot with name `~S' in class ~S" s c))
-  
+
 
 (define-method (slot-missing (c <class>) (o <object>) s value)
   (slot-missing c o s))
@@ -1799,7 +1805,7 @@
 
 (define-method (no-applicable-method (gf <generic>) args)
   (goops-error "No applicable method for ~S in call ~S"
-              gf (cons (generic-function-name gf) args)))
+               gf (cons (generic-function-name gf) args)))
 
 (define-method (no-method (gf <generic>) args)
   (goops-error "No method defined for ~S"  gf))
@@ -1810,26 +1816,26 @@
 
 (define-method (shallow-clone (self <object>))
   (let ((clone (%allocate-instance (class-of self) '()))
-       (slots (map slot-definition-name
-                   (class-slots (class-of self)))))
+        (slots (map slot-definition-name
+                    (class-slots (class-of self)))))
     (for-each (lambda (slot)
-               (if (slot-bound? self slot)
-                   (slot-set! clone slot (slot-ref self slot))))
-             slots)
+                (if (slot-bound? self slot)
+                    (slot-set! clone slot (slot-ref self slot))))
+              slots)
     clone))
 
 (define-method (deep-clone  (self <object>))
   (let ((clone (%allocate-instance (class-of self) '()))
-       (slots (map slot-definition-name
-                   (class-slots (class-of self)))))
+        (slots (map slot-definition-name
+                    (class-slots (class-of self)))))
     (for-each (lambda (slot)
-               (if (slot-bound? self slot)
-                   (slot-set! clone slot
-                              (let ((value (slot-ref self slot)))
-                                (if (instance? value)
-                                    (deep-clone value)
-                                    value)))))
-             slots)
+                (if (slot-bound? self slot)
+                    (slot-set! clone slot
+                               (let ((value (slot-ref self slot)))
+                                 (if (instance? value)
+                                     (deep-clone value)
+                                     value)))))
+              slots)
     clone))
 
 ;;;
@@ -1842,42 +1848,42 @@
 ;;; Has correct the following conditions:
 
 ;;; Methods
-;;; 
+;;;
 ;;; 1. New accessor specializers refer to new header
-;;; 
+;;;
 ;;; Classes
-;;; 
+;;;
 ;;; 1. New class cpl refers to the new class header
 ;;; 2. Old class header exists on old super classes direct-subclass lists
 ;;; 3. New class header exists on new super classes direct-subclass lists
 
 (define-method (class-redefinition (old <class>) (new <class>))
   ;; Work on direct methods:
-  ;;           1. Remove accessor methods from the old class 
-  ;;           2. Patch the occurences of new in the specializers by old
-  ;;           3. Displace the methods from old to new
-  (remove-class-accessors! old)                                        ;; -1-
+  ;;            1. Remove accessor methods from the old class
+  ;;            2. Patch the occurences of new in the specializers by old
+  ;;            3. Displace the methods from old to new
+  (remove-class-accessors! old)                                 ;; -1-
   (let ((methods (class-direct-methods new)))
     (for-each (lambda (m)
-                (update-direct-method! m new old))     ;; -2-
+                 (update-direct-method! m new old))     ;; -2-
               methods)
-    (slot-set! new
-              'direct-methods
-              (append methods (class-direct-methods old))))
+    (struct-set! new
+                 class-index-direct-methods
+                 (append methods (class-direct-methods old))))
 
   ;; Substitute old for new in new cpl
-  (set-car! (slot-ref new 'cpl) old)
-  
+  (set-car! (struct-ref new class-index-cpl) old)
+
   ;; Remove the old class from the direct-subclasses list of its super classes
-  (for-each (lambda (c) (slot-set! c 'direct-subclasses
-                                  (delv! old (class-direct-subclasses c))))
-           (class-direct-supers old))
+  (for-each (lambda (c) (struct-set! c class-index-direct-subclasses
+                                     (delv! old (class-direct-subclasses c))))
+            (class-direct-supers old))
 
   ;; Replace the new class with the old in the direct-subclasses of the supers
   (for-each (lambda (c)
-             (slot-set! c 'direct-subclasses
-                        (cons old (delv! new (class-direct-subclasses c)))))
-           (class-direct-supers new))
+              (struct-set! c class-index-direct-subclasses
+                           (cons old (delv! new (class-direct-subclasses c)))))
+            (class-direct-supers new))
 
   ;; Swap object headers
   (%modify-class old new)
@@ -1885,14 +1891,14 @@
   ;; Now old is NEW!
 
   ;; Redefine all the subclasses of old to take into account modification
-  (for-each 
-       (lambda (c)
-        (update-direct-subclass! c new old))
-       (class-direct-subclasses new))
+  (for-each
+   (lambda (c)
+     (update-direct-subclass! c new old))
+   (class-direct-subclasses new))
 
   ;; Invalidate class so that subsequent instances slot accesses invoke
   ;; change-object-class
-  (slot-set! new 'redefined old)
+  (struct-set! new class-index-redefined old)
   (%invalidate-class new) ;must come after slot-set!
 
   old)
@@ -1903,44 +1909,44 @@
 
 (define-method (remove-class-accessors! (c <class>))
   (for-each (lambda (m)
-             (if (is-a? m <accessor-method>)
-                 (let ((gf (slot-ref m 'generic-function)))
-                   ;; remove the method from its GF
-                   (slot-set! gf 'methods
-                              (delq1! m (slot-ref gf 'methods)))
-                   (invalidate-method-cache! gf)
-                   ;; remove the method from its specializers
-                   (remove-method-in-classes! m))))
-           (class-direct-methods c)))
+              (if (is-a? m <accessor-method>)
+                  (let ((gf (slot-ref m 'generic-function)))
+                    ;; remove the method from its GF
+                    (slot-set! gf 'methods
+                               (delq1! m (slot-ref gf 'methods)))
+                    (invalidate-method-cache! gf)
+                    ;; remove the method from its specializers
+                    (remove-method-in-classes! m))))
+            (class-direct-methods c)))
 
 ;;;
 ;;; update-direct-method!
 ;;;
 
 (define-method (update-direct-method! (m  <method>)
-                                     (old <class>)
-                                     (new <class>))
+                                      (old <class>)
+                                      (new <class>))
   (let loop ((l (method-specializers m)))
-    ;; Note: the <top> in dotted list is never used. 
+    ;; Note: the <top> in dotted list is never used.
     ;; So we can work as if we had only proper lists.
-    (if (pair? l)                
-       (begin
-         (if (eqv? (car l) old)  
-             (set-car! l new))
-         (loop (cdr l))))))
+    (if (pair? l)
+        (begin
+          (if (eqv? (car l) old)
+              (set-car! l new))
+          (loop (cdr l))))))
 
 ;;;
 ;;; update-direct-subclass!
 ;;;
 
 (define-method (update-direct-subclass! (c <class>)
-                                       (old <class>)
-                                       (new <class>))
+                                        (old <class>)
+                                        (new <class>))
   (class-redefinition c
-                     (make-class (class-direct-supers c)
-                                 (class-direct-slots c)
-                                 #:name (class-name c)
-                                 #:metaclass (class-of c))))
+                      (make-class (class-direct-supers c)
+                                  (class-direct-slots c)
+                                  #:name (class-name c)
+                                  #:metaclass (class-of c))))
 
 ;;;
 ;;; {Utilities for INITIALIZE methods}
@@ -1951,44 +1957,44 @@
 (define (compute-slot-accessors class slots)
   (for-each
       (lambda (s g-n-s)
-       (let ((getter-function (slot-definition-getter   s))
-             (setter-function (slot-definition-setter   s))
-             (accessor        (slot-definition-accessor s)))
-         (if getter-function
-             (add-method! getter-function
-                          (compute-getter-method class g-n-s)))
-         (if setter-function
-             (add-method! setter-function
-                          (compute-setter-method class g-n-s)))
-         (if accessor
-             (begin
-               (add-method! accessor
-                            (compute-getter-method class g-n-s))
-               (add-method! (setter accessor)
-                            (compute-setter-method class g-n-s))))))
-      slots (slot-ref class 'getters-n-setters)))
+        (let ((getter-function (slot-definition-getter   s))
+              (setter-function (slot-definition-setter   s))
+              (accessor        (slot-definition-accessor s)))
+          (if getter-function
+              (add-method! getter-function
+                           (compute-getter-method class g-n-s)))
+          (if setter-function
+              (add-method! setter-function
+                           (compute-setter-method class g-n-s)))
+          (if accessor
+              (begin
+                (add-method! accessor
+                             (compute-getter-method class g-n-s))
+                (add-method! (setter accessor)
+                             (compute-setter-method class g-n-s))))))
+      slots (struct-ref class class-index-getters-n-setters)))
 
 (define-method (compute-getter-method (class <class>) slotdef)
   (let ((init-thunk (cadr slotdef))
-       (g-n-s (cddr slotdef)))
+        (g-n-s (cddr slotdef)))
     (make <accessor-method>
           #:specializers (list class)
-         #:procedure (cond ((pair? g-n-s)
-                            (make-generic-bound-check-getter (car g-n-s)))
-                           (init-thunk
-                            (standard-get g-n-s))
-                           (else
-                            (bound-check-get g-n-s)))
-         #:slot-definition slotdef)))
+          #:procedure (cond ((pair? g-n-s)
+                             (make-generic-bound-check-getter (car g-n-s)))
+                            (init-thunk
+                             (standard-get g-n-s))
+                            (else
+                             (bound-check-get g-n-s)))
+          #:slot-definition slotdef)))
 
 (define-method (compute-setter-method (class <class>) slotdef)
   (let ((g-n-s (cddr slotdef)))
     (make <accessor-method>
           #:specializers (list class <top>)
-         #:procedure (if (pair? g-n-s)
-                         (cadr g-n-s)
-                         (standard-set g-n-s))
-         #:slot-definition slotdef)))
+          #:procedure (if (pair? g-n-s)
+                          (cadr g-n-s)
+                          (standard-set g-n-s))
+          #:slot-definition slotdef)))
 
 (define (make-generic-bound-check-getter proc)
   (lambda (o)
@@ -2032,47 +2038,47 @@
 
   (define (compute-slot-init-function name s)
     (or (let ((thunk (slot-definition-init-thunk s)))
-         (and thunk
-              (if (thunk? thunk)
+          (and thunk
+               (if (thunk? thunk)
                    thunk
                    (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
                                 name class thunk))))
-       (let ((init (slot-definition-init-value s)))
-         (and (not (unbound? init))
-              (lambda () init)))))
+        (let ((init (slot-definition-init-value s)))
+          (and (not (unbound? init))
+               (lambda () init)))))
 
   (define (verify-accessors slot l)
     (cond ((integer? l))
-         ((not (and (list? l) (= (length l) 2)))
-          (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
-                       slot class l))
-         (else
-          (let ((get (car l)) 
-                (set (cadr l)))
-            (if (not (procedure? get))
+          ((not (and (list? l) (= (length l) 2)))
+           (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+                        slot class l))
+          (else
+           (let ((get (car l))
+                 (set (cadr l)))
+             (if (not (procedure? get))
                  (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
-                             slot class get))
-            (if (not (procedure? set))
+                              slot class get))
+             (if (not (procedure? set))
                  (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
-                             slot class set))))))
+                              slot class set))))))
 
   (map (lambda (s)
-        ;; The strange treatment of nfields is due to backward compatibility.
-        (let* ((index (slot-ref class 'nfields))
-               (g-n-s (compute-get-n-set class s))
-               (size (- (slot-ref class 'nfields) index))
-               (name  (slot-definition-name s)))
-          ;; NOTE: The following is interdependent with C macros
-          ;; defined above goops.c:scm_sys_prep_layout_x.
-          ;;
-          ;; For simple instance slots, we have the simplest form
-          ;; '(name init-function . index)
-          ;; For other slots we have
-          ;; '(name init-function getter setter . alloc)
-          ;; where alloc is:
-          ;;   '(index size) for instance allocated slots
-          ;;   '() for other slots
-          (verify-accessors name g-n-s)
+         ;; The strange treatment of nfields is due to backward compatibility.
+         (let* ((index (slot-ref class 'nfields))
+                (g-n-s (compute-get-n-set class s))
+                (size (- (slot-ref class 'nfields) index))
+                (name  (slot-definition-name s)))
+           ;; NOTE: The following is interdependent with C macros
+           ;; defined above goops.c:scm_sys_prep_layout_x.
+           ;;
+           ;; For simple instance slots, we have the simplest form
+           ;; '(name init-function . index)
+           ;; For other slots we have
+           ;; '(name init-function getter setter . alloc)
+           ;; where alloc is:
+           ;;   '(index size) for instance allocated slots
+           ;;   '() for other slots
+           (verify-accessors name g-n-s)
            (case (slot-definition-allocation s)
              ((#:each-subclass #:class)
               (unless (and (zero? size) (pair? g-n-s))
@@ -2111,24 +2117,26 @@
   (case (slot-definition-allocation s)
     ((#:instance) ;; Instance slot
      ;; get-n-set is just its offset
-     (let ((already-allocated (slot-ref class 'nfields)))
-       (slot-set! class 'nfields (+ already-allocated 1))
+     (let ((already-allocated (struct-ref class class-index-nfields)))
+       (struct-set! class class-index-nfields (+ already-allocated 1))
        already-allocated))
 
     ((#:class)  ;; Class slot
-     ;; Class-slots accessors are implemented as 2 closures around 
+     ;; Class-slots accessors are implemented as 2 closures around
      ;; a Scheme variable. As instance slots, class slots must be
      ;; unbound at init time.
      (let ((name (slot-definition-name s)))
        (if (memq name (map slot-definition-name (class-direct-slots class)))
-          ;; This slot is direct; create a new shared variable
-          (make-closure-variable class (class-slot-init-value))
-          ;; Slot is inherited. Find its definition in superclass
-          (let loop ((l (cdr (class-precedence-list class))))
-            (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
-              (if r
-                  (cddr r)
-                  (loop (cdr l))))))))
+           ;; This slot is direct; create a new shared variable
+           (make-closure-variable class (class-slot-init-value))
+           ;; Slot is inherited. Find its definition in superclass
+           (let loop ((l (cdr (class-precedence-list class))))
+             (let ((r (assoc name
+                             (struct-ref (car l)
+                                         class-index-getters-n-setters))))
+               (if r
+                   (cddr r)
+                   (loop (cdr l))))))))
 
     ((#:each-subclass) ;; slot shared by instances of direct subclass.
      ;; (Thomas Buerger, April 1998)
@@ -2137,10 +2145,10 @@
     ((#:virtual) ;; No allocation
      ;; slot-ref and slot-set! function must be given by the user
      (let ((get (get-keyword #:slot-ref  (slot-definition-options s) #f))
-          (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
+           (set (get-keyword #:slot-set! (slot-definition-options s) #f)))
        (if (not (and get set))
-          (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
-                       s))
+           (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
+                        s))
        (list get set)))
     (else    (next-method))))
 
@@ -2165,31 +2173,32 @@
 (define-method (initialize (class <class>) initargs)
   (next-method)
   (let ((dslots (get-keyword #:slots initargs '()))
-       (supers (get-keyword #:dsupers    initargs '())))
-    (slot-set! class 'name             (get-keyword #:name initargs '???))
-    (slot-set! class 'direct-supers    supers)
-    (slot-set! class 'direct-slots     dslots)
-    (slot-set! class 'direct-subclasses '())
-    (slot-set! class 'direct-methods    '())
-    (slot-set! class 'cpl              (compute-cpl class))
-    (slot-set! class 'redefined                #f)
+        (supers (get-keyword #:dsupers    initargs '())))
+    (let ((name (get-keyword #:name initargs '???)))
+      (struct-set! class class-index-name            name))
+    (struct-set! class class-index-direct-supers     supers)
+    (struct-set! class class-index-direct-slots      dslots)
+    (struct-set! class class-index-direct-subclasses '())
+    (struct-set! class class-index-direct-methods    '())
+    (struct-set! class class-index-cpl               (compute-cpl class))
+    (struct-set! class class-index-redefined         #f)
     (let ((slots (compute-slots class)))
-      (slot-set! class 'slots            slots)
-      (slot-set! class 'nfields                  0)
-      (slot-set! class 'getters-n-setters (compute-getters-n-setters class 
-                                                                    slots))
+      (struct-set! class class-index-slots           slots)
+      (struct-set! class class-index-nfields         0)
+      (let ((getters-n-setters (compute-getters-n-setters class slots)))
+        (struct-set! class class-index-getters-n-setters getters-n-setters))
       ;; Build getters - setters - accessors
       (compute-slot-accessors class slots))
 
     ;; Update the "direct-subclasses" of each inherited classes
     (for-each (lambda (x)
-               (slot-set! x
-                          'direct-subclasses 
-                          (cons class (slot-ref x 'direct-subclasses))))
-             supers)
+                (let ((dsubs (struct-ref x class-index-direct-subclasses)))
+                  (struct-set! x class-index-direct-subclasses
+                               (cons class dsubs))))
+              supers)
 
     ;; Support for the underlying structs:
-    
+
     ;; Set the layout slot
     (%prep-layout! class)
     ;; Inherit class flags (invisible on scheme level) from supers
@@ -2198,9 +2207,9 @@
 (define (initialize-object-procedure object initargs)
   (let ((proc (get-keyword #:procedure initargs #f)))
     (cond ((not proc))
-         ((pair? proc)
-          (apply slot-set! object 'procedure proc))
-         (else
+          ((pair? proc)
+           (apply slot-set! object 'procedure proc))
+          (else
            (slot-set! object 'procedure proc)))))
 
 (define-method (initialize (applicable-struct <applicable-struct>) initargs)
@@ -2214,14 +2223,14 @@
 
 (define-method (initialize (generic <generic>) initargs)
   (let ((previous-definition (get-keyword #:default initargs #f))
-       (name (get-keyword #:name initargs #f)))
+        (name (get-keyword #:name initargs #f)))
     (next-method)
     (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
-                                   (list (method args
+                                    (list (method args
                                             (apply previous-definition args)))
-                                   '()))
+                                    '()))
     (if name
-       (set-procedure-property! generic 'name name))
+        (set-procedure-property! generic 'name name))
     (invalidate-method-cache! generic)))
 
 (define-method (initialize (eg <extended-generic>) initargs)
@@ -2235,11 +2244,11 @@
   (slot-set! method 'generic-function (get-keyword #:generic-function initargs 
#f))
   (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
   (slot-set! method 'procedure
-            (get-keyword #:procedure initargs #f))
+             (get-keyword #:procedure initargs #f))
   (slot-set! method 'formals (get-keyword #:formals initargs '()))
   (slot-set! method 'body (get-keyword #:body initargs '()))
   (slot-set! method 'make-procedure (get-keyword #:make-procedure initargs 
#f)))
-             
+
 
 ;;;
 ;;; {Change-class}
@@ -2249,26 +2258,26 @@
   (let ((new-instance (allocate-instance new-class '())))
     ;; Initialize the slots of the new instance
     (for-each (lambda (slot)
-               (if (and (slot-exists-using-class? old-class old-instance slot)
-                        (eq? (slot-definition-allocation
-                              (class-slot-definition old-class slot))
-                             #:instance)
-                        (slot-bound-using-class? old-class old-instance slot))
-                   ;; Slot was present and allocated in old instance; copy it 
-                   (slot-set-using-class!
-                    new-class 
-                    new-instance 
-                    slot 
-                    (slot-ref-using-class old-class old-instance slot))
-                   ;; slot was absent; initialize it with its default value
-                   (let ((init (slot-init-function new-class slot)))
-                     (if init
-                         (slot-set-using-class!
-                              new-class 
-                              new-instance 
-                              slot
-                              (apply init '()))))))
-             (map slot-definition-name (class-slots new-class)))
+                (if (and (slot-exists-using-class? old-class old-instance slot)
+                         (eq? (slot-definition-allocation
+                               (class-slot-definition old-class slot))
+                              #:instance)
+                         (slot-bound-using-class? old-class old-instance slot))
+                    ;; Slot was present and allocated in old instance; copy it
+                    (slot-set-using-class!
+                     new-class
+                     new-instance
+                     slot
+                     (slot-ref-using-class old-class old-instance slot))
+                    ;; slot was absent; initialize it with its default value
+                    (let ((init (slot-init-function new-class slot)))
+                      (if init
+                          (slot-set-using-class!
+                               new-class
+                               new-instance
+                               slot
+                               (apply init '()))))))
+              (map slot-definition-name (class-slots new-class)))
     ;; Exchange old and new instance in place to keep pointers valid
     (%modify-instance old-instance new-instance)
     ;; Allow class specific updates of instances (which now are swapped)
@@ -2277,8 +2286,8 @@
 
 
 (define-method (update-instance-for-different-class (old-instance <object>)
-                                                   (new-instance
-                                                    <object>))
+                                                    (new-instance
+                                                     <object>))
   ;;not really important what we do, we just need a default method
   new-instance)
 
@@ -2320,8 +2329,8 @@
       (no-method gf args))
   (let ((methods (compute-applicable-methods gf args)))
     (if methods
-       (apply-methods gf (sort-applicable-methods gf methods args) args)
-       (no-applicable-method gf args))))
+        (apply-methods gf (sort-applicable-methods gf methods args) args)
+        (no-applicable-method gf args))))
 
 ;; compute-applicable-methods is bound to %compute-applicable-methods.
 ;; *fixme* use let
@@ -2341,27 +2350,27 @@
 
 (define-method (apply-method (gf <generic>) methods build-next args)
   (apply (method-procedure (car methods))
-        (build-next (cdr methods) args)
-        args))
+         (build-next (cdr methods) args)
+         args))
 
 (define-method (apply-methods (gf <generic>) (l <list>) args)
   (letrec ((next (lambda (procs args)
-                  (lambda new-args
-                    (let ((a (if (null? new-args) args new-args)))
-                      (if (null? procs)
-                          (no-next-method gf a)
-                          (apply-method gf procs next a)))))))
+                   (lambda new-args
+                     (let ((a (if (null? new-args) args new-args)))
+                       (if (null? procs)
+                           (no-next-method gf a)
+                           (apply-method gf procs next a)))))))
     (apply-method gf l next args)))
 
 ;; We don't want the following procedure to turn up in backtraces:
 (for-each (lambda (proc)
-           (set-procedure-property! proc 'system-procedure #t))
-         (list slot-unbound
-               slot-missing
-               no-next-method
-               no-applicable-method
-               no-method
-               ))
+            (set-procedure-property! proc 'system-procedure #t))
+          (list slot-unbound
+                slot-missing
+                no-next-method
+                no-applicable-method
+                no-method
+                ))
 
 ;;;
 ;;; {<composite-metaclass> and <active-metaclass>}
@@ -2380,23 +2389,23 @@
 ;; duplicate the standard list->set function but using eq instead of
 ;; eqv which really sucks a lot, uselessly here
 ;;
-(define (list2set l)          
+(define (list2set l)
   (let loop ((l l)
-            (res '()))
-    (cond                     
+             (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))))))
+                      (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)))))
+                       (cons c (class-subclasses c)))))
 
 ;;;
 ;;; {Final initialization}



reply via email to

[Prev in Thread] Current Thread [Next in Thread]