suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

correct cut implementation without mutation

Browse Source
This commit is contained in:
Jay McCarthy 2012-08-27 15:12:53 -06:00
parent 614ff235fc
commit 9fdb0ac507
2 changed files with 30 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/racklog/racklog.rkt
View File

@ -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))))))))

17
collects/racklog/unify.rkt
View File

@ -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) ...))