From 878d3609b28ab784abc21e8991cc7949c1ea0041 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 6 Oct 1993 21:17:13 +0000
Subject: [PATCH] Add type-checking of tree arguments and interrupt locking.
Add new operations RB-TREE/KEY-LIST and RB-TREE/DATUM-LIST.
---
v7/src/runtime/rbtree.scm | 171 +++++++++++++++++++++++++------------
v7/src/runtime/runtime.pkg | 4 +-
v8/src/runtime/runtime.pkg | 4 +-
3 files changed, 124 insertions(+), 55 deletions(-)
diff --git a/v7/src/runtime/rbtree.scm b/v7/src/runtime/rbtree.scm
index b61820d4b..7ba0d96fa 100644
--- a/v7/src/runtime/rbtree.scm
+++ b/v7/src/runtime/rbtree.scm
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: rbtree.scm,v 1.1 1993/10/05 07:17:24 cph Exp $
+$Id: rbtree.scm,v 1.2 1993/10/06 21:16:35 cph Exp $
Copyright (c) 1993 Massachusetts Institute of Technology
@@ -67,6 +67,10 @@ MIT in each case. |#
((eq? key<? flo:<) (lambda (x y) (flo:< x y)))
(else key<?))))
+(define-integrable (guarantee-rb-tree tree procedure)
+ (if (not (rb-tree? tree))
+ (error:wrong-type-argument tree "red/black tree" procedure)))
+
(define-structure (node
(constructor make-node (key datum)))
key
@@ -126,8 +130,10 @@ MIT in each case. |#
(rotate+! tree x (-d d)))
(define (rb-tree/insert! tree key datum)
+ (guarantee-rb-tree tree 'RB-TREE/INSERT!)
(let ((key=? (tree-key=? tree))
- (key<? (tree-key<? tree)))
+ (key<? (tree-key<? tree))
+ (interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(let loop ((x (tree-root tree)) (y #f) (d #f))
(cond ((not x)
(let ((z (make-node key datum)))
@@ -139,7 +145,9 @@ MIT in each case. |#
(insert-fixup! tree z)))
((key=? key (node-key x)) (set-node-datum! x datum))
((key<? key (node-key x)) (loop (node-left x) x 'LEFT))
- (else (loop (node-right x) x 'RIGHT))))))
+ (else (loop (node-right x) x 'RIGHT))))
+ (set-interrupt-enables! interrupt-mask)
+ unspecific))
(define (insert-fixup! tree x)
;; Assumptions: X is red, and the only possible violation of the
@@ -179,13 +187,17 @@ MIT in each case. |#
tree))
(define (rb-tree/delete! tree key)
+ (guarantee-rb-tree tree 'RB-TREE/DELETE!)
(let ((key=? (tree-key=? tree))
- (key<? (tree-key<? tree)))
+ (key<? (tree-key<? tree))
+ (interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(let loop ((x (tree-root tree)))
(cond ((not x) unspecific)
((key=? key (node-key x)) (delete-node! tree x))
((key<? key (node-key x)) (loop (node-left x)))
- (else (loop (node-right x)))))))
+ (else (loop (node-right x)))))
+ (set-interrupt-enables! interrupt-mask)
+ unspecific))
(define (delete-node! tree z)
(let ((z
@@ -246,16 +258,23 @@ MIT in each case. |#
(case-4 (get-link- u d)))))))))))
(define (rb-tree/lookup tree key default)
+ (guarantee-rb-tree tree 'RB-TREE/LOOKUP)
(let ((key=? (tree-key=? tree))
- (key<? (tree-key<? tree)))
- (let loop ((x (tree-root tree)))
- (cond ((not x) default)
- ((key=? key (node-key x)) (node-datum x))
- ((key<? key (node-key x)) (loop (node-left x)))
- (else (loop (node-right x)))))))
+ (key<? (tree-key<? tree))
+ (interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((x (tree-root tree)))
+ (cond ((not x) default)
+ ((key=? key (node-key x)) (node-datum x))
+ ((key<? key (node-key x)) (loop (node-left x)))
+ (else (loop (node-right x)))))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
(define (rb-tree/copy tree)
- (let ((result (make-rb-tree (tree-key=? tree) (tree-key<? tree))))
+ (guarantee-rb-tree tree 'RB-TREE/COPY)
+ (let ((result (make-rb-tree (tree-key=? tree) (tree-key<? tree)))
+ (interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
(set-tree-root!
result
(let loop ((node (tree-root tree)) (up #f))
@@ -266,59 +285,105 @@ MIT in each case. |#
(set-node-left! node* (loop (node-left node) node*))
(set-node-right! node* (loop (node-right node) node*))
node*))))
+ (set-interrupt-enables! interrupt-mask)
result))
+(define (rb-tree/height tree)
+ (guarantee-rb-tree tree 'RB-TREE/HEIGHT)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((node (tree-root tree)))
+ (if node
+ (+ 1
+ (max (loop (node-left node))
+ (loop (node-right node))))
+ 0))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
+
+(define (rb-tree/size tree)
+ (guarantee-rb-tree tree 'RB-TREE/SIZE)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((node (tree-root tree)))
+ (if node
+ (+ 1
+ (loop (node-left node))
+ (loop (node-right node)))
+ 0))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
+
+(define (rb-tree/empty? tree)
+ (guarantee-rb-tree tree 'RB-TREE/EMPTY?)
+ (not (tree-root tree)))
+
(define (rb-tree/equal? x y datum=?)
- (let ((key=? (tree-key=? x)))
- (and (eq? key=? (tree-key=? y))
- (let loop ((nx (first-node x)) (ny (first-node y)))
- (if (not nx)
- (not ny)
- (and ny
- (key=? (node-key nx) (node-key ny))
- (datum=? (node-datum nx) (node-datum ny))
- (loop (next-node nx) (next-node ny))))))))
+ (guarantee-rb-tree x 'RB-TREE/EQUAL?)
+ (guarantee-rb-tree y 'RB-TREE/EQUAL?)
+ (let ((key=? (tree-key=? x))
+ (interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (and (eq? key=? (tree-key=? y))
+ (let loop ((nx (first-node x)) (ny (first-node y)))
+ (if (not nx)
+ (not ny)
+ (and ny
+ (key=? (node-key nx) (node-key ny))
+ (datum=? (node-datum nx) (node-datum ny))
+ (loop (next-node nx) (next-node ny))))))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
(define (rb-tree->alist tree)
- (let loop ((node (first-node tree)))
- (if node
- (cons (cons (node-key node) (node-datum node))
- (loop (next-node node)))
- '())))
+ (guarantee-rb-tree tree 'RB-TREE->ALIST)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((node (first-node tree)))
+ (if node
+ (cons (cons (node-key node) (node-datum node))
+ (loop (next-node node)))
+ '()))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
+
+(define (rb-tree/key-list tree)
+ (guarantee-rb-tree tree 'RB-TREE/KEY-LIST)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((node (first-node tree)))
+ (if node
+ (cons (node-key node) (loop (next-node node)))
+ '()))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
+
+(define (rb-tree/datum-list tree)
+ (guarantee-rb-tree tree 'RB-TREE/DATUM-LIST)
+ (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
+ (let ((result
+ (let loop ((node (first-node tree)))
+ (if node
+ (cons (node-datum node) (loop (next-node node)))
+ '()))))
+ (set-interrupt-enables! interrupt-mask)
+ result)))
(define (first-node tree)
(and (tree-root tree)
- (leftmost-node (tree-root tree))))
+ (let loop ((x (tree-root tree)))
+ (if (node-left x)
+ (loop (node-left x))
+ x))))
(define (next-node x)
(if (node-right x)
- (leftmost-node (node-right x))
+ (let loop ((x (node-right x)))
+ (if (node-left x)
+ (loop (node-left x))
+ x))
(let loop ((x x))
(let ((y (node-up x)))
(if (and y (eq? x (node-right y)))
(loop y)
- y)))))
-
-(define (leftmost-node x)
- (if (node-left x)
- (leftmost-node (node-left x))
- x))
-
-(define (rb-tree/height tree)
- (let loop ((node (tree-root tree)))
- (if node
- (+ 1
- (max (loop (node-left node))
- (loop (node-right node))))
- 0)))
-
-(define (rb-tree/size tree)
- (let loop ((node (tree-root tree)))
- (if node
- (+ 1
- (loop (node-left node))
- (loop (node-right node)))
- 0)))
-
-(define (rb-tree/empty? tree)
- (not (tree-root tree)))
\ No newline at end of file
+ y)))))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 26cca6e1a..23751390c 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.196 1993/10/05 07:16:21 cph Exp $
+$Id: runtime.pkg,v 14.197 1993/10/06 21:17:13 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
@@ -2543,11 +2543,13 @@ MIT in each case. |#
alist->rb-tree
rb-tree->alist
rb-tree/copy
+ rb-tree/datum-list
rb-tree/delete!
rb-tree/empty?
rb-tree/equal?
rb-tree/height
rb-tree/insert!
+ rb-tree/key-list
rb-tree/lookup
rb-tree/size
rb-tree?
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 26cca6e1a..23751390c 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.196 1993/10/05 07:16:21 cph Exp $
+$Id: runtime.pkg,v 14.197 1993/10/06 21:17:13 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
@@ -2543,11 +2543,13 @@ MIT in each case. |#
alist->rb-tree
rb-tree->alist
rb-tree/copy
+ rb-tree/datum-list
rb-tree/delete!
rb-tree/empty?
rb-tree/equal?
rb-tree/height
rb-tree/insert!
+ rb-tree/key-list
rb-tree/lookup
rb-tree/size
rb-tree?
--
2.25.1