* 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.

diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm
index 866bb5f298d62a0ef88e30acdab96fb6f4965563..d0282cf83041705e9bce2051025e00dec3c0d9eb 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.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))))
 \f
 ;;;; 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))))
-
+\f
   (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 46c368c7f119448553a8c3b022c1a7d15124f95b..3bb0ebe2baf13907729a69b28ad5d2c4835b78dc 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.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 c72284485d5b8d3ee48c9c5b3877cf5b6d4d930f..2be6e9b70fadfa4dedfb858eef219ccf28e6d473 100644 (file)
--- 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 53635af63eccdd2bfe78376f857ea242d00bb434..d210def45187abeba237a62163388cf8a580263e 100644 (file)
--- 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)))
 \f
 ;;;; FASLOAD Errors
 

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index f957f1254bef8b969c45b42c0ff46118ddc1bc20..0cd9fd97092a510068972a9599c16694c174c472 100644 (file)
--- 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 5d232912a77cebbd259bb62cbec512789d55e5df..d2bb82aa437f8cf446b150c5ec5b39bc5b1302a6 100644 (file)
--- 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