further improvements

parent d2b5b13c
......@@ -13,7 +13,7 @@
(define (procedure-name- x)
(let ((f (object-property x 'prolog-functor-type)))
(if (eq? f #:goal)
(let ((f (object-property x 'prolog-operator)))
(let ((f (procedure-property x 'prolog-operator)))
(if f
f
(procedure-name x)))
......
(define-module (logic guile-log prolog dynamic)
#:use-module (logic guile-log prolog compile)
#:use-module (logic guile-log prolog directives)
#:use-module (logic guile-log functional-database)
#:use-module (logic guile-log prolog goal)
#:use-module (logic guile-log prolog goal-functors)
......@@ -56,13 +57,13 @@
(if (not (dynamic? F))
(if (procedure? F)
(if (object-property F 'prolog-symbol)
(lp (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A))))))
(type_error callable F))
(lp (F))
(permission_error modify static_procedure
(vector
(list divide
F
(length (<scm> A))))))
(type_error callable F))
(<and>
(<push-dynamic> (<lookup> F)
......@@ -165,28 +166,32 @@
(else
(<match> (#:mode - #:name abolish) (pred)
(#((,divide F N))
(<recur> lp ((F (<lookup> F))
(<recur> lp ((F (<lookup> F))
(N (<lookup> N)))
(cond
((or (<var?> F) (<var?> N))
(instantiation_error))
(cond
((or (<var?> F) (<var?> N))
(instantiation_error))
((dynamic? F)
(if (and (number? N) (integer? N))
(if (< N 0)
(domain_error not_less_than_zero N)
(<code> (dynamic-abolish F)))
(type_error integer N)))
((dynamic? F)
(if (and (number? N) (integer? N))
(cond
((< N 0)
(domain_error not_less_than_zero N))
((< (get-flag max_arity) N)
(representation_error max_arity))
(else
(<code> (dynamic-abolish F))))
(type_error integer N)))
((object-property F 'prolog-symbol)
(lp (F) N))
((object-property F 'prolog-symbol)
(lp (F) N))
((procedure? F)
(permission_error modify static_procedure
(vector (list divide
F N))))
(else
(type_error atom F)))))
((procedure? F)
(permission_error modify static_procedure
(vector (list divide
F N))))
(else
(type_error atom F)))))
(_
(type_error predicate_indicator pred)))))))
......
......@@ -20,7 +20,7 @@
(vector `(,f ,(fkn-it x) ...)))
((_ x) x)))
(define *debug* #f)
(define *debug* #t)
(define (call-with-eh th . l)
(if *debug*
(call-with-error-handling th)
......
......@@ -583,9 +583,11 @@
(h first-map))
(cond
((not f)
(format #f "#f"))
((string? f)
(format #f "'~a'(~a~{, ~a~})" f (lp a) (map lp (gp->scm l s))))
((and (struct? f) (prolog-closure? f))
(let ((args (map (lambda (x) (first-redo h) (lp x))
(prolog-closure-state f)))
......
......@@ -89,7 +89,7 @@
(define atom-tok (mk-token (f-seq first-atom (f* rest-var))))
(define any (f-reg "."))
(define special (f-reg "[].[(),\"'{}|]"))
(define special (f-reg "[].[(),;\"'{}|]"))
;; SWI-PROLOG OPERATOR PRECEDENCE PARSER
(define expr* #f)
......@@ -684,7 +684,7 @@
char list-tok true/false
termvar-tok term-binop-tok termop-tok
termstring-tok term-tok scm-tok lam-tok
number qstring dstring atom variable #;symbolic-tok
number qstring dstring atom variable symbolic-tok
op-tok))
(define e (mk-operator-expression tok (f-or! op-tok symbolic-tok2)
......
......@@ -5,7 +5,7 @@
#:use-module (test-suite lib))
#| Mapping the examples from reasoned schemer to guile-log |#
;(set! *kanren-assq* #t)
(set! *kanren-assq* #t)
(define-guile-log <conde>
(syntax-rules ()
......@@ -1581,67 +1581,24 @@
(<define> (/o n m q r)
(<condi>
((<=> '() q) (<=> n r) (<o n m) (<pp> `(<o ,n ,m ,q ,r)) (<stall>))
((<=> '() q) (<=> n r) (<o n m))
((<=> '(1) q) (<=> '() r) (<=> n m)
(<o r m) (<pp> `(<o ,n ,m ,q ,r)) (<stall>))
(<o r m))
((<o m n) (<o r m)
(<var> (mq)
(<=lo mq n)
(*o m q mq)
(+o mq r n)
(<pp> `(+o ,n ,m ,q ,r))
(<stall>)))))
(define (runpair x y)
(let lp ((x x) (y y))
(pk '-------------------)
(let ((ax (x))
(sx #f)
(cx #f))
(set! x (lambda () ax))
(when (eq? ax 'stalled)
(set! sx (<state-ref>))
(set! cx (<cont-ref>))
(set! x (lambda ()
(<state-set!> sx)
(<cont-set!> cx)
(<continue>))))
(pk '+++++++++++++++++)
(let ((ay (y))
(sy #f)
(cy #f))
(set! y (lambda () ay))
(when (eq? ay 'stalled)
(set! sy (<state-ref>))
(set! cy (<cont-ref>))
(set! y (lambda ()
(<state-set!> sy)
(<cont-set!> cy)
(<continue>))))
(if (or (eq? ax 'stalled) (eq? ay 'stalled))
(lp x y)
(x))))))
(+o mq r n)))))
(with-test-prefix "/o"
(check?
(let ((fr (fluid-ref *current-stack*)))
(runpair
(lambda ()
(<run> 15 (t)
(<run> 15 (t)
(<logical++>)
(<var> (n m q r)
(/o n m q r)
(<=> (n m q r) t))))
(lambda ()
(<clear>)
(fluid-set! *current-stack* fr)
(<run> 15 (t)
;(<logical-->)
(<var> (n m q r)
(/o n m q r)
(<=> (n m q r) t))))))
(/o n m q r)
(<=> (n m q r) t)))
'((() (v0 . v1) () ())
((v0 . v1) (v0 . v1) (1) ())
((1 1) (0 1) (1) (1))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment