From 7d615fae2e572744c40d242da64d57b0a45e1fff Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 9 Jan 1993 09:46:54 +0000
Subject: [PATCH] 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.

---
 v7/src/edwin/fileio.scm | 37 +++++++++++++++++++++++--------------
 v7/src/edwin/utils.scm  | 35 +++++++++++++++++++++++++++++------
 2 files changed, 52 insertions(+), 20 deletions(-)

diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 6a741d6e1..33a836f4b 100644
--- 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)))))
 
 ;;;; Buffer Mode Initialization
 
diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm
index 42480e7d0..8a0033cea 100644
--- 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))
 
+(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))
+
 (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))
 
 (define (%substring-move! source start-source end-source
 			  target start-target)
-- 
2.25.1