             (add-slot-constraint-test (slot)
               (join-node-add-test join-node
                                   (make-predicate-test
-diff -Nurp lisa_ORIGINAL/src/rete/reference/rete-compiler.lisp~ lisa/src/rete/reference/rete-compiler.lisp~
---- lisa_ORIGINAL/src/rete/reference/rete-compiler.lisp~	1969-12-31 16:00:00.000000000 -0800
-+++ lisa/src/rete/reference/rete-compiler.lisp~	2008-02-19 08:25:28.093750000 -0800
-@@ -0,0 +1,239 @@
-+;;; This file is part of LISA, the Lisp-based Intelligent Software
-+;;; Agents platform.
-+
-+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
-+
-+;;; This library is free software; you can redistribute it and/or
-+;;; modify it under the terms of the GNU Lesser General Public License
-+;;; as published by the Free Software Foundation; either version 2.1
-+;;; of the License, or (at your option) any later version.
-+
-+;;; This library is distributed in the hope that it will be useful,
-+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-+;;; GNU Lesser General Public License for more details.
-+
-+;;; You should have received a copy of the GNU Lesser General Public License
-+;;; along with this library; if not, write to the Free Software
-+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
-+
-+;;; File: rete-compiler.lisp
-+;;; Description:
-+
-+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
-+
-+(in-package "LISA")
-+
-+(defvar *root-nodes* nil)
-+(defvar *rule-specific-nodes* nil)
-+(defvar *leaf-nodes* nil)
-+(defvar *logical-block-marker*)
-+
-+(declaim (inline set-leaf-node leaf-node left-input right-input logical-block-marker))
-+
-+(defun set-leaf-node (node address)
-+  (setf (aref *leaf-nodes* address) node))
-+
-+(defun leaf-node ()
-+  (aref *leaf-nodes* (1- (length *leaf-nodes*))))
-+
-+(defun left-input (address)
-+  (aref *leaf-nodes* (1- address)))
-+
-+(defun right-input (address)
-+  (aref *leaf-nodes* address))
-+
-+(defun logical-block-marker ()
-+  *logical-block-marker*)
-+  
-+(defclass rete-network ()
-+  ((root-nodes :initform (make-hash-table)
-+               :initarg :root-nodes
-+               :reader rete-roots)
-+   (node-test-cache :initform (make-hash-table :test #'equal)
-+                    :initarg :node-test-cache
-+                    :reader node-test-cache)))
-+
-+(defun record-node (node parent)
-+  (when (typep parent 'shared-node)
-+    (increment-use-count parent))
-+  (push (make-node-pair node parent) *rule-specific-nodes*)
-+  node)
-+
-+(defmethod remove-node-from-parent ((self rete-network) (parent t) child)
-+  (remhash (node1-test child) (rete-roots self)))
-+
-+(defmethod remove-node-from-parent ((self rete-network) 
-+                                    (parent shared-node) child)
-+  (remove-successor parent child))
-+
-+(defun make-root-node (class)
-+  (let* ((test (make-class-test class))
-+         (root (gethash test *root-nodes*)))
-+    (when (null root)
-+      (setf root (make-node1 test))
-+      (setf (gethash test *root-nodes*) root))
-+    (record-node root t)))
-+
-+(defmethod add-successor ((parent t) new-node connector)
-+  (declare (ignore connector))
-+  new-node)
-+
-+(defmethod add-successor :around ((parent shared-node) new-node connector)
-+  (declare (ignore new-node connector))
-+  (record-node (call-next-method) parent))
-+
-+(defun make-intra-pattern-node (slot)
-+  (let ((test
-+         (cond ((simple-slot-p slot)
-+                (make-simple-slot-test slot))
-+               ((constrained-slot-p slot)
-+                (make-intra-pattern-constraint-test slot))
-+               (t
-+                (make-intra-pattern-test slot)))))
-+    (make-node1 test)))
-+
-+(defun distribute-token (rete-network token)
-+  (loop for root-node being the hash-values 
-+      of (rete-roots rete-network)
-+      do (accept-token root-node token)))
-+
-+(defmethod make-rete-network (&rest args &key &allow-other-keys)
-+  (apply #'make-instance 'rete-network args))
-+
-+;;; The following functions serve as "connectors" between any two
-+;;; nodes. PASS-TOKEN connects two pattern (one-input) nodes, or a join node 
-+;;; to a terminal node; ENTER-JOIN-NETWORK-FROM-LEFT connects a pattern node
-+;;; to a join node; ENTER-JOIN-NETWORK-FROM-RIGHT also connects a pattern node
-+;;; to a join node; both PASS-TOKENS-ON-LEFT and PASS-TOKEN-ON-RIGHT connect
-+;;; two join nodes.
-+
-+(defun pass-token (node token)
-+  (accept-token node token))
-+
-+(defun pass-tokens-on-left (node2 tokens)
-+  (accept-tokens-from-left node2 tokens))
-+
-+(defun pass-token-on-right (node2 token)
-+  (accept-token-from-right node2 token))
-+
-+(defun enter-join-network-from-left (node2 tokens)
-+  (pass-tokens-on-left node2 (replicate-token tokens)))
-+
-+(defun enter-join-network-from-right (node2 token)
-+  (pass-token-on-right node2 (replicate-token token)))
-+
-+;;; end connector functions
-+
-+(defun add-intra-pattern-nodes (patterns)
-+  "The alpha memory nodes and tests"
-+  (dolist (pattern patterns)
-+    (cond ((test-pattern-p pattern)
-+           (set-leaf-node t (parsed-pattern-address pattern)))
-+          (t
-+           (let ((node
-+                  (make-root-node (parsed-pattern-class pattern)))
-+                 (address (parsed-pattern-address pattern)))
-+             (set-leaf-node node address)
-+             (dolist (slot (parsed-pattern-slots pattern))
-+               (when (intra-pattern-slot-p slot)
-+                 (setf node
-+                   (add-successor node (make-intra-pattern-node slot)
-+                                  #'pass-token))
-+                 (set-leaf-node node address))))))))
-+
-+(defun add-join-node-tests (join-node pattern)
-+  (labels ((add-simple-join-node-test (slot)
-+             (unless (= (binding-address (pattern-slot-slot-binding slot))
-+                        (parsed-pattern-address pattern))
-+               (add-slot-filter join-node slot)))
-+           (add-slot-constraint-test (slot)
-+             (join-node-add-test join-node
-+                                 (make-predicate-test
-+                                  (pattern-slot-constraint slot)
-+                                  (pattern-slot-constraint-bindings slot)
-+                                  (negated-slot-p slot))))
-+           (add-test-pattern-predicate ()
-+             (join-node-add-test join-node
-+                                 (make-predicate-test
-+                                  (parsed-pattern-test-forms pattern)
-+                                  (parsed-pattern-test-bindings pattern))))
-+           (add-generic-pattern-tests ()
-+             (dolist (slot (parsed-pattern-slots pattern))
-+               (cond ((simple-bound-slot-p slot)
-+                      (add-simple-join-node-test slot))
-+                     ((constrained-slot-p slot)
-+                      (add-slot-constraint-test slot))))))
-+    (if (test-pattern-p pattern)
-+        (add-test-pattern-predicate)
-+      (add-generic-pattern-tests))
-+    join-node))
-+
-+(defun make-join-node (pattern)
-+  (let ((join-node
-+         (cond ((negated-pattern-p pattern)
-+                (make-node2-not))
-+               ((test-pattern-p pattern)
-+                (make-node2-test))
-+               ((existential-pattern-p pattern)
-+                (make-node2-exists))
-+               (t (make-node2)))))
-+    (when (eql (parsed-pattern-address pattern) (logical-block-marker))
-+      (mark-as-logical-block join-node (logical-block-marker)))
-+    join-node))
-+
-+(defun make-left-join-connection (join-node node)
-+  (if (typep node 'shared-node)
-+      (add-successor node join-node #'enter-join-network-from-left)
-+    (add-successor node join-node #'pass-tokens-on-left))
-+  join-node)
-+
-+(defun make-right-join-connection (join-node node)
-+  (if (typep node 'shared-node)
-+      (add-successor node join-node #'enter-join-network-from-right)
-+    (add-successor node join-node #'pass-token-on-right))
-+  join-node)
-+
-+(defun add-inter-pattern-nodes (patterns)
-+  "The beta memory nodes and tests"
-+  (dolist (pattern (rest patterns))
-+    (let ((join-node (make-join-node pattern))
-+          (address (parsed-pattern-address pattern)))
-+      (add-join-node-tests join-node pattern)
-+      (make-left-join-connection join-node (left-input address))
-+      (make-right-join-connection join-node (right-input address))
-+      (set-leaf-node join-node address))))
-+
-+(defun add-terminal-node (rule)
-+  (add-successor (leaf-node) (make-terminal-node rule) #'pass-token))
-+
-+;;; addresses a problem reported by Andrew Philpot on 9/6/2007
-+(defun copy-node-test-table (src) src) 
-+;;;;   (let ((target (make-hash-table :test #'equal)))
-+;;;;     (maphash (lambda (key value)
-+;;;;                (setf (gethash key target) value))
-+;;;;              src)
-+;;;;     target))
-+
-+(defun compile-rule-into-network (rete-network patterns rule)
-+  (let ((*root-nodes* (rete-roots rete-network))
-+        (*rule-specific-nodes* (list))
-+        (*leaf-nodes* (make-array (length patterns)))
-+        (*logical-block-marker* (rule-logical-marker rule))
-+        (*node-test-table* (node-test-cache rete-network)))
-+    (add-intra-pattern-nodes patterns)
-+    (add-inter-pattern-nodes patterns)
-+    (add-terminal-node rule)
-+    (attach-rule-nodes rule (nreverse *rule-specific-nodes*))
-+    (setf (slot-value rete-network 'root-nodes) *root-nodes*)
-+    rete-network))
-+
-+(defun merge-rule-into-network (to-network patterns rule &key (loader nil))
-+  (let ((from-network
-+         (compile-rule-into-network
-+          (make-rete-network :node-test-cache (copy-node-test-table (node-test-cache to-network)))
-+          patterns rule)))
-+    (when loader
-+      (funcall loader from-network))
-+    (attach-rule-nodes rule (merge-networks from-network to-network))
-+    to-network))
+@@ -209,12 +208,12 @@
+   (add-successor (leaf-node) (make-terminal-node rule) #'pass-token))
+ 
+ ;;; addresses a problem reported by Andrew Philpot on 9/6/2007
+-(defun copy-node-test-table (src)
+-  (let ((target (make-hash-table :test #'equal)))
+-    (maphash (lambda (key value)
+-               (setf (gethash key target) value))
+-             src)
+-    target))
++(defun copy-node-test-table (src) src)
++;  (let ((target (make-hash-table :test #'equal)))
++;    (maphash (lambda (key value)
++;               (setf (gethash key target) value))
++;             src)
++;    target))
+ 
+ (defun compile-rule-into-network (rete-network patterns rule)
+   (let ((*root-nodes* (rete-roots rete-network))

+(defun hash-values-to-list (ht)
+  (loop for v being the hash-values of ht collect v))
+
diff -Nurp lisa_ORIGINAL/src/rete/reference/inter-pattern-filter.lisp~ lisa/src/rete/reference/inter-pattern-filter.lisp~
--- lisa_ORIGINAL/src/rete/reference/inter-pattern-filter.lisp~	1969-12-31 16:00:00.000000000 -0800
+++ lisa/src/rete/reference/inter-pattern-filter.lisp~	2008-02-20 15:42:51.937500000 -0800
@@ -0,0 +1,204 @@
+
+;;; Copyright (C) 2008 Aneil Mallavarapu
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; File: inter-pattern-filter.lisp
+
+(in-package "LISA")
+
+(defstruct (inter-pattern-filter (:constructor %make-inter-pattern-filter))
+  left-slot-name   ; = binding-slot-name
+  left-address     ; = binding-address
+  right-slot-name  ; = pattern-slot-name
+  ;; left/right-value-memories store hash-tables of tokens which match a particular value
+  ;; value memories are hash-tables where
+  ;;    key = slot-value, 
+  ;;    value = hash-table storing tokens (key=token-hash-code, value=token)
+  (negated nil)
+  (left-value-memory (make-hash-table :test #'equal))  
+  (right-value-memory (make-hash-table :test #'equal)))
+
+(defun make-inter-pattern-filter (slot)
+  (let ((binding (pattern-slot-slot-binding slot)))
+    (%make-inter-pattern-filter 
+     :left-slot-name (binding-slot-name binding)
+     :left-address (binding-address binding)
+     :right-slot-name (pattern-slot-name slot)
+     :negated (pattern-slot-negated slot))))
+;;;
+;;; LEFT/RIGHT-LOOKUPS: 
+;;; 
+(defun inter-pattern-filter-left-lookup (self right-token)
+  "Returns a hash-table of left-tokens which match the right-token for this slot-pattern binding"
+ (let* ((left-value-memory      (inter-pattern-filter-left-value-memory self))
+        (right-slot-name  (inter-pattern-filter-right-slot-name self))
+        (right-fact       (token-top-fact right-token))
+        (right-slot-value (get-slot-value right-fact right-slot-name)))
+
+   (cond
+    ((inter-pattern-filter-negated self)  (not-lookup left-value-memory right-slot-value))
+    (t                                    (get-token-memory left-value-memory right-slot-value)))))
+
+           
+(defun inter-pattern-filter-right-lookup (self left-tokens)
+  "Returns a hash-table of right-tokens which match the left-tokens for this slot-pattern binding"
+  (let* ((right-value-memory (inter-pattern-filter-right-value-memory self))
+         (left-slot-name     (inter-pattern-filter-left-slot-name self))
+         (left-fact          (token-find-fact left-tokens (inter-pattern-filter-left-address self)))
+         (left-slot-value    (get-slot-value left-fact left-slot-name)))
+    (cond
+     ((inter-pattern-filter-negated self)  (not-lookup right-value-memory left-slot-value))
+     (t                                    (get-token-memory right-value-memory left-slot-value)))))
+
+;;;
+;;; NOT handling:
+;;;
+(defun not-lookup (value-memory value)
+  "Returns a hash-table which contains an intersection of all tokens which do not match VALUE"
+  (let ((newht (copy-hash-table value-memory)))
+    ;; remove tokens which matching VALUE
+    (remhash value newht) 
+    ;; merge the remaining value memories
+    (apply #'merge-hash-tables nil (hash-values-to-list newht))))
+        
+(defun not-value-remove-token (value-memory value token)
+  "Removes TOKEN from all token memories which do not match VALUE"
+  (loop for k being the hash-keys of value-memory
+        for token-memory being the hash-values of value-memory
+        unless (equal k value)
+        do (forget-token token-memory token)))
+
+;;;
+;;; TOKEN-MEMORY - a value memory stores all tokens matching a particular value
+;;;                it is a hash-table mapping token-hash-codes to tokens
+;;;
+(defun inter-pattern-filter-left-token-memory (self value)
+  (get-token-memory (inter-pattern-filter-left-value-memory self) value))
+
+(defun inter-pattern-filter-right-token-memory (self value)
+  (get-token-memory (inter-pattern-filter-right-value-memory self) value))
+
+(defun get-token-memory (value-memory value)
+  (or (gethash value value-memory)
+      (setf (gethash value value-memory) (make-hash-table :test #'equal))))
+
+;;;
+;;; ADD LEFT/RIGHT TOKENS:
+;;;
+(defun inter-pattern-filter-add-left-tokens (self left-tokens)
+  (let* ((left-slot-name (inter-pattern-filter-left-slot-name self))
+         (fact           (token-find-fact left-tokens 
+                                          (inter-pattern-filter-left-address self)))
+         (value          (get-slot-value fact left-slot-name)))
+    (remember-token (inter-pattern-filter-left-token-memory self value)
+                    left-tokens)))
+
+(defun inter-pattern-filter-add-right-token (self right-token)
+  (let* ((right-slot-name  (inter-pattern-filter-right-slot-name self))
+         (fact             (token-top-fact right-token))
+         (value            (get-slot-value fact right-slot-name)))
+    (remember-token (inter-pattern-filter-right-token-memory self value)
+                    right-token)))
+
+;;;
+;;; REMOVE LEFT/RIGHT TOKENS:
+;;;
+
+(defun inter-pattern-filter-remove-left-tokens (self left-tokens)
+  (let* ((left-slot-name (inter-pattern-filter-left-slot-name self))
+         (fact           (token-find-fact left-tokens 
+                                          (inter-pattern-filter-left-address self)))
+         (value          (get-slot-value fact left-slot-name)))
+    (cond 
+     ((inter-pattern-filter-negated self) 
+      (not-value-remove-token (inter-pattern-filter-left-value-memory self)
+                              value
+                              left-tokens))
+     (t (forget-token (inter-pattern-filter-left-token-memory self value)
+                      left-tokens)))))
+
+(defun inter-pattern-filter-remove-right-token (self right-token)
+  (let* ((right-slot-name  (inter-pattern-filter-right-slot-name self))
+         (fact             (token-top-fact right-token))
+         (value            (get-slot-value fact right-slot-name)))
+    (cond
+     ((inter-pattern-filter-negated self)
+      (not-value-remove-token (inter-pattern-filter-right-value-memory self)
+                              value
+                              right-token))
+     (t (forget-token (inter-pattern-filter-right-token-memory self value)
+                      right-token)))))
+
+(defun inter-pattern-filter-left-size (self)
+  (value-memory-size (inter-pattern-filter-left-value-memory self)))
+
+(defun inter-pattern-filter-right-size (self)
+  (value-memory-size (inter-pattern-filter-right-value-memory self)))
+
+(defun value-memory-size (value-memory)
+  (hash-table-count 
+   (merge-hash-tables 
+    nil 
+    (hash-values-to-list value-memory))))
+
+(defmethod left-value-memory-count ((self inter-pattern-filter))
+  (inter-pattern-filter-left-size self))
+
+(defmethod right-value-memory-count ((self inter-pattern-filter))
+  (inter-pattern-filter-right-size self))
+
+(defun inter-pattern-filter-clear-memories (self)
+  (clrhash (inter-pattern-filter-left-value-memory self))
+  (clrhash (inter-pattern-filter-right-value-memory self)))
+
+;;;
+;;; HASH-TABLE utils:
+;;;
+
+(defun merge-hash-tables (&optional result &rest hash-tables)
+  "Copies the contents of hash-tables into RESULT.  
+   If argument RESULT is NIL, a new hash-table is created"
+  (flet ((hash-table-merge (ht1 ht2) ; merge ht2 into ht1
+           (copy-hash-table ht2 ht1)))
+    (reduce #'hash-table-merge 
+            (list* 
+             (or result
+                 (make-hash-table :test (if hash-tables
+                                            (hash-table-test (first hash-tables))
+                                            #'equal)))
+             hash-tables))))
+
+(defun copy-hash-table (ht1 &optional ht2)
+  "Copies hash-table HT1 - optionally to a user-provided hash-table, HT2"
+  (loop with result = (or ht2 (make-hash-table :test (hash-table-test ht1)))
+        for k being the hash-keys of ht1
+        for v being the hash-values of ht1
+        do (setf (gethash k result) v)
+        finally (return result)))
+
+(defun intersect-hash-table-keys (ht1 ht2)
+  "Creates a new hash-table with keys representing the intersection of keys from HT1 and HT2,
+   and the corresponding values of HT1."
+  (loop with newht = (make-hash-table :test (hash-table-test ht1))
+        for k being the hash-keys of ht1
+        for v being the hash-values of ht1
+        when (gethash k ht2)
+        do (setf (gethash k newht) v)
+        finally (return newht)))
+
+(defun hash-values-to-list (ht)
+  (loop for v being the hash-values of ht collect v))
+
diff -Nurp lisa_ORIGINAL/src/rete/reference/inter-pattern-test.lisp~ lisa/src/rete/reference/inter-pattern-test.lisp~
--- lisa_ORIGINAL/src/rete/reference/inter-pattern-test.lisp~	1969-12-31 16:00:00.000000000 -0800
+++ lisa/src/rete/reference/inter-pattern-test.lisp~	2008-02-17 02:40:22.781250000 -0800
@@ -0,0 +1,117 @@
+;;; This file is part of LISA, the Lisp-based Intelligent Software
+;;; Agents platform.
+
+;;; Copyright (C) 2000 David E. Young (de.young@computer.org)
+
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public License
+;;; as published by the Free Software Foundation; either version 2.1
+;;; of the License, or (at your option) any later version.
+
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Lesser General Public License for more details.
+
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; File: node2.lisp
+;;; Description:
+
+;;; $Id: lisa3_2-inter-pattern-filter.patch,v 1.1 2008/03/07 23:47:27 amallavarapu Exp $
+
+(in-package "LISA")
+
+(defstruct (inter-pattern-test (:constructor %make-inter-pattern-test))
+  slot-name binding-slot-name binding-address negated-p
+  ;; memories store all tokens which match a particular value
+  ;; implemented as hash-tables where key = slot-value, value = list of facts
+  (negated nil)
+  (left-memory (make-hash-table :test #'equal)) 
+  (right-memory (make-hash-table :test #'equalp)))
+
+;;;
+;;; LEFT/RIGHT-LOOKUPS: 
+;;;
+(defun inter-pattern-test-left-lookup (self right-token)
+  "Returns a list of left-tokens which match the right-token for this slot-pattern binding"
+ (let* ((left-memory      (inter-pattern-test-left-memory self))
+        (right-slot-name  (inter-pattern-test-slot-name self))
+        (fact             (token-top-fact right-token)))
+   (gethash (get-slot-value fact right-slot-name) 
+            left-memory)))
+
+(defun inter-pattern-test-right-lookup (self left-tokens)
+  "Returns a list of right-tokens which match the left-tokens for this slot-pattern binding"
+  (let* ((right-memory      (inter-pattern-test-right-memory self))
+         (left-slot-name    (inter-pattern-test-binding-slot-name self))
+         (left-fact         (token-find-fact left-tokens (inter-pattern-test-binding-address self))))
+    (gethash (get-slot-value left-fact left-slot-name)
+             right-memory))))
+
+;;;
+;;; ADD LEFT/RIGHT TOKENS:
+;;;
+(defun inter-pattern-test-add-left-tokens (self left-tokens)
+  (let* ((left-slot-name (inter-pattern-test-binding-slot-name self))
+         (left-memory    (inter-pattern-test-left-memory self))
+         (fact           (token-find-fact left-tokens 
+                                          (inter-pattern-test-binding-address self)))
+         (value          (get-slot-value fact left-slot-name)))
+    (push left-tokens (gethash value left-memory))))
+
+(defun inter-pattern-test-add-right-token (self right-token)
+  (let* ((right-slot-name  (inter-pattern-test-slot-name self))
+         (right-memory     (inter-pattern-test-right-memory self))
+         (fact             (token-top-fact right-token))
+         (value            (get-slot-value fact right-slot-name)))
+    (push right-token (gethash value right-memory))))
+
+;;;
+;;; REMOVE LEFT/RIGHT TOKENS:
+;;;
+
+(defun inter-pattern-test-remove-left-tokens (self left-tokens)
+  (let* ((left-slot-name (inter-pattern-test-binding-slot-name self))
+         (left-memory    (inter-pattern-test-left-memory self))
+         (fact           (token-find-fact left-tokens 
+                                          (inter-pattern-test-binding-address self)))
+         (value          (get-slot-value fact left-slot-name)))
+    (setf (gethash value left-memory)
+          (remove left-tokens (gethash value left-memory)
+                  :key #'token-hash-code
+                  :test #'equal))))
+
+
+(defun inter-pattern-test-remove-right-token (self right-token)
+  (let* ((right-slot-name  (inter-pattern-test-slot-name self))
+         (right-memory     (inter-pattern-test-right-memory self))
+         (fact             (token-top-fact right-token))
+         (value            (get-slot-value fact right-slot-name)))
+    (setf (gethash value right-memory)
+          (remove right-token (gethash value right-memory)
+                  :key #'token-hash-code
+                  :test #'equal))))
+
+(defun inter-patter-test-clear-memories (self)
+  (clrhash (inter-pattern-test-left-memory self))
+  (clrhash (inter-pattern-test-right-memory self)))
+
+(defun inter-pattern-test-left-size (iptest)
+  (hash-table-count (inter-pattern-test-left-memory iptest)))
+
+(defun inter-pattern-test-right-size (iptest)
+  (hash-table-count (inter-pattern-test-left-memory iptest)))
+
+(defmethod left-memory-count ((self inter-pattern-test))
+  (hash-table-count (inter-pattern-test-left-memory self)))
+
+
+(defmethod right-memory-count ((self inter-pattern-test))
+  (hash-table-count (inter-pattern-test-right-memory self)))
+
+(defun inter-pattern-test-clear-memories (self)
+  (clrhash (inter-pattern-test-left-memory self))
+  (clrhash (inter-pattern-test-right-memory self)))
\ No newline at end of file
diff -Nurp lisa_ORIGINAL/src/rete/reference/join-node.lisp lisa/src/rete/reference/join-node.lisp
--- lisa_ORIGINAL/src/rete/reference/join-node.lisp	2007-09-11 14:14:10.000000000 -0700
+++ lisa/src/rete/reference/join-node.lisp	2008-02-20 16:05:45.734375000 -0800
@@ -60,11 +60,11 @@
 (defun remove-token-from-right-memory (join-node token)
   (forget-token (join-node-right-memory join-node) token))

Index: lisa.asd
===================================================================
RCS file: /cvsroot/lisa/lisa/lisa.asd,v
retrieving revision 1.7
diff -u -r1.7 lisa.asd
--- lisa.asd	11 Sep 2007 21:14:07 -0000	1.7
+++ lisa.asd	6 Jun 2008 16:25:14 -0000
@@ -100,7 +100,8 @@
                (:module rete
                         :pathname "rete/reference/"
