From 3ddaf5e32b817332dd560299a88f46117acef2c5 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Tue, 14 Aug 2012 21:29:53 -0600
Subject: [PATCH] Fixing Racklog cut error found by Erik Dominikus

Basically, Racklog (and all versions of schelog) implement ! by
causing the failure continuation of the entire relation being
returned. They did not also cause the unification caused by the
relation to be un-done.

However, it is not easy to separate un-doing the local changes because
the unification just returns a failure continuation too. I had to call
that fail continuation but use state to communicate to its target that
the next clause should not be visited.

I don't know if this is correct. My test suite contains a lot of cut
tests that still pass. Erik's test passes too. But I'm not confident
that this really works.
---
 collects/racklog/racklog.rkt        | 36 ++++++++++++++++++-----------
 collects/tests/racklog/pr/pr-ed.rkt | 19 +++++++++++++++
 2 files changed, 42 insertions(+), 13 deletions(-)
 create mode 100644 collects/tests/racklog/pr/pr-ed.rkt

diff --git a/collects/racklog/racklog.rkt b/collects/racklog/racklog.rkt
index b204457e18..511d368ae8 100644
--- a/collects/racklog/racklog.rkt
+++ b/collects/racklog/racklog.rkt
@@ -52,19 +52,29 @@
   (syntax-rules ()
     ((%rel (v ...) ((a ...) subgoal ...) ...)
      (lambda __fmls
-       (lambda (__fk)
-         (let/racklog-cc __sk
-           (let ((this-! (lambda (fk1) __fk)))
-             (syntax-parameterize 
-              ([! (make-rename-transformer #'this-!)])
-              (%let (v ...)
-                    (let/racklog-cc __fk
-                      (let* ((__fk ((%= __fmls (list a ...)) __fk))
-                             (__fk ((logic-var-val* subgoal) __fk))
-                             ...)
-                        (__sk __fk)))
-                    ...
-                    (__fk 'fail))))))))))
+       (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)))
+                ...
+                (fail-relation 'fail))))))))
 
 (define %fail
   (lambda (fk) (fk 'fail)))
diff --git a/collects/tests/racklog/pr/pr-ed.rkt b/collects/tests/racklog/pr/pr-ed.rkt
new file mode 100644
index 0000000000..d80addf522
--- /dev/null
+++ b/collects/tests/racklog/pr/pr-ed.rkt
@@ -0,0 +1,19 @@
+#lang racket
+(require racklog)
+
+(define %a
+  (%rel (x)
+        ((x) (%b x))
+        ((x) (%c x))
+        ))
+
+(define %b
+  (%rel ()
+        ((1) !)
+        ((2))))
+
+(define %c
+  (%rel ()
+        ((2))))
+
+(%find-all (x) (%a x))