remains to fix canonical reading and writing terms + coroutining in match terms

parent ff2fa9ca
......@@ -2,14 +2,14 @@
#:use-module (logic guile-log prolog goal-transformers)
#:export
(
op2+ op2- op1- #{\\\\}# op2* op2/ //
op2+ op2- op1- #{\\}# op2* op2/ //
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
))
(define op2+ gop2+)
(define op2- gop2-)
(define op1- gop1-)
(define #{\\\\}# #{g\\\\}#)
(define #{\\}# #{g\\}#)
(define op2* gop2*)
(define op2/ gop2/)
(define // g//)
......
......@@ -119,8 +119,8 @@
;; current module and those are maped en evaluation.
^ op1:- :- #{,}# -> #{\\+}# op2= == =..
#{\\=}# #{\\==}# @< @> @>= @=< is
op2+ op2- op1- #{\\\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{/\\}# op2< op2> op2>= op2=< =:= #{=\\=}#
op2+ op2- op1- #{\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}#
)
#:export (make-unbound-term
......
}
\ No newline at end of file
'*'(1, 2)
\ No newline at end of file
......@@ -36,6 +36,7 @@
% open a file write to it, close it read back
%
-trace.
write_read1(TermOut, File, TermIn) :-
open(File, write, Sout),
set_output(Sout),
......@@ -46,6 +47,7 @@ write_read1(TermOut, File, TermIn) :-
read(TermIn),
close(Sin).
-trace.
write_read2(TermOut, File, TermIn) :-
open(File, write, Sout),
write(Sout, TermOut), write('. '),
......@@ -93,7 +95,6 @@ write_canonical_read2(TermOut, File, TermIn) :-
close(Sin).
%% _term forms
write_read_term2(TermOut, File, TermIn,WriteOptions, ReadOptions) :-
open(File, write, Sout),
set_output(Sout),
......@@ -110,6 +111,7 @@ write_read_term3(TermOut, File, TermIn, WriteOptions, ReadOptions) :-
close(Sout),
open(File, read, Sin),
read_term(Sin, TermIn,ReadOptions),
write(read_term(TermIn)),nl,
close(Sin).
......
......@@ -79,8 +79,8 @@ test_ones_complement :-
test_true(X1 is \10),
test_val(X2 is \(\10), X2, 10),
error_test(X3 is \ N ,instantiation_error),
error_test(X4 is \(3.14) ,type_error(integer, 3.14)),
error_test(X4 is \foo ,type_error(evaluable, foo/0)).
error_test(X4 is \(3.14) ,type_error(integer, 3.14)),
error_test(X4 is \foo ,type_error(evaluable, foo/0)).
test_ones_complement :-
log_nl, log( 'bitwise complement \\/2 not supported.'),
......
......@@ -237,7 +237,7 @@ do_catch(X,Y,Z) :-
%
eval_or_fail(X) :-
catch( call(X), _, fail).
catch( call(X), Y, (write(fail(Y)),nl,fail)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
......
......@@ -447,7 +447,7 @@
(syms (union syms syms)))
(pp 'res #`(begin
(eval-when (compile load eval)
(add-non-defined
(add-non-defined
(quote #,(datum->syntax stx syms))))
#,@ini
lam-def ... #,@l #,@evl))))))))))
......
......@@ -44,13 +44,14 @@
^ op1:- :- #{,}# -> #{\\+}# op2= ==
#{\\=}# #{\\==}# @< @> @>= @=< is
op2+ op2- op1- #{\\\\}# op2* op2/ // op2rem op2mod
op2+ op2- op1- #{\\}# op2* op2/ // op2rem op2mod
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
=..
gop2+ gop2- gop1- #{g\\\\}# gop2* gop2/ g// gop2rem gop2mod
gop2+ gop2- gop1- #{g\\}# gop2* gop2/ g// gop2rem gop2mod
g** g<< g>> #{g/\\}# #{g\\/}# gop2< gop2> gop2>= gop2=< g=:=
#{g=\\=}#
#{;}#
)
#:re-export(sin cos atan exp log sqrt))
......@@ -333,7 +334,7 @@
(mk-prolog-biop-not 'xfx "@>=" tr-0ge @>= term< a a)
(mk-prolog-biop-not 'xfx "@=<" tr-0le @=< term> a a)
(mk-prolog-biop-tr 'xfx "is" tr-is is <iss> (a s)
(mk-prolog-biop-tr 'xfx "is" tr-is is <iss> (a s)
((tr-is stx n m x y)
(match x
((#:variable v id nn mm)
......@@ -349,17 +350,17 @@
(mk-scheme-biop 'yfx "+" tr-+ op2+ .+ s s)
(mk-scheme-biop 'yfx "-" tr-- op2- .- s s)
(mk-scheme-unop 'fy "-" tr-u- op1- .-1 s )
(mk-scheme-unop 'fy "\\" tr-bitnot #{\\\\}# lognot 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)
(mk-scheme-biop 'yfx "//" tr-i/ // truncate/ s s)
(mk-scheme-biop 'yfx "rem" tr-rem op2rem remainder s s)
(mk-scheme-biop 'yfx "mod" tr-mod op2mod modulo s s)
(mk-scheme-biop 'yfx "rem" tr-rem op2rem remainder s s)
(mk-scheme-biop 'yfx "mod" tr-mod op2mod modulo s s)
(mk-scheme-biop 'xfx "**" tr-pow ** myexpt s s)
(mk-scheme-biop 'yfx "<<" tr-shr << .ash s s)
(mk-scheme-biop 'yfx ">>" tr-shr >> shr s s)
(mk-scheme-biop 'yfx "/\\" tr-bitand #{/\\}# logand s s)
(mk-scheme-biop 'yfx "\\/" tr-bitor #{\\/}# logior s s)
(mk-scheme-biop 'yfx "\\/" tr-bitor #{\\/}# .logior s s)
(mk-prolog-biop-when 'xfx "<" tr-< op2< .< s s)
(mk-prolog-biop-when 'xfx ">" tr-> op2> .> s s)
......@@ -371,7 +372,7 @@
(mk-scheme-biop 'yfx "+" tr-+g gop2+ + s s)
(mk-scheme-biop 'yfx "-" tr--g gop2- - s s)
(mk-scheme-unop 'fy "-" tr-u-g gop1- -1 s )
(mk-scheme-unop 'fy "\\" tr-bitnotg #{g\\\\}# lognot 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)
(mk-scheme-biop 'yfx "//" tr-i/g g// truncate/ s s)
......@@ -388,6 +389,9 @@
(mk-prolog-biop-when 'xfx "=:=" tr-equalg g=:= equal? s s)
(mk-prolog-biop-when-not 'xfx "=\\=" tr-not-equalg #{g=\\=}# equal? s s)
(define (.logior x y)
(check-num (logior (is-a-num? x) (is-a-num? y))))
(define (myexpt x y) (exact->inexact (expt x y)))
(define (.< x y)
......
......@@ -509,7 +509,9 @@
(define (gen@ ll a)
(cond
((not ns?)
(format #f "~a" (str (procedure-name a))))
(if quoted?
(format #f "'~a'" (str (procedure-name a)))
(format #f "~a" (str (procedure-name a)))))
((and ns? (not quoted?))
(let ((m (current-module))
......@@ -535,16 +537,16 @@
(else
(match ll
(('language 'prolog 'modules x)
(format #f "~a@@~a"
(format #f "'~a'@@~a"
(str (procedure-name a)) x))
(("language" "prolog" "modules" x)
(format #f "~a@@~a"
(format #f "'~a'@@~a"
(str (procedure-name a)) x))
((_ . _)
(format #f "~a@@(~a~{, ~a~})"
(format #f "'~a'@@(~a~{, ~a~})"
(str (procedure-name a)) (car ll) (cdr ll)))
(_
(format #f "~a" (str (procedure-name a))))))))
(format #f "'~a'" (str (procedure-name a))))))))
......@@ -596,12 +598,12 @@
(if quoted?
(let ((n (hashq-ref *closures* x #f)))
(if n
(format #f "~a[n]" pre)
(format #f "'~a'[n]" pre)
(let ((n (next)))
(hashq-set! *closures* x n)
(if (not (pair? args))
(format #f "~a[~a]" pre n)
(format #f "~a[~a,~a~{,~a~}]" pre n
(format #f "'~a'[~a]" pre n)
(format #f "'~a'[~a,~a~{,~a~}]" pre n
(car args) (cdr args))))))
(format #f "~a#~a"
(number->string
......@@ -621,9 +623,9 @@
(gp->scm l s)))
(let ((ll (map (lambda (x) (format #f "'~a'" x))
(get-attached-module f ns?))))
(format #f "~a(~a~{, ~a~})"
(gen@ ll f)
(lp a) (map lp (gp->scm l s))))))))))
(format #f "~a(~a~{, ~a~})"
(gen@ ll f)
(lp a) (map lp (gp->scm l s))))))))))
(#((f))
(let ((f (gp-lookup f s)))
......
......@@ -280,8 +280,12 @@
(mk-sym char_conversion)
(mk-sym char-convert)
(set! (@@ (logic guile-log prolog error) number) number)
(set! (@@ (logic guile-log prolog error) integer) integer)
(set! (@@ (logic guile-log prolog error) source_sink) source_sink)
(define first #t)
(if first
(begin
(set! first #f)
(set! (@@ (logic guile-log prolog error) number) number)
(set! (@@ (logic guile-log prolog error) integer) integer)
(set! (@@ (logic guile-log prolog error) source_sink) source_sink)))
(set! first? #f)
......@@ -808,8 +808,8 @@
(<p-cc> (retit (reverse d))))))
(define (prolog-read-token stx)
(let ((f (f-or 'statement (f-seq ws (f-read-1 stx expr)
ws (f-char #\.))
(let ((f (f-or 'statement (f-seq ws (f-read-1 stx expr)
ws (f-char #\.) ws)
ferr)))
(<p-lambda> (c)
(.. (d) (f '()))
......
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