write_term and read_term

parent 3d05b92c
......@@ -50,8 +50,12 @@
end_of_stream position variable mode file_name
flush_output
write_canonical writeq write write_term
read read_term variables variable_names singletons read_option
quoted ignore_ops numbervars write_option
;; replacings
append length read write open close member
append length open close member
;; Error functions
error type_error instantiation_error domain_error
......
......@@ -97,7 +97,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
`(#:term (#:atom assertz ,n ,m)
,(car x) ,n ,m))))
(match y
(()
......@@ -109,7 +109,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(mk-rhs stx
`(#:term (#:atom asserta ,n ,m)
`(#:term (#:atom assertz ,n ,m)
,(car x) ,n ,m))))
(list v '() z)))
......@@ -136,7 +136,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
`(#:term (#:atom assertz ,n ,m)
,x ,n ,m))))
(list v '() '())))
......@@ -144,7 +144,7 @@
(if (is-dynamic? v)
`(#:translated 1 ,#`(prolog-run
1 #,(goal stx
`(#:term (#:atom asserta ,n ,m)
`(#:term (#:atom assertz ,n ,m)
,x ,n ,m))))
(list v (get.. "," y) '())))))
......@@ -357,17 +357,43 @@
(clear-syms)
(let* ((r (prolog-parse-read stx)))
(if (pair? r)
(let* ((r (term stx (reverse (car r))))
(vs (term-get-variables))
(ws (map (lambda (x) (gp-make-var)) vs)))
(let* ((r (term stx (reverse (car r))))
(vl (term-get-variables-list))
(vs (term-get-variables))
(h (make-hash-table))
(w (map (lambda (x)
(let ((r (gp-make-var)))
(hash-set! h x r)
r))
vs))
(s (make-hash-table))
(wl (map (lambda (x)
(if (hash-ref s x)
(hash-set! s x #f)
(begin
(hash-set! s x #t)
(hash-ref h x))))
vl))
(ws (let lp ((vs vs))
(if (pair? vs)
(let ((x (car vs)))
(if (hash-ref s x)
(cons (cons x (hash-ref h x))
(lp (cdr vs)))
(cdr vs)))
'()))))
(add-non-defined (get-syms))
(apply
(eval (pp 'eval-term `(lambda ,vs
,(list 'quasiquote
(syntax->datum r))))
module)
ws))
(values
(apply
(eval (pp 'eval-term `(lambda ,vs
,(list 'quasiquote
(syntax->datum r))))
module)
w) w wl ws))
end_of_file))))))
(define (add-non-defined l)
......
......@@ -83,8 +83,8 @@
(define *dynamics* (make-fluid '()))
(define-syntax-rule (define-PI dynamic define-dynamic! err)
(define-parser-directive (dynamic stx l N M)
#`(begin
#,@(map
#`(begin
#,@(map
(lambda (f)
(if (pair? f)
(begin
......@@ -282,7 +282,6 @@
;; Setting up the default flags
(define p (lambda x #f))
(define cc (lambda x #t))
......
......@@ -17,10 +17,14 @@
set_input set_output put_char put_code stream_property
get_byte put_byte peek_byte
get_char get_code peek_char peek_code flush_output
read_term write_term write_canonical writeq
))
(define read #f)
(define write #f)
(define (stream-alias-lookup ss)
(if (procedure? ss)
(let ((r (procedure-property ss 'prolog-alias)))
(if r r ss))
ss))
(define *standard-input*
(make-fluid (current-input-port)))
......@@ -424,7 +428,7 @@
(nl (fluid-ref *current-output*)))))
(define (scm->pl s x)
(define* (scm->pl s x #:optional (quoted? #f) (ignore? #f) (numbervars? #f))
(define *variables* (make-hash-table))
(define i 0)
(define (next)
......@@ -485,12 +489,81 @@
(format #f "~a" a)))))))
(lp x))
(define write_term
(<case-lambda>
((s t opts)
(<let*> ((ss (<lookup> s))
(s (stream-alias-lookup ss)))
(cond
((<var?> s)
(instantiation_error))
((not (prolog-stream-alias? s))
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((not (prolog-output-stream? s))
(permission_error output stream ss))
((binary-port? s)
(permission_error input binary_stream ss))
(else
(<let> ((q #t)
(i #t)
(n #f))
(<recur> lp ((opts opts))
(<match> (#:mode + #:name write_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
(cond
((<var?> opt)
(instantiation_error))
(else
(<match> (#:mode + #:name write_term_opt) (opt)
(#((,quoted ,true))
(<code> (set! q #t)))
(#((,quoted ,false))
(<code> (set! q #f)))
(#((,ignore_ops ,true))
(<code> (set! i #t)))
(#((,ignore_ops ,false))
(<code> (set! i #f)))
(#((,numbervars ,false))
(<code> (set! n #f)))
(#((,numbervars ,true))
(<code> (set! n #t)))
(else
(domain_error write_option opt)))))
(lp opts)))
(()
(<code> (format s "~a" (scm->pl S t q i n))))
(_
(instantiation_error)))))))))
((t opts)
(write_term (fluid-ref *current-output*) t opts))))
(set! write
(<case-lambda>
((term)
(<code> (format (fluid-ref *current-output*) "~a" (scm->pl S term))))
(write_term term '()))
((stream term)
(<code> (format (<scm> stream) "~a" (scm->pl S term))))))
(write_term stream term '()))))
(define qt (list (vector (list quoted true)) (vector (list numbervars true))))
(define write_quoted
(<case-lambda>
((s t)
(write_term s t qt))
((t)
(write_term t qt))))
(define cn (list (vector (list quoted true)) (vector (list ignore_ops true))))
(define write_canonical
(<case-lambda>
((s t)
(write_term s t cn))
((t)
(write_term t cn))))
(set-procedure-property! write 'name 'write)
......@@ -501,22 +574,67 @@
((n x)
(<pp> `(,n ,x)))))
(set! read
(<define> (read* s term v vn si)
(<let*> ((fr (<newframe>))
(s (<scm> s))
(e (call-with-values
(lambda () (read-prolog-term s (current-module)))
(lambda x x))))
(<code> (<unwind> fr))
(<=> ,(list term v vn si) e)))
(define read_term
(<case-lambda>
((s term)
(<let*> ((fr (<newframe>))
(s (<scm> s))
(k (<cp> (read-prolog-term s (current-module)))))
(<code> (<unwind> fr))
(<=> term k)))
((s t opts)
(<let*> ((ss (<lookup> s))
(s (stream-alias-lookup ss)))
(cond
((<var?> s)
(instantiation_error))
((not (prolog-stream-alias? s))
(if (procedure? ss)
(existence_error stream ss)
(domain_error stream_or_alias ss)))
((prolog-stream-closed? s)
(existence_error stream ss))
((not (prolog-input-stream? s))
(permission_error input stream ss))
((binary-port? s)
(permission_error input binary_stream ss))
((term)
(<let*> ((fr (<newframe>))
(k (<cp> (read-prolog-term (fluid-ref *current-input*)
(current-module)))))
(<code> (<unwind> fr))
(<=> term k)))))
(else
(<var> (vars varnames singletons)
(<recur> lp ((opt opts))
(<match> (#:mode + #:name read_term_opts) (opts)
((opt . opts)
(<let> ((opt (<lookup> opt)))
(cond
((<var?> opt)
(instantiation_error))
(else
(<match> (#:mode + #:name read_term_opt) (opt)
(#((,variables X))
(<=> X vars))
(#((,variable_names X))
(<=> X varnames))
(#((,singletons X))
(<=> X singletons))
(else
(domain_error read_option opt)))
(lp opts)))))
(()
(read* s t vars varnames singletons))
(_
(instantiation_error)))))))))
((t opts)
(read_term (fluid-ref *current-input*) t opts))))
(set! read
(<case-lambda>
((s t) (read_term s t '()))
(( t) (read_term t '()))))
(set-procedure-property! read 'name 'read)
......@@ -569,12 +687,6 @@
(put_char (fluid-ref *current-output*) ch))))
(define (stream-alias-lookup ss)
(if (procedure? ss)
(let ((r (procedure-property ss 'prolog-alias)))
(if r r ss))
ss))
(define put_code
(<case-lambda>
((s ch)
......@@ -863,4 +975,4 @@
(()
(<code> (flush-all-ports)))))
\ No newline at end of file
(define-module (logic guile-log prolog names)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log functional-database)
#:use-module (logic guile-log prolog error)
#:use-module (ice-9 match)
#:replace (force)
#:export (make-unbound-fkn mk-sym
;;goal
character_code
not_less_than_zero
evaluable
callable
modify
static_procedure
private_procedure
access
end_of_file
character
predicate_indicator
source_sink
;; goal transformers
divide
plus
fact
true
fail
float
number
integer
;; directives
operator_specifier
fx
fy
xf
yf
xfx
yfx
xfy
operator_priority
flag_value
flag
prolog_flag
on
off
false
towards_zero
down
warning
chars
codes
bounded
auto_sym
max_integer
min_integer
integer_rounding_function
debug
max_arity
unknown
double_quotes
get_flag
is-a-num?
check-num
;;io
quoted
ignore_ops
numbervars
write_option
read
write
input
output
stream_or_alias
stream
stream_option
io_mode
text
binary
type
eof_action
reposition
alias
reset
eof_code
at
no
end_of_stream
position
variable
mode
file_name
binary_stream
text_stream
byte
variables
variable_names
singletons
read_option
;;char-conversion
char_conversion
char-convert))
(define get-flag #f)
(define cc (lambda x #t))
(define p (lambda x #f))
(define ss (fluid-ref *current-stack*))
(define (make-unbound-fkn nm)
(letrec ((warn-message
(format #f "fkn ~a is not evaluable, will fail" f))
(d #f)
(f (lambda k
(match k
(()
(if d
d
(begin
(mk-dyn nm (lambda (x) (set! d x)))
d)))
((x) d)
((a b c . l)
(if d (apply d k)
(apply
(<lambda> l
(<let> ((e (get-flag unknown)))
(cond
((eq? e error)
(existence_error
procedure
(vector `(,divide ,f
,(length l)))))
((eq? e warning)
(<code> (warn warn-message))
<fail>)
((eq? e fail)
<fail>)
(else
(<code>
(error
"Bug in prolog flag 'unknown' implementation"))))))
a b c l)))
(_
(type_error ss p cc evaluable
(vector `(,divide ,f
,(- (length k) 1)))))))))
(set-object-property! f 'prolog-symbol #t)
f))
(define-syntax-rule (mk-sym a)
(begin
(define a (make-unbound-fkn 'a))
(set-procedure-property! a 'name 'a)))
;; Error
(mk-sym type_error)
(mk-sym existence_error)
(mk-sym is-a-num?)
(mk-sym check-num)
(mk-sym divide)
(mk-sym plus)
(mk-sym fact)
(mk-sym true)
(mk-sym fail)
(mk-sym character_code)
(mk-sym not_less_than_zero)
(mk-sym evaluable)
(mk-sym callable)
(mk-sym modify)
(mk-sym static_procedure)
(mk-sym private_procedure)
(mk-sym access)
(mk-sym end_of_file)
(mk-sym character)
(mk-sym predicate_indicator)
(mk-sym source_sink)
(mk-sym operator_specifier)
(mk-sym fx)
(mk-sym fy)
(mk-sym xf)
(mk-sym yf)
(mk-sym xfx)
(mk-sym yfx)
(mk-sym xfy)
(mk-sym operator_priority)
(mk-sym flag_value)
(mk-sym flag)
(mk-sym prolog_flag)
(mk-sym on)
(mk-sym off)
(mk-sym false)
(mk-sym towards_zero)
(mk-sym down)
(mk-sym warning)
(mk-sym chars)
(mk-sym codes)
(mk-sym bounded)
(mk-sym auto_sym)
(mk-sym max_integer)
(mk-sym min_integer)
(mk-sym integer_rounding_function)
(mk-sym debug)
(mk-sym max_arity)
(mk-sym unknown)
(mk-sym double_quotes)
(mk-sym float)
(mk-sym number)
(mk-sym force)
(mk-sym input)
(mk-sym output)
(mk-sym stream_or_alias)
(mk-sym stream)
(mk-sym stream_option)
(mk-sym io_mode)
(mk-sym text)
(mk-sym binary)
(mk-sym type)
(mk-sym eof_action)
(mk-sym reposition)
(mk-sym alias)
(mk-sym reset)
(mk-sym eof_code)
(mk-sym at)
(mk-sym no)
(mk-sym end_of_stream)
(mk-sym position)
(mk-sym variable)
(mk-sym mode)
(mk-sym file_name)
(mk-sym binary_stream)
(mk-sym text_stream)
(mk-sym byte)
(mk-sym variables)
(mk-sym variable_names)
(mk-sym singletons)
(mk-sym read_option)
(mk-sym quoted)
(mk-sym ignore_ops)
(mk-sym numbervars)
(mk-sym write_option)
(mk-sym char_conversion)
(mk-sym char-convert)
\ No newline at end of file
......@@ -6,7 +6,8 @@
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module ((logic guile-log) #:select ((_ . GL:_)))
#:export (arg var var_ pat-match term-init-variables term-get-variables term))
#:export (arg var var_ pat-match term-init-variables
term-get-variables-list term-get-variables term))
(define arg #f)
(define arg-goal #f)
......@@ -110,6 +111,8 @@
,r)))))
(define *variables* (make-fluid (make-hash-table)))
(define *var-list* (make-fluid '()))
(define (term-get-variables)
(hash-fold
(lambda (k v s)
......@@ -117,7 +120,11 @@
'()
(fluid-ref *variables*)))
(define (term-get-variables-list)
(reverse (fluid-ref *var-list*)))
(define (term-init-variables)
(fluid-set! *var-list* '())
(fluid-set! *variables* (make-hash-table)))
(define (mk-term goal?)
......@@ -130,6 +137,7 @@
((#:group x) (fget x))
((#:variable '_ . _) #',((@@ (logic guile-log umatch) gp-make-var)))
((#:variable v . _)
(fluid-set! *var-list* (cons v (fluid-ref *var-list*)))
(hashq-set! (fluid-ref *variables*) v #t)
#`,#,(datum->syntax stx v))
((#:list () . _) '())
......@@ -148,10 +156,12 @@
#,@(map fget (get.. "," x))))))
((#:termvar v () . _)
(fluid-set! *var-list* (cons v (fluid-ref *var-list*)))
(hashq-set! (fluid-ref *variables*) v #t)
#`#((,#,(datum->syntax stx v))))
((#:termvar v x . _)
(fluid-set! *var-list* (cons v (fluid-ref *var-list*)))
(hashq-set! (fluid-ref *variables*) v #t)
#`(unquote
(vector
......
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