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 3d87bc24c39040234fd0fea953b54d39b5de56ec..78a16bb382ccecbf20c60fbefd924f3e5fad0652 100644 (file)
--- 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 8040584fe42a331a63fe811e3b6580adc354588c..f1bd8b7d12f34c961a6b4242db79960c9ef5008f 100644 (file)
--- 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 ca3b700b471b38fce99cc720d8a3d985d4523dc4..f48c5d5e58ec7eba9658646dadbc80baae41ee8d 100644 (file)
--- 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 900ab52e1c2f4cc6ddcb097536677279d7db63de..236428262075cf7e9923d793d3b05f0b81315d3f 100644 (file)
--- 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 378f7b0f4dc151d791bb230a216eb8263c3d908a..5a4c5e495d5900052b286f9e6cda1f2e18549f6a 100644 (file)
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -652,56 +652,48 @@ USA.
           (signal-condition condition)
           (default-handler condition)))))))
 \f
-;; 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)))))))
 \f
 ;;;; 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 9c28901e216646346e9577cfa31b86a570084122..53a1a2f2c98df1b5e9a0c9d43072b02c3349eac8 100644 (file)
--- 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 84f9350f88be64291a547a5aea03ffc627d3fcec..276bf719352a85e74bfa2222243d5939eafc6132 100644 (file)
--- 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)))))
 \f
 ;;;; 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 054de2de7d24fc9bd36270b0630d2b91dfe73b4a..5c5195ec0083de8de8587a094f4dfe0ed61859a6 100644 (file)
--- 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 7ef4f15c4d2cc88aa9e229c83c58e663f5f1796c..53bf50496ac241984b7389011dd45bfc4a8dc78a 100644 (file)
--- 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 f2564da60d6379f1e11a75a52370fec4c1c14aca..4df9fee5d81cdb811f7352fe5389927e86dc8b8b 100644 (file)
--- 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 e69109f04f56e95b4e5254e131ea5a5c77ea1efc..5dd8041d001d537d8924856c6a87e90ec9609dbb 100644 (file)
--- 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 862c3fddf622d4cc460a6f817b4010e2c32bb4fc..83b569fe19251721edfba82acb45e308e5510b1f 100644 (file)
--- 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"