1 (defun make-tree (entry left right)
2   (list entry left right))
3 (defun make-leaf (entry)
4   (list entry nil nil))
5 (defun entry (tree)
6   (car tree))
7 (defun set-entry! (tree ent)
8   (setf (car tree) ent))
9 (defun left-branch (tree)
10   (cadr tree))
11 (defun set-left-branch! (tree lb)
12   (setf (cadr tree) lb))
13 (defun right-branch (tree)
14   (caddr tree))
15 (defun set-right-branch! (tree rb)
16   (setf (caddr tree) rb))
17 (defun make-record (key data)
18   (list key data))
19 (defun key (record)
20   (car record))
21 (defun data (record)
22   (cadr record))
23 
24 (defun make-table (&key (<? #'<))
25   (let ((local-table (cons '*head* nil)))
26     (labels ((tree-root ()
27 	       (cdr local-table))
28 	     (set-tree-root! (node)
29 	       (setf (cdr local-table) node))
30 	     (node-lookup (key node)
31 	       (if (null node)
32 		   nil
33 		   (let* ((cur-entry (entry node))
34 			  (cur-key (key cur-entry)))
35 		     (cond ((funcall <? key cur-key)
36 			    (node-lookup
37 			     key
38 			     (left-branch node)))
39 			   ((funcall <? cur-key key)
40 			    (node-lookup
41 			     key
42 			     (right-branch node)))
43 			   (t ; equal
44 			    cur-entry)))))
45 	     (lookup (key)
46 	       (node-lookup key (cdr local-table)))
47 	     (node-insert (key data node)
48 	       (let* ((cur-entry (entry node))
49 		      (cur-key (key cur-entry)))
50 		 (cond ((funcall <? key cur-key)
51 			(if if (null (left-branch node))
52 			    (set-left-branch!
53 			     node
54 			     (make-leaf
55 			      (make-record key data)))
56 			    (node-insert
57 			     key data (left-branch node))))
58 		       ((funcall <? cur-key key)
59 			(if (null (right-branch node))
60 			    (set-right-branch!
61 			     node
62 			     (make-leaf
63 			      (make-record key data)))
64 			    (node-insert
65 			     key data (right-branch node))))
66 		       (t ;equal
67 			(set-entry!
68 			 node (make-record key data))))))
69 	     (insert! (key data)
70 	       (if (null (tree-root))
71 		   (set-tree-root!
72 		    (make-leaf (make-record key data)))
73 		   (node-insert key data (tree-root))))
74 	     (dispatch (m)
75 	       (case m
76 		 ('lookup-proc #'lookup)
77 		 ('insert-proc! #'insert!)
78 		 (otherwise (error "Bad dispatch ~a" m)))))
79       #'dispatch)))
80