Implement support for INITIAL-VALUE slot keyword. Add new generic

procedure INITIALIZE-INSTANCE, and give INSTANCE-CONSTRUCTOR and
optional boolean argument that, if true, says to call
INITIALIZE-INSTANCE on the instance before it is returned.

diff --git a/v7/src/sos/instance.scm b/v7/src/sos/instance.scm
index 41fbc1f47b9ac8de73a98310df40c28a2926e5e2..042c896c19bcee0bf19df986c47609100096deba 100644 (file)
--- a/v7/src/sos/instance.scm
+++ b/v7/src/sos/instance.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: instance.scm,v 1.3 1997/06/04 22:44:21 cph Exp $
+;;; $Id: instance.scm,v 1.4 1997/06/15 06:41:34 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -51,7 +51,7 @@
               ,@(loop (+ i 1)))))
      (ELSE ,default)))
 
-(define-macro (fixed-initialization n)
+(define-macro (fixed-if-initialization n)
   (let ((indexes
         (make-initialized-list n
           (lambda (index)
@@ -74,60 +74,74 @@
                indexes
                initializers)))))
 
-(define-macro (fixed-arity-constructor n)
+(define-macro (fixed-iv-initialization n)
   (let ((indexes
         (make-initialized-list n
           (lambda (index)
-            (intern (string-append "i" (number->string index))))))
-       (values
+            (intern (string-append "n" (number->string index))))))
+       (initial-values
         (make-initialized-list n
           (lambda (index)
-            (intern (string-append "v" (number->string index)))))))
-    (let ((make-lambda
-          (lambda (initialization)
-            `(LAMBDA ,values
-               (LET ((INSTANCE
-                      (OBJECT-NEW-TYPE
-                       (UCODE-TYPE RECORD)
-                       (MAKE-VECTOR INSTANCE-LENGTH
-                                    RECORD-SLOT-UNINITIALIZED))))
-                 (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
-                 ,@initialization
-                 ,@(map (lambda (index value)
-                          `(%RECORD-SET! INSTANCE ,index ,value))
-                        indexes
-                        values)
-                 INSTANCE)))))
-      `(LET ,(make-initialized-list n
+            (intern (string-append "i" (number->string index)))))))
+    `(LET (,@(make-initialized-list n
               (lambda (index)
                 `(,(list-ref indexes index)
                   (LIST-REF INDEXES ,index))))
-        (IF INITIALIZATION
-            ,(make-lambda `((INITIALIZATION INSTANCE)))
-            ,(make-lambda '()))))))
+          ,@(make-initialized-list n
+              (lambda (index)
+                `(,(list-ref initial-values index)
+                  (LIST-REF INITIAL-VALUES ,index)))))
+       (LAMBDA (INSTANCE)
+        ,@(map (lambda (index initial-value)
+                 `(%RECORD-SET! INSTANCE ,index ,initial-value))
+               indexes
+               initial-values)))))
 \f
-(define (instance-constructor class slot-names)
+(define-macro (fixed-arity-constructor n)
+  (let ((indexes
+        (make-initialized-list n
+          (lambda (index)
+            (intern (string-append "i" (number->string index))))))
+       (values
+        (make-initialized-list n
+          (lambda (index)
+            (intern (string-append "v" (number->string index)))))))
+    `(LET ,(make-initialized-list n
+            (lambda (index)
+              `(,(list-ref indexes index)
+                (LIST-REF INDEXES ,index))))
+       ,(let loop
+           ((alist '((IF-INIT . IF-INIT)
+                     (IV-INIT . IV-INIT)
+                     (CALL-INIT-INSTANCE? . INITIALIZE-INSTANCE)))
+            (exprs '()))
+         (if (null? alist)
+             `(LAMBDA ,values
+                (LET ((INSTANCE
+                       (OBJECT-NEW-TYPE
+                        (UCODE-TYPE RECORD)
+                        (MAKE-VECTOR INSTANCE-LENGTH
+                                     RECORD-SLOT-UNINITIALIZED))))
+                  (%RECORD-SET! INSTANCE 0 INSTANCE-TAG)
+                  ,@(map (lambda (index value)
+                           `(%RECORD-SET! INSTANCE ,index ,value))
+                         indexes
+                         values)
+                  ,@(reverse exprs)
+                  INSTANCE))
+             `(IF ,(caar alist)
+                  ,(loop (cdr alist) `((,(cdar alist) INSTANCE) ,@exprs))
+                  ,(loop (cdr alist) exprs)))))))
+
+(define (instance-constructor class slot-names #!optional call-init-instance?)
   (let ((slots (map (lambda (name) (class-slot class name #t)) slot-names))
+       (call-init-instance?
+        (if (default-object? call-init-instance?) #f call-init-instance?))
        (instance-length (fix:+ (length (class-slots class)) 1))
        (instance-tag (class->dispatch-tag class)))
     (let ((n-values (length slots))
-         (initialization
-          (let ((slots
-                 (list-transform-positive (class-slots class)
-                   (lambda (slot)
-                     (and (slot-initializer slot)
-                          (not (memq slot slots)))))))
-            (and (not (null? slots))
-                 (let ((indexes (map slot-index slots))
-                       (initializers (map slot-initializer slots)))
-                   (constructor-case (length slots) 1 4 fixed-initialization
-                     (lambda (instance)
-                       (do ((initializers initializers (cdr initializers))
-                            (indexes indexes (cdr indexes)))
-                           ((null? initializers) unspecific)
-                         (%record-set! instance
-                                       (car indexes)
-                                       ((car initializers)))))))))))
+         (if-init (make-if-initialization class slots))
+         (iv-init (make-iv-initialization class slots)))
       (let ((indexes (map slot-index slots)))
        (constructor-case n-values 0 8 fixed-arity-constructor
          (letrec
@@ -142,13 +156,54 @@
                          (make-vector instance-length
                                       record-slot-uninitialized))))
                    (%record-set! instance 0 instance-tag)
-                   (if initialization (initialization instance))
+                   (if if-init (if-init instance))
+                   (if iv-init (iv-init instance))
+                   (if call-init-instance? (initialize-instance instance))
                    (do ((indexes indexes (cdr indexes))
                         (values values (cdr values)))
                        ((null? indexes))
                      (%record-set! instance (car indexes) (car values)))
                    instance))))
            procedure))))))
+\f
+(define (make-if-initialization class arg-slots)
+  (let ((slots
+        (list-transform-positive (class-slots class)
+          (lambda (slot)
+            (and (slot-initializer slot)
+                 (not (memq slot arg-slots)))))))
+    (and (not (null? slots))
+        (let ((indexes (map slot-index slots))
+              (initializers (map slot-initializer slots)))
+          (constructor-case (length slots) 1 8 fixed-if-initialization
+            (lambda (instance)
+              (do ((initializers initializers (cdr initializers))
+                   (indexes indexes (cdr indexes)))
+                  ((null? initializers) unspecific)
+                (%record-set! instance
+                              (car indexes)
+                              ((car initializers))))))))))
+
+(define (make-iv-initialization class arg-slots)
+  (let ((slots
+        (list-transform-positive (class-slots class)
+          (lambda (slot)
+            (and (slot-initial-value? slot)
+                 (not (memq slot arg-slots)))))))
+    (and (not (null? slots))
+        (let ((indexes (map slot-index slots))
+              (initial-values (map slot-initial-value slots)))
+          (constructor-case (length slots) 1 8 fixed-iv-initialization
+            (lambda (instance)
+              (do ((initial-values initial-values (cdr initial-values))
+                   (indexes indexes (cdr indexes)))
+                  ((null? initial-values) unspecific)
+                (%record-set! instance
+                              (car indexes)
+                              (car initial-values)))))))))
+
+(define initialize-instance
+  (make-generic-procedure 1 'INITIALIZE-INSTANCE))
 
 (define (instance? object)
   (and (tagged-vector? object)

diff --git a/v7/src/sos/method.scm b/v7/src/sos/method.scm
index 07af9ef990e3b08456f50ae4fafa85cf964b2b37..018f3e092c48ecc58ed0dfab8f9bbb267932bb4b 100644 (file)
--- a/v7/src/sos/method.scm
+++ b/v7/src/sos/method.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: method.scm,v 1.2 1997/06/04 22:24:21 cph Exp $
+;;; $Id: method.scm,v 1.3 1997/06/15 06:41:40 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -453,4 +453,8 @@
            (slot-accessor-method <method> 'PROCEDURE))
 
 (add-method computed-emp-key
-           (slot-accessor-method <computed-emp> 'KEY))
\ No newline at end of file
+           (slot-accessor-method <computed-emp> 'KEY))
+
+(add-method initialize-instance
+           (make-method (list <instance>)
+                        (lambda (instance) instance unspecific)))
\ No newline at end of file

diff --git a/v7/src/sos/sos.pkg b/v7/src/sos/sos.pkg
index bdba13e61b1fde91c29728a480e1923f2d77888b..3e11dfe696beaff77c03247cef4e0e3e590b391d 100644 (file)
--- a/v7/src/sos/sos.pkg
+++ b/v7/src/sos/sos.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sos.pkg,v 1.2 1997/06/04 22:28:49 cph Exp $
+$Id: sos.pkg,v 1.3 1997/06/15 06:41:44 cph Exp $
 
 Copyright (c) 1995-97 Massachusetts Institute of Technology
 
@@ -127,6 +127,7 @@ MIT in each case. |#
   (files "instance")
   (parent ())
   (export ()
+         initialize-instance
          instance-class
          instance-constructor
          instance-of?