From: Chris Hanson Date: Mon, 7 May 2018 07:00:24 +0000 (-0700) Subject: Fix bug: error:file-operation couldn't work properly. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~76 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7fa433dfc5254cf4821ce3aeaaed8946d83a4743;p=mit-scheme.git Fix bug: error:file-operation couldn't work properly. This is because substitutable-value-condition-signaller was mis-designed. It added retries *after* building the condition, so they weren't in the condition and would never be shown. I rewrote error:file-operation based on the model in microcode-errors.scm which was apparently a workaround for the fact that error:file-operation didn't work. This entailed a small but incompatible change to the procedure's arguments. --- diff --git a/doc/ref-manual/error.texi b/doc/ref-manual/error.texi index 3d87bc24c..78a16bb38 100644 --- a/doc/ref-manual/error.texi +++ b/doc/ref-manual/error.texi @@ -1462,10 +1462,12 @@ and would generate a message like this: @end example @end deffn -@deffn procedure error:file-operation-error filename verb noun reason operator operands +@deffn procedure error:file-operation index verb noun reason operator operands This procedure signals a condition of type -@code{condition-type:file-operation-error}. The fields of the condition -are filled in from the corresponding arguments to the procedure. +@code{condition-type:file-operation-error}. The fields of the +condition are filled in from the corresponding arguments to the +procedure, except that the filename is taken as the @var{index}th +element of @var{operands}. @end deffn @deffn {condition type} condition-type:derived-file-error filename condition diff --git a/src/edwin/dosfile.scm b/src/edwin/dosfile.scm index 8040584fe..f1bd8b7d1 100644 --- a/src/edwin/dosfile.scm +++ b/src/edwin/dosfile.scm @@ -529,7 +529,7 @@ filename suffix \".gz\"." (file-namestring pathname) " > " (->namestring temporary))))) - (error:file-operation pathname + (error:file-operation 0 program "file" "[unknown]" @@ -551,7 +551,7 @@ filename suffix \".gz\"." (string-append (quote-program program arguments) " > " (file-namestring pathname))))) - (error:file-operation pathname + (error:file-operation 1 program "file" "[unknown]" diff --git a/src/edwin/unix.scm b/src/edwin/unix.scm index ca3b700b4..f48c5d5e5 100644 --- a/src/edwin/unix.scm +++ b/src/edwin/unix.scm @@ -426,7 +426,7 @@ of the filename suffixes \".gz\", \".bz2\", or \".Z\"." (file-namestring pathname) " > " (->namestring temporary))))) - (error:file-operation pathname + (error:file-operation 0 program "file" "[unknown]" @@ -448,7 +448,7 @@ of the filename suffixes \".gz\", \".bz2\", or \".Z\"." (string-append program " > " (file-namestring pathname))))) - (error:file-operation pathname + (error:file-operation 1 program "file" "[unknown]" diff --git a/src/runtime/dos-pathname.scm b/src/runtime/dos-pathname.scm index 900ab52e1..236428262 100644 --- a/src/runtime/dos-pathname.scm +++ b/src/runtime/dos-pathname.scm @@ -367,7 +367,7 @@ USA. (if (file-exists-direct? pathname) pathname (dos/pathname->truename - (error:file-operation pathname "find" "file" "file does not exist" + (error:file-operation 0 "find" "file" "file does not exist" dos/pathname->truename (list pathname))))) (define (dos/user-homedir-pathname host) diff --git a/src/runtime/error.scm b/src/runtime/error.scm index 378f7b0f4..5a4c5e495 100644 --- a/src/runtime/error.scm +++ b/src/runtime/error.scm @@ -652,56 +652,48 @@ USA. (signal-condition condition) (default-handler condition))))))) -;; This is similar to condition-signaller, but error procedures -;; 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 - 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)) - (arity (length field-names))) - (letrec - ((constructor - (lambda field-values - (if (not (fix:= arity (length field-values))) - (error:wrong-number-of-arguments constructor - arity - field-values)) - (call-with-current-continuation - (lambda (continuation) - (let ((condition - (apply make-condition - (cons* continuation - 'bound-restarts - field-values)))) - (with-restart 'use-value - (if (string? use-value-message) - use-value-message - (use-value-message condition)) - continuation - (let ((prompt - (if (string? use-value-prompt) - use-value-prompt - (use-value-prompt condition)))) - (lambda () - (values (prompt-for-evaluated-expression prompt)))) - (lambda () - (with-restart 'retry - (if (string? retry-message) - retry-message - (retry-message condition)) - (lambda () - (continuation (list-ref field-values index))) - values - (lambda () - (signal-condition condition) - (default-handler condition))))))))))) - constructor))) +;;;; File operation errors + +(define (error:file-operation index verb noun reason operator operands) + (call-with-current-continuation + (lambda (continuation) + (signal-file-operation continuation index verb noun reason + operator operands)))) + +(define (signal-file-operation continuation index verb noun reason + operator operands) + (with-restart 'use-value + (string-append "New " noun + " name (an expression to be evaluated)") + (lambda (operand) + (within-continuation continuation + (lambda () + (apply operator + (receive (head tail) (split-at operands index) + (append! head + (cons operand (cdr tail)))))))) + (let ((prompt + (string-append "Try to " verb " a different " noun + "."))) + (lambda () + (values (prompt-for-evaluated-expression prompt)))) + (lambda () + (with-restart 'retry + (string-append "Try to " verb " the same " noun + " again.") + (lambda () + (within-continuation continuation + (lambda () + (apply operator operands)))) + values + (lambda () + (let ((condition + (make-file-operation-error continuation 'bound-restarts + (list-ref operands index) + verb noun reason + operator operands))) + (signal-condition condition) + (standard-error-handler condition))))))) ;;;; Basic Condition Types @@ -743,11 +735,11 @@ USA. (define make-simple-error) (define make-simple-warning) +(define make-file-operation-error) (define error:bad-range-argument) (define error:datum-out-of-range) (define error:divide-by-zero) -(define error:file-operation) (define error:no-such-restart) (define error:derived-file) (define error:derived-port) @@ -1070,32 +1062,9 @@ USA. (write-string "No such " port) (write-string noun port)))) (write-string "." port))))) - (set! error:file-operation - (let ((get-verb - (condition-accessor condition-type:file-operation-error 'verb)) - (get-noun - (condition-accessor condition-type:file-operation-error 'noun))) - (substitutable-value-condition-signaller - condition-type:file-operation-error - '(filename verb noun reason operator operands) - standard-error-handler - 0 - (lambda (condition) - (string-append "New " - (get-noun condition) - " name (an expression to be evaluated)")) - (lambda (condition) - (string-append "Try to " - (get-verb condition) - " a different " - (get-noun condition) - ".")) - (lambda (condition) - (string-append "Try to " - (get-verb condition) - " the same " - (get-noun condition) - " again."))))) + (set! make-file-operation-error + (condition-constructor condition-type:file-operation-error + '(filename verb noun reason operator operands))) (set! condition-type:variable-error (make-condition-type 'variable-error condition-type:cell-error diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 9c28901e2..53a1a2f2c 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -313,7 +313,7 @@ USA. (define (load-failure procedure pathname . arguments) (apply procedure - (error:file-operation pathname + (error:file-operation 0 "find" "file" "file does not exist" procedure (cons pathname arguments)) diff --git a/src/runtime/microcode-errors.scm b/src/runtime/microcode-errors.scm index 84f9350f8..276bf7193 100644 --- a/src/runtime/microcode-errors.scm +++ b/src/runtime/microcode-errors.scm @@ -177,56 +177,10 @@ USA. thunk) (thunk)))) -(define (file-operation-signaller) - (let ((signal - (condition-signaller condition-type:file-operation-error - '(filename verb noun reason operator operands)))) - (lambda (continuation operator operands index verb noun reason) - (file-operation/use-value continuation operator operands index verb noun - (lambda () - (file-operation/retry continuation operator operands verb noun - (lambda () - (signal continuation (list-ref operands index) - verb noun reason operator operands)))))))) - -(define (file-operation/use-value continuation operator operands index - verb noun thunk) - (let ((continuation (continuation/next-continuation continuation))) - (if (continuation-restartable? continuation) - (with-restart 'use-value - (string-append "Try to " verb " 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 () - (values (prompt-for-evaluated-expression prompt)))) - thunk) - (thunk)))) - -(define (file-operation/retry continuation operator operands verb noun thunk) - (let ((continuation (continuation/next-continuation continuation))) - (if (continuation-restartable? continuation) - (with-restart 'retry - (string-append "Try to " verb " the same " noun " again.") - (lambda () - (within-continuation continuation - (lambda () - (apply operator operands)))) - values - thunk) - (thunk)))) - (define (substitute-element list index element) - (let loop ((list list) (i 0)) - (if (= i index) - (cons element (cdr list)) - (cons (car list) (loop (cdr list) (+ i 1)))))) + (receive (head tail) (split-at list index) + (append! head + (cons element (cdr tail))))) ;;;; Continuation Parsing @@ -693,8 +647,7 @@ USA. (define-error-handler 'out-of-file-handles (let ((signal (condition-signaller condition-type:out-of-file-handles - '(operator operands))) - (signal-file-operation (file-operation-signaller))) + '(operator operands)))) (lambda (continuation) (let ((frame (continuation/first-subproblem continuation))) (if (apply-frame? frame) @@ -712,8 +665,9 @@ USA. operator) (eq? (ucode-primitive new-file-open-append-channel) operator)) - (signal-file-operation continuation operator operands 0 - "open" "file" "channel table full") + (signal-file-operation continuation + 0 "open" "file" "channel table full" + operator operands) (signal continuation operator operands)))))))) ;++ This should identify the process, but that requires reverse lookup @@ -758,8 +712,7 @@ USA. (define system-call-error-handler (let ((make-condition (condition-constructor condition-type:system-call-error - '(operator operands system-call error-type))) - (signal-file-operation (file-operation-signaller))) + '(operator operands system-call error-type)))) (lambda (continuation error-code) (let ((frame (continuation/first-subproblem continuation))) (if (and (apply-frame? frame) @@ -797,9 +750,10 @@ USA. (receive (verb noun) (file-primitive-description operator) (if verb - (signal-file-operation - continuation operator operands 0 verb noun - (error-type->string error-type)) + (signal-file-operation continuation 0 verb noun + (error-type->string + error-type) + operator operands) (error (make-condition))))) (else (error (make-condition))))))))))) diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm index 054de2de7..5c5195ec0 100644 --- a/src/runtime/pathname.scm +++ b/src/runtime/pathname.scm @@ -611,7 +611,7 @@ these rules: (or (%find-library-file pathname) (if (if (default-object? required?) #t required?) (system-library-pathname - (error:file-operation pathname + (error:file-operation 0 "find" "file" "no such file in system library path" @@ -628,7 +628,7 @@ these rules: ((if (default-object? required?) #f required?) (system-library-directory-pathname (error:file-operation - pathname + 0 "find" "directory" "no such directory in system library path" diff --git a/src/runtime/primitive-io.scm b/src/runtime/primitive-io.scm index 7ef4f15c4..53bf50496 100644 --- a/src/runtime/primitive-io.scm +++ b/src/runtime/primitive-io.scm @@ -296,7 +296,7 @@ USA. (channel-close channel) (file-open primitive operator - (error:file-operation filename "open" "file" reason + (error:file-operation 0 "open" "file" reason operator (list filename)))) channel))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index f2564da60..4df9fee5d 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2116,6 +2116,7 @@ USA. write-condition-report write-restart-report) (export (runtime microcode-errors) + signal-file-operation write-operator) (export (runtime rep) param:bound-restarts diff --git a/src/runtime/unix-pathname.scm b/src/runtime/unix-pathname.scm index e69109f04..5dd8041d0 100644 --- a/src/runtime/unix-pathname.scm +++ b/src/runtime/unix-pathname.scm @@ -300,7 +300,7 @@ USA. (if (file-exists-direct? pathname) pathname (unix/pathname->truename - (error:file-operation pathname "find" "file" "file does not exist" + (error:file-operation 0 "find" "file" "file does not exist" unix/pathname->truename (list pathname))))) (define (unix/user-homedir-pathname host) diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm index 862c3fddf..83b569fe1 100644 --- a/src/runtime/wrkdir.scm +++ b/src/runtime/wrkdir.scm @@ -61,7 +61,7 @@ USA. ;; relative lookups, either by changing directory just before each ;; lookup or using relative lookup system calls. (if (not (file-directory? pathname)) - (error:file-operation name "enter" "directory" + (error:file-operation 0 "enter" "directory" (if (file-exists? (directory-pathname-as-file pathname)) "not a directory"