fixed <take>, doc update

parent 8d70c746
......@@ -251,7 +251,7 @@ recurrence check e.g. loop detection. @code{#f} if they do not unify (note that
@findex gp-fluid-set!
@findex gp-fluid-ref
@findex with-gp-fluids
@findex u-dynwind
@findex gp-dynwind
@code{(gp-make-fluid)} makes a special kind of fluid that follows the unify stack and not the call stack e.g. is a fluid referring to the current stack bank.
......@@ -261,7 +261,7 @@ recurrence check e.g. loop detection. @code{#f} if they do not unify (note that
@code{(with-gp-fluids ((fl v) ...) code ...)}, Compare with with-fluids
@code{(u-dynwind Redo Do Undo)} a similar tool as the dynwind construction but this one follows the current bank stack and not the call stack.
@code{(gp-dynwind Redo Do Undo)} a similar tool as the dynwind construction but this one follows the current bank stack and not the call stack.
@section spurious commands
@findex gp-print
......@@ -542,6 +542,7 @@ G.L. (if S X Y)
@findex <run>
@findex <stall>
@findex <continue>
@findex <take>
@code{Scm (<with-guile-log> (p cc) code ...)}, this will start a guile-log session using failure think p and continuation @code{cc} and use @code{p} as a cut as well.
......@@ -557,7 +558,9 @@ G.L. (if S X Y)
@code{G.L. (<continue>)}, this will make it possible to continue a stalled run, but if the run opted out after n successes then must ask for the number of more successes as well by using:
@code{G.L. (<continue> n)}, with @code{n} the number of more successes to return.
@code{G.L. (<continue> n)}, with @code{n} the number of more successes to returnif we started with @code{{<run> n () ...)}.
@code{G.L. <take>}, this is the same as @code{<continue>}.
@section Guile-log macro definitions
@findex define-guile-log
......
......@@ -6,7 +6,10 @@
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system repl repl)
#:re-export (umatch u-cons u-abort u-var! u-scm u-unify! u-unify-raw!))
#:re-export (u-cons u-abort u-var! u-scm u-unify! u-unify-raw!)
#:export (umatch))
(define-syntax umatch (syntax-rules () ((_ . l) (**um** . l))))
(define log-module
(resolve-module
......
(define-module (logic guile-log database)
#:use-module (logic guile-log guile-log)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
......
......@@ -8,7 +8,7 @@
<and!> <and!!> <succeeds>
<format> <tail-code> <code> <ret> <return>
<def> <<define>> <with-fail> <dynwind>
let<> <or!> <stall> <continue>)
let<> <or!> <stall> <continue> <take>)
(re-export define-guile-log guile-log-macro? log-code-macro log-code-macro?)
......@@ -17,17 +17,20 @@
(gp-fluid-set! *cc* #f)
(define (<stall> p cc)
(<return>
(set! *cc* (cons p cc))))
(set! *cc* (cons p cc))
'stalled)
(define (<take> n) (<continue> n))
(define <continue>
(case-lambda
(() (if (and *cc* (car *cc*))
((cdr *cc*) (car *cc*))
#f))
((n) (if (and *cc* (integer? n) (not (car *cc*)))
(() (let ((*cc* (pk (gp-fluid-ref *cc*))))
(if (and *cc* (car *cc*))
((cdr *cc*) (car *cc*))
#f)))
((n) (let ((*cc* (gp-fluid-ref *cc*)))
(if (and *cc* (integer? n) (not (car *cc*)))
((cdr *cc*) n)
'cannot-continue-and-take-n))))
'cannot-continue-and-take-n)))))
(define-syntax <eval>
(syntax-rules ()
......@@ -40,20 +43,24 @@
(define-syntax <run>
(syntax-rules (*)
((_ (v) code ...)
(let ((ret '()))
(let ((ret '())
(fr (gp-newframe)))
(<eval> (v)
(<and> code ...)
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(set! ret (cons (u-scm v) ret))
(u-abort p)))))
((_ (v ...) code ...)
(let ((ret '()))
(let ((ret '()) (fr (gp-newframe)))
(<eval> (v ...)
(<and> code ...)
(lambda x (reverse ret))
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(set! ret (cons (u-scm (list v ...)) ret))
(u-abort p)))))
......@@ -63,31 +70,41 @@
((_ m (v) code ...)
(let ((n m)
(fr (gp-newframe))
(ret '()))
(<eval> (v)
(<and> code ...)
(lambda x (reverse ret))
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(if (> n 0)
(if (= n 0)
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc* (cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
r)
(begin
(set! ret (cons (u-scm v) ret))
(set! n (- n 1))
(if (= n 0)
(reverse ret)
(u-abort p)))
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc* (cons #f (lambda (m)
(set! n m)
(u-abort p))))
r))))))
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc* (cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
r)
(u-abort p))))))))
((_ m (v ...) code ...)
(let ((n m) (ret '()))
(let ((n m) (ret '()) (fr (gp-newframe)))
(<eval> (v ...)
(<and> code ...)
(lambda x (reverse ret))
(lambda x
(gp-unwind fr)
(reverse ret))
(lambda (p)
(if (> n 0)
(begin
......@@ -97,9 +114,10 @@
(let ((r (reverse ret)))
(set! ret '())
(gp-set! *cc*
(cons #f (lambda (m)
(set! n m)
(cons #f (lambda (mm)
(set! n mm)
(u-abort p))))
(pk *cc*)
r)
(u-abort p)))
(reverse ret))))))))
......@@ -471,10 +489,11 @@
(n p cc v ...)))))
(define-guile-log <letrec>
((_ (cut q p cc) ((v lam) ...) code ...)
(letrec ((v lam) ...)
(parse<> (cut q p cc)
(<and> code ...)))))
(syntax-rules ()
((_ (cut q p cc) ((v . lam) ...) code ...)
(letrec ((v . lam) ...)
(parse<> (cut q p cc)
(<and> code ...))))))
(define-syntax find-last0
(syntax-rules ()
......
(define-module (logic guile-log postpone)
#:use-module (logic guile-log guile-log)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 match)
#:export (postpone-frame postpone))
(define-syntax umatch (syntax-rules () ((a . l) (um . l))))
(define *limit* (gp-make-fluid))
(define *max-limit* (gp-make-fluid))
......
......@@ -150,9 +150,9 @@ static inline void gp_unwind0(SCM *ci, SCM *si)
DB(printf("unwind>\n");fflush(stdout));
if(ci >= gp_ci || si >= gp_si)
if(ci > gp_ci || si > gp_si)
{
if(ci >= gp_ci && si >= gp_si)
if(ci > gp_ci && si > gp_si)
return;
printf("ERROR in unwind, ci and si not larger at the same time\n");
return;
......
......@@ -31,15 +31,16 @@
gp-car gp-cdr gp-pair?
gp-store-state gp-restore-state
gp-make-fluid gp-fluid-set! gp-fluid-ref with-gp-fluids
gp-dynwind
u-prompt u-abort u-set! u-var! u-call u-deref gp-atomic?
u-context u-modded
u-unify! u-scm u-unify-raw! u-cons u-dynwind umatch
gp-copy))
gp-copy **um**))
;;need to add modded,
(define-syntax **um** (syntax-rules () ((_ . l) (umatch . l))))
(define gp-module-init #f)
(define gp? #f)
......@@ -47,6 +48,15 @@
(define gp-car #f)
(define gp-cdr #f)
(define old gp-make-fluid)
(define gp-make-fluid
(case-lambda
(() (old))
((x) (let ((ret (old)))
(gp-fluid-set! ret x)
ret))))
(let ((file (%search-load-path "logic/guile-log/src/libguile-unify.so")))
(if file
(load-extension file "gp_init")
......@@ -104,6 +114,9 @@
(gp-dynwind p post)
(action)))))
(define-syntax gp-dynwind
(syntax-rules () ((_ . l) (u-dynwind . l))))
;;prompts will be just a continuation lambda
(define-syntax u-prompt
......@@ -213,10 +226,6 @@
;(pk `(umatch*** ,@(syntax->datum #'l)))
#'(umatch***+ . l)))))
(define-syntax ppq
(syntax-rules () ((_ a x) x)))
(define (mk-failure0 fr code)
(letrec ((base (case-lambda
(()
......@@ -240,7 +249,7 @@
(define-syntax umatch***+
(syntax-rules (+)
((_ (code ...) () () (n t _ _))
(let ((frame (ppq 'new (gp-newframe))))
(let ((frame (gp-newframe)))
(umatch0 (#:args)
((arguments) (-> t (mk-failure frame))
code)
......@@ -248,7 +257,7 @@
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t #t +))
(let ((frame (ppq 'new (gp-newframe))))
(let ((frame (gp-newframe)))
(umatch0 (#:args . arg)
((arguments (++ ++ a) ...)
(-> t (mk-failure frame))
......@@ -258,7 +267,7 @@
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (code ...) ((a ...) ...) arg (n t r m))
(let ((frame (ppq 'new (gp-newframe))))
(let ((frame (gp-newframe)))
(umatch0 (#:args . arg)
((arguments (m m a) ...)
(-> t (mk-failure frame))
......@@ -267,3 +276,4 @@
(_ (error (format #f "umatch ~a did not match" n))))))))
......@@ -135,4 +135,3 @@
(equal? '(#f #f #f #f #f) (f-alw-1)))
(pass-if "map and append test"
(equal? '(((1 2 3 4 5 6 7 8 9)) f-app))))
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