functional streams

parent 4dc79cb9
......@@ -39,6 +39,7 @@ Version 0.5,
* fast math and guile featured operators for numerics added.
Version 0.6, TODO
* Functional Streams DONE
* SWI Prolog namespacing
* if directives
* swi compability
......
......@@ -3,13 +3,27 @@
#:use-module (srfi srfi-9 gnu)
#:export (finsert finsert-l fwrite fwrite-l feof? feof-l?
fread fread-l fseek fseek-l
rw-fstream-from-file rw-fstream-from-string
r-fstream-from-file r-fstream-from-string
w-fstream-from-file-append w-fstream-from-string-append
fpeek fpeek-l
rw-fstream-from-file
rw-fstream-from-string
r-fstream-from-file
r-fstream-from-string
rw-fstream-from-file-append
w-fstream-from-file-append
w-fstream-from-string-append
rw-fstream-from-string-append
feof freadline freadline-l
make-empty-rw-fstream
make-empty-r-fstream
make-empty-w-fstream
fstream-rw?
fstream-r?
fstream-w?
write-fstream
rw-fstream-meta
r-fstream-meta
w-fstream-meta
fposition
))
;; Functional port or stream
......@@ -37,13 +51,28 @@
(l w-fstream-l set-w-fstream-l)
(meta w-fstream-meta set-w-fstream-meta))
(define (make-empty-rw-fstream)
(make-fstream-rw 0 0 '() '() '()))
(define (make-empty-r-fstream)
(make-fstream-r 0 '() '()))
(define (make-empty-w-fstream)
(make-fstream-r 0 '() '()))
(define make-empty-rw-fstream
(case-lambda
(()
(make-fstream-rw 0 0 '() '() '((#:open . #t) (#:file-name . #f))))
((str)
(make-fstream-rw 0 0 '() '() `((#:open . #t) (#:file-name . ,str))))))
(define make-empty-r-fstream
(case-lambda
(()
(make-fstream-r 0 '() '((#:open . #t) (#:file-name . #f))))
((str)
(make-fstream-r 0 '() `((#:open . #t) (#:file-name . ,str))))))
(define make-empty-w-fstream
(case-lambda
(()
(make-fstream-w 0 '() '((#:open . #t) (#:file-name . #f))))
((str)
(make-fstream-w 0 '() `((#:open . #t) (#:file-name . ,str))))))
(define (finsert stream x)
(cond
((fstream-rw? stream)
......@@ -282,30 +311,53 @@
(define (rw-fstream-from-file str)
(with-input-from-file str
(lambda ()
(let lp ((ch (read-char)) (s (make-empty-rw-fstream)))
(let lp ((ch (read-char)) (s (make-empty-rw-fstream `((#:file-name . ,str)
(#:open . #t))
)))
(if (eof-object? ch)
(fseek s 0)
(lp (read-char) (fwrite s ch)))))))
(define (rw-fstream-from-file-append str)
(with-input-from-file str
(lambda ()
(let lp ((ch (read-char)) (s (make-empty-rw-fstream `((#:file-name . ,str)
(#:open . #t))
)))
(if (eof-object? ch)
s
(lp (read-char) (fwrite s ch)))))))
(define (r-fstream-from-file str)
(rw->r (rw-fstream-from-file str)))
(define (w-fstream-from-file-append str)
(rw->w (seek-l (rw-fstream-from-file str) 0)))
(rw->w (rw-fstream-from-file-append str)))
(define (rw-fstream-from-string str)
(with-input-from-string str
(lambda ()
(let lp ((ch (read-char)) (s (make-empty-rw-fstream)))
(let lp ((ch (read-char)) (s (make-empty-rw-fstream `((#:file-name . #f)
(#:open . #t))
)))
(if (eof-object? ch)
(fseek s 0)
(lp (read-char) (fwrite s ch)))))))
(define (rw-fstream-from-string-append str)
(with-input-from-string str
(lambda ()
(let lp ((ch (read-char)) (s (make-empty-rw-fstream `((#:file-name . #f)
(#:open . #t))
)))
(if (eof-object? ch)
(lp (read-char) (fwrite s ch)))))))
(define (r-fstream-from-string str)
(rw->r (rw-fstream-from-string str)))
(define (w-fstream-from-string-append str)
(rw->w (seek-l (rw-fstream-from-string str) 0)))
(rw->w (rw-fstream-from-string-append str)))
(define (freadline stream)
(cond
......@@ -386,3 +438,38 @@
(else
(error "no rw/w fstream in freadline-l" stream))))
(define (write-fstream s)
(cond
((fstream-rw? s)
(let ((str ((assq #:file-name (rw-fstream-meta s)))))
(if str
(with-output-to-file str
(lambda ()
(let lp ((l (rw-fstream-r (fseek s 0))))
(if (pair? l)
(begin
(format #t "~a" (car l))
(lp (cdr l)))
#t)))))))
((fstream-w? s)
(let ((str ((assq #:file-name (w-fstream-meta s)))))
(if str
(with-output-to-file str
(lambda ()
(let lp ((l (reverse (w-fstream-l s))))
(if (pair? l)
(begin
(format #t "~a" (car l))
(lp (cdr l)))
#t)))))))
(else
#t)))
(define (fposition s)
(cond
((fstream-rw? s)
(rw-fstream-n s))
((fstream-w? s)
(rw-fstream-n s))
((fstream-w? s)
0)))
......@@ -53,6 +53,7 @@
ensure_loaded
;; io
functional
current_input current_output standard_input standard_output
set_input set_output
current_char_conversion char_conversion
......
......@@ -2,6 +2,7 @@
#:use-module (logic guile-log)
#:use-module (logic guile-log vlist)
#:use-module (logic guile-log memoize)
#:use-module (logic guile-log fstream)
#:use-module (logic guile-log attributed)
#:use-module (logic guile-log guile-prolog attribute)
#:use-module ((logic guile-log umatch)
......@@ -23,6 +24,7 @@
#:use-module (logic guile-log prolog operators)
#:use-module (logic guile-log prolog namespace)
#:use-module (rnrs io ports)
#:use-module (logic guile-log fstream)
#:replace (write open close read)
#:export (nl pp current_input current_output standard_input standard_output
set_input set_output put_char put_code stream_property
......@@ -48,10 +50,17 @@
(define atom? (@@ (logic guile-log prolog goal-transformers) atom?))
(define (fport? x)
(and (fluid? x)
(let ((x (fluid-ref x)))
(or (fstream-rw? x)
(fstream-r? x)
(fstream-w? x)))))
(define (binary-port? x) #f)
(define source/sink? (lambda (x)
(or (string? x) (procedure? x))))
(define prolog-stream? port?)
(define prolog-stream? (lambda (x) (or (port? x) (fport? x))))
(define prolog-alias? (lambda (x)
(and (procedure? x)
(procedure-property x 'prolog-alias))))
......@@ -60,12 +69,38 @@
(lambda (x)
(or (prolog-alias? x) (prolog-stream? x))))
(define prolog-output-stream? output-port?)
(define prolog-input-stream? input-port?)
(define prolog-stream-closed? port-closed?)
(define prolog-output-stream? output-port?)
(define prolog-input-stream? input-port?)
(define prolog-output-stream?
(lambda (x)
(or
(output-port? x)
(and (fluid? x)
(let ((x (fluid-ref x)))
(fstream-rw? x)
(fstream-w? x))))))
(define prolog-input-stream?
(lambda (x)
(or
(input-port? x)
(and (fluid? x)
(let ((x (fluid-ref x)))
(fstream-rw? x)
(fstream-r? x))))))
(define (assq-true x)
(and (pair? x) (cdr x)))
(define (prolog-stream-closed? x)
(or (port-closed? x)
(and
(fluid? x)
(let ((x (fluid-ref x)))
(or
(and (fstream-rw? x) (assq-true (assq #:open (rw-fstream-meta x))))
(and (fstream-r? x) (assq-true (assq #:open (r-fstream-meta x))))
(and (fstream-w? x) (assq-true (assq #:open
(w-fstream-meta x)))))))))
(define-syntax-rule (mk-test current_input *current-input*)
(<define> (current_input x)
......@@ -133,6 +168,8 @@
#t)
(#(((? (eq reposition)) (or (? (eq true)) (? (eq false)))))
#t)
(#(((? (eq functional)) (or (? eq true) (? eq false))))
#t)
(#(((? (eq alias)) a))
(let ((a (gp-lookup a s)))
(and (procedure? a) (or (not (prolog-alias? a))
......@@ -147,13 +184,28 @@
(define default-open-option `((#:type . ,text)
(#:reposition . ,false)
(#:eof-action . ,eof_code)
(#:alias . #f)))
(#:alias . #f)
(#:functional . #f)))
(define (open-file-wrap fn mode)
(let ((fn (cond
((procedure? fn)
(symbol->string (procedure-name fn)))
((symbol? fn)
(symbol->string fn))
(else fn))))
((@@ (guile) catch) #t
(lambda ()
(let ((s (open-file fn mode)))
(cons s #f)))
(lambda x (cons #t #t)))))
(define (open-ffile-wrap fn mode)
(let ((fn (cond
((procedure? fn)
(symbol->string (procedure-name fn)))
......@@ -163,8 +215,22 @@
((@@ (guile) catch) #t
(lambda ()
(let ((s (open-file fn mode)))
(cons s #f)))
(let ((s (cond
((equal? mode "w")
(make-fluid (make-empty-w-fstream `((#:file-name . ,fn)))))
((equal? mode "a")
(make-fluid (w-fstream-from-file-append fn)))
((equal? mode "r")
(make-fluid (r-fstream-from-file fn)))
((equal? mode "rw")
(make-fluid (rw-fstream-from-file fn)))
((equal? mode "rwa")
(make-fluid (rw-fstream-from-file-append fn)))
(else
#F))))
(if s
(cons s #f)
(cons #f #t))))
(lambda x (cons #t #t)))))
(define *open-ports* (make-fluid '()))
......@@ -216,7 +282,10 @@
(<and> <cc>))
(<and> <cc>))
(<var> (Repo Alias EOF Type)
(<var> (Repo Alias EOF Type Functional)
(<or>
(pr-member (vector (list functional Type)) Option)
(<=> Functional ,(cdr (assq #:functional default-open-option))))
(<or>
(pr-member (vector (list type Type)) Option)
(<=> Type ,(cdr (assq #:type default-open-option))))
......@@ -230,10 +299,11 @@
(pr-member (vector (list eof_action EOF)) Option)
(<=> EOF ,(cdr (assq #:eof-action default-open-option))))
(<cut>
(<let> ((t (<lookup> Type))
(r (<lookup> Repo))
(a (<lookup> Alias))
(e (<lookup> EOF)))
(<let> ((t (<lookup> Type))
(r (<lookup> Repo))
(a (<lookup> Alias))
(e (<lookup> EOF))
(fu (<lookup> Functional)))
(<let*> ((mode (if (eq? t text)
(cond
((eq? Mode write)
......@@ -249,7 +319,9 @@
"rb")
((eq? Mode append)
"ab"))))
(s-e (open-file-wrap SS mode))
(s-e (if (eq? fu true)
(open-ffile-wrap SS mode)
(open-file-wrap SS mode)))
(s (car s-e))
(er (cdr s-e)))
(if er
......@@ -267,7 +339,38 @@
(<=> Stream s)
)))))))))))))))
(define (assq-get x a)
(let ((q (assq a x)))
(if q (cdr q) q)))
(define (fstream-file s)
(if (fluid? s)
(let ((s (fluid-ref s)))
(cond
((fstream-rw? s)
(assq-get (rw-fstream-meta s) #:file-name))
((fstream-r? s)
(assq-get (r-fstream-meta s) #:file-name))
((fstream-w? s)
(assq-get (w-fstream-meta s) #:file-name))
(else
#f)))
#f))
(define (peek-char-adv s)
(if (port? s)
(peek-char s)
(let ((s (fluid-ref s)))
(fpeek s))))
(define (port-position-adv s)
(if (port? s)
(port-position s)
(let ((s (fluid-ref s)))
(fposition s))))
(<define> (stream_property s prop)
(<let*> ((ss (<lookup> s))
(s (stream-alias-lookup ss))
......@@ -305,7 +408,9 @@
(else
(<match> (#:mode - #:name stream_property) (prop)
(#((,file_name f))
(<cut> (<=> f ,(port-filename s))))
(if (port? s)
(<cut> (<=> f ,(port-filename s)))
(<cut> (<=> f ,(fstream-file s)))))
(#((,mode m))
(<cut>
......@@ -319,7 +424,7 @@
(#((,type t))
(<cut>
(<=> t ,(if (binary-port? s)
(<=> t ,(if (and (port? s) (binary-port? s))
binary
text))))
(,input
......@@ -336,13 +441,20 @@
(#((,position p))
(<cut>
(when (or (eq? (cdr (assq #:repos props)) true)
(port-has-port-position? s))
(<=> p ,(port-position s)))))
(if (port? s)
(port-has-port-position? s)
#t))
(<=> p ,(port-position-adv s)))))
(#((,reposition p))
(<cut>
(<=> p ,(if (or (eq? (cdr (assq #:repos props)) true)
(port-has-port-position? s))
(port-has-port-position? s)
(and (fluid? s)
(let ((s (fluid-ref s)))
(fstream-rw? s))))
true
false))))
......@@ -352,7 +464,7 @@
(if (prolog-input-stream? s)
(if (prolog-output-stream? s)
<fail>
(if (eof-object? (peek-char s))
(if (eof-object? (peek-char-adv s))
(<=> e at)
(<=> e no)))
(<=> e at))))
......@@ -373,6 +485,11 @@
(_
#f)))
(define (close-port-adv s)
(if (port? s)
(close-port s)
(let ((ss (fluid-ref s)))
(fluid-set! s (write-fstream ss)))))
(define close
(<case-lambda>
......@@ -421,7 +538,7 @@
(cdr l))
(lp (cdr l)
(cons (car l) r))))))
(close-port s))))))))))
(close-port-adv s))))))))))
......@@ -736,6 +853,16 @@
(<wrap-s> (with-atomic-frec (<lambda> (x) (rec-action00 action x))) s x)
(lp x))
(define (fformat port str . l)
(if (port? port)
(apply format port str l)
(let ((s (fluid-ref port))
(str (apply format #f str l)))
(let lp ((l (string->list str)) (s s))
(if (pair? l)
(lp (cdr l) (fwrite s (car l)))
(fluid-set! port s))))))
(define write_term
(<case-lambda>
((s t opts)
......@@ -784,9 +911,11 @@
(_
(domain_error write_option opt)))))
(lp opts)))
(()
(<and>
(<cut> (<code> (format s "~a" (scm->pl S t ns q i n))))))
(<cut>
(<code> (fformat s "~a" (scm->pl S t ns q i n))))))
(_
(instantiation_error)))))))))
((t opts)
......@@ -920,6 +1049,12 @@
(else
#f)))
(define (write-char-adv ch s)
(if (port? s)
(write-char ch s)
(let ((ss (fluid-ref s)))
(fluid-set! s (fwrite s ch)))))
(define put_char
(<case-lambda>
((s ch)
......@@ -944,7 +1079,7 @@
((binary-port? s)
(permission_error input binary_stream ss))
(else
(<code> (write-char (->ch ch) s))))))
(<code> (write-char-adv (->ch ch) s))))))
((ch)
(put_char (fluid-ref *current-output*) ch))))
......@@ -1028,6 +1163,21 @@
end_of_stream
(list->string (list ch))))
(define (read-char-adv s)
(if (port? s)
(read-char s)
(let ((ss (fluid-ref s)))
(call-with-values (lambda () (fread ss))
(lambda (st val)
(fluid-set! s st)
val)))))
(define (peek-char-adv s)
(if (port? s)
(peek-char s)
(let ((ss (fluid-ref s)))
(fpeek ss))))
(define get_char
(<case-lambda>
((ch)
......@@ -1054,7 +1204,7 @@
(permission_error input binary_stream ss))
(else
(<=> ch ,(<-ch (read-char s)))))))))
(<=> ch ,(<-ch (read-char-adv s)))))))))
(define get_code
(<case-lambda>
......@@ -1083,7 +1233,7 @@
(else
(<var> (ch)
(<=> ch ,(<-ch (read-char s)))
(<=> ch ,(<-ch (read-char-adv s)))
(char_code ch code))))))))
(define get_byte
......@@ -1175,7 +1325,7 @@
(else
(<var> (ch)
(<=> ch ,(<-ch (peek-char s)))
(<=> ch ,(<-ch (peek-char-adv s)))
(char_code ch code))))))))
(define peek_byte
......@@ -1234,7 +1384,8 @@
(permission_error output stream ss))
(else
(<code> (force-output s))))))
(if (port? s)
(<code> (force-output s)))))))
(()
(<code> (flush-all-ports)))))
......
......@@ -76,6 +76,7 @@
ignore_ops
numbervars
write_option
functional
read
write
......@@ -275,7 +276,7 @@
(mk-sym ignore_ops)
(mk-sym numbervars)
(mk-sym write_option)
(mk-sym functional)
(mk-sym char_conversion)
(mk-sym char-convert)
......
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