From 478d85b49e93407b912eb269d23bdb2b11def9d0 Mon Sep 17 00:00:00 2001 From: Arthur Gleckler Date: Fri, 23 Aug 1991 23:26:48 +0000 Subject: [PATCH] Make Scheme explain why it cannot open a file. --- v7/src/runtime/error.scm | 28 +++++++++++++++++++++++----- v7/src/runtime/io.scm | 5 +++-- v7/src/runtime/load.scm | 7 ++++--- v7/src/runtime/pathnm.scm | 10 +++++++--- v8/src/runtime/load.scm | 7 ++++--- 5 files changed, 41 insertions(+), 16 deletions(-) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 304434205..40de3b382 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.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 3bb0ebe2b..e87e7c49a 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.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 3c98c66fc..3cb2d5fe9 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.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 c7a6f4daa..587fc221f 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.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 8baa7eb33..209543b87 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.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)) -- 2.25.1