From 7bcc467b1719f3bc1c07081ffe5b9f34ba49b822 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 10 May 1991 00:04:04 +0000 Subject: [PATCH] * Change FILE-OPEN-OUTPUT-CHANNEL (and consequently all code to open files) not to call FILE-REMOVE-LINK. Opening an existing output file will consequently overwrite the file rather than deleting it and then opening a new file. * Add CONDITION-TYPE:DERIVED-FILE-ERROR and translate various system call errors to that type. * Define CONDITION/REPORT-STRING to capture common idiom. --- v7/src/runtime/error.scm | 33 +++++++++++++++++++++++++++++++-- v7/src/runtime/io.scm | 9 ++++++--- v7/src/runtime/runtime.pkg | 4 +++- v7/src/runtime/uerror.scm | 37 +++++++++++++++++++++++++++++++------ v7/src/runtime/version.scm | 4 ++-- v8/src/runtime/runtime.pkg | 4 +++- 6 files changed, 76 insertions(+), 15 deletions(-) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 866bb5f29..d0282cf83 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.13 1991/03/11 23:31:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.14 1991/05/10 00:03:27 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -257,6 +257,11 @@ MIT in each case. |# (guarantee-condition condition 'WRITE-CONDITION-REPORT) (guarantee-output-port port 'WRITE-CONDITION-REPORT) ((%condition-type/reporter (%condition/type condition)) condition port)) + +(define (condition/report-string condition) + (with-string-output-port + (lambda (port) + (write-condition-report condition port)))) ;;;; Restarts @@ -527,6 +532,7 @@ MIT in each case. |# (define condition-type:cell-error) (define condition-type:control-error) (define condition-type:datum-out-of-range) +(define condition-type:derived-file-error) (define condition-type:derived-port-error) (define condition-type:divide-by-zero) (define condition-type:error) @@ -559,6 +565,7 @@ MIT in each case. |# (define error:file-touch) (define error:no-such-restart) (define error:open-file) +(define error:derived-file) (define error:derived-port) (define error:wrong-number-of-arguments) (define error:wrong-type-argument) @@ -760,6 +767,28 @@ MIT in each case. |# port condition))))) + (set! condition-type:derived-file-error + (make-condition-type 'DERIVED-FILE-ERROR condition-type:file-error + '(CONDITION) + (lambda (condition port) + (write-string "The file " port) + (write (access-condition condition 'FILENAME) port) + (write-string " received an error:" port) + (newline port) + (write-condition-report (access-condition condition 'CONDITION) + port)))) + + (set! error:derived-file + (let ((make-condition + (condition-constructor condition-type:derived-file-error + '(FILENAME CONDITION)))) + (lambda (filename condition) + (guarantee-condition condition 'ERROR:DERIVED-FILE) + (error (make-condition (%condition/continuation condition) + (%condition/restarts condition) + filename + condition))))) + (set! condition-type:open-file-error (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error '() (lambda (condition port) @@ -774,7 +803,7 @@ MIT in each case. |# (write-string "The primitive file-touch signalled an error: " port) (write (access-condition condition 'MESSAGE) port) (write-string "." port)))) - + (set! condition-type:variable-error (make-condition-type 'VARIABLE-ERROR condition-type:cell-error '(ENVIRONMENT) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 46c368c7f..3bb0ebe2b 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.24 1991/05/06 18:43:58 cph Exp $ +$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 $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -333,7 +333,6 @@ MIT in each case. |# (file-open (ucode-primitive file-open-input-channel 1) filename)) (define (file-open-output-channel filename) - ((ucode-primitive file-remove-link 1) filename) (file-open (ucode-primitive file-open-output-channel 1) filename)) (define (file-open-io-channel filename) @@ -454,7 +453,11 @@ MIT in each case. |# (dynamic-wind (lambda () (set! input-channel (file-open-input-channel input-filename)) - (set! output-channel (file-open-output-channel output-filename))) + (set! output-channel + (begin + ((ucode-primitive file-remove-link 1) output-filename) + (file-open-output-channel output-filename))) + unspecific) (lambda () (let ((source-length (file-length input-channel)) (buffer-length 8192)) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index c72284485..2be6e9b70 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.103 1991/05/06 03:19:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.104 1991/05/10 00:03:45 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -551,6 +551,7 @@ MIT in each case. |# condition-type:cell-error condition-type:control-error condition-type:datum-out-of-range + condition-type:derived-file-error condition-type:derived-port-error condition-type:divide-by-zero condition-type:error @@ -587,6 +588,7 @@ MIT in each case. |# error-irritant/noise error:bad-range-argument error:datum-out-of-range + error:derived-file error:derived-port error:divide-by-zero error:file-touch diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 53635af63..d210def45 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.24 1991/03/23 01:17:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.25 1991/05/10 00:03:55 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -656,11 +656,36 @@ MIT in each case. |# system-call)) (let ((error-type (vector-ref error-code 1))) (or (microcode-system-call-error/code->name error-type) - error-type)))) - (port (port-error-test operator operands))) - (if port - (error:derived-port port condition) - (error condition))))))))) + error-type))))) + (cond ((port-error-test operator operands) + => (lambda (port) + (error:derived-port port condition))) + ((and (memq operator file-primitives) + (not (null? operands)) + (string? (car operands))) + (error:derived-file (car operands) condition)) + (else + (error condition)))))))))) + +(define file-primitives + (list (ucode-primitive file-open-input-channel 1) + (ucode-primitive file-open-output-channel 1) + (ucode-primitive file-open-io-channel 1) + (ucode-primitive file-open-append-channel 1) + (ucode-primitive file-exists? 1) + (ucode-primitive file-access 2) + (ucode-primitive file-directory? 1) + (ucode-primitive file-soft-link? 1) + (ucode-primitive file-remove 1) + (ucode-primitive file-remove-link 1) + (ucode-primitive file-rename 2) + (ucode-primitive file-link-hard 2) + (ucode-primitive file-link-soft 2) + (ucode-primitive link-file 3) + (ucode-primitive file-copy 2) + (ucode-primitive directory-make 1) + (ucode-primitive directory-open 1) + (ucode-primitive directory-open-noread 1))) ;;;; FASLOAD Errors diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index f957f1254..0cd9fd970 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.119 1991/05/09 03:27:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.120 1991/05/10 00:04:04 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 119)) + (add-identification! "Runtime" 14 120)) (define microcode-system) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 5d232912a..d2bb82aa4 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.103 1991/05/06 03:19:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.104 1991/05/10 00:03:45 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -551,6 +551,7 @@ MIT in each case. |# condition-type:cell-error condition-type:control-error condition-type:datum-out-of-range + condition-type:derived-file-error condition-type:derived-port-error condition-type:divide-by-zero condition-type:error @@ -587,6 +588,7 @@ MIT in each case. |# error-irritant/noise error:bad-range-argument error:datum-out-of-range + error:derived-file error:derived-port error:divide-by-zero error:file-touch -- 2.25.1