autonumbering

parent 0ddf389c
......@@ -116,13 +116,15 @@
;; Standard operator functors, these symbols need to be in the
;; current module and those are maped en evaluation.
^ op1:- :- #{,}# -> #{\\+}# op2= ==
^ op1:- :- #{,}# -> #{\\+}# op2= == =..
#{\\=}# #{\\==}# @< @> @>= @=< is
op2+ op2- op1- #{\\\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{/\\}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}#
)
#:export (make-unbound-term default_module))
)
#:export (make-unbound-term
default_module
re-export-iso-operators))
(define reset-flags init-flags)
(define (reset-prolog)
......@@ -136,9 +138,15 @@
(set-procedure-property! a 'name 'a)))
(<define> (default_module)
(<code> (set-current-module
(language-make-default-environment (current-language)))))
(<define> (set x y) (<set> x y))
(define-syntax-rule (re-export-iso-operators)
(re-export ^ op1:- :- #{,}# -> #{\\+}# op2= == =..
#{\\=}# #{\\==}# @< @> @>= @=< is
op2+ op2- op1- #{\\\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{/\\}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}#))
......@@ -9,7 +9,7 @@
#:use-module (srfi srfi-11)
#:use-module (system repl repl)
#:export (<next> <or> <and> <not> <cond> <if> <scm-if>
#:export (<next> <or> <and> <not> <cond> <if> <scm-if> <fast-if>
functorize adaptable_vars
<with-guile-log> <if-some>
<cc> <fail> <let> <let*> <var> <modvar> <hvar> </.> <when>
......@@ -39,6 +39,13 @@
<raw-attvar> <attvar-raw?> <set>
))
(define iter 0)
(define (gp-gc)
(if (= iter 10)
(begin
(set! iter 0)
((@ (logic guile-log umatch) gp-gc)))
(set! iter (+ iter 1))))
(define (<wrap> f . l)
(apply f (fluid-ref *current-stack*) (lambda x #f) (lambda (s . l) s) l))
......@@ -84,7 +91,11 @@
(syntax-parameterize ((CC (identifier-syntax cc)))
code ...))
(define-syntax-rule (<scm> x) (gp->scm x S))
(define-syntax-rule (<scm> x)
(if (number? x)
x
(gp->scm x S)))
(define-syntax-rule (<cons> x y) (gp-cons! x y S))
(define-syntax-rule (<car> x) (gp-car (gp-lookup x S) S))
(define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S))
......@@ -356,6 +367,20 @@
(parse<> (cut s p cc) a)
(parse<> (cut s p cc) b)))))
(define-guile-log <fast-if>
(syntax-rules ()
((_ (cut s p cc) pred a)
(if pred
(parse<> (cut s p cc) a)
(p)))
((_ (cut s p cc) pred a b)
(let ((p2 (lambda () (parse<> (cut s p cc) b))))
(let ((cc2 (lambda (s3 p3)
(parse<> (cut s3 p cc) a))))
(parse<> (cut s p2 cc2) pred))))))
(define-guile-log <if-some>
(syntax-rules ()
......@@ -666,8 +691,8 @@
(<match> (#:mode + #:name nm) (b ...)
(as ... codes)
...
(a ... (<cut> code))
(m ... (<cut> <fail>)))))
(a ... (<cut> code)))))
; (m ... (<cut> <fail>)))))
...))))))
......
......@@ -69,20 +69,22 @@
(cond
((<var?> f)
(instantiation_error))
((procedure? f)
(<cut>
(<let> ((x (object-property f 'prolog-functor-type)))
(case x
((#:goal)
(f cut))
(else
(f))))))
(case x
((#:goal)
(f cut))
(else
(f))))))
((and (struct? f) (prolog-closure? f))
((prolog-closure-closure f)))
((eq? f '!)
(<with-cut> cut (<and> <cut>)))
(else
(type_error callable (gp-var-ref *call-expression*))))))))
......
......@@ -46,7 +46,8 @@
#{\\=}# #{\\==}# @< @> @>= @=< is
op2+ op2- op1- #{\\\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
=..
gop2+ gop2- gop1- #{g\\\\}# gop2* gop2/ g// gop2rem gop2mod
g** g<< g>> #{g/\\}# #{g\\/}# gop2< gop2> gop2>= gop2=< g=:=
#{g=\\=}#
......@@ -453,7 +454,7 @@ floor(x) (floor x)
(project@ s (namespace-val (gp-lookup x s)))
x))
(<define> (func=.. x y)
(<define> (sup=.. x y)
(<let*> ((xx (<lookup> x))
(x (project@ S xx))
(y (<scm> y)))
......@@ -463,10 +464,10 @@ floor(x) (floor x)
((vector? x)
(<cut>
(<match> (#:mode - #:name func=..1) (x)
(<match> (#:mode - #:name =..1) (x)
(#(l)
(<cut>
(<match> (#:mode - #:name func=..2) (y)
(<match> (#:mode - #:name =..2) (y)
((f . u)
(<cut>
(<let> ((f (<lookup> f)))
......@@ -495,7 +496,7 @@ floor(x) (floor x)
(instantiation_error))
((list? y)
(<match> (#:mode - #:name func=..3) (y)
(<match> (#:mode - #:name =..3) (y)
((f . l)
(<cut>
(<let> ((f (<lookup> f)))
......@@ -529,13 +530,13 @@ floor(x) (floor x)
(else
(type_error list y))))))))
(<define-guile-log-rule> (mac=.. a b) (func=.. a b))
(mk-prolog-biop 'xfx "=.." -fkn-expand fkn_expand mac=.. a a)
(<define-guile-log-rule> (mac=.. a b) (sup=.. a b))
(mk-prolog-biop 'xfx "=.." tr=.. =.. mac=.. a a)
(define-goal-functor (#{;}# x y)
(<var> (if then)
(<if> (<=> x ,(vector `(,-> ,if ,then)))
(<if> (goal-eval if) (goal-eval then) (goal-eval y))
(<if> (goal-eval if) (goal-eval then) (goal-eval y))
(<or> (goal-eval x) (goal-eval y)))))
(set-object-property! #{;}# 'goal-compile-stub
......@@ -547,7 +548,14 @@ floor(x) (floor x)
(define-goal-transformer #{;}# (tr-disjunction stx n m x y)
(match x
((('xfy _ "->" _) i t n m)
#`(<if> #,(goal stx i) #,(goal stx t) #,(goal stx y)))
(let lp ((i i))
(match (pk i)
((x) (lp x))
(((_ _ (or "<" ">" "=<" ">=" "==" "=:=" "=\\=") _) a b n2 m2)
#`(<fast-if> #,(goal stx i) #,(goal stx t) #,(goal stx y)))
(_
#`(<if> #,(goal stx i) #,(goal stx t) #,(goal stx y))))))
(_
#`(<or> #,(goal stx x) #,(goal stx y)))))
......
......@@ -867,7 +867,7 @@
(<recur> lp ((opts opts))
(<match> (#:mode - #:name read_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
(<let> ((opt (<lookup> opt)))
(cond
((<var?> opt)
(instantiation_error))
......
......@@ -169,6 +169,9 @@
((#:number n . _)
(-eval- n))
(((_ _ "-" _) (#:number n _ _) _ _)
(- n))
((or ((tp _ op _) x y n m)
(#:termstring (#:string (and tp op) _ _) (x y) n m))
(-term-
......@@ -186,7 +189,7 @@
(define (var-arg x) #`,#,x)
(define x_x #',GL:_)
(define (eval-arg x) #`,#,x)
(define (list-arg x) #`x)
(define (list-arg x) x)
(define (term-arg x)
#`(unquote (vector (list
#,(car x)
......@@ -231,13 +234,18 @@
(define var-goal (mk-var #t))
; --------------------------------------------------------------
(define (var-term x) #`,#,x)
(define (var-term x)
(let ((v (syntax->datum x)))
(fluid-set! *var-list* (cons v (fluid-ref *var-list*)))
(hashq-set! (fluid-ref *variables*) v #t)
#`,#,x))
(define x_term #',GL:_)
(define (eval-term x) #`,#,x)
(define (list-term x) x)
(define (term-term x)
#`(unquote (vector (list
(car x)
#,(car x)
#,@(map (lambda (x) #``#,x)
(cdr x))))))
......
......@@ -469,6 +469,12 @@
((_ a b c (#f . l))
(error (format #f "umatch: #f in state position: ~a" '(a b c))))
((_ (code) () () (s n t _ _))
(umatch0 s (#:args)
((arguments) (-> t (mk-failure s))
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code ...) () () (s n t _ _))
(let ((s (gp-newframe s)))
(umatch0 s (#:args)
......@@ -485,6 +491,14 @@
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s))
(umatch0 s (#:args . arg)
((arguments (++ ++ a) ...)
(gp-clear-frame)
(let ((s sold)) code))
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t #t +))
(let ((sold s)
(s (gp-newframe s)))
......@@ -492,7 +506,7 @@
((arguments (++ ++ as) ...)
(-> t (mk-failure s))
code)
codes)
...
((arguments (++ ++ a) ...)
(gp-clear-frame)
......@@ -506,6 +520,15 @@
code)
(_ (error (format #f "umatch ~a did not match" n)))))
((_ (code) ((as ...) ... (a ...)) arg (s n t r m))
(let ((sold s))
(umatch0 s (#:args . arg)
((arguments (m m a) ...)
(let ((s sold))
(gp-clear-frame)
code))
(_ (error (format #f "umatch ~a did not match" n))))))
((_ (codes ... code) ((as ...) ... (a ...)) arg (s n t r m))
(let ((sold s)
(s (gp-newframe s)))
......@@ -580,7 +603,12 @@
(define (gp-cp . x) (apply (fluid-ref *gp-cp*) x))
(define *gp->scm* (make-fluid gp->scm-))
(define (gp->scm . x) (apply (fluid-ref *gp->scm*) x))
(define gp->scm
(case-lambda
((x s)
((fluid-ref *gp->scm*) x s))
(x
(apply (fluid-ref *gp->scm*) x))))
(define recurs-map (make-fluid (make-hash-table)))
(define (gp-cp+ . l) (apply gp-cp++ #f l))
......
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