#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.27 1991/10/29 14:31:40 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (condition-accessor type field-name)
(guarantee-condition-type type 'CONDITION-ACCESSOR)
(guarantee-symbol field-name 'CONDITION-ACCESSOR)
- (let ((type-description
- (string-append "condition of type " (write-to-string type)))
- (index
+ (let ((index
(%condition-type/field-index type
field-name
'CONDITION-ACCESSOR)))
(lambda (condition)
(if (not (and (condition? condition)
(eq? type (%condition/type condition))))
- (error:wrong-type-argument condition type-description
+ (error:wrong-type-argument condition
+ (string-append "condition of type "
+ (write-to-string type))
'CONDITION-ACCESSOR))
(vector-ref (%condition/field-values condition) index))))
(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
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((condition
+ (apply make-condition
+ continuation
+ 'BOUND-RESTARTS
+ field-values)))
+ (bind-restart 'USE-VALUE
+ (if (string? use-value-message)
+ use-value-message
+ (use-value-message condition))
continuation
(lambda (restart)
(restart/put! restart 'INTERACTIVE
(let ((prompt
- (if (procedure? use-value-prompt)
- (use-value-prompt field-value)
- use-value-prompt)))
+ (if (string? use-value-prompt)
+ use-value-prompt
+ (use-value-prompt condition))))
(lambda ()
(values (prompt-for-evaluated-expression prompt)))))
- (bind-restart 'RETRY retry-message
+ (bind-restart 'RETRY
+ (if (string? retry-message)
+ retry-message
+ (retry-message condition))
(lambda ()
- (continuation field-value))
+ (continuation (list-ref field-values index)))
(lambda (restart)
(restart/put! restart 'INTERACTIVE values)
- (let ((condition
- (apply make-condition
- continuation
- 'BOUND-RESTARTS
- field-values)))
- (signal-condition condition)
- (default-handler condition))))))))))))
+ (signal-condition condition)
+ (default-handler condition)))))))))))
constructor)))
\f
;;;; Basic Condition Types
(define condition-type:divide-by-zero)
(define condition-type:error)
(define condition-type:file-error)
-(define condition-type:file-touch-error)
+(define condition-type:file-operation-error)
(define condition-type:floating-point-overflow)
(define condition-type:floating-point-underflow)
(define condition-type:illegal-datum)
(define condition-type:no-such-restart)
-(define condition-type:open-file-error)
(define condition-type:port-error)
(define condition-type:serious-condition)
(define condition-type:simple-condition)
(define error:bad-range-argument)
(define error:datum-out-of-range)
(define error:divide-by-zero)
-(define error:file-touch)
+(define error:file-operation)
(define error:no-such-restart)
-(define error:open-file)
(define error:derived-file)
(define error:derived-port)
(define error:wrong-number-of-arguments)
filename
condition)))))
\f
- (set! condition-type:open-file-error
- (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error
- '(NOUN EXPLANATION)
+ (set! condition-type:file-operation-error
+ (make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error
+ '(VERB NOUN REASON OPERATOR OPERANDS)
(lambda (condition port)
- (let ((noun (access-condition condition 'NOUN))
- (explanation (access-condition condition 'EXPLANATION)))
- (write-string "Unable to open " port)
+ (let ((noun (access-condition condition 'NOUN)))
+ (write-string "Unable to " port)
+ (write-string (access-condition condition 'VERB) port)
+ (write-string " " port)
(write-string noun port)
(write-string " " port)
(write (let ((filename (access-condition condition '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
- '(MESSAGE)
- (lambda (condition port)
- (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))
+ (write-string " because: " port)
+ (let ((reason (access-condition condition 'REASON)))
+ (if reason
+ (write-string (string-capitalize reason) port)
+ (begin
+ (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.")))))
\f
(set! condition-type:variable-error
(make-condition-type 'VARIABLE-ERROR condition-type:cell-error
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.29 1991/10/29 14:31:49 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(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)))
+ (find-true-pathname
+ (->pathname
+ (error:file-operation pathname
+ "find"
+ "file"
+ "file does not exist"
+ find-true-pathname
+ (list pathname default-types)))
+ default-types)))
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.15 1991/10/29 14:31:56 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (canonicalize-input-pathname filename)
(let ((pathname (->pathname filename)))
(or (pathname->input-truename pathname)
- (canonicalize-input-pathname (error:open-file pathname)))))
+ (canonicalize-input-pathname
+ (error:file-operation pathname
+ "find"
+ "file"
+ "file does not exist"
+ canonicalize-input-pathname
+ (list filename))))))
(define (pathname->input-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname))
(truename-exists?
(lambda (pathname)
- (and ((ucode-primitive file-exists?) (pathname->string pathname))
+ (and ((ucode-primitive file-exists? 1) (pathname->string pathname))
pathname))))
(cond ((not (eq? 'NEWEST (pathname-version pathname)))
(truename-exists? pathname))
(pathname-new-version pathname 1)))))
(define (file-exists? filename)
- (pathname->input-truename (->pathname filename)))
+ (let ((pathname (pathname->absolute-pathname (->pathname filename)))
+ (pathname-exists?
+ (lambda (pathname)
+ ((ucode-primitive file-exists? 1) (pathname->string pathname)))))
+ (cond ((not (eq? 'NEWEST (pathname-version pathname)))
+ (pathname-exists? pathname))
+ ((not pathname-newest)
+ (pathname-exists? (pathname-new-version pathname false)))
+ (else
+ (pathname-newest pathname)))))
\f
(define (init-file-truename)
(let ((pathname (init-file-pathname)))
(if (null? directories)
(system-library-pathname
(->pathname
- (error:open-file pathname
- "no such file in system library path")))
+ (error:file-operation pathname
+ "find"
+ "file"
+ "no such file in system library path"
+ system-library-pathname
+ (list pathname))))
(or (pathname->input-truename
(merge-pathnames pathname (car directories)))
(loop (cdr directories)))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.123 1991/09/18 20:01:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.124 1991/10/29 14:32:03 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
condition-type:divide-by-zero
condition-type:error
condition-type:file-error
- condition-type:file-touch-error
+ condition-type:file-operation-error
condition-type:floating-point-overflow
condition-type:floating-point-underflow
condition-type:illegal-datum
condition-type:no-such-restart
- condition-type:open-file-error
condition-type:port-error
condition-type:serious-condition
condition-type:simple-condition
error:derived-file
error:derived-port
error:divide-by-zero
- error:file-touch
+ error:file-operation
error:no-such-restart
- error:open-file
error:wrong-number-of-arguments
error:wrong-type-argument
error:wrong-type-datum
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.7 1991/10/29 14:32:11 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(declare (usual-integrations))
-(define (canonicalize-existing-filename filename)
- (pathname->string (canonicalize-existing-pathname filename)))
-
-(define (canonicalize-existing-pathname filename)
- (let ((pathname (->pathname filename)))
- (or (pathname->existing-truename pathname)
- (canonicalize-existing-pathname (error:open-file pathname)))))
-
-(define (pathname->existing-truename pathname)
- (let ((pathname (pathname->absolute-pathname pathname))
- (truename-exists?
- (lambda (pathname)
- ;; This primitive, a unix-specific one, is used, because it
- ;; is the simplest way to do an lstat on the file. The
- ;; usual primitive, FILE-EXISTS?, does a stat.
- (and ((ucode-primitive file-mod-time 1) (pathname->string pathname))
- pathname))))
- (cond ((not (eq? 'NEWEST (pathname-version pathname)))
- (truename-exists? pathname))
- ((not pathname-newest)
- (truename-exists? (pathname-new-version pathname false)))
- (else
- (pathname-newest pathname)))))
-
(define (rename-file from to)
- ((ucode-primitive file-rename) (canonicalize-existing-filename from)
+ ((ucode-primitive file-rename) (canonicalize-input-filename from)
(canonicalize-output-filename to)))
(define (delete-file filename)
- (let ((truename (pathname->existing-truename (->pathname filename))))
+ (let ((truename (pathname->input-truename (->pathname filename))))
(and truename
(begin
((ucode-primitive file-remove) (pathname->string truename))
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.29 1991/10/29 14:32:14 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(thunk)))
(thunk))))
-(define (open-file-signaller)
+(define (file-operation-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
+ (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 ()
- (open-file/retry continuation operator operands noun
+ (file-operation/retry continuation operator operands verb noun
(lambda ()
- (signal continuation
- (list-ref operands index)
- noun
- explanation))))))))
+ (signal continuation (list-ref operands index)
+ verb noun reason operator operands))))))))
-(define (open-file/use-value continuation operator operands index noun thunk)
+(define (file-operation/use-value continuation operator operands index
+ verb noun thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if continuation
(bind-restart 'USE-VALUE
- (string-append "Try opening a different " noun ".")
+ (string-append "Try to " verb " a different " noun ".")
(lambda (operand)
(within-continuation continuation
(lambda ()
(thunk))))
(thunk))))
-(define (open-file/retry continuation operator operands noun thunk)
+(define (file-operation/retry continuation operator operands verb noun thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if continuation
(bind-restart 'RETRY
- (string-append "Try opening the same " noun " again.")
+ (string-append "Try to " verb " the same " noun " again.")
(lambda ()
(within-continuation continuation
(lambda ()
'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 (file-primitive-description primitive)
+ (cond ((eq? primitive (ucode-primitive file-exists? 1))
+ (values "determine existence of" "file"))
+ ((or (eq? primitive (ucode-primitive file-directory? 1))
+ (eq? primitive (ucode-primitive file-soft-link? 1)))
+ (values "determine type of of" "file"))
+ ((or (eq? primitive (ucode-primitive file-open-append-channel 1))
+ (eq? primitive (ucode-primitive file-open-input-channel 1))
+ (eq? primitive (ucode-primitive file-open-io-channel 1))
+ (eq? primitive (ucode-primitive file-open-output-channel 1)))
+ (values "open" "file"))
+ ((or (eq? primitive (ucode-primitive directory-open 1))
+ (eq? primitive (ucode-primitive directory-open-noread 1)))
+ (values "open" "directory"))
+ ((or (eq? primitive (ucode-primitive file-modes 1))
+ (eq? primitive (ucode-primitive file-access 2)))
+ (values "read permissions of" "file"))
+ ((eq? primitive (ucode-primitive set-file-modes! 2))
+ (values "set permissions of" "file"))
+ ((or (eq? primitive (ucode-primitive file-mod-time 1))
+ (eq? primitive (ucode-primitive file-mod-time-indirect 1)))
+ (values "read modification time of" "file"))
+ ((or (eq? primitive (ucode-primitive file-attributes 1))
+ (eq? primitive (ucode-primitive file-attributes-indirect 1)))
+ (values "read attributes of" "file"))
+ ((eq? primitive (ucode-primitive directory-make 1))
+ (values "create" "directory"))
+ ((eq? primitive (ucode-primitive file-copy 2))
+ (values "copy" "file"))
+ ((or (eq? primitive (ucode-primitive file-link-hard 2))
+ (eq? primitive (ucode-primitive file-link-soft 2))
+ (eq? primitive (ucode-primitive link-file 3)))
+ (values "link" "file"))
+ ((or (eq? primitive (ucode-primitive file-remove 1))
+ (eq? primitive (ucode-primitive file-remove-link 1)))
+ (values "delete" "file"))
+ ((eq? primitive (ucode-primitive file-rename 2))
+ (values "rename" "file"))
+ ((eq? primitive (ucode-primitive file-touch 1))
+ (values "touch" "file"))
+ (else
+ (values false false))))
\f
(define (initialize-package!)
(let ((signal
(condition-signaller condition-type:out-of-file-handles
'(OPERATOR OPERANDS)))
- (signal-open-file (open-file-signaller)))
+ (signal-file-operation (file-operation-signaller)))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(eq? (ucode-primitive file-open-io-channel) operator)
(eq? (ucode-primitive file-open-append-channel)
operator))
- (signal-open-file continuation operator operands 0 "file"
- "Channel table full.")
+ (signal-file-operation continuation operator operands 0
+ "open" "file" "channel table full")
(signal continuation operator operands))))))))
\f
(set! condition-type:system-call-error
(let ((make-condition
(condition-constructor condition-type:system-call-error
'(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))
- (signal-open-file (open-file-signaller)))
+ (signal-file-operation (file-operation-signaller)))
(lambda (continuation error-code)
(let ((frame (continuation/first-subproblem continuation)))
(if (and (apply-frame? frame)
(cond ((port-error-test operator operands)
=> (lambda (port)
(error:derived-port port (make-condition))))
- ((and (not (null? operands))
+ ((and (primitive-procedure? operator)
+ (not (null? operands))
(string? (car operands)))
- (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))))))
+ (with-values
+ (lambda ()
+ (file-primitive-description operator))
+ (lambda (verb noun)
+ (if verb
+ (signal-file-operation
+ continuation operator operands 0 verb noun
+ (error-type->string error-type))
+ (error (make-condition))))))
(else
(error (make-condition)))))))))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.14 1991/05/09 17:25:05 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.15 1991/10/29 14:32:22 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(pathname-new-version pathname false)))))))
(let ((result ((ucode-primitive file-touch) filename)))
(if (string? result)
- (error:file-touch filename result))
+ (error:file-operation filename
+ "touch"
+ "file"
+ result
+ (ucode-primitive file-touch)
+ (list filename)))
result)))
(define (make-directory name)
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.29 1991/10/29 14:31:49 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(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)))
+ (find-true-pathname
+ (->pathname
+ (error:file-operation pathname
+ "find"
+ "file"
+ "file does not exist"
+ find-true-pathname
+ (list pathname default-types)))
+ default-types)))
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.123 1991/09/18 20:01:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.124 1991/10/29 14:32:03 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
condition-type:divide-by-zero
condition-type:error
condition-type:file-error
- condition-type:file-touch-error
+ condition-type:file-operation-error
condition-type:floating-point-overflow
condition-type:floating-point-underflow
condition-type:illegal-datum
condition-type:no-such-restart
- condition-type:open-file-error
condition-type:port-error
condition-type:serious-condition
condition-type:simple-condition
error:derived-file
error:derived-port
error:divide-by-zero
- error:file-touch
+ error:file-operation
error:no-such-restart
- error:open-file
error:wrong-number-of-arguments
error:wrong-type-argument
error:wrong-type-datum
projects / mit-scheme.git / commitdiff