Modify %RECORD-ACCESSOR to signal an error if the accessed slot is

uninitialized.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 7728f6a01c36f981d687159484e8a4438dbd9d19..1db1f2f4f7e879c63aa1d95b84a3e8ebf025499e 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.58 1996/04/24 04:23:54 cph Exp $
+$Id: make.scm,v 14.59 1997/06/24 05:34:15 cph Exp $
 
-Copyright (c) 1988-96 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -439,6 +439,7 @@ MIT in each case. |#
    (RUNTIME MICROCODE-ERRORS)
    ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads

diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm
index c9ae17f4699bde9100e40cc921f6c1906e81d4f6..4193538a46d15d0525a466ecec6571abba050e95 100644 (file)
--- a/v7/src/runtime/recslot.scm
+++ b/v7/src/runtime/recslot.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: recslot.scm,v 1.1 1996/04/23 20:37:58 cph Exp $
+;;; $Id: recslot.scm,v 1.2 1997/06/24 05:33:57 cph Exp $
 ;;;
-;;; Copyright (c) 1995-96 Massachusetts Institute of Technology
+;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
 ;;; This material was developed by the Scheme project at the
 ;;; Massachusetts Institute of Technology, Department of Electrical
@@ -68,8 +68,12 @@
 (define (%record-accessor index)
   (generate-index-cases index 16
     (lambda (index)
-      (declare (integrate index))
-      (lambda (record) (%record-ref record index)))))
+      (declare (integrate index)
+              (ignore-reference-traps (set record-slot-uninitialized)))
+      (lambda (record)
+       (if (eq? record-slot-uninitialized (%record-ref record index))
+           (error:uninitialized-slot record index)
+           (%record-ref record index))))))
 
 (define (%record-modifier index)
   (generate-index-cases index 16
@@ -80,10 +84,26 @@
 (define (%record-initpred index)
   (generate-index-cases index 16
     (lambda (index)
-      (declare (integrate index))
+      (declare (integrate index)
+              (ignore-reference-traps (set record-slot-uninitialized)))
       (lambda (record)
        (not (eq? record-slot-uninitialized (%record-ref record index)))))))
 
+(define (%record-slot-name record index)
+  (if (not (and (exact-integer? index) (positive? index)))
+      (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME))
+  (let ((names
+        (call-with-current-continuation
+         (lambda (k)
+           (bind-condition-handler (list condition-type:no-applicable-methods)
+               (lambda (condition) condition (k 'UNKNOWN))
+             (lambda ()
+               (%record-slot-names record))))))
+       (index (- index 1)))
+    (and (list? names)
+        (< index (length names))
+        (list-ref names index))))
+\f
 (define %record-slot-index)
 (define %record-slot-names)
 
@@ -103,4 +123,62 @@
       generic
       (and (record-type? (dispatch-tag-contents (car tags)))
           (lambda (record)
-            (record-type-field-names (record-type-descriptor record)))))))
\ No newline at end of file
+            (record-type-field-names (record-type-descriptor record)))))))
+
+(define condition-type:uninitialized-slot)
+(define error:uninitialized-slot)
+
+(define (initialize-conditions!)
+  (set! condition-type:uninitialized-slot
+       (make-condition-type 'UNINITIALIZED-SLOT condition-type:cell-error
+           '(RECORD)
+         (lambda (condition port)
+           (write-string "Attempt to reference slot " port)
+           (write (access-condition condition 'LOCATION) port)
+           (write-string " in record " port)
+           (write (access-condition condition 'RECORD) port)
+           (write-string " failed because the slot is not initialized."
+                         port))))
+  (set! error:uninitialized-slot
+       (let ((signal
+              (condition-signaller condition-type:uninitialized-slot
+                                   '(RECORD LOCATION)
+                                   standard-error-handler)))
+         (lambda (record index)
+           (let ((location
+                  (or (%record-slot-name record index)
+                      index)))
+             (call-with-current-continuation
+              (lambda (k)
+                (with-restart 'STORE-VALUE
+                    (lambda (port)
+                      (write-string "Initialize slot " port)
+                      (write location port)
+                      (write-string " to a given value." port))
+                    (lambda (value)
+                      (%record-set! record index value)
+                      (k value))
+                    (let ((prompt
+                           (string-append "Set "
+                                          (write-to-string location)
+                                          " to")))
+                      (lambda ()
+                        (values (prompt-for-evaluated-expression prompt))))
+                  (lambda ()
+                    (with-restart 'USE-VALUE
+                        (lambda (port)
+                          (write-string
+                           "Specify a value to use instead of the contents of slot "
+                           port)
+                          (write location port)
+                          (write-string "." port))
+                        k
+                        (let ((prompt
+                               (string-append "Value to use instead of "
+                                              (write-to-string location))))
+                          (lambda ()
+                            (values
+                             (prompt-for-evaluated-expression prompt))))
+                      (lambda ()
+                        (signal record location)))))))))))
+  unspecific)
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 30076a97d05d40fd8d27d051c49e223b677ad5bf..a0fa8ec4d6734a47b4d02491cacfeee31f122443 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.281 1997/06/12 21:10:43 cph Exp $
+$Id: runtime.pkg,v 14.282 1997/06/24 05:34:20 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -3325,6 +3325,7 @@ MIT in each case. |#
   (files "recslot")
   (parent ())
   (export ()
+         condition-type:uninitialized-slot
          %record-accessor
          %record-accessor-generator
          %record-initpred
@@ -3332,6 +3333,7 @@ MIT in each case. |#
          %record-modifier
          %record-modifier-generator
          %record-slot-index
+         %record-slot-name
          %record-slot-names))
 
 (define-package (runtime generic-procedure eqht)

diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm
index 51f25ee4333d135d78394478401202bd39942801..aba32931455a2844d421f9cfb995d933953e9a79 100644 (file)
--- a/v8/src/runtime/make.scm
+++ b/v8/src/runtime/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.61 1996/07/26 14:38:26 adams Exp $
+$Id: make.scm,v 14.62 1997/06/24 05:34:09 cph Exp $
 
-Copyright (c) 1988-96 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -452,6 +452,7 @@ MIT in each case. |#
    (RUNTIME MICROCODE-ERRORS)
    ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS! #t)
    ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS! #t)
+   ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS! #t)
    ;; System dependent stuff
    (() INITIALIZE-SYSTEM-PRIMITIVES! #f)
    ;; Threads

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index e6fb04ee599dc0faee4019550c15ae883984a04e..3943e3f42e746f1037b76ecd51e8d38eec8932ab 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.287 1997/06/12 21:10:35 cph Exp $
+$Id: runtime.pkg,v 14.288 1997/06/24 05:34:28 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -3325,6 +3325,7 @@ MIT in each case. |#
   (files "recslot")
   (parent ())
   (export ()
+         condition-type:uninitialized-slot
          %record-accessor
          %record-accessor-generator
          %record-initpred
@@ -3332,6 +3333,7 @@ MIT in each case. |#
          %record-modifier
          %record-modifier-generator
          %record-slot-index
+         %record-slot-name
          %record-slot-names))
 
 (define-package (runtime generic-procedure eqht)