prescheme-demo/btree.scm

;;; btree: an example recursive Pre-Scheme record type

;; NOTE: Records are really pointers to a struct, so the recursive use
;; of btree-node below means the struct contains two pointer fields and
;; an integer.  The constructor allocates and returns a pointer.
(define-record-type btree-node :btree-node
  (make-btree left right value)
  (left  btree-node btree-left)
  (right btree-node btree-right)
  (value integer    btree-value))

;; XXX: Records can't be created at top-level; "no evaluator for MAKE-RECORD"
;; (define bnull (make-btree null-pointer null-pointer 0))

(define (btree-equal? a b)
  (or (eq? a b)
      (and (= (btree-value a) (btree-value b))
           (btree-equal? (btree-left a) (btree-left b))
           (btree-equal? (btree-right a) (btree-right b)))))

(define (deallocate-btree t)
  (if (not (null-pointer? (btree-left t)))
      (deallocate-btree (btree-left t)))
  (if (not (null-pointer? (btree-right t)))
      (deallocate-btree (btree-right t)))
  (deallocate t))

(define (main)
  (define out (current-output-port))
  (define null (null-pointer))

  (let* ((a1 (make-btree null null 6))
         (b1 (make-btree null null 5))
         (c1 (make-btree a1 b1 4))
         (a2 (make-btree null null 6))
         (b2 (make-btree null null 5))
         (c2 (make-btree a2 b2 4)))
    (cond ((btree-equal? c1 c2)
           (write-string "trees are equal\n" out))
          (else
           (write-string "trees are not equal\n" out)))
    (deallocate-btree c1)
    (deallocate-btree c2))

  0)