From 9fdb0ac50780a8a37470788acb0544ab62135240 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 27 Aug 2012 15:12:53 -0600
Subject: [PATCH] correct cut implementation without mutation

---
 collects/racklog/racklog.rkt | 33 ++++++++++++++++-----------------
 collects/racklog/unify.rkt   | 17 ++++++++++++++---
 2 files changed, 30 insertions(+), 20 deletions(-)

diff --git a/collects/racklog/racklog.rkt b/collects/racklog/racklog.rkt
index 511d368ae8..e2b8795c84 100644
--- a/collects/racklog/racklog.rkt
+++ b/collects/racklog/racklog.rkt
@@ -53,26 +53,25 @@
     ((%rel (v ...) ((a ...) subgoal ...) ...)
      (lambda __fmls
        (lambda (fail-relation)
-         (define cut? #f)
          (let/racklog-cc 
           __sk
           (%let (v ...)
-                (begin
-                  (let/racklog-cc 
-                   fail-case
-                   (define fail-unify
-                     ((%= __fmls (list a ...))
-                      fail-case))
-                   (define this-! 
-                     (lambda (fk1) 
-                       (set! cut? #t)
-                       fail-unify))
-                   (syntax-parameterize 
-                       ([! (make-rename-transformer #'this-!)])
-                     (__sk 
-                      ((%and subgoal ...) fail-unify))))
-                  (when cut?
-                    (fail-relation 'fail)))
+                (let/racklog-cc 
+                 fail-case
+                 (define-values
+                   (unify-cleanup fail-unify)
+                   ((inner-unify __fmls (list a ...))
+                    fail-case))
+                 (define this-! 
+                   (lambda (fk1) 
+                     (λ (fk2)
+                       (unify-cleanup)
+                       (fail-relation 'fail))))
+                 (syntax-parameterize 
+                     ([! (make-rename-transformer #'this-!)])
+                   (__sk 
+                    ((%and subgoal ...) 
+                     fail-unify))))
                 ...
                 (fail-relation 'fail))))))))
 
diff --git a/collects/racklog/unify.rkt b/collects/racklog/unify.rkt
index 7c4e73d252..85b2f4805a 100644
--- a/collects/racklog/unify.rkt
+++ b/collects/racklog/unify.rkt
@@ -427,9 +427,18 @@
      [(? atom? y) (eqv? x y)])]))
 
 (define (unify t1 t2)
+  (define iu (inner-unify t1 t2))
+  (λ (fk)
+    (define-values (cleanup k)
+      (iu fk))
+    k))
+
+(define (inner-unify t1 t2)
   (lambda (fk)
+    (define (cleanup s)
+      (for-each unbind-ref! s))
     (define (cleanup-n-fail s)
-      (for-each unbind-ref! s)
+      (cleanup s)
       (fk 'fail))
     (define (unify1 t1 t2 s)
       (cond [(eqv? t1 t2) s]
@@ -490,8 +499,10 @@
             [else
              (cleanup-n-fail s)]))
     (define s (unify1 t1 t2 empty))
-    (lambda (d)
-      (cleanup-n-fail s))))
+    (values
+     (λ () (cleanup s))
+     (lambda (d)
+       (cleanup-n-fail s)))))
 
 (define-syntax-rule (or* x f ...)
   (or (f x) ...))