From 0b4cd91b066e895fd02425d14c6899f73a58256c Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 25 Jun 1997 03:28:26 +0000 Subject: [PATCH] Add CONDITION-TYPE:NO-SUCH-SLOT and modify record code to signal this error when given an invalid slot name. --- v7/src/runtime/record.scm | 14 ++++-- v7/src/runtime/recslot.scm | 99 ++++++++++++++++++++++++-------------- v7/src/runtime/runtime.pkg | 8 ++- v8/src/runtime/runtime.pkg | 8 ++- 4 files changed, 85 insertions(+), 44 deletions(-) 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") -- 2.25.1