Initial commit

parents
This diff is collapsed. Click to expand it.
GNU Lesser General Public License (LGPL) version 2
This is a logic programming framework for guile
Copyright (c) Stefan Israelsson Tampe.
See "COPYING.LIB" for more information about the license.
GNU Lesser General Public License (LGPL) version 2
This is a port of racket-5.1 version of contracts which are
under,
Copyright (c) 2010-2011 PLT Scheme Inc.
With changes by Stefan Israelsson Tampe in order to make it work under
guile
See "COPYING.LIB" for more information about the license.
This is a draft for guile-2.0.6 and later and works for linux.
Add this directory to guiles load-path
Install:
Go to logic/guile-log/src/
issue
make
Now you are ready to use it from guile through,
> (use-modules (logic guile-log))
Have fun!
(define-module (logic guile-log)
#:use-module (system base compile)
#:use-module (ice-9 match-phd)
#:use-module (logic guile-log guile-log-pre)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system repl repl)
#:re-export (u-cons u-abort u-var! u-scm u-unify! u-unify-raw!)
#:export (umatch))
(define-syntax umatch (syntax-rules () ((a . l) (um . l))))
(define log-module
(resolve-module
'(logic guile-log)))
(include-from-path "logic/guile-log/macros.scm")
(define-module (logic guile-log guile-log-pre)
#:export (define-guile-log guile-log-macro? log-code-macro log-code-macro?))
(define (guile-log-macro? s)
(and (symbol? s) (symbol-property s 'guile-log-macro?)))
(define (log-code-macro? s)
(and (symbol? s) (symbol-property s 'log-code-macro?)))
(define (log-code-macro s)
(set-symbol-property! s 'log-code-macro? #t))
(define-syntax define-guile-log
(lambda (x)
(syntax-case x ()
((_ n . l)
#'(begin
(set-symbol-property! 'n 'guile-log-macro? #t)
(define-syntax n . l))))))
;; sematically after kanrens all-interleave
(define-guile-log <or!>
(syntax-rules ()
((_ w)
(parse<> w <fail>))
((_ w a)
(parse<> w a))
((_ w a ...)
(parse<> w (interleave (list (</.> a) ...))))))
(define (interleave p cc l)
(let ((s (gp-store-state)))
(gp-swap-to-b)
(let* ((ul (u-var!))
(ur (u-var!))
(n (u-var!))
(fr (gp-newframe)))
(u-set! n 0)
(gp-swap-to-a)
(letrec ((loop (lambda (l r)
(if (null? l)
(if (null? r)
(p)
(loop (reverse r) '()))
(begin
(gp-swap-to-b)
(u-set! ul l)
(u-set! ur r)
(gp-swap-to-a)
((car l)))))))
(define (unwind-if-more-then-one-set)
(begin
(gp-swap-to-b)
(let ((m (gp-lookup n)))
(if (= m 1)
(gp-unwind 2)
(u-set! n (+ m 1))))
(gp-swap-to-a)))
(loop
(map (lambda (a)
(lambda ()
(gp-restore-state s)
(a
(lambda ()
(loop (cdr (gp-lookup ul))
(gp-lookup ur)))
(lambda (pp)
(cc (let* ((s (gp-store-state))
(l (gp-lookup ul))
(r (gp-lookup ur)))
(unwind-if-more-then-one-set)
(lambda ()
(loop (cdr l)
(cons (lambda ()
(gp-restore-state s)
(pp))
r)))))))))
l)
'())))))
LIBS = `pkg-config --libs guile-2.0`
CFLAGS = `pkg-config --cflags guile-2.0`
libguile-unify.so : unify.h unify.c unify-undo-redo.c unify.x
gcc $(LIBS) $(CFLAGS) -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c
guile-snarf -o unify.x $(CFLAGS) unify.c
#define gp_store 1
#define gp_redo 2
#define gp_redo_tag 2
#define gp_save_tag 6
#define gp_unbd SCM_PACK(GP_MK_FRAME_UNBD(gp_type))
//#define DB(X)
static inline SCM gp_handle(SCM item, int ret)
{
SCM x = SCM_BOOL_F,q,a,b,*id;
if(SCM_CONSP(item))
{
if(GP(SCM_CAR(item)))
{
id = GP_GETREF(SCM_CAR(item));
q = SCM_CDR(item);
a = SCM_CAR(q);
b = SCM_CDR(q);
if(ret)
{
SCM_SETCAR(q,SCM_I_MAKINUM(id[0]));
SCM_SETCDR(q,id[1]);
}
id[0] = SCM_PACK(SCM_I_INUM(a));
id[1] = b;
return item;
}
scm_call_0(SCM_CDR(item));
return item;
}
else
{
id = GP_GETREF(item);
if(ret)
x = scm_cons(GP_UNREF(id),
scm_cons(SCM_I_MAKINUM(id[0]),id[1]));
id[0] = gp_unbd;
id[1] = SCM_UNBOUND;
return x;
}
}
static inline int gp_advanced(SCM item, int state, SCM *old)
{
SCM redo;
scm_t_bits tag = SCM_UNPACK(SCM_CAR(item));
switch(tag)
{
case gp_save_tag:
switch(state)
{
case gp_redo:
case gp_store:
SCM_SETCDR(*old, item);
case 0:
*old = item;
item = SCM_CDR(item);
SCM_SETCAR(*old, gp_handle(item, 1));
SCM_SETCDR(*old, SCM_EOL);
return gp_store;
}
case gp_redo_tag:
item = SCM_CDR(item);
redo = SCM_CAR(item);
if(state == gp_store)
SCM_SETCDR(*old, redo);
gp_handle(SCM_CDR(item), 0);
*old = redo;
return gp_redo;
default:
return 0;
}
}
/*
item
'(id id[0] id[1])
(redo . undo)
(i . l)
*/
static inline int gp_do_cons(SCM item, int state, SCM *old)
{
SCM q,a,b,*id,tag = SCM_CAR(item);
if(SCM_I_INUMP(tag))
return gp_advanced(item,state,old);
if(!GP(tag))
{
if(state)
switch(state)
{
case gp_store:
{
SCM newold = scm_cons(item,SCM_EOL);
SCM_SETCDR(*old, newold);
*old = newold;
break;
}
case gp_redo:
*old = SCM_CDR(*old);
}
scm_call_0(SCM_CDR(item));
return state;
}
id = GP_GETREF(tag);
q = SCM_CDR(item);
a = SCM_CAR(q);
b = SCM_CDR(q);
if(state)
{
switch(state)
{
case gp_store:
{
SCM_SETCAR(q, SCM_I_MAKINUM(id[0]));
SCM_SETCDR(q, id[1]);
item = scm_cons(item,SCM_EOL);
if(SCM_CONSP(*old))
SCM_SETCDR(*old,item);
*old = item;
break;
}
case gp_redo:
*old = SCM_CDR(*old);
}
}
id[0] = SCM_PACK(SCM_I_INUM(a));
id[1] = b;
return state;
}
static inline void gp_unwind0(SCM *ci, SCM *si)
{
SCM val, old = SCM_EOL;
SCM *i, *ci_old, *id;
int state = 0;
DB(printf("unwind>\n");fflush(stdout));
ci_old = gp_ci;
gp_ci = ci;
gp_si = si;
if (ci_old-1 >= gp_ci)
for(i = ci_old-1; i >= gp_ci; i-=1)
{
if(SCM_CONSP(*i))
{
state = gp_do_cons(*i, state, &old);
continue;
}
id = GP_GETREF(*i);
if(state)
{
switch(state)
{
case gp_store:
{
val = scm_cons(scm_cons(*i, scm_cons(SCM_I_MAKINUM(id[0]),
id[1])),
SCM_EOL);
if(SCM_CONSP(old))
SCM_SETCDR(old,val);
old = val;
break;
}
case gp_redo:
old = SCM_CDR(old);
}
}
id[0] = gp_unbd;
id[1] = SCM_UNBOUND;
}
if(state)
switch(state)
{
case gp_store:
if(gp_ci == gp_cstack)
{
SCM_SETCDR(old,SCM_EOL);
return;
}
if(SCM_CONSP(gp_ci[-1]))
{
SCM q = SCM_CAR(gp_ci[-1]);
if(SCM_I_INUMP(q))
{
switch(SCM_UNPACK(q))
{
case gp_save_tag:
SCM_SETCDR(old,gp_ci[-1]);
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp_ci[-1]));
return;
}
}
}
gp_ci[-1] = scm_cons(SCM_PACK(gp_save_tag),gp_ci[-1]);
SCM_SETCDR(old,gp_ci[-1]);
return;
case gp_redo:
if(gp_ci == gp_cstack)
return;
if(SCM_CONSP(gp_ci[-1]))
{
SCM q = SCM_CAR(gp_ci[-1]);
if(SCM_I_INUMP(q))
{
switch(SCM_UNPACK(q))
{
case gp_save_tag:
SCM_SETCDR(old,gp_ci[-1]);
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp_ci[-1]));
return;
}
}
}
gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(SCM_CDR(old), gp_ci[-1]));
}
}
static inline void gp_unwind(SCM fr)
{
SCM *ci,*si;
if(SCM_CONSP(fr))
{
ci = NUM2PTR(SCM_CAR(fr));
si = NUM2PTR(SCM_CDR(fr));
}
else
{
ci = gp_ci - SCM_I_INUM(fr);
if(ci < gp_cstack)
ci = gp_cstack;
si = gp_si;
}
gp_unwind0(ci,si);
}
SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
"unwinds the prolog stack till frame refered by the argument")
#define FUNC_NAME s_gp_gp_unwind
{
gp_unwind(fr);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static inline SCM gp_store_state()
{
SCM head, data;
if(gp_ci == gp_cstack)
{
return scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(0), SCM_EOL));
}
data = gp_ci[-1];
head = SCM_EOL;
if(SCM_CONSP(data) && SCM_I_INUM(SCM_CAR(data)))
{
switch(SCM_UNPACK(SCM_CAR(data)))
{
case gp_save_tag:
head = data;
break;
case gp_redo_tag:
head = SCM_CADR(data);
}
}
else
{
head = scm_cons(SCM_PACK(gp_save_tag),data);
gp_ci[-1] = head;
}
return scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(gp_ci - gp_cstack), head));
}
SCM_DEFINE(gp_gp_store_state, "gp-store-state", 0, 0, 0, (),
"sore a continuation point at the current state")
#define FUNC_NAME s_gp_gp_store_state
{
return gp_store_state();
}
#undef FUNC_NAME
//#define DB(X)
static inline SCM * gp_get_branch(SCM *p, SCM *ci)
{
SCM d;
SCM pp = *p;
int i = 0;
retry:
i++;
if(pp == SCM_EOL)
return gp_cstack;
if(pp == *ci)
{
*p = pp;
return ci;
}
if(pp == ci[i+1])
{
gp_debug0("off by +1\n");
}
if(pp == ci[i-1])
{
gp_debug0("off by -1\n");
}
if(SCM_CONSP(*ci) && SCM_UNPACK(SCM_CAR(*ci)) == gp_redo_tag)
{
i--;
d = SCM_CADR(*ci);
gp_debug0("a redo_shift\n");
goto cdrcdr;
}
if(SCM_CONSP(pp))
{
pp = SCM_CDR(pp);
}
else
{
scm_misc_error ("gp_get_branch", "not a pair or '() pp ~a n ~a",
scm_list_2 (pp, SCM_I_MAKINUM(i)));
}
ci--;
goto retry;
cdrcdr:
i++;
if(pp == SCM_EOL)
return gp_cstack;
if(SCM_CONSP(pp) && SCM_CDR(pp) == d)
{
gp_debug0("pp off py +1\n");
}
if(SCM_CONSP(d) && SCM_CDR(d) == pp)
{
gp_debug0("pp off py -1\n");
}
if(pp == d)
{
*p = pp;
return ci;
}
if(SCM_CONSP(*ci) && SCM_UNPACK(SCM_CAR(*ci)) == gp_save_tag)
{
i--;
goto retry;
}
if(SCM_CONSP(pp))
{
pp = SCM_CDR(pp);
}
else
{
scm_misc_error ("gp_get_branch", "pp not a pair or '() pp ~a n ~a",
scm_list_2 (pp, SCM_I_MAKINUM(i)));
}
if(SCM_CONSP(d))
{
d = SCM_CDR(d);
}
else
{
scm_misc_error ("gp_get_branch", "d not a pair or '() d ~a n ~a",
scm_list_2 (d, SCM_I_MAKINUM(i)));
}
ci--;
goto cdrcdr;
}
static int gp_rewind(SCM pp, SCM pend, SCM *ci)
{
SCM *id,q,stack[50];
int sp;
if( pp == SCM_EOL) return 0;
if(pend == pp) return 0;
sp = 0;
while(1)
{
if(pend == pp) break;
if( pp == SCM_EOL) break;
stack[sp++] = pp;
if(sp == 50)
{
gp_rewind(SCM_CDR(pp), pend, ci);
break;
}
pp = SCM_CDR(pp);
}
sp--;
while(sp >= 0)
{
pp = stack[sp];
q = SCM_CAR(pp);
if(GP(SCM_CAR(q)))
{
id = GP_GETREF(SCM_CAR(q));
q = SCM_CDR(q);
gp_store_var_2(id,0);
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(q)));
id[1] = SCM_CDR(q);
}
else
{
scm_call_0(SCM_CAR(q));
gp_ci[0] = q;
gp_ci ++;
}
sp--;
}
return 1;
}
static void gp_restore_state(SCM data)
{
SCM *si, q, path;
int n, m;
SCM *ci,*ci_x,pp_x;
int restored;
gp_debug0("to restore\n");
if(SCM_CONSP(data))
{
si = NUM2PTR(SCM_CAR(data));
q = SCM_CDR(data);
if(SCM_CONSP(q))
{
n = SCM_I_INUM(SCM_CAR(q));
path = SCM_CDR(q);
m = gp_ci - gp_cstack;
}
else
{
scm_simple_format(SCM_BOOL_T,
scm_from_locale_string("d: ~a q: ~a~%"),
scm_list_2(data, q));
printf("wrong input (1) to gp-restore-state\n");fflush(stdout);
return;
}
}
else
{
printf("wrong input (0) to gp-restore-state\n");fflush(stdout);
return;
}
gp_debug0("prepare si state\n");
if(si > gp_si)
{
SCM *s;
for(s = gp_si; s < si; s++)
{
s[0] = gp_unbd;
s[1] = SCM_UNBOUND;
}
gp_si = si;
}
gp_debug0("make paths equal length\n");
ci_x = gp_ci - 1;
pp_x = path;
if(m > n)
{
gp_debug0("m > n\n");
ci_x = gp_ci - (m - n) - 1;
gp_unwind0(ci_x + 1, si);
}
if(n > m)
{
gp_debug0("n > m\n");
pp_x = path;
for(;n > m; n--)
{
pp_x = SCM_CDR(pp_x);
}
}
gp_debug0("get-branch\n");
ci = gp_get_branch(&pp_x, ci_x);
gp_debug0("unwind\n");
gp_unwind0(ci + 1, si);
gp_debug0("rewind\n");
restored = gp_rewind(path,pp_x,ci);
gp_debug0("check restored\n");
if(restored)
gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(path, gp_ci[-1]));
}
//#define DB(X)
SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 1, 0, 0, (SCM cont),
"restore a continuation point")
#define FUNC_NAME s_gp_gp_restore_state
{
gp_restore_state(cont);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define DB(X)