Start working on generic BST backend for dictionaries and sets.

src/util-bst.scm

@@ -0,0 +1,69 @@
+
+(declare (unit util-bst))
+
+(import duck)
+
+(module*
+ util-bst
+ #:doc ("Binary Search Tree implementation")
+ (
+  make-bst
+  bst?
+
+  bst-empty?
+  ;;bst-ref
+  ;;bst-contains?
+
+  ;;bst-set
+  ;;bst-remove ;;
+
+  ;;bst->kvv
+  ;;kvv->bst
+  ;;kvv-filter
+  
+  ;;bst-balance
+  )
+
+ (import scheme
+	 util-tag
+	 testing)
+
+ ;; Unique tags
+ (define TAG-BST (make-tag 'bst))
+ (define TAG-KVV (make-tag 'kvv))
+
+ (define/doc (make-bst subtag EQ? <?)
+   ("Creates empty BST with given comparators")
+   (cons TAG-BST
+	 (cons (cons #f 0)
+	       (cons subtag
+		     (cons EQ? <?)))))
+
+ ;; BST accessors
+ (define bst-tag car)
+ (define bst-root+count cadr)
+ (define bst-root caadr)
+ (define bst-count cdadr)
+ (define bst-type cddr)
+ (define bst-subtag caddr)
+ (define bst-comparators cdddr)
+ (define bst-EQ? cadddr)
+ (define bst-<? cddddr)
+
+ (define/doc ((bst? subtag) v)
+   ("Curried predicate for particular bst type.")
+   (and (pair? v)
+	(eq? (bst-tag v) TAG-BST)
+	(eq? (bst-subtag v) subtag)))
+
+ (define/doc (bst-empty? bst)
+   ("Returns #t if given BST is empty.")
+   (not (bst-root bst)))
+
+ ;; Module self-tests
+ (define (util-bst-tests!)
+   (run-tests
+    util-bst
+    ))
+
+ )