Make Scheme explain why it cannot open a file.

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 304434205d4795456fc34476df08ea7b493fa0aa..40de3b3823f0ecfd64041b6779aa0d42827b1b0c 100644 (file)
--- 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.17 1991/08/22 01:15:03 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.18 1991/08/23 23:25:44 arthur Exp $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -878,11 +878,29 @@ MIT in each case. |#
                                   condition)))))
 
   (set! condition-type:open-file-error
-       (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error '()
+       (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error
+                            '(EXPLANATION)
          (lambda (condition port)
            (write-string "Unable to open file " port)
            (write (access-condition condition 'FILENAME) port)
-           (write-string "." 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))))))
 
   (set! condition-type:file-touch-error
        (make-condition-type 'FILE-TOUCH-ERROR condition-type:file-error
@@ -980,9 +998,9 @@ MIT in each case. |#
                             standard-error-handler))
   (set! error:open-file
        (substitutable-value-condition-signaller
-        condition-type:open-file-error '(FILENAME)
+        condition-type:open-file-error '(FILENAME EXPLANATION)
         standard-error-handler
-        (lambda (pathname)
+        (lambda (pathname explanation)
           (string-append
            "Expression to yield replacement for file name \""
            (if (pathname? pathname)

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 3bb0ebe2baf13907729a69b28ad5d2c4835b78dc..e87e7c49a49beaa48083bef08fc14efe76cb533c 100644 (file)
--- 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.25 1991/05/10 00:03:37 cph Exp $
+$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 $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -317,7 +317,8 @@ MIT in each case. |#
                (make-condition condition-type:open-file-error
                                (condition/continuation condition)
                                (condition/restarts condition)
-                               `(FILENAME ,filename))))
+                               `(FILENAME ,filename
+                                 EXPLANATION ,condition))))
           (lambda ()
             (without-interrupts
              (lambda ()

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 3c98c66fcfb388df5118da256d55638151b9f290..3cb2d5fe9f03cb0c9c9801bbd9c09eaed91cba2b 100644 (file)
--- 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.26 1991/08/23 16:25:14 arthur Exp $
+$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 $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -186,8 +186,9 @@ MIT in each case. |#
                   (load/default-find-pathname-with-type pathname
                                                         default-types)))))
        (or truename
-           (find-true-pathname (->pathname (error:open-file pathname))
-                               default-types)))))
+           (find-true-pathname
+            (->pathname (error:open-file pathname "The file does not exist."))
+            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 c7a6f4daabb4852fb259d0f0b3cfa4f4ce411c0b..587fc221f5343fc06d9e118eafd77d1695970a1f 100644 (file)
--- 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.12 1991/08/22 15:17:51 arthur Exp $
+$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 $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -341,7 +341,8 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|#
   (let ((pathname (->pathname filename)))
     (let ((truename (pathname->input-truename pathname)))
       (or truename
-         (canonicalize-input-pathname (error:open-file pathname))))))
+         (canonicalize-input-pathname
+          (error:open-file pathname "The file does not exist."))))))
 
 (define (pathname->input-truename pathname)
   (let ((pathname (pathname->absolute-pathname pathname))
@@ -430,7 +431,10 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|#
       pathname
       (let loop ((directories library-directory-path))
        (if (null? directories)
-           (system-library-pathname (->pathname (error:open-file pathname)))
+           (system-library-pathname
+            (->pathname
+             (error:open-file pathname
+                              "Cannot find file in system library path.")))
            (or (pathname->input-truename
                 (merge-pathnames pathname (car directories)))
                (loop (cdr directories)))))))

diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm
index 8baa7eb3352fc5f27d54242230ee29ffc64b182a..209543b87b0163013b7372cc37840fe96330a56e 100644 (file)
--- 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.26 1991/08/23 16:25:14 arthur Exp $
+$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 $
 
 Copyright (c) 1988-91 Massachusetts Institute of Technology
 
@@ -186,8 +186,9 @@ MIT in each case. |#
                   (load/default-find-pathname-with-type pathname
                                                         default-types)))))
        (or truename
-           (find-true-pathname (->pathname (error:open-file pathname))
-                               default-types)))))
+           (find-true-pathname
+            (->pathname (error:open-file pathname "The file does not exist."))
+            default-types)))))
 
 (define (search-types-in-order pathname default-types)
   (let loop ((types default-types))