namespace unification core code coded, remains to hook into C unifyer and prolog parser

parent 2ca1b934
......@@ -41,6 +41,8 @@ SOURCES = \
logic/guile-log/dynamic-features.scm \
logic/guile-log/prolog/pre.scm \
logic/guile-log/prolog/error.scm \
logic/guile-log/prolog/closed.scm \
logic/guile-log/prolog/namespace.scm \
logic/guile-log/prolog/symbols.scm \
logic/guile-log/prolog/names.scm \
logic/guile-log/prolog/parser.scm \
......@@ -61,7 +63,6 @@ SOURCES = \
logic/guile-log/prolog/functions.scm \
logic/guile-log/prolog/util.scm \
logic/guile-log/prolog/conversion.scm \
logic/guile-log/prolog/closed.scm \
logic/guile-log/iso-prolog.scm \
logic/guile-log/guile-prolog/continuations.scm \
logic/guile-log/guile-prolog/hash.scm \
......
Prerequisits
A 64 bit system
This is a draft for guile-2.0.6 and later and works for linux.
You need to have guile-syntax-parse installed into the system
......
......@@ -58,26 +58,28 @@ Next: <a href="Index.html#Index" accesskey="n" rel="next">Index</a>, Previous: <
<hr>
<a name="Prolog"></a>
<h2 class="chapter">10 Prolog</h2>
<p>Guile log sports also a iso-prolog interface as a logic programming interface besides kanren. The interface is pretty complete at this point appart a few points that have not yet been resolved but shure it is alpha software. With this most programs written in iso prolog should work. The intention is to enhance this interface so that the bulk of already written prolog programs should be able to be run on guile. We will also add the fetures unique to guile-log and hence enhance the prolog experience. Featurewise guile-log prolog is taking over many properties of scheme like closures, continuations, delimeted continuations, the interleaving constructs of kanren and a delicate system to treat dynamic objects like dynamic functions, dynamic hashes and a well thought out library to tell how you want the dynamism to work at a very fine grained level.
<p>Guile log also sports an iso-prolog interface as a logic programming interface besides kanren. The interface is pretty complete at this point appart a few points that have not yet been resolved but sure it is currently alpha software and help is very very much appriciated. With this most programs written in iso prolog should probably work. The intention is to enhance this interface so that the bulk of already written prolog programs should be able to run on guile. We will also add the fetures unique to guile-log and hence enhance the prolog experience. Featurewise guile-log prolog is taking over many properties of scheme like closures, continuations, delimeted continuations, the interleaving constructs of kanren and a delicate system to treat dynamic objects like dynamic functions, dynamic hashes and a library to tell how you want the dynamism to work at a fine grained level.
</p>
<table class="menu" border="0" cellspacing="0">
<tr><td align="left" valign="top">&bull; <a href="running.html#running" accesskey="1">running</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">How to hook in prolog code
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="deviations.html#deviations" accesskey="2">deviations</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">What is different and not according to standard and why.
<tr><td align="left" valign="top">&bull; <a href="interpreter.html#interpreter" accesskey="2">interpreter</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A interactive shell for prolog
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="modules.html#modules" accesskey="3">modules</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">How to handle name spacing
<tr><td align="left" valign="top">&bull; <a href="deviations.html#deviations" accesskey="3">deviations</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">What is different and not according to standard and why.
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="scheme.html#scheme" accesskey="4">scheme</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Hooking in scheme expressions
<tr><td align="left" valign="top">&bull; <a href="modules.html#modules" accesskey="4">modules</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">How to handle name spacing
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="closures.html#closures" accesskey="5">closures</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Using closures in prolog
<tr><td align="left" valign="top">&bull; <a href="scheme.html#scheme" accesskey="5">scheme</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Hooking in scheme expressions
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="prolog_002ddynamic_002dfunctions.html#prolog_002ddynamic_002dfunctions" accesskey="6">prolog-dynamic-functions</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A discussion of guile log&rsquo;s version of this
<tr><td align="left" valign="top">&bull; <a href="closures.html#closures" accesskey="6">closures</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Using closures in prolog
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="dynamic_002dfeatures.html#dynamic_002dfeatures" accesskey="7">dynamic-features</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Special construct to manage dynamic objects
<tr><td align="left" valign="top">&bull; <a href="prolog_002ddynamic_002dfunctions.html#prolog_002ddynamic_002dfunctions" accesskey="7">prolog-dynamic-functions</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A discussion of guile log&rsquo;s version of this
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="prolog_002dlibraries.html#prolog_002dlibraries" accesskey="8">prolog-libraries</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Libraries that exposes guile-log features
<tr><td align="left" valign="top">&bull; <a href="dynamic_002dfeatures.html#dynamic_002dfeatures" accesskey="8">dynamic-features</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Special construct to manage dynamic objects
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="internals.html#internals" accesskey="9">internals</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A short discussion of the prolog internals used.
<tr><td align="left" valign="top">&bull; <a href="prolog_002dlibraries.html#prolog_002dlibraries" accesskey="9">prolog-libraries</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">Libraries that exposes guile-log features
</td></tr>
<tr><td align="left" valign="top">&bull; <a href="internals.html#internals">internals</a>:</td><td>&nbsp;&nbsp;</td><td align="left" valign="top">A short discussion of the prolog internals used.
</td></tr>
</table>
......
......@@ -15,5 +15,67 @@
#:reader read-prolog
#:compilers `((tree-il . ,compile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write)
#:printer write
#:make-default-environment
(lambda ()
(let ((m (make-module)))
(define (--f--)
(let ((spec-mod (resolve-module '(language prolog spec))))
(define! 'use-modules #f)
(module-set! (current-module) 'use-modules
(module-ref spec-mod 'patched-use-modules))
(use-modules ((guile) #:renamer (symbol-prefix-proc 'scm-)))))
(set-module-name! m '(prolog-user))
(module-use! m (module-public-interface
(resolve-module '(logic guile-log iso-prolog))))
(save-module-excursion
(lambda ()
(set-current-module m)
(--f--)))
m)))
(define (ask str ok?)
(let lp ()
(format #t "~%~a" str)
(let ((ans ((@@ (logic guile-log guile-prolog readline) readline_))))
(if (ok? (with-input-from-string ans (lambda () (read))))
#t
(begin
(format #t "wrong input!")
(lp))))))
(define-syntax-rule (patched-use-modules . l)
(let ((mod (current-module))
(patch (make-module)))
(save-module-excursion
(lambda ()
(set-current-module patch)
(use-modules . l)))
(let ((yall? #f)
(nall? #f))
(for-each-module
(lambda (k v)
(when (module-defined? old k)
(if yall? (module-define! k v))
(if nall?
#t
(ask (format
#f "'~a' already defined, overwrite? (y/n/yall/nall)> " k)
(lambda (x)
(cond
((equal? x 'yall')
(set! yall? #t)
(set! x 'y))
((equal? x 'nall)
(set! nall? #t)
(set! x 'y)))
(cond
((equal? x 'y)
(module-define! k v)
#t)
((equal? x 'n)
#t)
(else
#f)))))))))))
\ No newline at end of file
......@@ -79,11 +79,19 @@
prolog-closure-closed?
setup-closed
make-namespace
namespace?
namespace-val
namespace-ns
namespace-local?
setup-namespace
<namespace-type>
))
;; Tos silence the compiler, those are fetched from the .so file
(define setup-vlist #f)
(define setup-vlist #f)
(define set-closure-struct! #f)
;;need to add modded,
(catch #t
......@@ -203,6 +211,23 @@
(format port "#<vlist ~a>"
(vlist->list vl))))))
(define-record-type <namespace-type>
(make-namespace val ns local?)
namespace?
(val namespace-val)
(ns namespace-ns)
(local? namespace-local?))
(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)))))
(define x (setup-vlist <vlist>))
(define vlist-null (list-ref x 0))
(define block-growth-factor (list-ref x 1))
......
......@@ -2,7 +2,7 @@
#:use-module ((logic guile-log) #:select
(<clear> <define> <let> <let*> <=> <lookup> <match> <fail>
<cut> <wrap> <state-ref> <state-set!> <continue>
<code> <scm>))
<code> <scm> <stall>))
#:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog fluid)
#:use-module (logic guile-log vlist)
......@@ -16,7 +16,9 @@
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log guile-prolog dynamic-features)
#:export (prolog-shell conversation leave read-prolog user_ref user_set))
#:export (prolog-shell conversation leave read-prolog user_ref user_set
stall thin_stall))
(define -all- (make-fluid false))
(<wrap> add-fluid-dynamics -all-)
......@@ -69,6 +71,15 @@
(define -n- (@ (logic guile-log guile-prolog readline)
-n-))
(define lold #f)
(<define> (stall)
(<code> (set! lold (<state-ref>)))
(<stall>))
(<define> (thin_stall)
(<stall>))
(define *states* (make-hash-table))
(define (read-prolog port env)
(define all? #f)
......@@ -81,6 +92,7 @@
(define cont #f)
(define ref #f)
(define set #f)
(define old #f)
(let* ((l
(with-input-from-port port
(lambda ()
......@@ -111,12 +123,15 @@
((ref) (set! ref ((@ (guile) read))))
((set) (set! set (list ((@ (guile) read))
((@ (guile) read)))))
((lo lold)
(set! old #t)
(if lold (<state-set!> lold)))
(else
(set! fail? #t))))
(cond
((or fail? help?)
#f)
((or load save cont ref set)
((or load save cont ref set old)
#t)
(else
(lp #t (peek-char) '()))))
......@@ -140,6 +155,8 @@
(lp #f (peek-char) (cons ch r)))))))))
(cond
(old
'((@ (guile) if) #f #f))
(ref
`((@@ (logic guile-log guile-prolog interpreter) usr-ref) ,ref))
......
......@@ -4,7 +4,7 @@
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log dynamic-features)
#:export(closed_closure error_at_closed_p_handle close_error_true close_error_false))
#:export(closed_closure error_at_closed_p_handle close_error_true close_error_false error-when-closed?))
(mk-sym closed_closure)
......
......@@ -5,7 +5,7 @@
#:use-module (logic guile-log prolog error)
#:use-module (ice-9 match)
#:replace (force)
#:export (make-unbound-fkn mk-sym
#:export (make-unbound-fkn mk-sym make-sym
;;goal
character_code
......@@ -165,6 +165,15 @@
(set-procedure-property! a 'module (module-name (current-module)))
(set-procedure-property! a 'name 'a)))
(define (make-sym mod a)
(if (not (module-defined? mod a))
(let ((f (make-unbound-fkn a)))
(module-define! mod a f)
(set-procedure-property! f 'module (module-name (current-module)))
(set-procedure-property! f 'name a)
f)
#f))
(mk-sym is-a-num?)
(mk-sym check-num)
......
(define-module (logic guile-log prolog namespace)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog closed)
#:use-module (logic guile-log prolog names)
#:use-module (ice-9 match)
#:export (ns-it))
#|
Unification that varifies namespaces in a unification e.g. we can do
X@@a = Y
X@ = current open module
Two things will happen
1) Var = string, will be translated to an actual function in a lookup
for the namespace
2) Var = atom, atom have to be in the namespaced module.
3) new namespaces found changes the restricted namespace
|#
(define fail-when-new-namespace? (make-fluid #f))
(define (comp-fail? ns1 local1? ns2 local2?)
(let ((fail (fluid-ref fail-when-new-namespace?)))
(if (and (equal? ns1 ns2) (or local1? (not local2?)))
#f
(if fail
(if (eq? fail #t)
#t
(let lp-wl ((l fail))
(match l
(((local? . dir) . l)
(if (or local? (not local2?))
(let lp ((dir dir) (ns ns2))
(match dir
((*) #f)
(() (if (null? ns)
#f
(lp-wl l)))
((x . dir)
(match ns
((y . ns)
(if (equal? x y)
(lp dir ns)
(lp-wl l)))
(_ (lp-wl l))))))
(lp-wl l)))
(() #t))))
#f))))
(define (translate x ns l?)
(let ((sym (string->symbol x))
(mod (resolve-module ns)))
(if l?
(if (module-defined? mod sym)
(module-ref mod sym)
(let ((f (make-sym mod sym)))
(module-define! mod sym f)
f))
(let ((pub (module-public-interface mod)))
(if (module-defined? pub sym)
(module-ref pub sym)
(let ((f (make-sym mod sym)))
(module-define! mod sym f)
(module-set! pub sym (module-ref mod sym))
f))))))
(define (ns-it x ns local? s)
(define (f x s cont)
(cond
((prolog-closure? x)
(if (ns-it (prolog-closure-parent x) ns local? s)
(ns-it (prolog-closure-state x) ns local? s)
#f))
((namespace? x)
(if (comp-fail? ns local? (namespace-ns x) (namespace-local? x))
#f
s))
((vector? x)
(ns-it (vector->list x) ns local? s))
((gp-var? x s)
(gp-unify! x (make-namespace (gp-var! s) ns local?) s))
((procedure? x)
(let ((mod (procedure-property x 'module)))
(if mod
(if (equal? mod ns)
(if (not local?)
(if (module-defined?
(module-public-interface (resolve-module mod))
(procedure-name x))
s
#f)
s)
#f)
#f)))
(else
(cont x s))))
(f x s
(lambda (x s)
(let lp ((s s) (x x))
(umatch (#:mode - #:status s #:name ns-it) (x)
((x . l)
(let ((s (ns-it (gp-lookup x s) ns local? s)))
(if s
(lp s (gp-lookup l s))
s)))
(x (f x s (lambda (x s) s))))))))
(define (ns-unify s ns y)
(let ((x (namespace-val ns))
(ns (namespace-ns ns))
(lx? (namespace-local? ns)))
(let ((s (ns-it x ns lx? s)))
(if s
(let lp ((x (gp-lookup x s)) (y (gp-lookup y s))
(ns-x ns) (ns-y #f)
(lx? lx?) (ly? #f)
(x? #t) (y? #f) (s s))
(cond
((namespace? y)
(let ((ns-y2 (namespace-ns y))
(ly2? (namespace-local? y)))
(if (comp-fail? ns-y ly? ns-y2 ly2?)
#f
(lp x (gp-lookup (namespace-val y) s)
ns-x ns-y2
lx? ly2?
x? y s))))
((namespace? x)
(let ((ns-x2 (namespace-ns x))
(lx2? (namespace-local? x)))
(if (comp-fail? ns-x lx? ns-x2 lx2?)
#f
(lp (gp-lookup (namespace-val x) s) y
ns-x2 ns-y
lx2? ly?
x? x s))))
(else
(if (and (equal? ns-x ns-y) (eq? lx? ly?))
(cond
((gp-var? x s)
(if (gp-var? y s)
(cond
((and x? y?)
(gp-unify! x y s))
(x?
(gp-unify! x? y s))
(y?
(gp-unify! y? x s))
(else
(let ((s (gp-unify! x y s)))
(if s
(gp-unify! x
(make-namespace (gp-var! s) ns-x lx?)
s)
s))))
))
(imprint! x y ns-x lx? s)
((gp-var? y s)
(imprint! y x ly? lx? s))
((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? y? s)
#f))
((or (procedure? x) (procedure? y))
(if (eq? (procedure? x) (procedure? y))
s
#f))
((or (prolog-closure? x) (prolog-closure? y))
(if (and (prolog-closure? x) (prolog-closure? y))
(if (eq? (prolog-closure-parent x)
(prolog-closure-parent y))
(lp (prolog-closure-state x)
(prolog-closure-state y)
ns-x ns-y lx? ly? x? y? s)
(if (fluid-ref error-when-closed?)
((@@ (logic guile-log prolog closed) err)
x y)
#f))))
(else
(umatch (#:mode - #:status s #:name ns-1) (x y)
((xa . xl) (ya . yl)
(let lp-x ((s s) (x x) (y y))
(umatch (#:mode - #:status s #:name ns-2) (x y)
((xa . xl) (ya . yl)
(lp-x (lp xa ya ns-x ns-y lx? ly? #f #f s)
xl yl))
(x y
(lp x y ns-x ns-y lx? ly? #f #f s)))))
(x y
(if (equal? x y)
s
#f)))))
#f))))
#f))))
(define (imprint! x y ns lx? s)
(let lp ((s s) (y (gp-lookup y s)) (x (gp-lookup x s)))
(if (gp-var? y s)
(gp-unify! x y s)
(umatch (#:mode + #:status s #:name imprint!) (y x)
((y . ly) (x . lx)
(lp (lp s y x) ly lx))
(_ _
(cond
((vector? y)
(let* ((xx (gp-var! s))
(ly (vector->list y))
(lx (map (lambda (x) (gp-var! s)) ly)))
(gp-unify! x (list->vector lx)
(lp s ly lx))))
((string? y)
(gp-unify! x (translate y ns lx?) s))
((prolog-closure? y)
(let* ((xx (gp-var! s))
(ly (prolog-closure-state y))
(lx (map (lambda (x) (gp-var! s)) ly)))
(gp-unify! x (make-prolog-closure
(prolog-closure-closure y)
(prolog-closure-parent y)
lx
(prolog-closure-closed? y))
(lp s ly lx))))
((namespace? y)
(let ((ns2 (namespace-ns y))
(lx2? (namespace-local? y)))
(if (comp-fail? ns lx? ns2 lx2?)
#f
(imprint! x y ns2 lx2? s))))
(else
(gp-unify! x y s))))))))
(setup-namespace <namespace-type> ns-unify)
......@@ -903,6 +903,19 @@ SCM_DEFINE(gp_setup_closed, "setup-closed",1,0,0,(SCM err),
}
#undef FUNC_NAME
SCM namespace_fkn = SCM_BOOL_F;
SCM namespace_struct = SCM_BOOL_F;
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
{
namespace_fkn = nsfkn;
namespace_struct = record;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static int gp_recurent(SCM *id1,SCM *id2, SCM *l)
{
SCM scm;
......
......@@ -32,6 +32,7 @@
#include "vlist/vlist.h"
#include "indexer/indexer.h"
SCM_API SCM gp_setup_namespace(SCM record, SCM nsfkn);
SCM_API SCM gp_setup_closed(SCM err);
SCM_API SCM gp_set_closure_struct(SCM scm);
SCM_API SCM gp_gp(SCM scm);
......
......@@ -2,6 +2,7 @@
#include<stdio.h>
#define VLIST 0
#define VHASH 1
// This code only works on 64 bit systems
void vhash_truncate_x(SCM vhash);
void vhash_block_clear(SCM *base, int offset);
......@@ -57,9 +58,9 @@ SCM vhash_cache = SCM_BOOL_F;
#define NEXT_REF(x) ((int) LOW(x))
#define COMB_REFS(low,high) ((((ulong) high) << TAGN) | ((ulong) ((uint) low)))
#define NEXTFREE(x) ((int) LOW(x))
#define INCREF(x) (x + (1L << TAGN))
#define DECREF(x) (x - (1L << TAGN))
#define REFCOUNT(x) ((x) & TAGU(TAGN))
#define INCREF(x) ((ulong) (x + (1L << TAGN)))
#define DECREF(x) ((ulong) (x - (1L << TAGN)))
#define REFCOUNT(x) ((ulong) ((x) & TAGU(TAGN)))
SCM thread_seq_number;
SCM thread_id;
SCM thread_inc;
......@@ -301,7 +302,7 @@ inline void vlist_truncate_x(SCM vlist)
SCM* base = vlist_base(vlist);
int offset = vlist_offset(vlist);
ulong freeref = my_scm_to_ulong(block_next_free_ref(base));
int count = REFCOUNT(freeref);
ulong count = REFCOUNT(freeref);
ulong seq = my_scm_to_ulong(scm_fluid_ref(thread_seq_number));
ulong thr = my_scm_to_ulong(scm_fluid_ref(thread_id));
......@@ -310,6 +311,8 @@ inline void vlist_truncate_x(SCM vlist)
SCM *bc = dB(block_content(base));
freeref = NEXTFREE(freeref);
if(!count && seq == SEQ(os) && thr == THR(st))
{
for(--freeref; freeref > offset; freeref--)
......@@ -974,7 +977,7 @@ void vhash_truncate_x(SCM vhash)
SCM *content = dB(block_content(base));
ulong freeref = my_scm_to_ulong(block_next_free_ref(base));
int count = REFCOUNT(freeref);
ulong count = REFCOUNT(freeref);
ulong seq = my_scm_to_ulong(scm_fluid_ref(thread_seq_number));
ulong thr = my_scm_to_ulong(scm_fluid_ref(thread_id));
......@@ -987,6 +990,7 @@ void vhash_truncate_x(SCM vhash)
{
for(--freeref; freeref > offset; freeref--)
{
freeref = NEXTFREE(freeref);
ulong os = my_scm_to_ulong
(block_hash_table_next_offset(content, size, freeref));
int off = NEXT_REF(os);
......
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