some refactoring to reduce lambda creation and code complexity

parent 78724e41
......@@ -118,34 +118,34 @@ PSSOURCES = \
logic/guile-log/guile-prolog/attributator.scm \
logic/guile-log/examples/kanren/type-inference.scm \
logic/guile-log/imatch.scm \
prolog-user.scm \
language/prolog/install.scm \
language/prolog/spec.scm \
language/prolog/modules/user.scm \
language/prolog/modules/sandbox.pl \
language/prolog/modules/boot/expand.pl \
language/prolog/modules/boot/dcg.pl \
language/prolog/modules/boot/if.pl \
language/prolog/modules/swi/term_macro.pl \
language/prolog/modules/library/error.pl \
language/prolog/modules/library/vhash.scm \
language/prolog/modules/library/pairs.pl \
language/prolog/modules/library/lists.pl \
language/prolog/modules/library/dcg_basics.pl \
language/prolog/modules/library/option.pl \
language/prolog/modules/library/optparse.pl \
language/prolog/modules/library/sort.pl \
language/prolog/modules/library/apply.pl \
language/prolog/modules/library/heaps.pl \
language/prolog/modules/library/assoc.pl \
language/prolog/modules/library/gensym.pl \
language/prolog/modules/library/occurs.pl \
language/prolog/modules/library/ordsets.pl \
language/prolog/modules/library/oset.pl \
language/prolog/modules/library/rbtrees.p \
language/prolog/modules/library/forward_chaining.pl \
language/prolog/modules/ex/att.pl \
language/prolog/modules/examples/cluster.pl
prolog-user.scm
# language/prolog/install.scm \
# language/prolog/spec.scm \
# language/prolog/modules/user.scm \
# language/prolog/modules/sandbox.pl \
# language/prolog/modules/boot/expand.pl \
# language/prolog/modules/boot/dcg.pl \
# language/prolog/modules/boot/if.pl \
# language/prolog/modules/swi/term_macro.pl \
# language/prolog/modules/library/error.pl \
# language/prolog/modules/library/vhash.scm \
# language/prolog/modules/library/pairs.pl \
# language/prolog/modules/library/lists.pl \
# language/prolog/modules/library/dcg_basics.pl \
# language/prolog/modules/library/option.pl \
# language/prolog/modules/library/optparse.pl \
# language/prolog/modules/library/sort.pl \
# language/prolog/modules/library/apply.pl \
# language/prolog/modules/library/heaps.pl \
# language/prolog/modules/library/assoc.pl \
# language/prolog/modules/library/gensym.pl \
# language/prolog/modules/library/occurs.pl \
# language/prolog/modules/library/ordsets.pl \
# language/prolog/modules/library/oset.pl \
# language/prolog/modules/library/rbtrees.p \
# language/prolog/modules/library/forward_chaining.pl \
# language/prolog/modules/ex/att.pl \
# language/prolog/modules/examples/cluster.pl
# language/prolog/modules/library/clpb.pl
# language/prolog/modules/library/clpfd.pl
# language/prolog/modules/library/apply_macros.pl
......
......@@ -1658,72 +1658,67 @@ add/run * vlist *
(if s #t #f))))
#f)))
(define-syntax-rule (wrapu s1 code)
(define (wrapu code)
(let* ((s1 (gp-newframe (fluid-ref *current-stack*)))
(s2 (gp-newframe s1)))
(with-fluids ((*current-stack* s2))
(let ((ret code))
(let ((ret (code s1)))
(gp-unwind s1)
ret))))
(define (wapu ff mk-dyn . lams)
(define f #f)
(if (and (module-locally-bound? (current-module) ff)
(dynamic? (module-ref (current-module) ff)))
(set! f (module-ref (current-module) ff))
(mk-dyn 'f (lambda (x) (set! f x))))
(for-each
(lambda (lam) (wrapu (lam f)))
lams)
f)
(define-syntax lambda*
(syntax-rules ()
((_ (x y) code ...)
(lambda (x) (lambda (y) code ...)))))
(define-syntax <<case-lambda-dyn>>
(lambda (z)
(syntax-case z ()
((_ ff ((pat ... code) ...) ...)
#'(let ()
(define f #f)
(if (and (module-locally-bound? (current-module) 'ff)
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn 'f (lambda (x) (set! f x))))
(wrapu s (apply dynamic-append s f (<lambda-dyn> (pat ...) code)))
... ...
f)))))
#'(wapu 'ff mk-dyn
(lambda* (f s)
(apply dynamic-append s f (<lambda-dyn> (pat ...) code)))
... ...)))))
(define-syntax <<case-lambda-dyn-ii>>
(lambda (z)
(syntax-case z ()
((_ ff ((pat ... code) ...) ...)
#'(let ()
(define f #f)
(if (and (module-locally-bound? (current-module) 'ff)
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn-ii 'f (lambda (x) (set! f x))))
(wrapu s (apply dynamic-append s f (<lambda-dyn> (pat ...) code)))
... ...
f)))))
#'(wapu 'ff mk-dyn-ii
(lambda* (f s)
(apply dynamic-append s f (<lambda-dyn> (pat ...) code)))
... ...)))))
(define-syntax <<case-lambda-dyn-extended>>
(lambda (z)
(syntax-case z ()
((_ ff ((pat ... code) ...) ...)
#'(let ()
(define f #f)
(if (and (module-locally-bound? (current-module) 'ff)
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn 'f (lambda (x) (set! f x))))
(wrapu s (apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...
f)))))
#'(wapu 'ff mk-dyn
(lambda* (f s)
(apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...)))))
(define-syntax <<case-lambda-dyn-extended-ii>>
(lambda (z)
(syntax-case z ()
((_ ff ((pat ... code) ...) ...)
#'(let ()
(define f #f)
(if (and (module-locally-bound? (current-module) 'ff)
(dynamic? (module-ref (current-module) 'ff)))
(set! f (module-ref (current-module) 'ff))
(mk-dyn-ii 'f (lambda (x) (set! f x))))
(wrapu s (apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...
f)))))
#'(wapu 'ff mk-dyn-ii
(lambda* (f s)
(apply dynamic-append s f
(<lambda-dyn-extended> (pat ...) code)))
... ...)))))
(define-syntax-parameter
<<case-lambda-dyn-combined>>
......
......@@ -304,6 +304,7 @@
#{;}#))
(compile-prolog-string
"
unique([X|L],LL) :- member(X,L) -> unique(L,LL)
......
......@@ -620,7 +620,16 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(define-syntax parse2<>
(lambda (x)
(syntax-case x (if when fast-when cond else case)
(syntax-case x (if when fast-when cond else case let let* letrec)
((_ meta (letrec . l))
#'(<letrec> meta . l))
((_ meta (let . l))
#'(<let> meta . l))
((_ meta (let* . l))
#'(<let> meta . l))
((_ meta (if p . l) )
#'(<scm-if> meta p . l))
......@@ -746,7 +755,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(lp (cdr l)))
(<code> (fluid-set! delayers old)))))
(define-syntax-rule (dls-wrap (cut s p cc) code)
(define (dls-wrap- cut s p cc code)
(let* ((old (fluid-ref delayers))
(p2 (lambda ()
(fluid-set! delayers old)
......@@ -757,7 +766,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(fl-let (cut2 s p2 cc)
(<and> (cut2 s p2 cc)
code
(code)
(if (eq? (fluid-ref delayers) old)
(if (eq? P p2)
(<with-fail> p <cc>)
......@@ -768,12 +777,19 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(<with-fail> p <cc>)
<cc>)))))))
(define-syntax-rule (dls-wrap (cut s p cc) code)
(dls-wrap- cut s p cc (<lambda> () code)))
(define-syntax-rule (dls-match (cut s p cc) old code ...)
(dls-match- cut s p cc old
(<lambda> (cut) (<with-cut> cut code ...))))
(define (dls-match- cut s p cc old code)
(<and> (cut s p cc)
(if (eq? (fluid-ref delayers) old)
<cc>
(dls old))
code ...))
(code cut)))
(define *depth* (make-fluid))
......
......@@ -167,9 +167,10 @@
(define fop (mk-fop data))
(define fop1 (fop '(fy fx)))
(define fop2 (mk (fop '(xfx xfy yfx yf xf))))
(<p-define> (term To PP)
(<var> (Res New)
(<or>
(<or>
(<and>
(.. (c) (ws <_>))
(.. (t) (op-atom <_>))
......@@ -178,7 +179,7 @@
(<and>
(.. (c) (ws <_>))
(.. (p) (fop1 <_>))
(<match> (#:mode - #:name 'term) (p)
(<match> (#:mode - #:name 'term) (p)
(('fx (= <scm> P) . _)
(when (<= P (<scm> PP))
(.. (t) (term New (- P 1)))
......
......@@ -149,22 +149,23 @@
(<apply> trace-fkn 'out ff Level x)))
xx)))
(define-syntax-rule (define-or-set! x)
(let* ((bd? (module-locally-bound? (current-module) Fkn))
(fold (module-ref (current-module) Fkn))
(xx x)
(define (-define-or-set! xx fkn)
(let* ((bd? (module-locally-bound? (current-module) fkn))
(fold (module-ref (current-module) fkn))
(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 xxf)
(define! Fkn xxf))
(module-set! (current-module) fkn xxf)
(define! fkn xxf))
(set-procedure-property! xxf 'module (module-name (current-module)))
(set-procedure-property! xxf 'shallow #t)
(set-procedure-property! xxf 'name Fkn)))
(set-procedure-property! xxf 'name fkn)))
(define-syntax-rule (define-or-set! x) (-define-or-set! x Fkn))
(define (define-or-set-fkn! f x)
(letrec ((bd? (module-locally-bound? (current-module) Fkn))
......
......@@ -632,7 +632,6 @@
(scan-goal f)
(set! match-map-i match-map)
(pp `(compile ,a ,f))
(let* ((aa (pp 'aa (compile-match a)))
(ff (compile-goal f))
......@@ -690,12 +689,12 @@
<lambda-dyn>) ,aa
(,(GL <var>) ,vars ,ff)
,(list (G cons) `,aaa `,fff)))))))))
(if (not source?)
(if meta-only?
(eval (src (list (G lambda)) '())
(current-module))
(compile (src (list (G lambda)) '())
#:env (current-module))))))
(if (not source?)
(if meta-only?
(eval (src (list (G lambda)) '())
(current-module))
(compile (src (list (G lambda)) '())
#:env (current-module))))))
(define (lamlam lam)
(lambda (f)
(lam f)))
......
......@@ -69,6 +69,53 @@
s a
)
#:re-export(sin cos atan exp log sqrt))
#|
We could make all variable references through a stack frame e.g.
(m A),(m B)
(lambda (s p cc a b)
((ref a 1) s p
(lambda (ss pp)
((ref a 2) ss pp cc (ref a 3)))
(ref a 4)))
(define (m code)
(lambda (b)
(lambda (s p c cc a)
(exec a b c code))))
(define (, x y)
(lambda (b)
(let ((xx (x b))
(yy (y b)))
(lambda (s p c cc a)
(xx s p (lambda (ss pp) (yy ss pp cc a)) a)))))
(define (or x y)
(lambda (b)
(let ((xx (x b))
(yy (y b)))
(lambda (s p c cc a)
(let ((fr (gp-newframe s)))
(xx s (lambda ()
(gp-unwind fr)
(yy s p c cc a)) c cc a))))))
(define (if p x y)
(lambda (b)
(let ((pp (p b))
(xx (x b))
(yy (y b)))
(lambda (s p c cc a)
(let ((fr (gp-newframe s)))
(pp s (lambda ()
(gp-unwind fr)
(yy s p c cc a))
c
(lambda (ss pp)
(xx ss p c cc a))))))))
|#
(define (transfer-o-p from to)
(set-object-properties! to (object-properties from)))
......@@ -358,37 +405,39 @@
(procedure-name l)))
(namespace-switch module l))))
(define-syntax-rule (mk-meta --if -if)
(<define-guile-log-rule> (--if x (... ...))
(-if (let ((cut CUT)) (<lambda> () (<with-cut> cut x))) (... ...))))
(define-syntax-rule (mk-meta --ifa -ifa)
(<define-guile-log-rule> (--ifa x (... ...))
(-ifa x (... ...))))
(define -if
(<case-lambda>
((p a) (p) <cut> (a))
((p a b) (<if> (p) (a) (b)))))
(mk-meta --if -if)
(define -if-ii
(<case-lambda>
((p a) (<once-ii> (p)) (a))
((p a b) (<if> (<once-ii> (p)) (a) (b)))))
(mk-meta --if <if>)
(define-guile-log -if-ii
(lambda (x)
(syntax-case x ()
((_ w p x) #'(<and> w (<once-ii> p) x ))
((_ w p x y) #'(<if> w (<once-ii> p) x y)))))
(mk-meta --if-ii -if-ii)
(<define> (-and x y) (<and> (x) (y)))
(mk-meta --and -and)
(mk-meta --and <and>)
(<define> (-and-ii x y) (<and-ii> (x) (y)))
(mk-meta --and-ii -and-ii)
(mk-meta --and-ii <and-ii>)
(<define> (-or x y) (<or> (x) (y)))
(mk-meta --or -or)
(mk-meta --or <or>)
(<define> (-or-ii x y) (<or-ii> (x) (y)))
(mk-meta --or-ii -or-ii)
(mk-meta --or-ii <or-ii>)
(<define> (-not x) (<not> (x)))
(mk-meta --not -not)
(mk-meta --not <not>)
(mk-prolog-biop 'xfy ":" tr-ns: op2: <:> a a)
(mk-prolog-biop 'xfy "," tr-and #{,}# --and g g)
......
......@@ -77,10 +77,10 @@
(()
#'<cc>)
(((kind _ op _) x y n m)
(f->stxfkn #f op #f #f garg #:goal stx 2 n m (list x y)))
(f->stxfkn #f #f op #f #f garg #:goal stx 2 n m (list x y)))
(((kind _ op _) x n m)
(f->stxfkn #f op #f #f garg #:goal stx 1 n m (list x)))
(f->stxfkn #f #f op #f #f garg #:goal stx 1 n m (list x)))
((#:group x)
(goal stx x))
......@@ -122,11 +122,11 @@
#`(goal-eval CUT #,(garg stx z)))
((#:term (and atom (#:atom f . _)) () #f n m)
(f->stxfkn #f f #f atom garg #:goal stx #f n m '()))
(f->stxfkn #f #f f #f atom garg #:goal stx #f n m '()))
((#:term (and atom (#:atom f amp _ _ _)) l #f n m)
(let ((l (get.. "," l)))
(f->stxfkn #f f #f atom garg #:goal stx #f n m l)))
(f->stxfkn #f #f f #f atom garg #:goal stx #f n m l)))
((#:termvar v id l . _)
#`(goal-eval `#,(arg stx z)))
......@@ -145,10 +145,10 @@
(- x))
(((kind _ op _) x y n m)
(f->stxfkn #f op #f #f sscm #:scm stx 2 n m (list x y)))
(f->stxfkn #f #f op #f #f sscm #:scm stx 2 n m (list x y)))
(((kind _ op _) x n m)
(f->stxfkn #f op #f #f sscm #:scm stx 1 n m (list x)))
(f->stxfkn #f #f op #f #f sscm #:scm stx 1 n m (list x)))
((#:group x)
(scm stx x))
......@@ -162,11 +162,11 @@
((#:number x . _) x)
((and atom (#:atom f _ _ n m))
(f->stxfkn #f f #f atom sscm #:scm stx #f n m '()))
(f->stxfkn #f #f f #f atom sscm #:scm stx #f n m '()))
((#:term (and atom (#:atom f . _)) l #f n m)
(let ((l (get.. "," l)))
(f->stxfkn #f f #f atom sscm #:sscm stx #f n m l)))))
(f->stxfkn #f #f f #f atom sscm #:sscm stx #f n m l)))))
(define (add x y z n m)
(if z
......
......@@ -37,18 +37,18 @@
(define (wrap-ns-sym f)
(define res
(lambda (mod s . l)
(lambda (q mod s . l)
(cond
((not mod)
(apply res (current-module) s l))
(apply res q (current-module) s l))
((eq? mod 1)
(if (symbol? s) (symbol->string s) s))
((pair? mod)
(apply res (resolve-module mod) s l))
(apply res q (resolve-module mod) s l))
((string? s)
(apply res mod (string->symbol s) l))
(apply res q mod (string->symbol s) l))
(else
(apply f mod s l)))))
(apply f q mod s l)))))
res)
(define get-op-fkn
......@@ -130,7 +130,7 @@
(define f->stxfkn
(wrap-ns-sym
(lambda (mod f local? atom arg goal? stx N n m l . u)
(lambda (worker mod f local? atom arg goal? stx N n m l . u)
(define ll (map (lambda (x) (arg stx x)) l))
(define uu (if (pair? u) (arg stx (car u)) '()))
(define lll (if (pair? u) (append ll (list uu)) ll))
......@@ -138,13 +138,19 @@
(define (get-funct-from-proc f)
(let ((extr (if (eq? goal? #:goal) #'CUT #'S)))
#`(#,(wrap (procedure-name f)) #,extr #,@lll)))
(if worker
#`(#,worker #,(wrap (procedure-name f)) #,extr #,@lll)
#`(#,(wrap (procedure-name f)) #,extr #,@lll))))
(define (get-func-from-proc f)
#`(#,(wrap (procedure-name f)) #,@lll))
(if worker
#`(#,worker #,(wrap (procedure-name f)) #,@lll)
#`(#,(wrap (procedure-name f)) #,@lll)))
(define (get-func-from-sym f)
#`(#,(wrap f) #,@lll))
(if worker
#`(#,worker #,(wrap f) #,@lll)
#`(#,(wrap f) #,@lll)))
(define (get-funct/stx-from-proc f)
(if goal?
......
......@@ -13,7 +13,7 @@
#:use-module (ice-9 pretty-print)
#:use-module ((logic guile-log)
#:select (procedure-name
(<_> . GL:_) <define>
(<_> . GL:_) <define> <lambda>
<code> <cc> <lookup> CUT S))
#:export (arg pat-match var term term-init-variables v-variables
term-get-variables-list term-get-variables))
......@@ -169,38 +169,38 @@
((#:term (and atom (#:atom f _ _ n m)) () #f . _)
(add-sym mod local? atom)
(-eval- (car (f->stxfkn mod f local? atom arg #f stx #f n m '()))))
(-eval- (car (f->stxfkn #f mod f local? atom arg #f stx #f n m '()))))
((#:term (and atom (#:atom f _ _ n m)) () meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
(-eval-
#`(metah #,@(f->stxfkn mod f local? atom arg #f stx #f n m '())
#`(metah #,@(f->stxfkn #f mod f local? atom arg #f stx #f n m '())
#,@meta))))
((#:term (and atom (#:atom f _ _ n m)) ((_ _ "|" _) x y _ _) #f . _)
(add-sym mod local? atom)
(-*term-
(f->stxfkn mod f local? atom arg #f stx #f n m
(f->stxfkn #f mod f local? atom arg #f stx #f n m
(get.. "," x) y)))
((#:term (and atom (#:atom f _ _ n m)) ((_ _ "|" _) y _ _) #f . _)
(add-sym mod local? atom)
(-*term-
(f->stxfkn mod f local? atom arg #f stx #f n m
(f->stxfkn #f mod f local? atom arg #f stx #f n m
'() y)))
((#:term (and atom (#:atom f _ _ n m)) x #f . _)
(add-sym mod local? atom)
(-term-
(f->stxfkn mod f local? atom arg #f stx #f n m
(f->stxfkn #f mod f local? atom arg #f stx #f n m
(get.. "," x))))
((#:term (and atom (#:atom f _ _ n m)) x meta . _)
(add-sym mod local? atom)
(let ((meta (map fget (get.. "," meta))))
(-term-
#`((metah #,@(f->stxfkn mod f local? atom arg #f stx #f n m '())
#`((metah #,@(f->stxfkn #f mod f local? atom arg #f stx #f n m '())
#,@meta)
#,@(map fget (get.. "," x))))))
......@@ -214,7 +214,7 @@
((and atom (#:atom f _ _ n m))
(add-sym mod local? atom)
(-eval- (car (f->stxfkn mod f local? atom arg #f stx #f n m
(-eval- (car (f->stxfkn #f mod f local? atom arg #f stx #f n m
'()))))
((#:termstring (#:string str _ _) l _ _)
......@@ -230,13 +230,13 @@
(#:termstring (#:string (and tp op) _ _) (x y) n m))
(add-sym mod local? `(#:atom ,(string->symbol op) #f #f ,n ,m))
(-term-
(f->stxfkn #f op #f #f arg #f stx 2 n m (list x y))))
(f->stxfkn #f #f op #f #f arg #f stx 2 n m (list x y))))
((or ((tp _ op _) x n m)
(#:termstring (#:string (and tp op) _ _) (x) n m))
(add-sym mod local? `(#:atom ,(string->symbol op) #f #f ,n ,m))
(-term-
(f->stxfkn #f op #f #f arg #f stx 1 n m (list x))))
(f->stxfkn #f #f op #f #f arg #f stx 1 n m (list x))))
((x) (fget x))))))
arg0)))
......
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