better debugging in hot compiler

parent 31d2c521
......@@ -133,7 +133,9 @@ PSSOURCES = \
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/clpfd1.pl \
language/prolog/modules/library/clpfd2.pl \
language/prolog/modules/library/clpfd3.pl
# language/prolog/modules/library/apply_macros.pl
AM_MAKEINFOFLAGS=--force
......
......@@ -42,6 +42,9 @@
(#:boot (language prolog modules test2))
(#:boot (language prolog modules examples cluster))
(language prolog modules library clpb)
(language prolog modules library clpfd1)
(language prolog modules library clpfd2)
(language prolog modules library clpfd3)
(language prolog modules library clpfd)
(#:boot (language prolog modules swi term_macro))))
......
......@@ -15,8 +15,8 @@ exception(X,Y,Tag) :- fail.
(<define> ($exe x atfail)
(<or>
(<and>
(<<match>> (#:mode -) (x)
(#(("error" #(("existence_error" tag val)) _))
(<match> (#:mode -) (x)
(#(("error" #(("existence_error" tag val)) _))
(<var> (action)
(exception tag val action)
(<<match>> (#:mode -) (action)
......
......@@ -3,13 +3,12 @@
#:use-module (logic guile-log prolog goal-transformers)
#:replace
(
op2+ op2- op1- #{\\}# op2* op2/ //
op2+ op2- #{\\}# op2* op2/ //
** ^ << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
))
(define-op op2+ gop2+)
(define-op op2- gop2-)
(define-op op1- gop1-)
(define-op #{\\}# #{g\\}#)
(define-op op2* gop2*)
(define-op op2/ gop2/)
......
......@@ -204,9 +204,9 @@
;; Standard operator functors, these symbols need to be in the
;; current module and those are maped en evaluation.
^ op1:- :- #{,}# -> #{\\+}# op2= == =..
^ :- #{,}# -> #{\\+}# op2= == =..
#{\\=}# #{\\==}# @< @> @>= @=< is op2:
op2+ op2- op1- op1+ #{\\}# op2* op2/ // rem mod div
op2+ op2- #{\\}# op2* op2/ // rem mod div
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}# --> ? $ ?-
......
......@@ -141,7 +141,7 @@
(define ariths '("=" "floor" "+" "-" "*" "/" "truncate/" "remainder"
"<" "<=" ">=" ">" "abs" "floor" "round" "ceiling" "truncate"
"inexact->exact"))
(define (id x) (x) (pk 'end))
(define (id x) (x))
(define arith-ints '("ash" "logior" "logand" "lognot" "modulo"))
......
......@@ -47,13 +47,13 @@
-var -atom
halt
^ op1:- :- #{,}# -> #{\\+}# op2= == =@=
^ :- #{,}# -> #{\\+}# op2= == =@=
#{\\=}# #{\\==}# #{\\=@=}# @< @> @>= @=< is
op2+ op2- op1- op1+ #{\\}# op2* op2/ // rem mod div
op2+ op2- #{\\}# op2* op2/ // rem mod div
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
=.. --> ? $ ?-
gop2+ gop2- gop1- gop1+
gop2+ gop2-
#{g\\}# gop2* gop2/ g// gop2rem gop2mod
g** g^
g<< g>> #{g/\\}# #{g\\/}# gop2< gop2> gop2>= gop2=< g=:=
......@@ -260,6 +260,36 @@
(meta-mk-scheme-op mk-scheme-unop stx nm-code
(x) (tp1) -1-)
(define-syntax-rule (meta-mk-scheme-op-dual mk-scheme stx nm-code
(a1 a2) (tp1 tp2) code1 code2)
(define-syntax-rule (mk-scheme op-type op nm-tr nm-func nm-code tp1 tp2)
(begin
(define-scm-functor (nm-func s . a)
(apply (case-lambda
((a1 a2)
(syntax-parameterize ((S (identifier-syntax s)))
(scm-ck 'code2 'nm-code
(tp1 'a1) (tp2 'a2))))
((a1)
(syntax-parameterize ((S (identifier-syntax s)))
(scm-ck 'code1 'nm-code
(tp1 'a1)))))
a))
(define-goal-transformer nm-func (nm-tr stx n m . a)
(apply (case-lambda
((a1 a2)
#`(code2 nm-code #,(tp1 stx a1) #,(tp2 stx a2)))
((a1)
#`(code1 nm-code #,(tp1 stx a1))))
a))
(bind-operator-to-functor nm-func op))))
(meta-mk-scheme-op-dual mk-scheme-dual stx nm-code
(x y) (tp1 tp2) -1- -2-)
; ------------------------------
(define (tr-error op)
(lambda (stx n m . l)
......@@ -309,7 +339,6 @@
(set-procedure-property! fk-name 'name 'fk-name)
(bind-operator-to-functor fk-name op)))
(mk-prolog-abstract 'fy ":-" op1:- tr-directive)
(mk-prolog-abstract 'xfx ":-" :- tr-fact)
(mk-prolog-abstract 'xfx "-->" --> tr-dcg)
(mk-prolog-abstract 'fx "?" ? tr-?)
......@@ -379,10 +408,8 @@
#`(<iss> #,(-arg- stx x) #,(scm stx y))))))
(define (my-rem x y) (- x (* (quotient x y) y)))
(define-syntax-rule (shr x y) (ash x (- y)))
(mk-scheme-biop 'yfx "+" tr-+ oop2+ .+ s s)
(mk-scheme-biop 'yfx "-" tr-- oop2- .- s s)
(mk-scheme-unop 'fy "-" tr-u- oop1- .-1 s )
(mk-scheme-unop 'fy "+" tr-u+ oop1+ .+1 s )
(mk-scheme-dual 'yfx "+" tr-+ op2+ .+ s s)
(mk-scheme-dual 'yfx "-" tr-- op2- .- s s)
(mk-scheme-unop 'fy "\\" tr-bitnot #{\\}# lognot s )
(mk-scheme-biop 'yfx "*" tr-* op2* .* s s)
(mk-scheme-biop 'yfx "/" tr-/ op2/ ./ s s)
......@@ -399,25 +426,6 @@
(define (name-as f g) (set-procedure-property! f 'name (procedure-name g)))
(define o-
(case-lambda
((s x y) (oop2- s x y))
((s x) (oop1- s x))))
(transfer-o-p oop2- o-)
(set-procedure-property! o- 'name 'op2-)
(define op1- o-)
(define op2- o-)
(define o+
(case-lambda
((s x y) (oop2+ s x y))
((s x) (oop1+ s x))))
(transfer-o-p oop2+ o+)
(set-procedure-property! o+ 'name 'op2+)
(define op1+ o+)
(define op2+ o+)
(mk-prolog-biop-when 'xfx "<" tr-< op2< .< s s)
(mk-prolog-biop-when 'xfx ">" tr-> op2> .> s s)
......@@ -426,10 +434,8 @@
(mk-prolog-biop-when 'xfx "=:=" tr-equal =:= my-equal? s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equal #{=\\=}# my-equal? s s)
(mk-scheme-biop 'yfx "+" tr-+g ggop2+ + s s)
(mk-scheme-biop 'yfx "-" tr--g ggop2- - s s)
(mk-scheme-unop 'fy "-" tr-u-g ggop1- -1 s )
(mk-scheme-unop 'fy "-" tr-u-g ggop1+ +1 s )
(mk-scheme-dual 'yfx "+" tr-+g gop2+ + s s)
(mk-scheme-dual 'yfx "-" tr--g gop2- - s s)
(mk-scheme-unop 'fy "\\" tr-bitnotg #{g\\}# lognot s )
(mk-scheme-biop 'yfx "*" tr-*g gop2* * s s)
(mk-scheme-biop 'yfx "/" tr-/g gop2/ / s s)
......@@ -442,24 +448,6 @@
(mk-scheme-biop 'yfx "\\/" tr-bitorg #{g\\/}# logior s s)
(define go-
(case-lambda
((s x y) (ggop2- s x y))
((s x) (ggop1- s x))))
(name-as go- op2-)
(transfer-o-p ggop2- go-)
(set! gop1- go-)
(set! gop2- go-)
(define go+
(case-lambda
((s x y) (ggop2+ s x y))
((s x) (ggop1+ s x))))
(name-as go+ op2+)
(transfer-o-p ggop2+ go+)
(set! gop1+ go+)
(set! gop2+ go+)
(mk-prolog-biop-when 'xfx "<" tr-<g gop2< < s s)
(mk-prolog-biop-when 'xfx ">" tr->g gop2> > s s)
(mk-prolog-biop-when 'xfx ">=" tr->=g gop2>= >= s s)
......@@ -829,7 +817,7 @@ floor(x) (floor x)
(define-syntax-rule (mk-num float float*)
(<define> (float x)
(<match> (#:mode - #:name float) (x)
(#((,op1- x))
(#((,op2- x))
(<cut> (float* x)))
(x
(<cut> (float* x))))))
......@@ -942,7 +930,7 @@ floor(x) (floor x)
(term (<lookup> term)))
(<<match>> (#:mode - #:name arg) (n)
(#((,op1- x))
(#((,op2- x))
(if (integer? (<lookup> x))
(domain_error not_less_than_zero n)
(type_error integer n)))
......@@ -1035,9 +1023,6 @@ floor(x) (floor x)
(name-as gop2- op2-)
(name-as gop2+ op2+)
(name-as gop2- op2-)
(name-as gop1- op1-)
(name-as gop1+ op1+)
(name-as #{g\\}# #{\\}#)
(name-as gop2* op2*)
(name-as gop2/ op2/)
......@@ -1068,7 +1053,7 @@ floor(x) (floor x)
(set! (@ (logic guile-log prolog names) prolog=..) =..)
(set! (@ (logic guile-log prolog names) divide) op2/)
(set! (@ (logic guile-log prolog names) plus) op2+)
(set! (@ (logic guile-log prolog names) unary-minus) op1-)
(set! (@ (logic guile-log prolog names) unary-minus) op2-)
(set! (@ (logic guile-log prolog names) binary-minus) op2-)
(set! (@ (logic guile-log prolog names) binary-plus) op2+)
(set! (@ (logic guile-log prolog names) fact) :-)
......
......@@ -66,8 +66,8 @@
(if (pair? l)
(let ((x (car l)))
(if (eq? x #\\)
(cons* #\\ #\\ (lp (cdr l)))
(cons* x (lp (cdr l)))))
(cons* #\\ (lp (cdr l)))
(cons* x (lp (cdr l)))))
'()))))
(define relative-path (make-fluid #f))
......@@ -214,7 +214,7 @@
)
(when (pair? module-goaldata)
(format #t "((@ (guile) define) *public-module-goal-expansions* '(~{~a ~}))~%"
(format #t "((@ (guile) define) *public-module-goal-expansions* ((@ (guile) list) ~{~a ~}))~%"
module-goaldata)
)
......
......@@ -959,14 +959,17 @@
(define-syntax-rule (with (f s b c a ...))
(let* ((u s)
(u (gp-newframe u)))
(let ((r (f u b c a ...) #;((<lambda> ()
(<catch> 'prolog #f
(let ((r #;(f u b c a ...)
(scheme-wrapper
(lambda ()
((<lambda> ()
(<catch> 'prolog #f
(<lambda> () (f a ...))
(<lambda> (tag next l)
(<format> #t
"DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> #f))))
u b c)))
(<format> #t
"DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> #f))))
u b c)))))
(gp-unwind u)
r)))
......
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