From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Jun 1997 03:28:26 +0000 (+0000)
Subject: Add CONDITION-TYPE:NO-SUCH-SLOT and modify record code to signal this
X-Git-Tag: 20090517-FFI~5114
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0b4cd91b066e895fd02425d14c6899f73a58256c;p=mit-scheme.git

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 5e0eda663..efc06b001 100644
--- 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)
+
+(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))))))
-
+
 (define (->string object)
   (if (string? object)
       object
diff --git a/v7/src/runtime/recslot.scm b/v7/src/runtime/recslot.scm
index 4193538a4..f0e69b5d3 100644
--- 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)))
+
+(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 a0fa8ec4d..802210f6e 100644
--- 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 3943e3f42..09b0aea18 100644
--- 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")