#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.25 1991/09/08 02:56:42 jinx Exp $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(default-handler condition)))))))
\f
;; This is similar to condition-signaller, but error procedures
-;; created with this allow substitution of the FIRST argument by
+;; 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
- #!optional use-value-prompter use-value-message retry-message)
- (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER)
+ 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))
- (use-value-prompter
- (if (default-object? use-value-prompter)
- (lambda (field-value . all)
- all ;ignore
- (string-append "Substitute "
- (write-to-string field-value)
- " with"))
- use-value-prompter))
- (use-value-message
- (if (default-object? use-value-message)
- "Retry operation with a different value."
- use-value-message))
- (retry-message
- (if (default-object? retry-message)
- "Retry operation with the same value."
- retry-message)))
- (lambda field-values
- (let ((field-value (car field-values)))
- (call-with-current-continuation
- (lambda (continuation)
- (let ((core
- (lambda ()
- (let ((condition
- (apply make-condition
- continuation
- 'BOUND-RESTARTS
- field-values)))
- (signal-condition condition)
- (default-handler condition)))))
- (bind-restart
- 'USE-VALUE
- use-value-message
- continuation
- (lambda (use-value-restart)
- (restart/put! use-value-restart 'INTERACTIVE
- (let ((prompt
- (apply use-value-prompter field-values)))
- (lambda ()
- (values (prompt-for-evaluated-expression
- prompt
- (nearest-repl/environment))))))
- (bind-restart 'RETRY
- retry-message
- (lambda ()
- (continuation field-value))
- (lambda (retry-restart)
- (restart/put! retry-restart 'INTERACTIVE
- values)
- (core))))))))))))
+ (arity (length field-names)))
+ (letrec
+ ((constructor
+ (lambda field-values
+ (if (not (= arity (length field-values)))
+ (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
+ continuation
+ (lambda (restart)
+ (restart/put! restart 'INTERACTIVE
+ (let ((prompt
+ (if (procedure? use-value-prompt)
+ (use-value-prompt field-value)
+ use-value-prompt)))
+ (lambda ()
+ (values (prompt-for-evaluated-expression prompt)))))
+ (bind-restart 'RETRY retry-message
+ (lambda ()
+ (continuation field-value))
+ (lambda (restart)
+ (restart/put! restart 'INTERACTIVE values)
+ (let ((condition
+ (apply make-condition
+ continuation
+ 'BOUND-RESTARTS
+ field-values)))
+ (signal-condition condition)
+ (default-handler condition))))))))))))
+ constructor)))
\f
;;;; Basic Condition Types
(%condition/restarts condition)
filename
condition)))))
-
+\f
(set! condition-type:open-file-error
(make-condition-type 'OPEN-FILE-ERROR condition-type:file-error
- '(EXPLANATION)
+ '(NOUN EXPLANATION)
(lambda (condition port)
- (write-string "Unable to open file " port)
- (write (access-condition condition 'FILENAME) 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))))))
+ (let ((noun (access-condition condition 'NOUN))
+ (explanation (access-condition condition 'EXPLANATION)))
+ (write-string "Unable to open " port)
+ (write-string noun port)
+ (write-string " " port)
+ (write (let ((filename (access-condition condition 'FILENAME)))
+ (if (pathname? 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
(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))
\f
(set! condition-type:variable-error
(make-condition-type 'VARIABLE-ERROR condition-type:cell-error
(condition-signaller condition-type:no-such-restart
'(NAME)
standard-error-handler))
- (set! error:open-file
- (substitutable-value-condition-signaller
- condition-type:open-file-error '(FILENAME EXPLANATION)
- standard-error-handler
- (lambda (pathname explanation)
- explanation ; ignored
- (string-append
- "Expression to yield replacement for file name \""
- (if (pathname? pathname)
- (pathname->string pathname)
- pathname)
- "\""))
- "Try opening a different file."
- "Try opening the same file."))
- (set! error:file-touch
- (condition-signaller condition-type:file-touch-error
- '(FILENAME MESSAGE)
- standard-error-handler))
unspecific)
\f
#| -*-Scheme-*-
-$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 $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.27 1991/10/26 16:20:48 cph Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (file-open primitive filename)
(let ((channel
- (bind-condition-handler (list condition-type:error)
- (lambda (condition)
- (error
- (make-condition condition-type:open-file-error
- (condition/continuation condition)
- (condition/restarts condition)
- `(FILENAME ,filename
- EXPLANATION ,condition))))
- (lambda ()
- (without-interrupts
- (lambda ()
- (make-channel (primitive filename))))))))
+ (without-interrupts
+ (lambda ()
+ (make-channel (primitive filename))))))
(if (or (channel-type=directory? channel)
(channel-type=unknown? channel))
(begin
#| -*-Scheme-*-
-$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 $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
\f
(define (find-true-pathname pathname default-types)
(or (pathname->input-truename pathname)
- (let ((truename
- (let ((pathname (pathname-default-version pathname 'NEWEST)))
- (if (pathname-type pathname)
- (pathname->input-truename pathname)
- (load/default-find-pathname-with-type pathname
- default-types)))))
- (or truename
- (find-true-pathname
- (->pathname (error:open-file pathname "The file does not exist."))
- default-types)))))
+ (let ((pathname (pathname-default-version pathname 'NEWEST)))
+ (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)))
(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.13 1991/08/23 23:26:48 arthur Exp $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (canonicalize-input-pathname filename)
(let ((pathname (->pathname filename)))
- (let ((truename (pathname->input-truename pathname)))
- (or truename
- (canonicalize-input-pathname
- (error:open-file pathname "The file does not exist."))))))
+ (or (pathname->input-truename pathname)
+ (canonicalize-input-pathname (error:open-file pathname)))))
(define (pathname->input-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname))
(system-library-pathname
(->pathname
(error:open-file pathname
- "Cannot find file in system library path.")))
+ "no such file in system library path")))
(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/sfile.scm,v 14.5 1991/10/22 12:12:46 cph Exp $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(define (canonicalize-existing-pathname filename)
(let ((pathname (->pathname filename)))
(or (pathname->existing-truename pathname)
- (canonicalize-existing-pathname
- (error:open-file pathname "The file does not exist.")))))
+ (canonicalize-existing-pathname (error:open-file pathname)))))
(define (pathname->existing-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.27 1991/06/24 22:50:33 cph Exp $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(thunk)))
(thunk))))
+(define (open-file-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
+ (lambda ()
+ (open-file/retry continuation operator operands noun
+ (lambda ()
+ (signal continuation
+ (list-ref operands index)
+ noun
+ explanation))))))))
+
+(define (open-file/use-value continuation operator operands index noun thunk)
+ (let ((continuation (continuation/next-continuation continuation)))
+ (if continuation
+ (bind-restart 'USE-VALUE
+ (string-append "Try opening 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 (restart)
+ (restart/put! restart 'INTERACTIVE
+ (lambda ()
+ (values (prompt-for-evaluated-expression prompt))))
+ (thunk))))
+ (thunk))))
+
+(define (open-file/retry continuation operator operands noun thunk)
+ (let ((continuation (continuation/next-continuation continuation)))
+ (if continuation
+ (bind-restart 'RETRY
+ (string-append "Try opening the same " noun " again.")
+ (lambda ()
+ (within-continuation continuation
+ (lambda ()
+ (apply operator operands))))
+ (lambda (restart)
+ (restart/put! restart 'INTERACTIVE values)
+ (thunk)))
+ (thunk))))
+
(define (substitute-element list index element)
(let loop ((list list) (i 0))
(if (= i index)
\f
;;;; Utilities
-(define (write-code object what port)
- (if (integer? object)
- (begin
- (write-string what port)
- (write-string " " port)
- (write object port))
- (begin
- (write-string "the " port)
- (write object port)
- (write-string " " port)
- (write-string what port))))
+(define (error-type->string error-type)
+ (if (symbol? error-type)
+ (string-replace (symbol->string error-type) #\- #\space)
+ (string-append "error " (write-to-string error-type))))
(define (normalize-trap-code-name name)
(let loop ((prefixes '("floating-point " "integer ")))
(string-ci=? "divide by zero" name))
'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)))
\f
(define (initialize-package!)
(define-error-handler 'OUT-OF-FILE-HANDLES
(let ((signal
(condition-signaller condition-type:out-of-file-handles
- '(OPERATOR OPERANDS))))
+ '(OPERATOR OPERANDS)))
+ (signal-open-file (open-file-signaller)))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
- (let ((operator (apply-frame/operator frame)))
+ (let ((operator (apply-frame/operator frame))
+ (operands (apply-frame/operands frame)))
(if (or (eq? (ucode-primitive file-open-input-channel) operator)
(eq? (ucode-primitive file-open-output-channel) operator)
(eq? (ucode-primitive file-open-io-channel) operator)
(eq? (ucode-primitive file-open-append-channel)
operator))
- (signal-open-file-error continuation
- (apply-frame/operand frame 0))
- (signal continuation
- operator
- (apply-frame/operands frame)))))))))
-
-(define signal-open-file-error
- (condition-signaller condition-type:open-file-error '(FILENAME)))
+ (signal-open-file continuation operator operands 0 "file"
+ "Channel table full.")
+ (signal continuation operator operands))))))))
\f
(set! condition-type:system-call-error
(make-condition-type 'SYSTEM-CALL-ERROR
(write-string "The primitive " port)
(write-operator (access-condition condition 'OPERATOR) port)
(write-string ", while executing " port)
- (write-code (access-condition condition 'SYSTEM-CALL) "system call" port)
+ (let ((system-call (access-condition condition 'SYSTEM-CALL)))
+ (if (symbol? system-call)
+ (begin
+ (write-string "the " port)
+ (write system-call port)
+ (write-string " system call" port))
+ (begin
+ (write-string "system call " port)
+ (write system-call port))))
(write-string ", received " port)
- (write-code (access-condition condition 'ERROR-TYPE) "error" port)
+ (let ((error-type (access-condition condition 'ERROR-TYPE)))
+ (if (symbol? error-type)
+ (write-string "the error: " port))
+ (write-string (error-type->string error-type) port))
(write-string "." port))))
(define-low-level-handler 'SYSTEM-CALL
(let ((make-condition
(condition-constructor condition-type:system-call-error
- '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE))))
+ '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))
+ (signal-open-file (open-file-signaller)))
(lambda (continuation error-code)
(let ((frame (continuation/first-subproblem continuation)))
(if (and (apply-frame? frame)
(vector? error-code)
(= 3 (vector-length error-code)))
(let ((operator (apply-frame/operator frame))
- (operands (apply-frame/operands frame)))
- (let ((condition
- (make-condition
- continuation
- 'BOUND-RESTARTS
- operator
- operands
- (let ((system-call (vector-ref error-code 2)))
- (or (microcode-system-call/code->name system-call)
- system-call))
- (let ((error-type (vector-ref error-code 1)))
- (or (microcode-system-call-error/code->name error-type)
- error-type)))))
+ (operands (apply-frame/operands frame))
+ (system-call
+ (let ((system-call (vector-ref error-code 2)))
+ (or (microcode-system-call/code->name system-call)
+ system-call)))
+ (error-type
+ (let ((error-type (vector-ref error-code 1)))
+ (or (microcode-system-call-error/code->name
+ error-type)
+ error-type))))
+ (let ((make-condition
+ (lambda ()
+ (make-condition continuation 'BOUND-RESTARTS
+ operator operands
+ system-call error-type))))
(cond ((port-error-test operator operands)
=> (lambda (port)
- (error:derived-port port condition)))
- ((and (memq operator file-primitives)
- (not (null? operands))
+ (error:derived-port port (make-condition))))
+ ((and (not (null? operands))
(string? (car operands)))
- (error:derived-file (car operands) condition))
+ (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))))))
(else
- (error condition))))))))))
-
-(define file-primitives
- (list (ucode-primitive directory-make 1)
- (ucode-primitive directory-open 1)
- (ucode-primitive directory-open-noread 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-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)
- (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)))
+ (error (make-condition)))))))))))
\f
;;;; FASLOAD Errors
#| -*-Scheme-*-
-$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 $
+$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 $
Copyright (c) 1988-91 Massachusetts Institute of Technology
\f
(define (find-true-pathname pathname default-types)
(or (pathname->input-truename pathname)
- (let ((truename
- (let ((pathname (pathname-default-version pathname 'NEWEST)))
- (if (pathname-type pathname)
- (pathname->input-truename pathname)
- (load/default-find-pathname-with-type pathname
- default-types)))))
- (or truename
- (find-true-pathname
- (->pathname (error:open-file pathname "The file does not exist."))
- default-types)))))
+ (let ((pathname (pathname-default-version pathname 'NEWEST)))
+ (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)))
(define (search-types-in-order pathname default-types)
(let loop ((types default-types))
projects / mit-scheme.git / commitdiff