Fix bug in SPLIT-INTERVAL-LEFT!: because the splitting process could

insert a new interval node in a non-leaf position, one of the
assumptions of INSERT-FIXUP! was violated.  This is fixed by making
sure that the inserted node is always inserted in a leaf position.

diff --git a/v7/src/edwin/txtprp.scm b/v7/src/edwin/txtprp.scm
index f6988990e4ea0c07fca093286e051a1bd457a256..f0070fda891689edd7b89654af86483b890d4d8f 100644 (file)
--- a/v7/src/edwin/txtprp.scm
+++ b/v7/src/edwin/txtprp.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: txtprp.scm,v 1.15 1994/10/11 23:10:12 cph Exp $
+;;;    $Id: txtprp.scm,v 1.16 1994/10/12 07:24:28 cph Exp $
 ;;;
-;;;    Copyright (c) 1993 Massachusetts Institute of Technology
+;;;    Copyright (c) 1993-94 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -610,25 +610,27 @@
   interval)
 
 (define (split-interval-left interval index group)
-  (let ((start (interval-start interval))
-       (left (interval-left interval)))
-    (let ((interval*
-          (make-interval interval
-                         left
-                         #f
-                         'RED
-                         (fix:+ (if left (interval-total-length left) 0)
-                                (fix:- index start))
-                         start
-                         (properties/copy (interval-properties interval)))))
-      (set-interval-left! interval interval*)
-      (if left (set-interval-up! left interval*))
-      (set-interval-start! interval index)
-      (insert-fixup! group
-                    (if (and left (eq? 'RED (interval-color left)))
-                        left
-                        interval*))
-      interval*)))
+  (let ((delta (fix:- index (interval-start interval)))
+       (start (interval-start interval)))
+    (set-interval-start! interval index)
+    (let ((new
+          (lambda (parent d)
+            (let ((interval*
+                   (make-interval parent #f #f 'RED delta start
+                                  (properties/copy
+                                   (interval-properties interval)))))
+              (set-link+! parent d interval*)
+              (insert-fixup! group interval*)
+              interval*))))
+      (if (not (interval-left interval))
+         (new interval 'LEFT)
+         (let loop ((parent (interval-left interval)))
+           (set-interval-total-length! parent
+                                       (fix:+ (interval-total-length parent)
+                                              delta))
+           (if (not (interval-right parent))
+               (new parent 'RIGHT)
+               (loop (interval-right parent))))))))
 
 (define (insert-fixup! group x)
   ;; Assumptions: X is red, and the only possible violation of the