arg debugging and trace system implemented

parent 7a84510e
......@@ -162,7 +162,7 @@
:- op(700, xfx, cis_leq).
:- op(700, xfx, cis_lt).
:- fast_compile(true).
%:- fast_compile(true).
/** <module> Constraint Logic Programming over Finite Domains
......
......@@ -1054,12 +1054,16 @@ add/run * vlist *
(p))))
((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a)))))))
(setter g)
(set-object-property! g 'dynamic-data
(define gg (lambda x (apply g x)))
(define sg (case-lambda (() g) ((h) (set! g h))))
(setter gg)
(set-procedure-property! gg 'debug-fkn sg)
(set-object-property! gg 'dynamic-data
(vector add-l add-r rm compile
env-ref env-set! compi
truncate! ref++ ref-- walk-lr))
(set-procedure-property! g 'name f))))
(set-procedure-property! gg 'name f))))
(define-syntax-rule (define-dynamic f)
......
......@@ -2,6 +2,33 @@
#:use-module (logic guile-log dynlist)
#:export ())
#|
Let us introduce the concept of parent generations.
It's constructive e.g. we can remove arrows
|#
(define set-to-generation (make-hash-table))
(define-inlinable (register-singleton-parent set)
(hash-set! set-to-generation set 0)
(add-generation generation-data 0
(define-inlinable (get-generation set)
(aif (r) (hash-ref set-to-generation set #f)
(values (car r) (cdr r) r)
(values
(define (a=p=>b set-a set-b state)
(call-with-values (lambda (x) (get-generation set-b state))
(lambda (p s qa)
(if (not (medlem set-b s state)
(call-with-values (lambda (x) (get-parent-generation set-b state))
(lambda (p s qp)
(move-generation set-a qa qp state))))))))
(define i 1)
(define set-to-i (make-hash-table))
(define i-to-set (make-hash-table))
......@@ -33,6 +60,12 @@
(let ((high (get-high-bit ih)))
(cons (hash-ref i-to-set high #f) (lp (lognot ih high))))))))
(define (a->b-generations a b)
(if (not (a=>b? a b))
(call-with-values (lambda () (get-generation a))
(lambda (s p)
(if (and (a-in-b b s)
#|
Typically function matchers make use of a subset of the available types
......
......@@ -316,53 +316,54 @@ sort(X,L) :- msort(X,LL),unique(LL,L).
(<code>
(aif (r) (hashq-ref original f #f)
#t
(let* ((n (procedure-name f))
(mod (resolve-module (procedure-property f 'module)))
(v (lambda (x) (if simple? n (vector (cons f x)))))
(new (<lambda> x
(<dyn>
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x)))
(nl))
(<with-log-in-code>
(wr)
(write `(enter - ,(v x)))
(nl)
(<code> (set! i (- i 1)))))
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x))) (nl)
(<apply> f x)
(<dyn>
(<with-log-in-code>
(wr)
(write `(leave + ,(v x)))
(nl)
(<code> (set! i (- i 1))))
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(leave - ,(v x)))
(nl)))
(wr)
(write `(leave + ,(v x)))
(<code> (set! i (- i 1)))
(nl))))
(hashq-set! original new f)
(module-set! mod n new)
(set-procedure-properties! new (procedure-properties f))
(set-object-properties! new (object-properties f))))))
(aif (r) (procedure-property f 'debug-fkn)
(let* ((ff (r))
(n (procedure-name f))
(v (lambda (x) (if simple? n (vector (cons f x)))))
(new (<lambda> x
(<dyn>
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x)))
(nl))
(<with-log-in-code>
(wr)
(write `(enter - ,(v x)))
(nl)
(<code> (set! i (- i 1)))))
(<code> (set! i (+ i 1)))
(wr)
(write `(enter + ,(v x))) (nl)
(<apply> ff x)
(<dyn>
(<with-log-in-code>
(wr)
(write `(leave + ,(v x)))
(nl)
(<code> (set! i (- i 1))))
(<with-log-in-code>
(<code> (set! i (+ i 1)))
(wr)
(write `(leave - ,(v x)))
(nl)))
(wr)
(write `(leave + ,(v x)))
(<code> (set! i (- i 1)))
(nl))))
(hashq-set! original f ff)
(r new))
#t))))
(<define> (untr f)
(<code>
(aif (r) (hashq-ref original f #f)
(let ((n (procedure-name f))
(mod (resolve-module (procedure-property f 'module))))
(module-set! mod n r)
(hashq-set! original f #f))
(aif (s) (procedure-property f 'debug-fkn)
(begin
(s r)
(hashq-set! original f #f))
#t)
#t)))
(set-procedure-property! list 'name 'list)
(export-scm)
......@@ -10,7 +10,7 @@
#:re-export (define-and-log
define-guile-log guile-log-macro? log-code-macro
log-code-macro?)
#:replace (procedure-name)
#:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if>
functorize adaptable_vars
<with-guile-log> <if-some>
......@@ -46,6 +46,14 @@
dls-match
))
(define old-pn (@ (guile) procedure-name))
(define-inlinable (procedure-name f)
(let ((fnm (procedure-property f 'name)))
(if fnm
fnm
(pk 'old (old-pn f)))))
(define (<wrap> f . l)
(apply f (fluid-ref *current-stack*) (lambda x #f) (lambda (s . l) s) l))
(define (<wrap-s> f s . l)
......
......@@ -150,27 +150,36 @@
xx)))
(define-syntax-rule (define-or-set! x)
(let* ((bd? (module-locally-bound? (current-module) Fkn))
(fold (module-ref (current-module) Fkn))
(xx x))
(let* ((bd? (module-locally-bound? (current-module) Fkn))
(fold (module-ref (current-module) Fkn))
(xx x)
(xxf (if (procedure? xx) (<lambda> z (<apply> xx z)) xx))
(sf (case-lambda
(() xx)
((f) (set! xx f)))))
(set-procedure-property! xxf 'debug-fkn sf)
(if bd?
(module-set! (current-module) Fkn xx)
(define! Fkn xx))
(module-set! (current-module) Fkn xxf)
(define! Fkn xxf))
(set-procedure-property! xx 'module (module-name (current-module)))
(set-procedure-property! xx 'name Fkn)))
(set-procedure-property! xxf 'module (module-name (current-module)))
(set-procedure-property! xxf 'name Fkn)))
(define (define-or-set-fkn! f x)
(letrec ((bd? (module-locally-bound? (current-module) Fkn))
(fold (module-ref (current-module) Fkn))
(xx x))
(xx x)
(xxf (if (procedure? xx) (<lambda> z (<apply> xx z)) xx))
(sf (case-lambda
(() xx)
((f) (set! xx f)))))
(set-procedure-property! xxf 'debug-fkn sf)
(if bd?
(module-set! (current-module) f xx)
(define! f xx))
(module-set! (current-module) f xxf)
(define! f xxf))
(set-procedure-property! xx 'module (module-name (current-module)))
(set-procedure-property! xx 'name f)))
(set-procedure-property! xxf 'module (module-name (current-module)))
(set-procedure-property! xxf 'name f)))
(define lambdas (make-fluid '()))
......
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log guile-prolog closure)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 match)
#:use-module (ice-9 time)
#:use-module (logic guile-log)
#:use-module (logic guile-log functional-database)
#:use-module ((logic guile-log prolog names)
......
......@@ -17,7 +17,8 @@
#:use-module (logic guile-log attributed)
#:use-module (logic guile-log hash-dynamic)
#:use-module ((logic guile-log)
#:select (<define> <let> <scm> <var?> <pp> <fail>
#:select (procedure-name
<define> <let> <scm> <var?> <pp> <fail>
<lookup> <match> <<match>> <cut>
<or> <=> <recur> <code> <cc>))
#:use-module (ice-9 match)
......
(define-module (logic guile-log prolog error)
#:use-module ((logic guile-log)
#:select (</.> <abort> <define> <match> <cut> <let> <cp>
S <pp> <lookup> <var?> <cc> <fail> <lambda> <fail>))
#:select (procedure-name
</.> <abort> <define> <match> <cut> <let> <cp>
S <pp> <lookup> <var?> <cc> <fail> <lambda> <fail>))
#:use-module (ice-9 match)
#:use-module (logic guile-log prompts)
#:use-module (logic guile-log umatch)
......
......@@ -3,7 +3,7 @@
(CUT <if> <define> <match> <<match>>
<let> <apply> <cut> <fail> S
<and> <with-cut> <cc> <pp> <lookup> <var?> <pp> <cut>
<code> </.>
<code> </.> procedure-name
define-guile-log))
#:use-module (logic guile-log guile-prolog closure)
#:use-module (logic guile-log umatch)
......
......@@ -990,60 +990,66 @@ floor(x) (floor x)
(domain_error not_less_than_zero n)
(type_error integer n)))
(_ (<cut> <cc>)))
(cond
((procedure? term)
<fail>)
((<var?> term)
(instantiation_error))
((<var?> n) <cc>)
((not (integer? n))
(type_error integer n))
((< n 0)
(domain_error not_less_than_zero n))
(else <cc>))
(cond
((<var?> n)
(<let> ((lam (<lambda> (term)
(<recur> lp ((i 0) (term term))
(<<match>> (#:mode - #:name arg) (term)
(<match> (#:mode + #:name arg) (term)
((,a . l)
(<or> (<=> n i) (lp (+ i 1) l)))
((_ . l)
(<=> n i))
((_ . l)
(lp (+ i 1) l))
(_ <fail>))))))
(cond
((and (vector? term) (= (vector-length term) 1))
(lam (vector-ref term 1)))
(cond
((and (vector? term) (= (vector-length term) 1))
(lam (vector-ref term 0)))
(else
(<<match>> (#:mode - #:name 'arg2) (term)
((x . l) (lam (list cons x l)))
(_ (domain_error "term" term)))))))
((and (vector? term) (= (vector-length term) 1))
(<recur> lp ((l (vector-ref term 0)) (n n))
(<<match>> (#:mode - #:name arg-2) (l)
((x . l)
(if (= n 0)
(<=> x a)
(lp l (- n 1))))
(()
<fail>))))
(else
(<<match>> (#:mode - #:name 'arg2) (term)
((x . l) (lam (list cons x l)))
(_ (domain_error "term" term)))))))
((not (integer? n))
(type_error integer n))
((< n 0)
(domain_error not_less_than_zero n))
(else <cc>))
(cond
((and (vector? term) (= (vector-length term) 1))
(<recur> lp ((l (vector-ref term 0)) (n n))
(<<match>> (#:mode - #:name arg-2) (l)
(<<match>> (#:mode - #:name 'arg3) (term)
((x . l)
(if (= n 0)
(<=> x a)
(lp l (- n 1))))
(cond
((= n 0) (<=> a cons))
((= n 1) (<=> a x))
((= n 2) (<=> a l))
(else
<fail>)))
(()
<fail>))))
(else
(<<match>> (#:mode - #:name 'arg3) (term)
((x . l)
(cond
((= n 0) (<=> a cons))
((= n 1) (<=> a x))
((= n 2) (<=> a l))
(else
<fail>)))
(()
<fail>)
(_
(domain_error "term" term)))))))
<fail>)
(_
(domain_error "term" term)))))))
(<define> (procedure_name f out)
(<let> ((f (<lookup> f)))
......
(define-module (logic guile-log prolog namespace)
#:use-module (logic guile-log code-load)
#:use-module ((logic guile-log)
#:select (<define> <lookup> <scm> <=> <code> <wrap>))
#:select (procedure-name
<define> <lookup> <scm> <=> <code> <wrap>))
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog closed)
......
(define-module (logic guile-log prolog operators)
#:use-module ((logic guile-log) #:select (CUT <define> <with-cut>))
#:use-module ((logic guile-log)
#:select (procedure-name CUT <define> <with-cut>))
#:use-module (ice-9 match)
#:use-module (logic guile-log prolog pre)
#:export (f->stxfkn
......
......@@ -14,13 +14,15 @@
#:use-module (logic guile-log prolog names)
#:use-module (logic guile-log prolog error)
#:use-module (logic guile-log prolog symbols)
#:use-module ((logic guile-log) #:select (<let> <pp> <scm> <code> <let*>
<var> <=> <fail> <match>
<cut> <and> <or> <define>
<cc> <not> <if> <values>
<recur> <<match>> <lambda>
<catch> <ret> <format> S
(<_> . GL:_)))
#:use-module ((logic guile-log)
#:select (<let> <pp> <scm> <code> <let*>
<var> <=> <fail> <match>
<cut> <and> <or> <define>
<cc> <not> <if> <values>
<recur> <<match>> <lambda>
<catch> <ret> <format> S
(<_> . GL:_)
procedure-name))
#:re-export (*prolog-file* get-refstr)
#:export (prolog-parse define-parser-directive add-op rem-op
reset-operator-map
......
......@@ -40,7 +40,7 @@
group_pairs_by_key
transpose))
(define term_variables
(define term_variables
(<case-lambda>
((term l tail)
(<let> ((seen (make-hash-table)))
......
......@@ -11,8 +11,10 @@
#:use-module (ice-9 eval-string)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module ((logic guile-log) #:select ((<_> . GL:_) <define>
<code> <cc> <lookup> CUT S))
#:use-module ((logic guile-log)
#:select (procedure-name
(<_> . GL:_) <define>
<code> <cc> <lookup> CUT S))
#:export (arg pat-match var term term-init-variables v-variables
term-get-variables-list term-get-variables))
......
......@@ -13,6 +13,15 @@
} while(0)
#endif
inline int getNsol(scm_t_bits x)
{
int i;
bsf(i,x);
if(i < 0) return 0;
if( (x & ~(1UL << i)) == 0) return 1;
return 2;
}
inline SCM make_indexer()
{
SCM ret = scm_c_make_vector(5, SCM_BOOL_F);
......@@ -225,7 +234,7 @@ inline SCM get_fs_from_atoms(SCM a, SCM *dlink)
SCM rr = get_in_strings(dlink);
if(scm_is_true(rr))
{
SCM aa = scm_procedure_name(a);
SCM aa = gp_procedure_name(a);
aa = scm_symbol_to_string(aa);
SCM ww = vhash_assoc(aa,rr);
if(!scm_is_eq(ww, SCM_UNSPECIFIED))
......@@ -309,6 +318,7 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus)
//gp_format2("index for ~a db ~a~%", e, db_);fflush(stdout);
db = dB(db_);
if(scm_is_false(db_))
{
data[0] = 0UL;
......@@ -377,8 +387,14 @@ void get_index_set_0(SCM s, SCM e, SCM db_, int *n, ulong *data, int isPlus)
//printf("CAR\n");
get_index_set_0(s,x,dcar, n, data, isPlus);
}
int nsol = 0;
for(i = 0; i < *n && nsol < 2; i++)
{
nsol += getNsol(data[i]);
}
if(scm_is_true(dcdr))
if(nsol > 1 && scm_is_true(dcdr))
{
//printf("CDR\n");
get_index_set_0(s,l,dcdr, n, data, isPlus);
......
......@@ -105,6 +105,19 @@ SCM closure_tag;
scm_list_3(x,y,z)))
SCM gp_name_sym = SCM_BOOL_F;
SCM gp_procedure_name(SCM f)
{
SCM ret = scm_procedure_property(f, gp_name_sym);
if(scm_is_false(ret))
{
ret = scm_procedure_name(f);
format1("non simple name > ~a~%",ret);
return ret;
}
return ret;
}
#define DB(X)
#define DS(X)
......@@ -1881,7 +1894,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
{
if(scm_is_true(scm_procedure_p (scm2)))
{
scm2 = scm_procedure_name(scm2);
scm2 = gp_procedure_name(scm2);
if(scm_is_true (scm2))
{
scm2 = scm_symbol_to_string (scm2);
......@@ -1896,7 +1909,7 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
{
if(scm_is_true(scm_procedure_p (scm1)))
{
scm1 = scm_procedure_name(scm1);
scm1 = gp_procedure_name(scm1);
if(scm_is_true (scm1))
{
scm1 = scm_symbol_to_string (scm1);
......@@ -3479,6 +3492,11 @@ void gp_init()
scm_set_smob_print(gp_type, gp_printer);
{
SCM name_str = scm_from_locale_string ("name");
gp_name_sym = scm_string_to_symbol (name_str);
}
gp_current_stack = scm_make_fluid();
gp_module_stack_init();
......
......@@ -13,3 +13,4 @@
#:use-module (logic guile-log guile-prolog dynamic-features)
#:filename #f)
(compile-prolog-string ":- use_module(boot(if)).")
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