flush_output added, fix =.. error handling

parent 7a7a0173
......@@ -45,6 +45,7 @@
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
flush_output
;; replacings
append length read write open close member
......
......@@ -313,13 +313,83 @@ floor(x) (floor x)
|#
(<define> (func=.. x y)
(<match> (#:mode + #:name =..) (x)
(#(fl) (<cut> (<=> y fl)))
(f (<cut> (<let> ((f (<lookup> f)))
(if (procedure? f)
(<=> y (f))
<fail>))))))
(<let> ((x (<lookup> x))
(y (<scm> y)))
(cond
((or (number? x))
(<=> (x) y))
((vector? x)
(<match> (#:mode -) (x)
(#(l)
(<match> (#:mode -) (y)
((f . u)
(<cut>
(<let> ((f (<lookup> f)))
(cond
((string? f)
(<let> ((g (module-ref (currrent-module) (string->symbol f))))
(if (procedure? g)
(<=> l ,(cons g u))
(existence_error
procedure
(vector `(,divide ,f
,(length (<scm> u))))))))
(else
(<=> l y))))))
(y
(<cut>
(<=> l y)))))
(_ (type_error 'compound x))))
((<var?> x)
(cond
((<var?> y)
(instantiation_error))
((list? y)
(<match> (#:mode -) (y)
((f . l)
(<let> ((f (<lookup> f)))
(cond
((procedure? f)
(<=> x ,(cons f l)))
((string? f)
(<let> ((g (module-ref (currrent-module) (string->symbol f))))
(if (procedure? g)
(<=> x ,(vector (cons g l)))
(existence_error
procedure
(vector `(,divide ,f
,(length (<scm> l))))))))
((and (number? f) (null? (<lookup> l)))
(<=> x f))
((number? f)
(type_error atom f))
((<var?> f)
(instantiation_error))
(else
(type_error atom f)))))
(()
(type_error list y))))
((pair? y)
(<recur> lp ((z y))
(if (pair? z)
(lp (cdr z))
(if (<var?> z)
(instantiation_error)
(type_error list y)))))
(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)
......
......@@ -18,7 +18,7 @@
binary type eof_action reposition alias reset eof_code at no
end_of_stream position variable mode file_name binary_stream
text_stream byte get_byte put_byte peek_byte
get_char get_code peek_char peek_code
get_char get_code peek_char peek_code flush_output
))
(define read #f)
......@@ -869,4 +869,31 @@
(<=> code ,(lookahead-u8 s))))))))
(define mode-list (list read write append))
\ No newline at end of file
(define mode-list (list read write append))
(define flush_output
(<case-lambda>
((s)
(<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))
((prolog-input-stream? s)
(permission_error output stream ss))
(else
(<code> (force-output s))))))
(()
(<code> (flush-all-ports)))))
\ No newline at end of file
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