mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Load port bindings in separate (ice-9 ports) module

Browse source 
* module/ice-9/ports.scm: New file.
* am/bootstrap.am (SOURCES): Add ice-9/ports.scm.
* libguile/fports.c (scm_init_ice_9_fports): New function.
  (scm_init_fports): Arrange for scm_init_ice_9_fports to be called via
  load-extension, and load snarfed things there.  Move open-file
  definition early, to allow ports to bootstrap.
* libguile/ioext.c (scm_init_ice_9_ioext): New function.
  (scm_init_ioext): Similarly, register scm_init_ice_9_ioext as an
  extension.
* libguile/ports.c (scm_set_current_input_port)
  (scm_set_current_output_port, scm_set_current_error_port): Don't
  define Scheme bindings; do that in Scheme.
* libguile/ports.c (scm_i_set_default_port_encoding):
  (scm_i_default_port_encoding, scm_i_default_port_conversion_handler):
  (scm_i_set_default_port_conversion_handler): Since we now init
  encoding early, remove the "init" flags on these encoding/strategy
  vars.
  (scm_init_ice_9_ports): New function.
  (scm_init_ports): Register scm_init_ice_9_ports extension, and define
  some bindings needed by the bootstrap.
* module/Makefile.am (SOURCES): Add ice-9/ports.scm.
* module/ice-9/boot-9.scm: Remove code that's not on the boot path,
  moving it to ice-9/ports.scm.  At the end, load (ice-9 ports).
* module/ice-9/psyntax.scm (include): Use close-port instead of
  close-input-port.
* module/ice-9/psyntax-pp.scm (include): Regenerate.
This commit is contained in:
Andy Wingo 2016-04-14 15:44:34 +02:00
parent 5e470ea48f
commit 44b3342c4d
9 changed files with 607 additions and 402 deletions
Download patch file Download diff file Expand all files Collapse all files

1
am/bootstrap.am
View file

@ -123,6 +123,7 @@ SOURCES = \
system/base/ck.scm \
\
ice-9/boot-9.scm \
ice-9/ports.scm \
ice-9/r5rs.scm \
ice-9/deprecated.scm \
ice-9/binary-ports.scm \

26
libguile/fports.c
View file

@ -121,8 +121,8 @@ SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
static SCM sys_file_port_name_canonicalization;
SCM_SYMBOL (sym_relative, "relative");
SCM_SYMBOL (sym_absolute, "absolute");
static SCM sym_relative;
static SCM sym_absolute;
static SCM
fport_canonicalize_filename (SCM filename)
@ -677,16 +677,34 @@ scm_init_fports_keywords ()
k_encoding = scm_from_latin1_keyword ("encoding");
}
static void
scm_init_ice_9_fports (void)
{
#include "libguile/fports.x"
}
void
scm_init_fports ()
{
scm_tc16_fport = scm_make_fptob ();
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_ice_9_fports",
(scm_t_extension_init_func) scm_init_ice_9_fports,
NULL);
/* The following bindings are used early in boot-9.scm. */
/* Used by `include' and also by `file-exists?' if `stat' is
unavailable. */
scm_c_define_gsubr (s_scm_i_open_file, 2, 0, 1, (scm_t_subr) scm_i_open_file);
/* Used by `open-file.', also via C. */
sym_relative = scm_from_latin1_symbol ("relative");
sym_absolute = scm_from_latin1_symbol ("absolute");
sys_file_port_name_canonicalization = scm_make_fluid ();
scm_c_define ("%file-port-name-canonicalization",
sys_file_port_name_canonicalization);
#include "libguile/fports.x"
}
/*

11
libguile/ioext.c
View file

@ -302,12 +302,21 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
#undef FUNC_NAME
static void
scm_init_ice_9_ioext (void)
{
#include "libguile/ioext.x"
}
void
scm_init_ioext ()
{
scm_add_feature ("i/o-extensions");
#include "libguile/ioext.x"
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_ice_9_ioext",
(scm_t_extension_init_func) scm_init_ice_9_ioext,
NULL);
}

166
libguile/ports.c
View file

@ -425,14 +425,9 @@ SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
(SCM port),
"@deffnx {Scheme Procedure} set-current-output-port port\n"
"@deffnx {Scheme Procedure} set-current-error-port port\n"
"Change the ports returned by @code{current-input-port},\n"
"@code{current-output-port} and @code{current-error-port}, respectively,\n"
"so that they use the supplied @var{port} for input or output.")
#define FUNC_NAME s_scm_set_current_input_port
SCM
scm_set_current_input_port (SCM port)
#define FUNC_NAME "set-current-input-port"
{
SCM oinp = scm_fluid_ref (cur_inport_fluid);
SCM_VALIDATE_OPINPORT (1, port);
@ -441,11 +436,9 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
(SCM port),
"Set the current default output port to @var{port}.")
#define FUNC_NAME s_scm_set_current_output_port
SCM
scm_set_current_output_port (SCM port)
#define FUNC_NAME "scm-set-current-output-port"
{
SCM ooutp = scm_fluid_ref (cur_outport_fluid);
port = SCM_COERCE_OUTPORT (port);
@ -455,11 +448,9 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
(SCM port),
"Set the current default error port to @var{port}.")
#define FUNC_NAME s_scm_set_current_error_port
SCM
scm_set_current_error_port (SCM port)
#define FUNC_NAME "set-current-error-port"
{
SCM oerrp = scm_fluid_ref (cur_errport_fluid);
port = SCM_COERCE_OUTPORT (port);
@ -469,7 +460,6 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
}
#undef FUNC_NAME
SCM
scm_set_current_warning_port (SCM port)
#define FUNC_NAME "set-current-warning-port"
@ -482,7 +472,6 @@ scm_set_current_warning_port (SCM port)
}
#undef FUNC_NAME
void
scm_dynwind_current_input_port (SCM port)
#define FUNC_NAME NULL
@ -916,19 +905,12 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0,
/* A fluid specifying the default encoding for newly created ports. If it is
a string, that is the encoding. If it is #f, it is in the "native"
(Latin-1) encoding. */
SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding");
static int scm_port_encoding_init = 0;
static SCM default_port_encoding_var;
/* Use ENCODING as the default encoding for future ports. */
void
scm_i_set_default_port_encoding (const char *encoding)
{
if (!scm_port_encoding_init
|| !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized",
SCM_EOL);
if (encoding_matches (encoding, "ISO-8859-1"))
scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F);
else
@ -940,12 +922,6 @@ scm_i_set_default_port_encoding (const char *encoding)
const char *
scm_i_default_port_encoding (void)
{
if (!scm_port_encoding_init)
return "ISO-8859-1";
else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var)))
return "ISO-8859-1";
else
{
SCM encoding;
encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var));
@ -953,50 +929,34 @@ scm_i_default_port_encoding (void)
return "ISO-8859-1";
else
return scm_i_string_chars (encoding);
}
}
/* A fluid specifying the default conversion handler for newly created
ports. Its value should be one of the symbols below. */
SCM_VARIABLE (default_conversion_strategy_var,
"%default-port-conversion-strategy");
/* Whether the above fluid is initialized. */
static int scm_conversion_strategy_init = 0;
static SCM default_conversion_strategy_var;
/* The possible conversion strategies. */
SCM_SYMBOL (sym_error, "error");
SCM_SYMBOL (sym_substitute, "substitute");
SCM_SYMBOL (sym_escape, "escape");
static SCM sym_error;
static SCM sym_substitute;
static SCM sym_escape;
/* Return the default failed encoding conversion policy for new created
ports. */
scm_t_string_failed_conversion_handler
scm_i_default_port_conversion_handler (void)
{
scm_t_string_failed_conversion_handler handler;
SCM value;
if (!scm_conversion_strategy_init
|| !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
else
{
SCM fluid, value;
fluid = SCM_VARIABLE_REF (default_conversion_strategy_var);
value = scm_fluid_ref (fluid);
value = scm_fluid_ref (SCM_VARIABLE_REF (default_conversion_strategy_var));
if (scm_is_eq (sym_substitute, value))
handler = SCM_FAILED_CONVERSION_QUESTION_MARK;
return SCM_FAILED_CONVERSION_QUESTION_MARK;
else if (scm_is_eq (sym_escape, value))
handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE;
else
/* Default to 'error also when the fluid's value is not one of
the valid symbols. */
handler = SCM_FAILED_CONVERSION_ERROR;
}
return handler;
return SCM_FAILED_CONVERSION_ERROR;
}
/* Use HANDLER as the default conversion strategy for future ports. */
@ -1006,11 +966,6 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle
{
SCM strategy;
if (!scm_conversion_strategy_init
|| !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var)))
scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized",
SCM_EOL);
switch (handler)
{
case SCM_FAILED_CONVERSION_ERROR:
@ -3286,36 +3241,16 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
/* Initialization. */
void
scm_init_ports ()
static void
scm_init_ice_9_ports (void)
{
#include "libguile/ports.x"
/* lseek() symbols. */
scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET));
scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR));
scm_c_define ("SEEK_END", scm_from_int (SEEK_END));
scm_tc16_void_port = scm_make_port_type ("void", void_port_read,
void_port_write);
cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid ();
cur_warnport_fluid = scm_make_fluid ();
cur_loadport_fluid = scm_make_fluid ();
scm_i_port_weak_set = scm_c_make_weak_set (31);
#include "libguile/ports.x"
/* Use Latin-1 as the default port encoding. */
SCM_VARIABLE_SET (default_port_encoding_var,
scm_make_fluid_with_default (SCM_BOOL_F));
scm_port_encoding_init = 1;
SCM_VARIABLE_SET (default_conversion_strategy_var,
scm_make_fluid_with_default (sym_substitute));
scm_conversion_strategy_init = 1;
/* These bindings are used when boot-9 turns `current-input-port' et
al into parameters. They are then removed from the guile module. */
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
@ -3324,6 +3259,61 @@ scm_init_ports ()
scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid);
}
void
scm_init_ports (void)
{
scm_tc16_void_port = scm_make_port_type ("void", void_port_read,
void_port_write);
scm_i_port_weak_set = scm_c_make_weak_set (31);
cur_inport_fluid = scm_make_fluid ();
cur_outport_fluid = scm_make_fluid ();
cur_errport_fluid = scm_make_fluid ();
cur_warnport_fluid = scm_make_fluid ();
cur_loadport_fluid = scm_make_fluid ();
sym_substitute = scm_from_latin1_symbol ("substitute");
sym_escape = scm_from_latin1_symbol ("escape");
sym_error = scm_from_latin1_symbol ("error");
/* Use Latin-1 as the default port encoding. */
default_port_encoding_var =
scm_c_define ("%default-port-encoding",
scm_make_fluid_with_default (SCM_BOOL_F));
default_conversion_strategy_var =
scm_c_define ("%default-port-conversion-strategy",
scm_make_fluid_with_default (sym_substitute));
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_ice_9_ports",
(scm_t_extension_init_func) scm_init_ice_9_ports,
NULL);
/* The following bindings are used early in boot-9.scm. */
/* Used by `include'. */
scm_c_define_gsubr (s_scm_set_port_encoding_x, 2, 0, 0,
(scm_t_subr) scm_set_port_encoding_x);
scm_c_define_gsubr (s_scm_eof_object_p, 1, 0, 0,
(scm_t_subr) scm_eof_object_p);
/* Used by a number of error/warning-printing routines. */
scm_c_define_gsubr (s_scm_force_output, 0, 1, 0,
(scm_t_subr) scm_force_output);
/* Used by `file-exists?' and related functions if `stat' is
unavailable. */
scm_c_define_gsubr (s_scm_close_port, 1, 0, 0,
(scm_t_subr) scm_close_port);
/* Used by error routines. */
scm_c_define_gsubr (s_scm_current_error_port, 0, 0, 0,
(scm_t_subr) scm_current_error_port);
scm_c_define_gsubr (s_scm_current_warning_port, 0, 0, 0,
(scm_t_subr) scm_current_warning_port);
}
/*
Local Variables:
c-file-style: "gnu"

1
module/Makefile.am
View file

@ -88,6 +88,7 @@ SOURCES = \
ice-9/poe.scm \
ice-9/poll.scm \
ice-9/popen.scm \
ice-9/ports.scm \
ice-9/posix.scm \
ice-9/pretty-print.scm \
ice-9/psyntax-pp.scm \

311
module/ice-9/boot-9.scm
View file

@ -151,38 +151,6 @@ a-cont
;;; {Low-Level Port Code}
;;;
;; These are used to request the proper mode to open files in.
;;
(define OPEN_READ "r")
(define OPEN_WRITE "w")
(define OPEN_BOTH "r+")
(define *null-device* "/dev/null")
;; NOTE: Later in this file, this is redefined to support keywords
(define (open-input-file str)
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file str OPEN_READ))
;; NOTE: Later in this file, this is redefined to support keywords
(define (open-output-file str)
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
name. If the file cannot be opened, an error is signalled. If a
file with the given name already exists, the effect is unspecified."
(open-file str OPEN_WRITE))
(define (open-io-file str)
"Open file with name STR for both input and output."
(open-file str OPEN_BOTH))
;;; {Simple Debugging Tools}
;;;
@ -315,11 +283,10 @@ file with the given name already exists, the effect is unspecified."
(for-eachn (cdr l1) (map cdr rest))))))))
;; Temporary definition used in the include-from-path expansion;
;; replaced later.
;; Temporary definitions used by `include'; replaced later.
(define (absolute-file-name? file-name)
#t)
(define (absolute-file-name? file-name) #t)
(define (open-input-file str) (open-file str "r"))
;;; {and-map and or-map}
;;;
@ -1195,11 +1162,6 @@ VALUE."
;;
;; It should print OBJECT to PORT.
(define (inherit-print-state old-port new-port)
(if (get-print-state old-port)
(port-with-print-state new-port (get-print-state old-port))
new-port))
;; 0: type-name, 1: fields, 2: constructor
(define record-type-vtable
(let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
@ -1446,29 +1408,6 @@ CONV is not applied to the initial value."
;;; Current ports as parameters.
;;;
(let ()
(define-syntax-rule (port-parameterize! binding fluid predicate msg)
(begin
(set! binding (fluid->parameter (module-ref (current-module) 'fluid)
(lambda (x)
(if (predicate x) x
(error msg x)))))
(hashq-remove! (%get-pre-modules-obarray) 'fluid)))
(port-parameterize! current-input-port %current-input-port-fluid
input-port? "expected an input port")
(port-parameterize! current-output-port %current-output-port-fluid
output-port? "expected an output port")
(port-parameterize! current-error-port %current-error-port-fluid
output-port? "expected an output port")
(port-parameterize! current-warning-port %current-warning-port-fluid
output-port? "expected an output port"))
;;; {Languages}
;;;
@ -1483,140 +1422,6 @@ CONV is not applied to the initial value."
;;; {High-Level Port Routines}
;;;
(define* (open-input-file
file #:key (binary #f) (encoding #f) (guess-encoding #f))
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file file (if binary "rb" "r")
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (open-output-file file #:key (binary #f) (encoding #f))
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
name. If the file cannot be opened, an error is signalled. If a
file with the given name already exists, the effect is unspecified."
(open-file file (if binary "wb" "w")
#:encoding encoding))
(define* (call-with-input-file
file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The file must
already exist. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-input-file file
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The behaviour is unspecified if the file
already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-output-file file #:binary binary #:encoding encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-output-port p)
(apply values vals)))))
(define (with-input-from-port port thunk)
(parameterize ((current-input-port port))
(thunk)))
(define (with-output-to-port port thunk)
(parameterize ((current-output-port port))
(thunk)))
(define (with-error-to-port port thunk)
(parameterize ((current-error-port port))
(thunk)))
(define* (with-input-from-file
file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The file must already exist. The file is opened for
input, an input port connected to it is made
the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-file file
(lambda (p) (with-input-from-port p thunk))
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-output-to-port p thunk))
#:binary binary
#:encoding encoding))
(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-error-to-port p thunk))
#:binary binary
#:encoding encoding))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
input port from which @var{string}'s contents may be read. The value
yielded by the @var{proc} is returned."
(proc (open-input-string string)))
(define (with-input-from-string string thunk)
"THUNK must be a procedure of no arguments.
The test of STRING is opened for
input, an input port connected to it is made,
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed.
Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-string string
(lambda (p) (with-input-from-port p thunk))))
(define (call-with-output-string proc)
"Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
@ -1625,18 +1430,6 @@ written into the port is returned."
(proc port)
(get-output-string port)))
(define (with-output-to-string thunk)
"Calls THUNK and returns its output as a string."
(call-with-output-string
(lambda (p) (with-output-to-port p thunk))))
(define (with-error-to-string thunk)
"Calls THUNK and returns its error output as a string."
(call-with-output-string
(lambda (p) (with-error-to-port p thunk))))
(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
;;; {Booleans}
@ -1758,95 +1551,9 @@ written into the port is returned."
;;; {File Descriptors and Ports}
;;; {C Environment}
;;;
(define file-position ftell)
(define* (file-set-position port offset #:optional (whence SEEK_SET))
(seek port offset whence))
(define (move->fdes fd/port fd)
(cond ((integer? fd/port)
(dup->fdes fd/port fd)
(close fd/port)
fd)
(else
(primitive-move->fdes fd/port fd)
(set-port-revealed! fd/port 1)
fd/port)))
(define (release-port-handle port)
(let ((revealed (port-revealed port)))
(if (> revealed 0)
(set-port-revealed! port (- revealed 1)))))
(define dup->port
(case-lambda
((port/fd mode)
(fdopen (dup->fdes port/fd) mode))
((port/fd mode new-fd)
(let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
(set-port-revealed! port 1)
port))))
(define dup->inport
(case-lambda
((port/fd)
(dup->port port/fd "r"))
((port/fd new-fd)
(dup->port port/fd "r" new-fd))))
(define dup->outport
(case-lambda
((port/fd)
(dup->port port/fd "w"))
((port/fd new-fd)
(dup->port port/fd "w" new-fd))))
(define dup
(case-lambda
((port/fd)
(if (integer? port/fd)
(dup->fdes port/fd)
(dup->port port/fd (port-mode port/fd))))
((port/fd new-fd)
(if (integer? port/fd)
(dup->fdes port/fd new-fd)
(dup->port port/fd (port-mode port/fd) new-fd)))))
(define (duplicate-port port modes)
(dup->port port modes))
(define (fdes->inport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "r")))
(set-port-revealed! result 1)
result))
((input-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (fdes->outport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "w")))
(set-port-revealed! result 1)
result))
((output-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (port->fdes port)
(set-port-revealed! port (+ (port-revealed port) 1))
(fileno port))
(define (setenv name value)
(if value
(putenv (string-append name "=" value))
@ -4322,6 +4029,16 @@ when none is available, reading FILE-NAME with READER."
;;; {Ports}
;;;
;; Allow code in (guile) to use port bindings.
(module-use! the-root-module (resolve-interface '(ice-9 ports)))
;; Allow users of (guile) to see port bindings.
(module-use! the-scm-module (resolve-interface '(ice-9 ports)))
;;; SRFI-4 in the default environment. FIXME: we should figure out how
;;; to deprecate this.
;;;

469
module/ice-9/ports.scm Normal file
View file

@ -0,0 +1,469 @@
;;; Ports
;;; Copyright (C) 2016 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;;;
;;; Implementation of input/output routines over ports.
;;;
;;; Note that loading this module overrides some core bindings; see the
;;; `replace-bootstrap-bindings' invocation below for details.
;;;
;;; Code:
(define-module (ice-9 ports)
#:export (;; Definitions from ports.c.
%port-property
%set-port-property!
current-input-port current-output-port
current-error-port current-warning-port
set-current-input-port set-current-output-port
set-current-error-port
port-mode
port?
input-port?
output-port?
port-closed?
eof-object?
close-port
close-input-port
close-output-port
;; These two are currently defined by scm_init_ports; fix?
;; %default-port-encoding
;; %default-port-conversion-strategy
port-encoding
set-port-encoding!
port-conversion-strategy
set-port-conversion-strategy!
read-char
peek-char
unread-char
unread-string
setvbuf
drain-input
force-output
char-ready?
seek SEEK_SET SEEK_CUR SEEK_END
truncate-file
port-line
set-port-line!
port-column
set-port-column!
port-filename
set-port-filename!
port-for-each
flush-all-ports
%make-void-port
;; Definitions from fports.c.
open-file
file-port?
port-revealed
set-port-revealed!
adjust-port-revealed!
;; note: %file-port-name-canonicalization is used in boot-9
;; Definitions from ioext.c.
ftell
redirect-port
dup->fdes
dup2
fileno
isatty?
fdopen
primitive-move->fdes
fdes->ports
;; Definitions in Scheme
file-position
file-set-position
move->fdes
release-port-handle
dup->port
dup->inport
dup->outport
dup
duplicate-port
fdes->inport
fdes->outport
port->fdes
OPEN_READ OPEN_WRITE OPEN_BOTH
*null-device*
open-input-file
open-output-file
open-io-file
call-with-input-file
call-with-output-file
with-input-from-port
with-output-to-port
with-error-to-port
with-input-from-file
with-output-to-file
with-error-to-file
call-with-input-string
with-input-from-string
call-with-output-string
with-output-to-string
with-error-to-string
the-eof-object
inherit-print-state))
(define (replace-bootstrap-bindings syms)
(for-each
(lambda (sym)
(let* ((var (module-variable the-scm-module sym))
(mod (current-module))
(iface (module-public-interface mod)))
(unless var (error "unbound in root module" sym))
(module-add! mod sym var)
(when (module-local-variable iface sym)
(module-add! iface sym var))))
syms))
(replace-bootstrap-bindings '(open-file
open-input-file
set-port-encoding!
eof-object?
force-output
call-with-output-string
close-port
current-error-port
current-warning-port))
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_ports")
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_fports")
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_ioext")
;;; Current ports as parameters.
;;;
(define current-input-port
(fluid->parameter %current-input-port-fluid
(lambda (x)
(unless (input-port? x)
(error "expected an input port" x))
x)))
(define current-output-port
(fluid->parameter %current-output-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
(define current-error-port
(fluid->parameter %current-error-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
(define current-warning-port
(fluid->parameter %current-warning-port-fluid
(lambda (x)
(unless (output-port? x)
(error "expected an output port" x))
x)))
;;; {File Descriptors and Ports}
;;;
(define file-position ftell)
(define* (file-set-position port offset #:optional (whence SEEK_SET))
(seek port offset whence))
(define (move->fdes fd/port fd)
(cond ((integer? fd/port)
(dup->fdes fd/port fd)
(close fd/port)
fd)
(else
(primitive-move->fdes fd/port fd)
(set-port-revealed! fd/port 1)
fd/port)))
(define (release-port-handle port)
(let ((revealed (port-revealed port)))
(if (> revealed 0)
(set-port-revealed! port (- revealed 1)))))
(define dup->port
(case-lambda
((port/fd mode)
(fdopen (dup->fdes port/fd) mode))
((port/fd mode new-fd)
(let ((port (fdopen (dup->fdes port/fd new-fd) mode)))
(set-port-revealed! port 1)
port))))
(define dup->inport
(case-lambda
((port/fd)
(dup->port port/fd "r"))
((port/fd new-fd)
(dup->port port/fd "r" new-fd))))
(define dup->outport
(case-lambda
((port/fd)
(dup->port port/fd "w"))
((port/fd new-fd)
(dup->port port/fd "w" new-fd))))
(define dup
(case-lambda
((port/fd)
(if (integer? port/fd)
(dup->fdes port/fd)
(dup->port port/fd (port-mode port/fd))))
((port/fd new-fd)
(if (integer? port/fd)
(dup->fdes port/fd new-fd)
(dup->port port/fd (port-mode port/fd) new-fd)))))
(define (duplicate-port port modes)
(dup->port port modes))
(define (fdes->inport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "r")))
(set-port-revealed! result 1)
result))
((input-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (fdes->outport fdes)
(let loop ((rest-ports (fdes->ports fdes)))
(cond ((null? rest-ports)
(let ((result (fdopen fdes "w")))
(set-port-revealed! result 1)
result))
((output-port? (car rest-ports))
(set-port-revealed! (car rest-ports)
(+ (port-revealed (car rest-ports)) 1))
(car rest-ports))
(else
(loop (cdr rest-ports))))))
(define (port->fdes port)
(set-port-revealed! port (+ (port-revealed port) 1))
(fileno port))
;; Legacy interfaces.
(define (set-current-input-port port)
"Set the current default input port to @var{port}."
(current-input-port port))
(define (set-current-output-port port)
"Set the current default output port to @var{port}."
(current-output-port port))
(define (set-current-error-port port)
"Set the current default error port to @var{port}."
(current-error-port port))
;;;; high level routines
;;; {High-Level Port Routines}
;;;
;; These are used to request the proper mode to open files in.
;;
(define OPEN_READ "r")
(define OPEN_WRITE "w")
(define OPEN_BOTH "r+")
(define *null-device* "/dev/null")
(define* (open-input-file
file #:key (binary #f) (encoding #f) (guess-encoding #f))
"Takes a string naming an existing file and returns an input port
capable of delivering characters from the file. If the file
cannot be opened, an error is signalled."
(open-file file (if binary "rb" "r")
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (open-output-file file #:key (binary #f) (encoding #f))
"Takes a string naming an output file to be created and returns an
output port capable of writing characters to a new file by that
name. If the file cannot be opened, an error is signalled. If a
file with the given name already exists, the effect is unspecified."
(open-file file (if binary "wb" "w")
#:encoding encoding))
(define (open-io-file str)
"Open file with name STR for both input and output."
(open-file str OPEN_BOTH))
(define* (call-with-input-file
file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The file must
already exist. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-input-file file
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-input-port p)
(apply values vals)))))
(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
"PROC should be a procedure of one argument, and FILE should be a
string naming a file. The behaviour is unspecified if the file
already exists. These procedures call PROC
with one argument: the port obtained by opening the named file for
input or output. If the file cannot be opened, an error is
signalled. If the procedure returns, then the port is closed
automatically and the values yielded by the procedure are returned.
If the procedure does not return, then the port will not be closed
automatically unless it is possible to prove that the port will
never again be used for a read or write operation."
(let ((p (open-output-file file #:binary binary #:encoding encoding)))
(call-with-values
(lambda () (proc p))
(lambda vals
(close-output-port p)
(apply values vals)))))
(define (with-input-from-port port thunk)
(parameterize ((current-input-port port))
(thunk)))
(define (with-output-to-port port thunk)
(parameterize ((current-output-port port))
(thunk)))
(define (with-error-to-port port thunk)
(parameterize ((current-error-port port))
(thunk)))
(define* (with-input-from-file
file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The file must already exist. The file is opened for
input, an input port connected to it is made
the default value returned by `current-input-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-file file
(lambda (p) (with-input-from-port p thunk))
#:binary binary
#:encoding encoding
#:guess-encoding guess-encoding))
(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-output-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-output-to-port p thunk))
#:binary binary
#:encoding encoding))
(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
"THUNK must be a procedure of no arguments, and FILE must be a
string naming a file. The effect is unspecified if the file already exists.
The file is opened for output, an output port connected to it is made
the default value returned by `current-error-port',
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed and the previous
default is restored. Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-output-file file
(lambda (p) (with-error-to-port p thunk))
#:binary binary
#:encoding encoding))
(define (call-with-input-string string proc)
"Calls the one-argument procedure @var{proc} with a newly created
input port from which @var{string}'s contents may be read. The value
yielded by the @var{proc} is returned."
(proc (open-input-string string)))
(define (with-input-from-string string thunk)
"THUNK must be a procedure of no arguments.
The test of STRING is opened for
input, an input port connected to it is made,
and the THUNK is called with no arguments.
When the THUNK returns, the port is closed.
Returns the values yielded by THUNK. If an
escape procedure is used to escape from the continuation of these
procedures, their behavior is implementation dependent."
(call-with-input-string string
(lambda (p) (with-input-from-port p thunk))))
(define (call-with-output-string proc)
"Calls the one-argument procedure @var{proc} with a newly created output
port. When the function returns, the string composed of the characters
written into the port is returned."
(let ((port (open-output-string)))
(proc port)
(get-output-string port)))
(define (with-output-to-string thunk)
"Calls THUNK and returns its output as a string."
(call-with-output-string
(lambda (p) (with-output-to-port p thunk))))
(define (with-error-to-string thunk)
"Calls THUNK and returns its error output as a string."
(call-with-output-string
(lambda (p) (with-error-to-port p thunk))))
(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
(define (inherit-print-state old-port new-port)
(if (get-print-state old-port)
(port-with-print-state new-port (get-print-state old-port))
new-port))

2
module/ice-9/psyntax-pp.scm
View file

@ -3246,7 +3246,7 @@
(set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
(let f ((x (read p)) (result '()))
(if (eof-object? x)
(begin (close-input-port p) (reverse result))
(begin (close-port p) (reverse result))
(f (read p) (cons (datum->syntax k x) result)))))))))
(let ((src (syntax-source x)))
(let ((file (if src (assq-ref src 'filename) #f)))

2
module/ice-9/psyntax.scm
View file

@ -3183,7 +3183,7 @@
(result '()))
(if (eof-object? x)
(begin
(close-input-port p)
(close-port p)
(reverse result))
(f (read p)
(cons (datum->syntax k x) result)))))))