Define a new condition type that is signalled when STRING-ALLOCATE is

unable to allocate the string due to a lack of memory.  Set up a
condition handler for this type in the file-reading code so that the
error message tells the user that the file is too big to fit in
memory.

diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 6a741d6e1ab65eb92cb99b4eaa1a9d95938e60a9..33a836f4b7b7f89752ab78966bee595cdf0a0d7b 100644 (file)
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: fileio.scm,v 1.114 1993/01/09 01:16:10 cph Exp $
+;;;    $Id: fileio.scm,v 1.115 1993/01/09 09:46:54 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
 ;;;
@@ -146,20 +146,29 @@ Each procedure is called with three arguments:
                (fix:- end index))))))))
 
 (define (group-insert-file! group index truename)
-  (let ((channel (file-open-input-channel (->namestring truename))))
-    (let ((length (file-length channel)))
-      (without-interrupts
-       (lambda ()
-         (prepare-gap-for-insert! group index length)))
-      (let ((n
-            (channel-read channel (group-text group) index (+ index length))))
-       (without-interrupts
+  (let ((filename (->namestring truename)))
+    (let ((channel (file-open-input-channel filename)))
+      (let ((length (file-length channel)))
+       (bind-condition-handler (list condition-type:allocation-failure)
+           (lambda (condition)
+             condition
+             (error "File too large to fit in memory:" filename))
          (lambda ()
-           (let ((gap-start* (fix:+ index n)))
-             (undo-record-insertion! group index gap-start*)
-             (finish-group-insert! group index n))))
-       (channel-close channel)
-       n))))
+           (without-interrupts
+             (lambda ()
+               (prepare-gap-for-insert! group index length)))))
+       (let ((n
+              (channel-read channel
+                            (group-text group)
+                            index
+                            (+ index length))))
+         (without-interrupts
+           (lambda ()
+             (let ((gap-start* (fix:+ index n)))
+               (undo-record-insertion! group index gap-start*)
+               (finish-group-insert! group index n))))
+         (channel-close channel)
+         n)))))
 \f
 ;;;; Buffer Mode Initialization
 

diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm
index 42480e7d030ed561d266173ee10957070aef99a4..8a0033cea8da927d6ed74fc0b147bf1474aba732 100644 (file)
--- a/v7/src/edwin/utils.scm
+++ b/v7/src/edwin/utils.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: utils.scm,v 1.28 1993/01/09 01:16:25 cph Exp $
+;;;    $Id: utils.scm,v 1.29 1993/01/09 09:46:49 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
 ;;;
@@ -46,6 +46,31 @@
 
 (declare (usual-integrations))
 \f
+(define (guarantee-heap-available n-words operator)
+  (gc-flip)
+  (if (not ((ucode-primitive heap-available? 1) n-words))
+      (error:allocation-failure n-words operator)))
+
+(define condition-type:allocation-failure
+  (make-condition-type 'ALLOCATION-FAILURE condition-type:error
+      '(OPERATOR N-WORDS)
+    (lambda (condition port)
+      (let ((operator (access-condition condition 'OPERATOR)))
+       (if operator
+           (begin
+             (write-string "The procedure " port)
+             (write operator port)
+             (write-string " is unable" port))
+           (write-string "Unable" port)))
+      (write-string " to allocate " port)
+      (write (access-condition condition 'N-WORDS) port)
+      (write-string " of storage." port))))
+
+(define error:allocation-failure
+  (condition-signaller condition-type:allocation-failure
+                      '(N-WORDS OPERATOR)
+                      standard-error-handler))
+\f
 (define-macro (chars-to-words-shift)
   ;; This is written as a macro so that the shift will be a constant
   ;; in the compiled code.
@@ -62,10 +87,7 @@
       (error:bad-range-argument n-chars 'STRING-ALLOCATE))
   (let ((n-words (fix:+ (fix:lsh n-chars (chars-to-words-shift)) 3)))
     (if (not ((ucode-primitive heap-available? 1) n-words))
-       (begin
-         (gc-flip)
-         (if (not ((ucode-primitive heap-available? 1) n-words))
-             (error "Unable to allocate string of this length:" n-chars))))
+       (guarantee-heap-available n-words 'STRING-ALLOCATE))
     (let ((mask (set-interrupt-enables! interrupt-mask/none)))
       (let ((result
             ((ucode-primitive primitive-get-free 1)
@@ -103,7 +125,8 @@
     (set-string-length! string n-chars)
     ;; This won't work if range-checking is turned on.
     (string-set! string (fix:+ n-chars 1) #\nul)
-    (set-interrupt-enables! mask)))
+    (set-interrupt-enables! mask)
+    unspecific))
 \f
 (define (%substring-move! source start-source end-source
                          target start-target)