From: Chris Hanson Date: Tue, 24 Jun 1997 05:34:28 +0000 (+0000) Subject: Modify %RECORD-ACCESSOR to signal an error if the accessed slot is X-Git-Tag: 20090517-FFI~5115 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2f68e837f7f10b0d66949d001cde381d20260681;p=mit-scheme.git 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 7728f6a01..1db1f2f4f 100644 --- 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 c9ae17f46..4193538a4 100644 --- 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)))) + (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 30076a97d..a0fa8ec4d 100644 --- 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 51f25ee43..aba329314 100644 --- 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 e6fb04ee5..3943e3f42 100644 --- 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)