GOOPS cosmetics

[bpt/guile.git] / module / oop / goops.scm

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index fd1b9ff..172839a 100644 (file)
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1998,1999,2000-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.
+;;;; goops.scm -- The Guile Object-Oriented Programming System
+;;;;
+;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015 Free Software Foundation, Inc.

 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or


@@ -132,8 +132,7 @@
             method-specializers method-formals
             primitive-generic-generic enable-primitive-generic!
             method-procedure accessor-method-slot-definition
             method-specializers method-formals
             primitive-generic-generic enable-primitive-generic!
             method-procedure accessor-method-slot-definition

-            make find-method get-keyword)
-  #:no-backtrace)
+            make find-method get-keyword))

 
 
 ;;;
 
 
 ;;;


@@ -247,9 +246,10 @@
 ;;; class-index-flags.  `vtable-flag-vtable' indicates that instances of
 ;;; a vtable are themselves vtables, and `vtable-flag-validated'
 ;;; indicates that the struct's layout has been validated.  goops.c
 ;;; class-index-flags.  `vtable-flag-vtable' indicates that instances of
 ;;; a vtable are themselves vtables, and `vtable-flag-validated'
 ;;; indicates that the struct's layout has been validated.  goops.c

-;;; defines a couple of additional flags: one to indicate that a vtable
-;;; is actually a class, and one to indicate that the class is "valid",
-;;; meaning that it hasn't been redefined.
+;;; defines a few additional flags: one to indicate that a vtable is
+;;; actually a class, one to indicate that the class is "valid" (meaning
+;;; that it hasn't been redefined), and one to indicate that instances
+;;; of a class are slot definition objects (<slot> instances).

 ;;;
 (define vtable-flag-goops-metaclass
   (logior vtable-flag-vtable vtable-flag-goops-class))
 ;;;
 (define vtable-flag-goops-metaclass
   (logior vtable-flag-vtable vtable-flag-goops-class))


@@ -269,6 +269,10 @@
 (define-inlinable (class? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
 
 (define-inlinable (class? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-metaclass))
 

+(define-inlinable (slot? obj)
+  (and (struct? obj)
+       (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
+

 (define-inlinable (instance? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
 
 (define-inlinable (instance? obj)
   (class-has-flags? (struct-vtable obj) vtable-flag-goops-class))
 


@@ -377,7 +381,6 @@ subclasses of @var{c}."
 ;;; more of the protocol.  Again, the CPL and class hierarchy slots
 ;;; remain uninitialized.
 ;;;
 ;;; more of the protocol.  Again, the CPL and class hierarchy slots
 ;;; remain uninitialized.
 ;;;

-

 (define* (get-keyword key l #:optional default)
   "Determine an associated value for the keyword @var{key} from the list
 @var{l}.  The list @var{l} has to consist of an even number of elements,
 (define* (get-keyword key l #:optional default)
   "Determine an associated value for the keyword @var{key} from the list
 @var{l}.  The list @var{l} has to consist of an even number of elements,


@@ -426,70 +429,65 @@ followed by its associated value.  If @var{l} does not hold a value for
       (struct-set! <slot> class-index-redefined #f)
       <slot>)))
 
       (struct-set! <slot> class-index-redefined #f)
       <slot>)))
 

-(define-inlinable (slot? obj)
-  (and (struct? obj)
-       (class-has-flags? (struct-vtable obj) vtable-flag-goops-slot)))
-
-(define-syntax-rule (define-slot-accessor name docstring field)
-  (define (name obj)
-    docstring
-    (let ((val obj))
-      (unless (slot? val)
+;;; Access to slot objects is performance-sensitive for slot-ref, so in
+;;; addition to the type-checking accessors that we export, we also
+;;; define some internal inlined helpers that just do an unchecked
+;;; struct-ref in cases where we know the object must be a slot, as
+;;; when accessing class-slots.
+;;;
+(define-syntax-rule (define-slot-accessor name docstring %name field)
+  (begin
+    (define-syntax-rule (%name obj)
+      (struct-ref obj field))
+    (define (name obj)
+      docstring
+      (unless (slot? obj)

         (scm-error 'wrong-type-arg #f "Not a slot: ~S"
         (scm-error 'wrong-type-arg #f "Not a slot: ~S"

-                   (list val) #f))
-      (struct-ref val field))))
+                   (list obj) #f))
+      (%name obj))))

 
 (define-slot-accessor slot-definition-name
   "Return the name of @var{obj}."
 
 (define-slot-accessor slot-definition-name
   "Return the name of @var{obj}."

-  slot-index-name)
+   %slot-definition-name slot-index-name)

 (define-slot-accessor slot-definition-allocation
   "Return the allocation of the slot @var{obj}."
 (define-slot-accessor slot-definition-allocation
   "Return the allocation of the slot @var{obj}."

-  slot-index-allocation)
+   %slot-definition-allocation slot-index-allocation)

 (define-slot-accessor slot-definition-init-keyword
   "Return the init keyword of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-init-keyword
   "Return the init keyword of the slot @var{obj}, or @code{#f}."

-  slot-index-init-keyword)
+   %slot-definition-init-keyword slot-index-init-keyword)

 (define-slot-accessor slot-definition-init-form
   "Return the init form of the slot @var{obj}, or the unbound value"
 (define-slot-accessor slot-definition-init-form
   "Return the init form of the slot @var{obj}, or the unbound value"

-  slot-index-init-form)
+   %slot-definition-init-form slot-index-init-form)

 (define-slot-accessor slot-definition-init-value
   "Return the init value of the slot @var{obj}, or the unbound value."
 (define-slot-accessor slot-definition-init-value
   "Return the init value of the slot @var{obj}, or the unbound value."

-  slot-index-init-value)
+   %slot-definition-init-value slot-index-init-value)

 (define-slot-accessor slot-definition-init-thunk
   "Return the init thunk of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-init-thunk
   "Return the init thunk of the slot @var{obj}, or @code{#f}."

-  slot-index-init-thunk)
+   %slot-definition-init-thunk slot-index-init-thunk)

 (define-slot-accessor slot-definition-options
   "Return the initargs given when creating the slot @var{obj}."
 (define-slot-accessor slot-definition-options
   "Return the initargs given when creating the slot @var{obj}."

-  slot-index-options)
+   %slot-definition-options slot-index-options)

 (define-slot-accessor slot-definition-getter
   "Return the getter of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-getter
   "Return the getter of the slot @var{obj}, or @code{#f}."

-  slot-index-getter)
+   %slot-definition-getter slot-index-getter)

 (define-slot-accessor slot-definition-setter
   "Return the setter of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-setter
   "Return the setter of the slot @var{obj}, or @code{#f}."

-  slot-index-setter)
+   %slot-definition-setter slot-index-setter)

 (define-slot-accessor slot-definition-accessor
   "Return the accessor of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-accessor
   "Return the accessor of the slot @var{obj}, or @code{#f}."

-  slot-index-accessor)
+   %slot-definition-accessor slot-index-accessor)

 (define-slot-accessor slot-definition-slot-ref
   "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-slot-ref
   "Return the slot-ref procedure of the slot @var{obj}, or @code{#f}."

-  slot-index-slot-ref)
+   %slot-definition-slot-ref slot-index-slot-ref)

 (define-slot-accessor slot-definition-slot-set!
   "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-slot-set!
   "Return the slot-set! procedure of the slot @var{obj}, or @code{#f}."

-  slot-index-slot-set!)
+   %slot-definition-slot-set! slot-index-slot-set!)

 (define-slot-accessor slot-definition-index
   "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-index
   "Return the allocated struct offset of the slot @var{obj}, or @code{#f}."

-  slot-index-index)
+   %slot-definition-index slot-index-index)

 (define-slot-accessor slot-definition-size
   "Return the number fields used by the slot @var{obj}, or @code{#f}."
 (define-slot-accessor slot-definition-size
   "Return the number fields used by the slot @var{obj}, or @code{#f}."

-  slot-index-size)
-
-(define (class-slot-definition class slot-name)
-  (let lp ((slots (class-slots class)))
-    (match slots
-      (() #f)
-      ((slot . slots)
-       (if (eq? (struct-ref slot slot-index-name) slot-name)
-           slot
-           (lp slots))))))
+   %slot-definition-size slot-index-size)

 
 ;; Boot definition.
 (define (direct-slot-definition-class class initargs)
 
 ;; Boot definition.
 (define (direct-slot-definition-class class initargs)


@@ -507,7 +505,7 @@ followed by its associated value.  If @var{l} does not hold a value for
     (init-slot slot-index-init-value #:init-value *unbound*)
     (struct-set! slot slot-index-init-thunk
                  (or (get-keyword #:init-thunk initargs #f)
     (init-slot slot-index-init-value #:init-value *unbound*)
     (struct-set! slot slot-index-init-thunk
                  (or (get-keyword #:init-thunk initargs #f)

-                     (let ((val (struct-ref slot slot-index-init-value)))
+                     (let ((val (%slot-definition-init-value slot)))

                        (if (unbound? val)
                            #f
                            (lambda () val)))))
                        (if (unbound? val)
                            #f
                            (lambda () val)))))


@@ -628,12 +626,12 @@ followed by its associated value.  If @var{l} does not hold a value for
 
 (define (build-slots-list dslots cpl)
   (define (slot-memq slot slots)
 
 (define (build-slots-list dslots cpl)
   (define (slot-memq slot slots)

-    (let ((name (slot-definition-name slot)))
+    (let ((name (%slot-definition-name slot)))

       (let lp ((slots slots))
         (match slots
           (() #f)
           ((slot . slots)
       (let lp ((slots slots))
         (match slots
           (() #f)
           ((slot . slots)

-           (or (eq? (slot-definition-name slot) name) (lp slots)))))))
+           (or (eq? (%slot-definition-name slot) name) (lp slots)))))))

   (define (check-cpl slots static-slots)
     (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
       (scm-error 'misc-error #f
   (define (check-cpl slots static-slots)
     (when (or-map (lambda (slot) (slot-memq slot slots)) static-slots)
       (scm-error 'misc-error #f


@@ -644,7 +642,7 @@ followed by its associated value.  If @var{l} does not hold a value for
       (match slots
         (() res)
         ((slot . slots)
       (match slots
         (() res)
         ((slot . slots)

-         (let ((name (slot-definition-name slot)))
+         (let ((name (%slot-definition-name slot)))

            (if (memq name seen)
                (lp slots res seen)
                (lp slots (cons slot res) (cons name seen))))))))
            (if (memq name seen)
                (lp slots res seen)
                (lp slots (cons slot res) (cons name seen))))))))


@@ -714,7 +712,7 @@ slots as we go."
   (define (slot-protection-and-kind slot)
     (define (subclass? class parent)
       (memq parent (class-precedence-list class)))
   (define (slot-protection-and-kind slot)
     (define (subclass? class parent)
       (memq parent (class-precedence-list class)))

-    (let ((type (kw-arg-ref (struct-ref slot slot-index-options) #:class)))
+    (let ((type (kw-arg-ref (%slot-definition-options slot) #:class)))

       (if (and type (subclass? type <foreign-slot>))
           (values (cond
                    ((subclass? type <self-slot>) #\s)
       (if (and type (subclass? type <foreign-slot>))
           (values (cond
                    ((subclass? type <self-slot>) #\s)


@@ -737,10 +735,10 @@ slots as we go."
                (error "bad layout for class"))))
          layout)
         ((slot . slots)
                (error "bad layout for class"))))
          layout)
         ((slot . slots)

-         (unless (= n (slot-definition-index slot)) (error "bad allocation"))
+         (unless (= n (%slot-definition-index slot)) (error "bad allocation"))

          (call-with-values (lambda () (slot-protection-and-kind slot))
            (lambda (protection kind)
          (call-with-values (lambda () (slot-protection-and-kind slot))
            (lambda (protection kind)

-             (let init ((n n) (size (slot-definition-size slot)))
+             (let init ((n n) (size (%slot-definition-size slot)))

                (cond
                 ((zero? size) (lp n slots))
                 (else
                (cond
                 ((zero? size) (lp n slots))
                 (else


@@ -1049,33 +1047,6 @@ function."
 
 ;;;
 ;;; Slot access.
 
 ;;;
 ;;; Slot access.

-;;;
-(define (get-slot-value-using-name class obj slot-name)
-  (cond
-   ((class-slot-definition class slot-name)
-    => (lambda (slot)
-         (cond
-          ((slot-definition-slot-ref slot)
-           => (lambda (slot-ref) (slot-ref obj)))
-          (else
-           (struct-ref obj (slot-definition-index slot))))))
-   (else (slot-missing class obj slot-name))))
-
-(define (set-slot-value-using-name! class obj slot-name value)
-  (cond
-   ((class-slot-definition class slot-name)
-    => (lambda (slot)
-         (cond
-          ((slot-definition-slot-set! slot)
-           => (lambda (slot-set!) (slot-set! obj value)))
-          (else
-           (struct-set! obj (slot-definition-index slot) value)))))
-   (else (slot-missing class obj slot-name))))
-
-(define (test-slot-existence class obj slot-name)
-  (and (class-slot-definition class slot-name)
-       #t))
-

 ;;;
 ;;; Before we go on, some notes about class redefinition.  In GOOPS,
 ;;; classes can be redefined.  Redefinition of a class marks the class
 ;;;
 ;;; Before we go on, some notes about class redefinition.  In GOOPS,
 ;;; classes can be redefined.  Redefinition of a class marks the class


@@ -1089,38 +1060,93 @@ function."
 ;;; here though as the { class, object data } pair needs to be accessed
 ;;; atomically, not the { class, object } pair.
 ;;;
 ;;; here though as the { class, object data } pair needs to be accessed
 ;;; atomically, not the { class, object } pair.
 ;;;

+(define-inlinable (%class-slot-definition class slot-name kt kf)
+  (let lp ((slots (struct-ref class class-index-slots)))
+    (match slots
+      ((slot . slots)
+       (if (eq? (%slot-definition-name slot) slot-name)
+           (kt slot)
+           (lp slots)))
+      (_ (kf)))))
+
+(define (class-slot-definition class slot-name)
+  (unless (class? class)
+    (scm-error 'wrong-type-arg #f "Not a class: ~S" (list class) #f))
+  (%class-slot-definition class slot-name
+                          (lambda (slot) slot)
+                          (lambda () #f)))

 
 (define (slot-ref obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."
 
 (define (slot-ref obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."

-  (unless (symbol? slot-name)
-    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
-               (list slot-name) #f))
-  (let* ((class (class-of obj))
-         (val (get-slot-value-using-name class obj slot-name)))
-    (if (unbound? val)
-        (slot-unbound class obj slot-name)
-        val)))
+  (let ((class (class-of obj)))
+    (define (slot-value slot)
+      (cond
+       ((%slot-definition-slot-ref slot)
+        => (lambda (slot-ref) (slot-ref obj)))
+       (else
+        (struct-ref obj (%slot-definition-index slot)))))
+    (define (have-slot slot)
+      (let ((val (slot-value slot)))
+        (if (unbound? val)
+            (slot-unbound class obj slot-name)
+            val)))
+    (define (no-slot)
+      (unless (symbol? slot-name)
+        (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+                   (list slot-name) #f))
+      (let ((val (slot-missing class obj slot-name)))
+        (if (unbound? val)
+            (slot-unbound class obj slot-name)
+            val)))
+    (%class-slot-definition class slot-name have-slot no-slot)))

 
 (define (slot-set! obj slot-name value)
   "Set the slot named @var{slot_name} of @var{obj} to @var{value}."
 
 (define (slot-set! obj slot-name value)
   "Set the slot named @var{slot_name} of @var{obj} to @var{value}."

-  (unless (symbol? slot-name)
-    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
-               (list slot-name) #f))
-  (set-slot-value-using-name! (class-of obj) obj slot-name value))
+  (let ((class (class-of obj)))
+    (define (have-slot slot)
+      (cond
+       ((%slot-definition-slot-set! slot)
+        => (lambda (slot-set!) (slot-set! obj value)))
+       (else
+        (struct-set! obj (%slot-definition-index slot) value))))
+    (define (no-slot)
+      (unless (symbol? slot-name)
+        (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+                   (list slot-name) #f))
+      (slot-missing class obj slot-name value))
+
+    (%class-slot-definition class slot-name have-slot no-slot)))

 
 (define (slot-bound? obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."
 
 (define (slot-bound? obj slot-name)
   "Return the value from @var{obj}'s slot with the nam var{slot_name}."

-  (unless (symbol? slot-name)
-    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
-               (list slot-name) #f))
-  (not (unbound? (get-slot-value-using-name (class-of obj) obj slot-name))))
+  (let ((class (class-of obj)))
+    (define (slot-value slot)
+      (cond
+       ((%slot-definition-slot-ref slot)
+        => (lambda (slot-ref) (slot-ref obj)))
+       (else
+        (struct-ref obj (%slot-definition-index slot)))))
+    (define (have-slot slot)
+      (not (unbound? (slot-value slot))))
+    (define (no-slot)
+      (unless (symbol? slot-name)
+        (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+                   (list slot-name) #f))
+      (let ((val (slot-missing class obj slot-name)))
+        (if (unbound? val)
+            (slot-unbound class obj slot-name)
+            val)))
+    (%class-slot-definition class slot-name have-slot no-slot)))

 
 (define (slot-exists? obj slot-name)
   "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."
 
 (define (slot-exists? obj slot-name)
   "Return @code{#t} if @var{obj} has a slot named @var{slot_name}."

-  (unless (symbol? slot-name)
-    (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
-               (list slot-name) #f))
-  (test-slot-existence (class-of obj) obj slot-name))
+  (define (have-slot slot) #t)
+  (define (no-slot)
+    (unless (symbol? slot-name)
+      (scm-error 'wrong-type-arg #f "Not a symbol: ~S"
+                 (list slot-name) #f))
+    #f)
+  (%class-slot-definition (class-of obj) slot-name have-slot no-slot))

 
 (begin-deprecated
  (define (check-slot-args class obj slot-name)
 
 (begin-deprecated
  (define (check-slot-args class obj slot-name)


@@ -1531,7 +1557,7 @@ function."
     (match slot-spec
       (((? symbol? name) . args) name)
       ;; We can get here when redefining classes.
     (match slot-spec
       (((? symbol? name) . args) name)
       ;; We can get here when redefining classes.

-      ((? slot? slot) (slot-definition-name slot))))
+      ((? slot? slot) (%slot-definition-name slot))))

 
   (let* ((name (get-keyword #:name options *unbound*))
          (supers (if (not (or-map (lambda (class)
 
   (let* ((name (get-keyword #:name options *unbound*))
          (supers (if (not (or-map (lambda (class)


@@ -2161,8 +2187,8 @@ function."
 ;;; Slots
 ;;;
 (define (slot-init-function class slot-name)
 ;;; Slots
 ;;;
 (define (slot-init-function class slot-name)

-  (slot-definition-init-thunk (or (class-slot-definition class slot-name)
-                                  (error "slot not found" slot-name))))
+  (%slot-definition-init-thunk (or (class-slot-definition class slot-name)
+                                   (error "slot not found" slot-name))))

 
 (define (accessor-method-slot-definition obj)
   "Return the slot definition of the accessor @var{obj}."
 
 (define (accessor-method-slot-definition obj)
   "Return the slot definition of the accessor @var{obj}."


@@ -2224,7 +2250,7 @@ function."
           (display "#<" file)
           (display (class-name class) file)
           (display #\space file)
           (display "#<" file)
           (display (class-name class) file)
           (display #\space file)

-          (display (slot-definition-name slot) file)
+          (display (%slot-definition-name slot) file)

           (display #\space file)
           (display-address slot file)
           (display #\> file))
           (display #\space file)
           (display-address slot file)
           (display #\> file))


@@ -2372,18 +2398,18 @@ function."
 
 (define (class-slot-ref class slot-name)
   (let ((slot (class-slot-definition class slot-name)))
 
 (define (class-slot-ref class slot-name)
   (let ((slot (class-slot-definition class slot-name)))

-    (unless (memq (slot-definition-allocation slot) '(#:class #:each-subclass))
+    (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))

       (slot-missing class slot-name))
       (slot-missing class slot-name))

-    (let ((x ((slot-definition-slot-ref slot) #f)))
+    (let ((x ((%slot-definition-slot-ref slot) #f)))

       (if (unbound? x)
           (slot-unbound class slot-name)
           x))))
 
 (define (class-slot-set! class slot-name value)
   (let ((slot (class-slot-definition class slot-name)))
       (if (unbound? x)
           (slot-unbound class slot-name)
           x))))
 
 (define (class-slot-set! class slot-name value)
   (let ((slot (class-slot-definition class slot-name)))

-    (unless (memq (slot-definition-allocation slot) '(#:class #:each-subclass))
+    (unless (memq (%slot-definition-allocation slot) '(#:class #:each-subclass))

       (slot-missing class slot-name))
       (slot-missing class slot-name))

-    ((slot-definition-slot-set! slot) #f value)))
+    ((%slot-definition-slot-set! slot) #f value)))

 
 (define-method (slot-unbound (c <class>) (o <object>) s)
   (goops-error "Slot `~S' is unbound in object ~S" s o))
 
 (define-method (slot-unbound (c <class>) (o <object>) s)
   (goops-error "Slot `~S' is unbound in object ~S" s o))


@@ -2562,10 +2588,10 @@ function."
 (define (compute-slot-accessors class slots)
   (for-each
    (lambda (slot)
 (define (compute-slot-accessors class slots)
   (for-each
    (lambda (slot)

-     (let ((getter (slot-definition-getter slot))
-           (setter (slot-definition-setter slot))
+     (let ((getter (%slot-definition-getter slot))
+           (setter (%slot-definition-setter slot))

            (accessor-setter setter)
            (accessor-setter setter)

-           (accessor (slot-definition-accessor slot)))
+           (accessor (%slot-definition-accessor slot)))

        (when getter
          (add-method! getter (compute-getter-method class slot)))
        (when setter
        (when getter
          (add-method! getter (compute-getter-method class slot)))
        (when setter


@@ -2715,30 +2741,49 @@ function."
 (define (%initialize-object obj initargs)
   "Initialize the object @var{obj} with the given arguments
 var{initargs}."
 (define (%initialize-object obj initargs)
   "Initialize the object @var{obj} with the given arguments
 var{initargs}."

+  (define (valid-initargs? initargs)
+    (match initargs
+      (() #t)
+      (((? keyword?) _ . initargs) (valid-initargs? initargs))
+      (_ #f)))

   (unless (instance? obj)
     (scm-error 'wrong-type-arg #f "Not an object: ~S"
                (list obj) #f))
   (unless (instance? obj)
     (scm-error 'wrong-type-arg #f "Not an object: ~S"
                (list obj) #f))

-  (unless (even? (length initargs))
-    (scm-error 'wrong-type-arg #f "Initargs has odd length: ~S"
+  (unless (valid-initargs? initargs)
+    (scm-error 'wrong-type-arg #f "Invalid initargs: ~S"

                (list initargs) #f))
   (let ((class (class-of obj)))
     (define (get-initarg kw)
       (if kw
                (list initargs) #f))
   (let ((class (class-of obj)))
     (define (get-initarg kw)
       (if kw

-          (get-keyword kw initargs *unbound*)
+          ;; Inlined get-keyword to avoid checking initargs for validity
+          ;; each time.
+          (let lp ((initargs initargs))
+            (match initargs
+              ((kw* val . initargs)
+               (if (eq? kw* kw)
+                   val
+                   (lp initargs)))
+              (_ *unbound*)))

           *unbound*))
     (let lp ((slots (struct-ref class class-index-slots)))
       (match slots
         (() obj)
         ((slot . slots)
           *unbound*))
     (let lp ((slots (struct-ref class class-index-slots)))
       (match slots
         (() obj)
         ((slot . slots)

-         (let ((initarg (get-initarg (slot-definition-init-keyword slot))))
+         (define (initialize-slot! value)
+           (cond
+            ((%slot-definition-slot-set! slot)
+             => (lambda (slot-set!) (slot-set! obj value)))
+            (else
+             (struct-set! obj (%slot-definition-index slot) value))))
+         (let ((initarg (get-initarg (%slot-definition-init-keyword slot))))

            (cond
             ((not (unbound? initarg))
            (cond
             ((not (unbound? initarg))

-             (slot-set! obj (slot-definition-name slot) initarg))
-            ((slot-definition-init-thunk slot)
+             (initialize-slot! initarg))
+            ((%slot-definition-init-thunk slot)

              => (lambda (init-thunk)
                   (unless (memq (slot-definition-allocation slot)
                                 '(#:class #:each-subclass))
              => (lambda (init-thunk)
                   (unless (memq (slot-definition-allocation slot)
                                 '(#:class #:each-subclass))

-                    (slot-set! obj (slot-definition-name slot) (init-thunk)))))))
+                    (initialize-slot! (init-thunk)))))))

          (lp slots))))))
 
 (define-method (initialize (object <object>) initargs)
          (lp slots))))))
 
 (define-method (initialize (object <object>) initargs)


@@ -2747,11 +2792,11 @@ var{initargs}."
 (define-method (initialize (slot <slot>) initargs)
   (next-method)
   (struct-set! slot slot-index-options initargs)
 (define-method (initialize (slot <slot>) initargs)
   (next-method)
   (struct-set! slot slot-index-options initargs)

-  (let ((init-thunk (struct-ref slot slot-index-init-thunk)))
+  (let ((init-thunk (%slot-definition-init-thunk slot)))

     (when init-thunk
       (unless (thunk? init-thunk)
         (goops-error "Bad init-thunk for slot `~S': ~S"
     (when init-thunk
       (unless (thunk? init-thunk)
         (goops-error "Bad init-thunk for slot `~S': ~S"

-                     (slot-definition-name slot) init-thunk)))))
+                     (%slot-definition-name slot) init-thunk)))))

 
 (define-method (initialize (class <class>) initargs)
   (define (make-direct-slot-definition dslot)
 
 (define-method (initialize (class <class>) initargs)
   (define (make-direct-slot-definition dslot)


@@ -2852,7 +2897,7 @@ var{initargs}."
     (for-each
      (lambda (slot)
        (if (and (slot-exists? old-instance slot)
     (for-each
      (lambda (slot)
        (if (and (slot-exists? old-instance slot)

-                (eq? (slot-definition-allocation
+                (eq? (%slot-definition-allocation

                       (class-slot-definition old-class slot))
                      #:instance)
                 (slot-bound? old-instance slot))
                       (class-slot-definition old-class slot))
                      #:instance)
                 (slot-bound? old-instance slot))