Add CONDITION-TYPE:NO-SUCH-SLOT and modify record code to signal this

error when given an invalid slot name.

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 5e0eda663586e9cbfa71ab4aa391aa1cd92ad98a..efc06b001076f00d9980cc0720f5c4bfd6177ef1 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: record.scm,v 1.25 1997/06/05 03:06:03 cph Exp $
+$Id: record.scm,v 1.26 1997/06/25 03:27:54 cph Exp $
 
 Copyright (c) 1989-97 Massachusetts Institute of Technology
 
@@ -255,14 +255,18 @@ MIT in each case. |#
 
 (define record-updater
   record-modifier)
-
-(define (record-type-field-index record-type field-name error-name)
+\f
+(define (record-type-field-index record-type field-name error?)
   (let loop ((field-names (record-type-field-names record-type)) (index 1))
     (cond ((null? field-names)
-          (and error-name (error:bad-range-argument field-name error-name)))
+          (and error?
+               (record-type-field-index
+                record-type
+                (error:no-such-slot record-type field-name)
+                error?)))
          ((eq? field-name (car field-names)) index)
          (else (loop (cdr field-names) (+ index 1))))))
-\f
+
 (define (->string object)
   (if (string? object)
       object

diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm
index 4193538a46d15d0525a466ecec6571abba050e95..f0e69b5d37566497b63ac6fb82ea39d56076b71d 100644 (file)
--- a/v7/src/runtime/recslot.scm
+++ b/v7/src/runtime/recslot.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: recslot.scm,v 1.2 1997/06/24 05:33:57 cph Exp $
+;;; $Id: recslot.scm,v 1.3 1997/06/25 03:27:44 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -125,12 +125,40 @@
           (lambda (record)
             (record-type-field-names (record-type-descriptor record)))))))
 
+(define (store-value-restart location k thunk)
+  (let ((location (write-to-string location)))
+    (with-restart 'STORE-VALUE
+       (string-append "Initialize slot " location " to a given value.")
+       k
+       (string->interactor (string-append "Set " location " to"))
+      thunk)))
+
+(define (use-value-restart noun-phrase k thunk)
+  (with-restart 'USE-VALUE
+      (string-append "Specify a " noun-phrase ".")
+      k
+      (string->interactor (string-capitalize noun-phrase))
+    thunk))
+
+(define ((string->interactor string))
+  (values (prompt-for-evaluated-expression string)))
+\f
+(define condition-type:slot-error)
 (define condition-type:uninitialized-slot)
+(define condition-type:no-such-slot)
 (define error:uninitialized-slot)
+(define error:no-such-slot)
 
 (define (initialize-conditions!)
+  (set! condition-type:slot-error
+       (make-condition-type 'SLOT-ERROR condition-type:cell-error
+           '()
+         (lambda (condition port)
+           (write-string "Anonymous error for slot " port)
+           (write (access-condition condition 'LOCATION) port)
+           (write-string "." port))))
   (set! condition-type:uninitialized-slot
-       (make-condition-type 'UNINITIALIZED-SLOT condition-type:cell-error
+       (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error
            '(RECORD)
          (lambda (condition port)
            (write-string "Attempt to reference slot " port)
@@ -139,46 +167,47 @@
            (write (access-condition condition 'RECORD) port)
            (write-string " failed because the slot is not initialized."
                          port))))
+  (set! condition-type:no-such-slot
+       (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error
+           '(RECORD-TYPE)
+         (lambda (condition port)
+           (write-string "No slot named " port)
+           (write (access-condition condition 'LOCATION) port)
+           (write-string " in records of type " port)
+           (write (access-condition condition 'RECORD-TYPE) port)
+           (write-string "." 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)))
+           (let* ((location (or (%record-slot-name record index) index))
+                  (ls (write-to-string location)))
              (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))))
+                (store-value-restart ls
+                                     (lambda (value)
+                                       (%record-set! record index value)
+                                       (k value))
                   (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)))))))))))
+                    (use-value-restart
+                     (string-append
+                      "value to use instead of the contents of slot "
+                      ls)
+                     k
+                     (lambda () (signal record location)))))))))))
+  (set! error:no-such-slot
+       (let ((signal
+              (condition-signaller condition-type:no-such-slot
+                                   '(RECORD-TYPE LOCATION)
+                                   standard-error-handler)))
+         (lambda (record-type name)
+           (call-with-current-continuation
+            (lambda (k)
+              (use-value-restart
+               (string-append "slot name to use instead of "
+                              (write-to-string name))
+               k
+               (lambda () (signal record-type name))))))))
   unspecific)
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index a0fa8ec4d6734a47b4d02491cacfeee31f122443..802210f6e8495f407b519f524e83e587074fbb80 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.282 1997/06/24 05:34:20 cph Exp $
+$Id: runtime.pkg,v 14.283 1997/06/25 03:28:17 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -3325,6 +3325,8 @@ MIT in each case. |#
   (files "recslot")
   (parent ())
   (export ()
+         condition-type:no-such-slot
+         condition-type:slot-error
          condition-type:uninitialized-slot
          %record-accessor
          %record-accessor-generator
@@ -3334,7 +3336,9 @@ MIT in each case. |#
          %record-modifier-generator
          %record-slot-index
          %record-slot-name
-         %record-slot-names))
+         %record-slot-names)
+  (export (runtime record)
+         error:no-such-slot))
 
 (define-package (runtime generic-procedure eqht)
   (files "geneqht")

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 3943e3f42e746f1037b76ecd51e8d38eec8932ab..09b0aea1834dbab3cfa1762770e8361d24c6232d 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.288 1997/06/24 05:34:28 cph Exp $
+$Id: runtime.pkg,v 14.289 1997/06/25 03:28:26 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -3325,6 +3325,8 @@ MIT in each case. |#
   (files "recslot")
   (parent ())
   (export ()
+         condition-type:no-such-slot
+         condition-type:slot-error
          condition-type:uninitialized-slot
          %record-accessor
          %record-accessor-generator
@@ -3334,7 +3336,9 @@ MIT in each case. |#
          %record-modifier-generator
          %record-slot-index
          %record-slot-name
-         %record-slot-names))
+         %record-slot-names)
+  (export (runtime record)
+         error:no-such-slot))
 
 (define-package (runtime generic-procedure eqht)
   (files "geneqht")