Commit 09f74137 authored by Erick's avatar Erick

Starting implementation of R7 RS functions.

Added the flags to distinguish textual and binary ports (a port can be both too)
R7RS functions implemented:
   - call-with-port
   - textual-port?
   - binary-port?
   - open-binary-input-file
   - open-binary-output-file
parent 96eca9eb
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 10-Jul-2018 15:31 (eg)
;;;; Last file update: 14-Jul-2018 19:29 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -634,3 +634,55 @@ doc>
(error 'vector-for-each "bad list of vectors ~S" vectors))
(apply map proc (map vector->list vectors))
(void))
;;;; ----------------------------------------------------------------------
;;;; 6.13 Input and Output
;;;; ----------------------------------------------------------------------
;;;
;;; 6.13.1 Ports
;;;
#|
<doc R7RS call-with-port
* (call-with-port port proc)
*
* The |call-with-port| procedure calls |proc| with |port| as an
* argument. If |proc| returns, then the |port| is closed automatically
* and the values yielded by the |proc| are returned.
* If |proc| does not return, then the |port| must not be closed
* automatically unless it is possible to prove that the port
* will never again be used for a read or write operation.
*
* It is an error if proc does not accept one argument.
|#
(define (call-with-port port proc)
#;(unless (port? port)
(error 'call-with-port "bad port ~S" port))
#;(unless (and (procedure? proc) (memq (%procedure-arity proc) '(-2 -1 1)))
(error 'call-with-port "bad procedure ~S" proc))
(%claim-error 'call-with-port
(let ((res (proc port)))
(close-port port)
res)))
#|
<doc R7RS input-port-open? output-port-open?
* (input-port-open? port)
* (output-port-open? port)
*
* Returns #t if port is still open and capable of performing
* input or output, respectively, and #f otherwise.
doc>
|#
(define (input-port-open? port)
(unless (input-port? port)
(error "bad input port ~S" port))
(not (port-closed? port)))
(define (output-port-open? port)
(unless (output-port? port)
(error "bad output port ~S" port))
(not (port-closed? port)))
This diff is collapsed.
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 6-Jul-2018 19:29 (eg)
* Last file update: 14-Jul-2018 19:38 (eg)
*
*/
......@@ -121,7 +121,27 @@ DEFINE_PRIMITIVE("output-port?", output_portp, subr1, (SCM port))
}
/*
<doc EXT port?
<doc R7RS textual-port? binary-port?
* (textual-port? obj)
* (binary-port? obj)
*
* Returns |#t| if |obj| is an textual port or binary port respectively,
* otherwise returns #f.
doc>
*/
DEFINE_PRIMITIVE("textual-port?", textual_portp, subr1, (SCM port))
{
return MAKE_BOOLEAN(PORTP(port) && (PORT_FLAGS(port) & PORT_TEXTUAL));
}
DEFINE_PRIMITIVE("binary-port?", binary_portp, subr1, (SCM port))
{
return MAKE_BOOLEAN(PORTP(port) && (PORT_FLAGS(port) & PORT_BINARY));
}
/*
<doc R7RS port?
* (port? obj)
*
* Returns |#t| if |obj| is an input port or an output port,
......@@ -617,7 +637,7 @@ DEFINE_PRIMITIVE("write-char", write_char, subr12, (SCM c, SCM port))
* Writes the character of string |str| to the given |port| and
* returns an unspecified value. The |port| argument may be omitted,
* in which case it defaults to the value returned by
* |current-output-port|.
* |current-output-port|.
* @l
* ,(bold "Note:") This function is generally
* faster than |display| for strings. Furthermore, this primitive does
......@@ -1135,7 +1155,7 @@ DEFINE_PRIMITIVE("close-output-port", close_output_port, subr1, (SCM port))
/*
<doc EXT close-port
<doc R7RS close-port
* (close-port port)
*
* Closes the port associated with |port|.
......@@ -1150,10 +1170,17 @@ DEFINE_PRIMITIVE("close-port", close_port, subr1, (SCM port))
}
/*
<doc EXT port-closed?
<doc EXT port-closed? port-open?
* (port-closed? port)
* (port-open? port)
*
* Returns |#t| if |port| is closed and |#f| otherwise.
* |port-closed| returns |#t| if |port| is closed and |#f| otherwise.
* On the contrary, |port-open?| returns |#t| if |port| is open and
* |#f| otherwise.
* @l
* ,(bold "Note:") |port-closed?| was the usual STklos function to
* test if a port is closed. |port-open?| has been added to be the companion
* of the ,(rseven) functions |input-port-open?| and |output-port-open?|
doc>
*/
DEFINE_PRIMITIVE("port-closed?", port_closed, subr1, (SCM port))
......@@ -1163,6 +1190,13 @@ DEFINE_PRIMITIVE("port-closed?", port_closed, subr1, (SCM port))
return MAKE_BOOLEAN(PORT_IS_CLOSEDP(port));
}
DEFINE_PRIMITIVE("port-open?", port_open, subr1, (SCM port))
{
if (!PORTP(port)) STk_error_bad_port(port);
return MAKE_BOOLEAN(!PORT_IS_CLOSEDP(port));
}
/*
<doc EXT read-line
......@@ -1511,6 +1545,8 @@ int STk_init_port(void)
/* and its associated primitives */
ADD_PRIMITIVE(input_portp);
ADD_PRIMITIVE(output_portp);
ADD_PRIMITIVE(binary_portp);
ADD_PRIMITIVE(textual_portp);
ADD_PRIMITIVE(portp);
ADD_PRIMITIVE(interactive_portp);
ADD_PRIMITIVE(current_input_port);
......@@ -1545,6 +1581,7 @@ int STk_init_port(void)
ADD_PRIMITIVE(close_output_port);
ADD_PRIMITIVE(close_port);
ADD_PRIMITIVE(port_closed);
ADD_PRIMITIVE(port_open);
ADD_PRIMITIVE(copy_port);
ADD_PRIMITIVE(read_line);
......
......@@ -842,13 +842,13 @@ SCM STk_resolve_link(char *path, int count);
----
---- P O R T . C
----
---- (and sio.c, fport.c, sport.c, vport.c)
---- (and s, fport.c, sport.c, vport.c)
----
------------------------------------------------------------------------------
*/
/* Code for port is splitted in several files:
* - sio.c contains the low level IO functions which mimic the C IO. All
* - s contains the low level IO functions which mimic the C IO. All
* these functions take Scheme ports as parameter instead of FILE *
* - fport.c contains the specific code for port associated to files
* - sport.c contains the specific code for port associated to string ports
......@@ -892,9 +892,12 @@ struct port_obj {
#define PORT_IS_PIPE (1<<4)
#define PORT_IS_FILE (1<<5)
#define PORT_IS_STRING (1<<6)
#define PORT_IS_VIRTUAL (1<<7)
#define PORT_IS_INTERACTIVE (1<<8)
#define PORT_CASE_SENSITIVE (1<<9)
#define PORT_IS_BYTEVECTOR (1<<7)
#define PORT_IS_VIRTUAL (1<<8)
#define PORT_IS_INTERACTIVE (1<<9)
#define PORT_CASE_SENSITIVE (1<<10)
#define PORT_TEXTUAL (1<<11)
#define PORT_BINARY (1<<12)
#define PORT_STREAM(x) (((struct port_obj *) (x))->stream)
#define PORT_FLAGS(x) (((struct port_obj *) (x))->flags)
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 11-Jul-2018 18:22 (eg)
;;;; Last file update: 13-Jul-2018 15:06 (eg)
;;;;
(require "test")
......@@ -393,4 +393,16 @@
'(42 42 42 42)
(make-list 4 42))
;;------------------------------------------------------------------
(test-subsection "Input and Output")
(test "call-with-port"
'(123 . #t)
(let* ((p (open-input-string "123 456"))
(v (call-with-port p read)))
(cons v (port-closed? p))))
(test-section-end)
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