From 230a7c60393d59bd2a93ae6f09dc65ee8a52a205 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 26 Oct 1991 16:21:08 +0000 Subject: [PATCH] When file- or directory-opening primitives get errors, signal those errors as open-file-error conditions. In those cases, don't use another condition as the explanation: create a meaninful error string from the error's context. This change has these effects: * All file/directory-opening primitives now signal the same condition. * RETRY and USE-VALUE handlers are available whenever that condition is signalled; previously these handlers were only sometimes available, and there was no reasonable way to provide them when they were not. --- v7/src/runtime/error.scm | 178 ++++++++++++++++---------------- v7/src/runtime/io.scm | 17 +--- v7/src/runtime/load.scm | 18 ++-- v7/src/runtime/pathnm.scm | 10 +- v7/src/runtime/sfile.scm | 5 +- v7/src/runtime/uerror.scm | 207 +++++++++++++++++++++++++------------- v8/src/runtime/load.scm | 18 ++-- 7 files changed, 247 insertions(+), 206 deletions(-) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 2cff9df16..73aedf795 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.25 1991/09/08 02:56:42 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.26 1991/10/26 16:20:41 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -546,65 +546,51 @@ MIT in each case. |# (default-handler condition))))))) ;; This is similar to condition-signaller, but error procedures -;; created with this allow substitution of the FIRST argument by +;; created with this allow substitution of the INDEXth argument by ;; using the USE-VALUE restart and allow retrying the operation by ;; using the RETRY restart. The RETRY restart will return the ;; original irritant, while USE-VALUE will return a value prompted for. (define (substitutable-value-condition-signaller type field-names default-handler - #!optional use-value-prompter use-value-message retry-message) - (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER) + index use-value-prompt use-value-message retry-message) + (guarantee-condition-handler default-handler + 'SUBSTITUTABLE-VALUE-CONDITION-SIGNALLER) (let ((make-condition (condition-constructor type field-names)) - (use-value-prompter - (if (default-object? use-value-prompter) - (lambda (field-value . all) - all ;ignore - (string-append "Substitute " - (write-to-string field-value) - " with")) - use-value-prompter)) - (use-value-message - (if (default-object? use-value-message) - "Retry operation with a different value." - use-value-message)) - (retry-message - (if (default-object? retry-message) - "Retry operation with the same value." - retry-message))) - (lambda field-values - (let ((field-value (car field-values))) - (call-with-current-continuation - (lambda (continuation) - (let ((core - (lambda () - (let ((condition - (apply make-condition - continuation - 'BOUND-RESTARTS - field-values))) - (signal-condition condition) - (default-handler condition))))) - (bind-restart - 'USE-VALUE - use-value-message - continuation - (lambda (use-value-restart) - (restart/put! use-value-restart 'INTERACTIVE - (let ((prompt - (apply use-value-prompter field-values))) - (lambda () - (values (prompt-for-evaluated-expression - prompt - (nearest-repl/environment)))))) - (bind-restart 'RETRY - retry-message - (lambda () - (continuation field-value)) - (lambda (retry-restart) - (restart/put! retry-restart 'INTERACTIVE - values) - (core)))))))))))) + (arity (length field-names))) + (letrec + ((constructor + (lambda field-values + (if (not (= arity (length field-values))) + (error:wrong-number-of-arguments constructor + arity + field-values)) + (let ((field-value (list-ref field-values index))) + (call-with-current-continuation + (lambda (continuation) + (bind-restart 'USE-VALUE use-value-message + continuation + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (let ((prompt + (if (procedure? use-value-prompt) + (use-value-prompt field-value) + use-value-prompt))) + (lambda () + (values (prompt-for-evaluated-expression prompt))))) + (bind-restart 'RETRY retry-message + (lambda () + (continuation field-value)) + (lambda (restart) + (restart/put! restart 'INTERACTIVE values) + (let ((condition + (apply make-condition + continuation + 'BOUND-RESTARTS + field-values))) + (signal-condition condition) + (default-handler condition)))))))))))) + constructor))) ;;;; Basic Condition Types @@ -882,31 +868,50 @@ MIT in each case. |# (%condition/restarts condition) filename condition))))) - + (set! condition-type:open-file-error (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error - '(EXPLANATION) + '(NOUN EXPLANATION) (lambda (condition port) - (write-string "Unable to open file " port) - (write (access-condition condition 'FILENAME) port) - (let ((explanation (access-condition condition 'EXPLANATION))) - (or (and explanation - (if (condition? explanation) - (and - (eq? condition-type:derived-file-error - (condition/type explanation)) - (let ((inner-condition - (access-condition explanation 'CONDITION))) - (and inner-condition - (eq? condition-type:system-call-error - (condition/type inner-condition)) - (begin (write-string " because: " port) - (write-condition-report - inner-condition port) - true)))) - (begin (write-string " because: " port) - (write-string explanation port)))) - (write-char #\. port)))))) + (let ((noun (access-condition condition 'NOUN)) + (explanation (access-condition condition 'EXPLANATION))) + (write-string "Unable to open " port) + (write-string noun port) + (write-string " " port) + (write (let ((filename (access-condition condition 'FILENAME))) + (if (pathname? filename) + (pathname->string filename) + filename)) + port) + (cond ((string? explanation) + (write-string " because: " port) + (write-string (string-capitalize explanation) port) + (write-string "." port)) + ((condition? explanation) + (write-string " because: " port) + (write-condition-report explanation port)) + (else + (write-string " because: No such " port) + (write-string noun port) + (write-string "." port))))))) + + (set! error:open-file + (let ((signaller + (substitutable-value-condition-signaller + condition-type:open-file-error + '(FILENAME EXPLANATION NOUN) + standard-error-handler + 0 + "New file name (an expression to be evaluated)" + "Try opening a different file." + "Try opening the same file again."))) + (lambda (filename #!optional explanation noun) + (signaller filename + (and (not (default-object? explanation)) explanation) + (if (or (default-object? noun) + (not noun)) + "file" + noun))))) (set! condition-type:file-touch-error (make-condition-type 'FILE-TOUCH-ERROR condition-type:file-error @@ -915,6 +920,11 @@ MIT in each case. |# (write-string "The primitive file-touch signalled an error: " port) (write (access-condition condition 'MESSAGE) port) (write-string "." port)))) + + (set! error:file-touch + (condition-signaller condition-type:file-touch-error + '(FILENAME MESSAGE) + standard-error-handler)) (set! condition-type:variable-error (make-condition-type 'VARIABLE-ERROR condition-type:cell-error @@ -1002,24 +1012,6 @@ MIT in each case. |# (condition-signaller condition-type:no-such-restart '(NAME) standard-error-handler)) - (set! error:open-file - (substitutable-value-condition-signaller - condition-type:open-file-error '(FILENAME EXPLANATION) - standard-error-handler - (lambda (pathname explanation) - explanation ; ignored - (string-append - "Expression to yield replacement for file name \"" - (if (pathname? pathname) - (pathname->string pathname) - pathname) - "\"")) - "Try opening a different file." - "Try opening the same file.")) - (set! error:file-touch - (condition-signaller condition-type:file-touch-error - '(FILENAME MESSAGE) - standard-error-handler)) unspecific) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index e87e7c49a..cc9ac9abd 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.26 1991/08/23 23:25:24 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.27 1991/10/26 16:20:48 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -311,18 +311,9 @@ MIT in each case. |# (define (file-open primitive filename) (let ((channel - (bind-condition-handler (list condition-type:error) - (lambda (condition) - (error - (make-condition condition-type:open-file-error - (condition/continuation condition) - (condition/restarts condition) - `(FILENAME ,filename - EXPLANATION ,condition)))) - (lambda () - (without-interrupts - (lambda () - (make-channel (primitive filename)))))))) + (without-interrupts + (lambda () + (make-channel (primitive filename)))))) (if (or (channel-type=directory? channel) (channel-type=unknown? channel)) (begin diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 3cb2d5fe9..561e33337 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.27 1991/08/23 23:26:14 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.28 1991/10/26 16:20:56 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -179,16 +179,12 @@ MIT in each case. |# (define (find-true-pathname pathname default-types) (or (pathname->input-truename pathname) - (let ((truename - (let ((pathname (pathname-default-version pathname 'NEWEST))) - (if (pathname-type pathname) - (pathname->input-truename pathname) - (load/default-find-pathname-with-type pathname - default-types))))) - (or truename - (find-true-pathname - (->pathname (error:open-file pathname "The file does not exist.")) - default-types))))) + (let ((pathname (pathname-default-version pathname 'NEWEST))) + (if (pathname-type pathname) + (pathname->input-truename pathname) + (load/default-find-pathname-with-type pathname default-types))) + (find-true-pathname (->pathname (error:open-file pathname)) + default-types))) (define (search-types-in-order pathname default-types) (let loop ((types default-types)) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index 587fc221f..065549ec6 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.13 1991/08/23 23:26:48 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.14 1991/10/26 16:21:00 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -339,10 +339,8 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (canonicalize-input-pathname filename) (let ((pathname (->pathname filename))) - (let ((truename (pathname->input-truename pathname))) - (or truename - (canonicalize-input-pathname - (error:open-file pathname "The file does not exist.")))))) + (or (pathname->input-truename pathname) + (canonicalize-input-pathname (error:open-file pathname))))) (define (pathname->input-truename pathname) (let ((pathname (pathname->absolute-pathname pathname)) @@ -434,7 +432,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (system-library-pathname (->pathname (error:open-file pathname - "Cannot find file in system library path."))) + "no such file in system library path"))) (or (pathname->input-truename (merge-pathnames pathname (car directories))) (loop (cdr directories))))))) diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index 9771015fd..82a4a492b 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.5 1991/10/22 12:12:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.6 1991/10/26 16:21:04 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -43,8 +43,7 @@ MIT in each case. |# (define (canonicalize-existing-pathname filename) (let ((pathname (->pathname filename))) (or (pathname->existing-truename pathname) - (canonicalize-existing-pathname - (error:open-file pathname "The file does not exist."))))) + (canonicalize-existing-pathname (error:open-file pathname))))) (define (pathname->existing-truename pathname) (let ((pathname (pathname->absolute-pathname pathname)) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 95989b27e..e7c424033 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.27 1991/06/24 22:50:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.28 1991/10/26 16:21:08 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -182,6 +182,55 @@ MIT in each case. |# (thunk))) (thunk)))) +(define (open-file-signaller) + (let ((signal + (condition-signaller condition-type:open-file-error + '(FILENAME NOUN EXPLANATION)))) + (lambda (continuation operator operands index noun explanation) + (open-file/use-value continuation operator operands index noun + (lambda () + (open-file/retry continuation operator operands noun + (lambda () + (signal continuation + (list-ref operands index) + noun + explanation)))))))) + +(define (open-file/use-value continuation operator operands index noun thunk) + (let ((continuation (continuation/next-continuation continuation))) + (if continuation + (bind-restart 'USE-VALUE + (string-append "Try opening a different " noun ".") + (lambda (operand) + (within-continuation continuation + (lambda () + (apply operator + (substitute-element operands index operand))))) + (let ((prompt + (string-append "New " + noun + " name (an expression to be evaluated)"))) + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (lambda () + (values (prompt-for-evaluated-expression prompt)))) + (thunk)))) + (thunk)))) + +(define (open-file/retry continuation operator operands noun thunk) + (let ((continuation (continuation/next-continuation continuation))) + (if continuation + (bind-restart 'RETRY + (string-append "Try opening the same " noun " again.") + (lambda () + (within-continuation continuation + (lambda () + (apply operator operands)))) + (lambda (restart) + (restart/put! restart 'INTERACTIVE values) + (thunk))) + (thunk)))) + (define (substitute-element list index element) (let loop ((list list) (i 0)) (if (= i index) @@ -253,17 +302,10 @@ MIT in each case. |# ;;;; Utilities -(define (write-code object what port) - (if (integer? object) - (begin - (write-string what port) - (write-string " " port) - (write object port)) - (begin - (write-string "the " port) - (write object port) - (write-string " " port) - (write-string what port)))) +(define (error-type->string error-type) + (if (symbol? error-type) + (string-replace (symbol->string error-type) #\- #\space) + (string-append "error " (write-to-string error-type)))) (define (normalize-trap-code-name name) (let loop ((prefixes '("floating-point " "integer "))) @@ -285,6 +327,36 @@ MIT in each case. |# (string-ci=? "divide by zero" name)) 'DIVIDE-BY-ZERO) (else false))) + +(define file-open-primitives + (list (ucode-primitive file-open-append-channel 1) + (ucode-primitive file-open-input-channel 1) + (ucode-primitive file-open-io-channel 1) + (ucode-primitive file-open-output-channel 1))) + +(define directory-open-primitives + (list (ucode-primitive directory-open 1) + (ucode-primitive directory-open-noread 1))) + +(define file-primitives + (list (ucode-primitive directory-make 1) + (ucode-primitive file-access 2) + (ucode-primitive file-attributes 1) + (ucode-primitive file-attributes-indirect 1) + (ucode-primitive file-copy 2) + (ucode-primitive file-directory? 1) + (ucode-primitive file-exists? 1) + (ucode-primitive file-link-hard 2) + (ucode-primitive file-link-soft 2) + (ucode-primitive file-mod-time-indirect 1) + (ucode-primitive file-modes 1) + (ucode-primitive file-remove 1) + (ucode-primitive file-remove-link 1) + (ucode-primitive file-rename 2) + (ucode-primitive file-soft-link? 1) + (ucode-primitive file-touch 1) + (ucode-primitive link-file 3) + (ucode-primitive set-file-modes! 2))) (define (initialize-package!) @@ -601,24 +673,21 @@ MIT in each case. |# (define-error-handler 'OUT-OF-FILE-HANDLES (let ((signal (condition-signaller condition-type:out-of-file-handles - '(OPERATOR OPERANDS)))) + '(OPERATOR OPERANDS))) + (signal-open-file (open-file-signaller))) (lambda (continuation) (let ((frame (continuation/first-subproblem continuation))) (if (apply-frame? frame) - (let ((operator (apply-frame/operator frame))) + (let ((operator (apply-frame/operator frame)) + (operands (apply-frame/operands frame))) (if (or (eq? (ucode-primitive file-open-input-channel) operator) (eq? (ucode-primitive file-open-output-channel) operator) (eq? (ucode-primitive file-open-io-channel) operator) (eq? (ucode-primitive file-open-append-channel) operator)) - (signal-open-file-error continuation - (apply-frame/operand frame 0)) - (signal continuation - operator - (apply-frame/operands frame))))))))) - -(define signal-open-file-error - (condition-signaller condition-type:open-file-error '(FILENAME))) + (signal-open-file continuation operator operands 0 "file" + "Channel table full.") + (signal continuation operator operands)))))))) (set! condition-type:system-call-error (make-condition-type 'SYSTEM-CALL-ERROR @@ -628,69 +697,69 @@ MIT in each case. |# (write-string "The primitive " port) (write-operator (access-condition condition 'OPERATOR) port) (write-string ", while executing " port) - (write-code (access-condition condition 'SYSTEM-CALL) "system call" port) + (let ((system-call (access-condition condition 'SYSTEM-CALL))) + (if (symbol? system-call) + (begin + (write-string "the " port) + (write system-call port) + (write-string " system call" port)) + (begin + (write-string "system call " port) + (write system-call port)))) (write-string ", received " port) - (write-code (access-condition condition 'ERROR-TYPE) "error" port) + (let ((error-type (access-condition condition 'ERROR-TYPE))) + (if (symbol? error-type) + (write-string "the error: " port)) + (write-string (error-type->string error-type) port)) (write-string "." port)))) (define-low-level-handler 'SYSTEM-CALL (let ((make-condition (condition-constructor condition-type:system-call-error - '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))) + '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE))) + (signal-open-file (open-file-signaller))) (lambda (continuation error-code) (let ((frame (continuation/first-subproblem continuation))) (if (and (apply-frame? frame) (vector? error-code) (= 3 (vector-length error-code))) (let ((operator (apply-frame/operator frame)) - (operands (apply-frame/operands frame))) - (let ((condition - (make-condition - continuation - 'BOUND-RESTARTS - operator - operands - (let ((system-call (vector-ref error-code 2))) - (or (microcode-system-call/code->name system-call) - system-call)) - (let ((error-type (vector-ref error-code 1))) - (or (microcode-system-call-error/code->name error-type) - error-type))))) + (operands (apply-frame/operands frame)) + (system-call + (let ((system-call (vector-ref error-code 2))) + (or (microcode-system-call/code->name system-call) + system-call))) + (error-type + (let ((error-type (vector-ref error-code 1))) + (or (microcode-system-call-error/code->name + error-type) + error-type)))) + (let ((make-condition + (lambda () + (make-condition continuation 'BOUND-RESTARTS + operator operands + system-call error-type)))) (cond ((port-error-test operator operands) => (lambda (port) - (error:derived-port port condition))) - ((and (memq operator file-primitives) - (not (null? operands)) + (error:derived-port port (make-condition)))) + ((and (not (null? operands)) (string? (car operands))) - (error:derived-file (car operands) condition)) + (let ((signal-open-file + (lambda (noun) + (signal-open-file + continuation operator operands 0 noun + (error-type->string error-type))))) + (cond ((memq operator file-open-primitives) + (signal-open-file "file")) + ((memq operator directory-open-primitives) + (signal-open-file "directory")) + ((memq operator file-primitives) + (error:derived-file (car operands) + (make-condition))) + (else + (error (make-condition)))))) (else - (error condition)))))))))) - -(define file-primitives - (list (ucode-primitive directory-make 1) - (ucode-primitive directory-open 1) - (ucode-primitive directory-open-noread 1) - (ucode-primitive file-access 2) - (ucode-primitive file-attributes 1) - (ucode-primitive file-attributes-indirect 1) - (ucode-primitive file-copy 2) - (ucode-primitive file-directory? 1) - (ucode-primitive file-exists? 1) - (ucode-primitive file-link-hard 2) - (ucode-primitive file-link-soft 2) - (ucode-primitive file-mod-time-indirect 1) - (ucode-primitive file-modes 1) - (ucode-primitive file-open-append-channel 1) - (ucode-primitive file-open-input-channel 1) - (ucode-primitive file-open-io-channel 1) - (ucode-primitive file-open-output-channel 1) - (ucode-primitive file-remove 1) - (ucode-primitive file-remove-link 1) - (ucode-primitive file-rename 2) - (ucode-primitive file-soft-link? 1) - (ucode-primitive file-touch 1) - (ucode-primitive link-file 3) - (ucode-primitive set-file-modes! 2))) + (error (make-condition))))))))))) ;;;; FASLOAD Errors diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index 209543b87..1f679c267 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.27 1991/08/23 23:26:14 arthur Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.28 1991/10/26 16:20:56 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -179,16 +179,12 @@ MIT in each case. |# (define (find-true-pathname pathname default-types) (or (pathname->input-truename pathname) - (let ((truename - (let ((pathname (pathname-default-version pathname 'NEWEST))) - (if (pathname-type pathname) - (pathname->input-truename pathname) - (load/default-find-pathname-with-type pathname - default-types))))) - (or truename - (find-true-pathname - (->pathname (error:open-file pathname "The file does not exist.")) - default-types))))) + (let ((pathname (pathname-default-version pathname 'NEWEST))) + (if (pathname-type pathname) + (pathname->input-truename pathname) + (load/default-find-pathname-with-type pathname default-types))) + (find-true-pathname (->pathname (error:open-file pathname)) + default-types))) (define (search-types-in-order pathname default-types) (let loop ((types default-types)) -- 2.25.1