refined unworking solution for ns unification

parent e621cbf3
......@@ -85,6 +85,7 @@
namespace-val
namespace-ns
namespace-local?
namespace-lexical?
setup-namespace
<namespace-type>
))
......@@ -212,29 +213,33 @@
(vlist->list vl))))))
(define-record-type <namespace-type>
(make-namespace_ val ns local?)
(make-namespace_ val ns local? lexical?)
namespace?
(val namespace-val)
(ns namespace-ns)
(local? namespace-local?))
(val namespace-val)
(ns namespace-ns)
(local? namespace-local?)
(lexical? namespace-lexical?))
(define (make-namespace a l b)
(define (make-namespace a l b q)
(let ((l (map (lambda (x)
(if (string? x)
(string->symbol x)
x))
l)))
(make-namespace_ a l b)))
(make-namespace_ a l b q)))
(set-record-type-printer!
<namespace-type>
(lambda (vl port)
(let ((li (namespace-ns vl))
(l? (namespace-local? vl))
(x (namespace-val vl)))
(if l?
(format port "~a@@~a" x li)
(format port "~a@~a" x li)))))
(letrec ((f (lambda (vl port)
(let ((li (namespace-ns vl))
(l? (namespace-local? vl))
(x (namespace-val vl)))
(if (namespace? x)
(f x port)
(if l?
(format port "~a@@~a" x li)
(format port "~a@~a" x li)))))))
f))
(define x (setup-vlist <vlist>))
(define vlist-null (list-ref x 0))
......
......@@ -109,15 +109,15 @@
(let* ((l
(with-input-from-port port
(lambda ()
(let lp ((first? #t) (ch (peek-char)) (r '()))
(let lp ((first? #t) (ch (peek-char)) (r '()) (dot-cont? #f))
(when (eof-object? ch)
(set! ch #\.))
(match ch
(#\space
(read-char)
(if first?
(lp first? (peek-char) r)
(lp first? (peek-char) (cons ch r))))
(lp first? (peek-char) r #f)
(lp first? (peek-char) (cons ch r) #f)))
(#\.
(read-char)
......@@ -152,18 +152,23 @@
((or load save cont ref set old)
#t)
(else
(lp #t (peek-char) '()))))))
(list->string (reverse (cons #\. r)))))
(lp #t (peek-char) '() #f))))))
(let ((ch (peek-char)))
(if dot-cont?
(lp #f ch (cons #\. r) #f)
(if (eq? ch #\.)
(lp #f ch (cons #\. r) #t)
(list->string (reverse (cons #\. r))))))))
(#\,
(read-char)
(if first?
(cons ch (string->list (read-line)))
(lp #f (peek-char) (cons ch r))))
(lp #f (peek-char) (cons ch r) #f)))
(_
(read-char)
(lp #f (peek-char) (cons ch r)))))))))
(lp #f (peek-char) (cons ch r) #f))))))))
(cond
(old
......@@ -326,7 +331,7 @@ vtosym(X,Y) :- make_vhash(H),make_fluid(0,I),vtosym(X,Y,H,I).
vtosym(X,Y,H,I) :-
var(X) -> (!, (vhashq_ref(H,X,Y);hash_new(X,Y,H,I)));
namespace_p(X) -> (!, namespace_val(X,XX),pp(XX),
namespace_p(X) -> (!, namespace_val(X,XX),
vtosym(XX,YY,H,I),
wrap_namespace(X,Y,YY)) ; fail.
......
This diff is collapsed.
......@@ -32,13 +32,7 @@
(define v-variables (make-fluid '()))
(define (@wrapper v li ? s)
(let* ((fr (gp-newframe s))
(s2 (ns-it v li ? #f s)))
(if (and s (eq? s s2))
v
(begin
(gp-unwind fr)
(make-namespace v li ?)))))
(make-namespace v li ? #t))
(define (fa x) x)
......@@ -160,11 +154,15 @@
(define *var-list* (make-fluid '()))
(define (term-get-variables)
(hash-fold
(lambda (k v s)
(cons k s))
'()
(fluid-ref *variables*)))
(define h (make-hash-table))
(let lp ((l (reverse (fluid-ref *var-list*))))
(if (pair? l)
(if (hash-ref h (car l) #f)
(lp (cdr l))
(begin
(hash-set! h (car l) #t)
(cons (car l) (lp (cdr l)))))
'())))
(define (term-get-variables-list)
(reverse (fluid-ref *var-list*)))
......
......@@ -891,7 +891,12 @@ static inline SCM gp_mk_cons(SCM s)
return GP_UNREF(ret + 4);
}
#define gp_struct_ref(scm,i) SCM_PACK(SCM_STRUCT_DATA(scm)[i])
SCM closure_struct = SCM_BOOL_F;
#define GP_MK_CLOSURE(x,y,z,w) \
scm_c_make_struct(closure_struct, 0, \
SCM_UNPACK(x),SCM_UNPACK(y),SCM_UNPACK(z),SCM_UNPACK(w));
#define GP_CLOSURE_P(x) (SCM_STRUCT_VTABLE(x) == closure_struct)
......@@ -919,6 +924,10 @@ SCM_DEFINE(gp_setup_closed, "setup-closed",1,0,0,(SCM err),
SCM namespace_fkn = SCM_BOOL_F;
SCM namespace_struct = SCM_BOOL_F;
#define GP_NAMESPACE_P(x) (SCM_STRUCT_VTABLE(x) == namespace_struct)
#define GP_MK_NAMESPACE(x,y,z,w) \
scm_c_make_struct(namespace_struct, 0, \
SCM_UNPACK(x),SCM_UNPACK(y),SCM_UNPACK(z),SCM_UNPACK(w));
SCM_DEFINE(gp_setup_namespace, "setup-namespace",2,0,0,(SCM record, SCM nsfkn),
"supplies the record for the namespace struct and the name space unification function")
#define FUNC_NAME s_setup_namespace
......@@ -978,12 +987,12 @@ static int gp_recurent(SCM *id1,SCM *id2, SCM *l)
{
if(GP_CLOSURE_P(scm))
{
scm = SCM_PACK(SCM_STRUCT_DATA(scm)[2]);
scm = gp_struct_ref(scm,2);
goto retry;
}
else if (GP_NAMESPACE_P(scm))
{
scm = SCM_PACK(SCM_STRUCT_DATA(scm)[0]);
scm = gp_struct_ref(scm,0);
goto retry;
}
......@@ -1093,8 +1102,26 @@ SCM_DEFINE( smob2scm, "gp->scm", 2, 0, 0, (SCM scm, SCM s),
return scm;
return scm_cons(car,cdr);
}
else
return scm;
if(SCM_STRUCTP(scm))
{
if(GP_CLOSURE_P(scm))
{
SCM args = smob2scm(gp_struct_ref(scm,2), s);
SCM f = gp_struct_ref(scm,1);
return GP_MK_CLOSURE(scm_apply_0(f,args), f, args,
gp_struct_ref(scm,3));
}
if(GP_NAMESPACE_P(scm))
return GP_MK_NAMESPACE(smob2scm(gp_struct_ref(scm,0), s),
gp_struct_ref(scm,1),
gp_struct_ref(scm,2),
gp_struct_ref(scm,3));
}
return scm;
}
}
#undef FUNC_NAME
......@@ -1137,36 +1164,34 @@ int len(SCM x, SCM *l)
#define QCAR(x) GP_GETREF(SCM_CAR(GP_UNREF(x)))
#define QCONSP(x) SCM_CONSP(GP_UNREF(x))
#define DO_NAMESPACE(scm2, id2, id1) \
{ \
SCM scm2 = GP_STAR(id2)?GP_SCM(id2):GP_UNREF(id2); \
gp_format1("(do_ns ~a)~%",scm2); \
if(SCM_STRUCTP(scm2)) \
{ \
if(GP_NAMESPACE_P(scm2)) \
{ \
#define DO_NAMESPACE(scm2, id2, id1) \
{ \
SCM scm2 = GP_STAR(id2)?GP_SCM(id2):GP_UNREF(id2); \
gp_format1("(do_ns ~a)~%",scm2); \
if(SCM_STRUCTP(scm2)) \
{ \
if(GP_NAMESPACE_P(scm2)) \
{ \
SCM bang = SCM_BOOL_T; \
if(!gp_plus_unify) \
{ \
scm_t_bits *bits1 = SCM_STRUCT_DATA(scm2); \
id2 = GP_GETREF(SCM_PACK(bits1[0])); \
goto retry; \
bang = SCM_BOOL_F; \
} \
else \
{ \
SCM s = gp_make_s(ci,l); \
s = scm_call_3(namespace_fkn,s,scm2,GP_UNREF(id1)); \
if(scm_is_false(s)) \
return (SCM) 0; \
{ \
SCM s = gp_make_s(ci,l); \
s = scm_call_4(namespace_fkn,s,scm2,GP_UNREF(id1),bang); \
if(scm_is_false(s)) \
return (SCM) 0; \
\
SCM ll = SCM_CDR(s); \
if(vlist_p(ll)) \
{ \
l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0)))); \
l[2] = SCM_PACK(my_scm_to_int(S(ll,1))); \
} \
else \
l[0] = ll; \
} \
SCM ll = SCM_CDR(s); \
if(vlist_p(ll)) \
{ \
l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0)))); \
l[2] = SCM_PACK(my_scm_to_int(S(ll,1))); \
} \
else \
l[0] = ll; \
} \
\
U_NEXT; \
} \
......@@ -2247,6 +2272,7 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
UNPACK_ALL(ci, l,ggp,gp,s,"failed to unpack s in gp_pair_bang");
gp_debus0("gp-pair!?>\n");
retry:
if(GP(x))
x = gp_gp_lookup(x,s);
if(GP(x))
......@@ -2279,6 +2305,13 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
goto retry;
}
return SCM_CONSP(x) ? s : SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -2302,6 +2335,7 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
{
gp_debus0("gp-pair?>\n");
retry:
if(GP(x))
x = gp_gp_lookup(x,s);
......@@ -2314,6 +2348,13 @@ SCM_DEFINE(gp_pair, "gp-pair?", 2, 0, 0, (SCM x, SCM s),
}
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
goto retry;
}
return SCM_CONSP(x) ? s : SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -2335,6 +2376,8 @@ SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s),
#define FUNC_NAME s_gp_null
{
gp_debus0("gp-null?>\n");
retry:
if(GP(x))
x = gp_gp_lookup(x,s);
......@@ -2347,6 +2390,13 @@ SCM_DEFINE(gp_null, "gp-null?", 2, 0, 0, (SCM x, SCM s),
}
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
goto retry;
}
return SCM_NULLP(x) ? s : SCM_BOOL_F;
}
#undef FUNC_NAME
......@@ -2373,6 +2423,7 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
UNPACK_ALL(ci,l,ggp,gp,s,"failed to unpack s in gp_null_bang");
gp_debus0("gp-null!?>\n");
retry:
if(GP(x))
x = gp_gp_lookup(x,s);
......@@ -2392,6 +2443,13 @@ SCM_DEFINE(gp_null_bang, "gp-null!?", 2, 0, 0, (SCM x, SCM s),
}
return SCM_BOOL_F;
}
if(GP_NAMESPACE_P(x))
{
x = scm_struct_ref(x,0);
goto retry;
}
return SCM_NULLP(x) ? s : SCM_BOOL_F;
}
#undef FUNC_NAME
......
......@@ -493,10 +493,14 @@
(prolog-closure-closed? x))))
((namespace? x)
(make-namespace
(lp (namespace-val x))
(namespace-ns x)
(namespace-local? x)))
(let ((val (lp (namespace-val x))))
(if (namespace? x)
x
(make-namespace
val
(namespace-ns x)
(namespace-local? x)
(namespace-lexical? x)))))
(else
x)))))
......
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