diff options
| -rw-r--r-- | am/bootstrap.am | 1 | ||||
| -rw-r--r-- | libguile/fports.c | 26 | ||||
| -rw-r--r-- | libguile/ioext.c | 11 | ||||
| -rw-r--r-- | libguile/ports.c | 176 | ||||
| -rw-r--r-- | module/Makefile.am | 1 | ||||
| -rw-r--r-- | module/ice-9/boot-9.scm | 311 | ||||
| -rw-r--r-- | module/ice-9/ports.scm | 469 | ||||
| -rw-r--r-- | module/ice-9/psyntax-pp.scm | 2 | ||||
| -rw-r--r-- | module/ice-9/psyntax.scm | 2 |
9 files changed, 602 insertions, 397 deletions
diff --git a/am/bootstrap.am b/am/bootstrap.am index d613d7f02..0eaa87b06 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -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 \ diff --git a/libguile/fports.c b/libguile/fports.c index 11aa1707b..efbcf73a0 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -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" } /* diff --git a/libguile/ioext.c b/libguile/ioext.c index 607eec636..3f0a53f5d 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -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); } diff --git a/libguile/ports.c b/libguile/ports.c index 8fe8dbe0d..d1bb231f0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -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,63 +922,41 @@ 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))) + SCM encoding; + + encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); + if (!scm_is_string (encoding)) return "ISO-8859-1"; else - { - SCM encoding; - - encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); - if (!scm_is_string (encoding)) - return "ISO-8859-1"; - else - return scm_i_string_chars (encoding); - } + 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; - - 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; + SCM 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; - else if (scm_is_eq (sym_escape, value)) - handler = 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; + if (scm_is_eq (sym_substitute, value)) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + else if (scm_is_eq (sym_escape, value)) + return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + else + /* Default to 'error also when the fluid's value is not one of + the valid symbols. */ + 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,42 +3241,77 @@ 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)); + /* 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); + scm_c_define ("%current-output-port-fluid", cur_outport_fluid); + scm_c_define ("%current-error-port-fluid", cur_errport_fluid); + 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 (); - scm_i_port_weak_set = scm_c_make_weak_set (31); - -#include "libguile/ports.x" + 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. */ - 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); - scm_c_define ("%current-output-port-fluid", cur_outport_fluid); - scm_c_define ("%current-error-port-fluid", cur_errport_fluid); - scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid); + 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); } /* diff --git a/module/Makefile.am b/module/Makefile.am index 6cb160314..71b265ae4 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -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 \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 9e9efe65b..ee3648027 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -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. ;;; diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm new file mode 100644 index 000000000..0dd1df718 --- /dev/null +++ b/module/ice-9/ports.scm @@ -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)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 6029f0565..0d30b7c3f 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -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))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index c9c309ae1..0bc602431 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -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))))))) |