namespace unification starts working reasonable, buggs remain

parent 5997b060
......@@ -78,13 +78,13 @@
(<case-lambda>
(()
(<code>
(usr-set 'stall-ret '())
(usr-set! 'stall-ret '())
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
((l)
(<code>
(usr-set 'stall-ret l)
(usr-set! 'stall-ret l)
(fluid-set! *usr-state* S)
(set! lold (<state-ref>))))
(<stall>)))
......@@ -279,10 +279,12 @@ HELP FOR PROLOG COMMANDS
(<define> (wrap_namespace x y yy)
(<let> ((x (<lookup> x)))
(<=> y ,(make-namespace
yy
(namespace-ns x)
(namespace-local? x)))))
(<code> (gp-set! y (make-namespace
yy
(namespace-ns x)
(namespace-local? x)
(namespace-lexical? x))
S))))
(compile-prolog-string
"
......
......@@ -12,6 +12,7 @@
namespace-val
namespace-ns
namespace-local?
namespace-lexical?
setup-namespace)
#:export (namespace_p
......@@ -31,7 +32,7 @@
(<define> (namespace_lexical_p
x v) (when (namespace-lexical? (<lookup> x))))
(define do-print #t)
(define do-print #f)
(define pp
(case-lambda
((s . x)
......@@ -188,7 +189,7 @@ Two things will happen
(let lp ((x (gp-lookup x s)) (y (gp-lookup y s))
(ns-x ns) (ns-y #f)
(lx? lx?) (ly? #f)
(x-lex? lex?) (y-lex? #f) (s s))
(x-lex? lex?) (y-lex? #f) (? #f) (s s))
(pp 'lp x y ns-x ns-y lx? ly? #:x-lex? x-lex? #:y-lex? y-lex?)
......@@ -198,11 +199,11 @@ Two things will happen
(ly2? (namespace-local? y))
(lex2? (namespace-lexical? y)))
(if (if (not ns-y) #f (comp-fail? ns-y ly? ns-y2 ly2? #f))
#f
#f
(lp x (gp-lookup (namespace-val y) s)
ns-x ns-y2
lx? ly2?
x-lex? lex2? s))))
x-lex? lex2? #t s))))
((namespace? x)
(let ((ns-x2 (namespace-ns x))
......@@ -210,16 +211,22 @@ Two things will happen
(lex2? (namespace-lexical? x)))
(if (comp-fail? ns-x lx? ns-x2 lx2? #f)
#f
(lp (gp-lookup (namespace-val x) s) y
ns-x2 ns-y
lx2? ly?
lex2? y-lex? s))))
(if ?
(lp (gp-lookup (namespace-val x) s) y
ns-x2 ns-y
lx2? ly?
lex2? y-lex? ? s)
(lp (gp-lookup (namespace-val x) s) y
ns-x2 ns-x2
lx2? lx2?
lex2? lex2? ? s)))))
((not ns-y)
(lp x y
ns-x ns-x
lx? lx?
x-lex? #t s))
x-lex? #t ? s))
(else
......@@ -228,12 +235,18 @@ Two things will happen
((gp-var? x s)
(if (gp-var? y s)
(if (and x-lex? y-lex? bang?)
(let ((s (gp-unify! x y s)))
(gp-unify! x (make-namespace (gp-var! s)
ns-x lx? #f)
s))
(if (or x-lex? y-lex?)
(error "vars of patial lex is impossible BUG!")
(let ((s (gp-set! x y s)))
(gp-set! x (make-namespace (gp-var! s)
ns-x lx? #f)
s))
(if bang?
(cond
(x-lex?
(gp-set! x (make-namespace y ns-x lx? #f) s))
(y-lex?
(gp-set! y (make-namespace x ns-y ly? #f) s))
(else
(gp-set! x y s)))
(if (eq? x y)
s
#f)))
......@@ -245,7 +258,7 @@ Two things will happen
((or (vector? x) (vector? y))
(if (and (vector? x) (vector? y))
(lp (vector->list x) (vector->list y) ns-x ns-y lx? ly?
x-lex? y-lex? s)
x-lex? y-lex? ? s)
#f))
((or (procedure? x) (procedure? y))
......@@ -259,7 +272,7 @@ Two things will happen
(prolog-closure-parent y))
(lp (prolog-closure-state x)
(prolog-closure-state y)
ns-x ns-y lx? ly? x-lex? y-lex? s)
ns-x ns-y lx? ly? x-lex? y-lex? ? s)
(if (fluid-ref error-when-closed?)
((@@ (logic guile-log prolog closed) err)
x y)
......@@ -274,22 +287,22 @@ Two things will happen
(let ((s (lp (gp-lookup xa s)
(gp-lookup ya s)
ns-x ns-y lx? ly?
x-lex? y-lex? s)))
x-lex? y-lex? ? s)))
(if s
(lp-x s (gp-lookup xl s) (gp-lookup yl s))
s)))
(x y
(lp x y ns-x ns-y lx? ly?
x-lex? y-lex? s)))))
x-lex? y-lex? ? s)))))
(x y
(if (equal? x y) s #f)))))
#f))))))
(define (imprint! x y ns lx? lex? y-lex? s bang?)
(if bang?
(define (imprint! x y ns lx? lex? y-lex? s bang?)
(if (not bang?)
#f
(imprint!* x y ns lx? lex? y-lex? s)))
(define (imprint!* x y ns lx? lex? y-lex? s)
......@@ -378,23 +391,27 @@ Two things will happen
((gp-var? y s)
(let ((s (unify x y s)))
(if s
(gp-set! x
(let ((s (gp-set! x y s)))
(if y-lex?
(gp-set! y
(make-namespace (gp-var! s) ns lx? #f)
s)
s)))
(else
(gp-set! x y s))))))
(umatch (#:mode + #:status s #:name imprint!) (y x)
((yy . ly) (xx . lx)
(let ((s (lp s (gp-lookup y s) (gp-lookup x s) y-lex? ns lx?)))
(if s
(lp s (gp-lookup ly s) (gp-lookup lx s) y-lex? ns lx?)
s)))
(umatch (#:mode - #:status s #:name imprint!) (y)
((yy . ly)
(umatch (#:mode + #:status s #:name 'imprint2) (x)
((xx . lx)
(let ((s (lp s (gp-lookup yy s) (gp-lookup xx s)
y-lex? ns lx?)))
(if s
(lp s (gp-lookup ly s) (gp-lookup lx s)
y-lex? ns lx?)
s)))))
(_ _ (f))))))
(_ (f))))))
(setup-namespace <namespace-type> ns-unify)
......@@ -1582,7 +1582,13 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
else
{
SCM s = gp_make_s(ci,l);
s = scm_call_3(namespace_fkn,s,scm1,scm2);
SCM bang = SCM_BOOL_T;
if(!gp_plus_unify)
{
bang = SCM_BOOL_F;
}
s = scm_call_4(namespace_fkn,s,scm1,scm2,bang);
if(scm_is_false(s))
return (SCM) 0;
......@@ -2306,9 +2312,9 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
x = gp_struct_ref(x,0);
goto retry;
}
......@@ -2349,9 +2355,9 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
x = gp_struct_ref(x,0);
goto retry;
}
......@@ -2391,9 +2397,9 @@ SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s),
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
x = gp_struct_ref(x,0);
goto retry;
}
......@@ -2444,9 +2450,9 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
if(SCM_STRUCTP(x) && GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
x = gp_struct_ref(x,0);
goto retry;
}
......
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