Back to index

plt-scheme  4.2.1
portfun.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* This file implements the least platform-specific aspects of MzScheme
00027    port types. */
00028 
00029 #include "schpriv.h"
00030 
00031 static Scheme_Object *input_port_p (int, Scheme_Object *[]);
00032 static Scheme_Object *output_port_p (int, Scheme_Object *[]);
00033 static Scheme_Object *port_closed_p (int, Scheme_Object *[]);
00034 static Scheme_Object *current_input_port (int, Scheme_Object *[]);
00035 static Scheme_Object *current_output_port (int, Scheme_Object *[]);
00036 static Scheme_Object *current_error_port (int, Scheme_Object *[]);
00037 static Scheme_Object *make_input_port (int, Scheme_Object *[]);
00038 static Scheme_Object *make_output_port (int, Scheme_Object *[]);
00039 static Scheme_Object *open_input_file (int, Scheme_Object *[]);
00040 static Scheme_Object *open_output_file (int, Scheme_Object *[]);
00041 static Scheme_Object *open_input_output_file (int, Scheme_Object *[]);
00042 static Scheme_Object *close_input_port (int, Scheme_Object *[]);
00043 static Scheme_Object *close_output_port (int, Scheme_Object *[]);
00044 static Scheme_Object *call_with_output_file (int, Scheme_Object *[]);
00045 static Scheme_Object *call_with_input_file (int, Scheme_Object *[]);
00046 static Scheme_Object *with_input_from_file (int, Scheme_Object *[]);
00047 static Scheme_Object *with_output_to_file (int, Scheme_Object *[]);
00048 static Scheme_Object *read_f (int, Scheme_Object *[]);
00049 static Scheme_Object *read_recur_f (int, Scheme_Object *[]);
00050 static Scheme_Object *read_honu_f (int, Scheme_Object *[]);
00051 static Scheme_Object *read_honu_recur_f (int, Scheme_Object *[]);
00052 static Scheme_Object *read_syntax_f (int, Scheme_Object *[]);
00053 static Scheme_Object *read_syntax_recur_f (int, Scheme_Object *[]);
00054 static Scheme_Object *read_honu_syntax_f (int, Scheme_Object *[]);
00055 static Scheme_Object *read_honu_syntax_recur_f (int, Scheme_Object *[]);
00056 static Scheme_Object *read_language (int, Scheme_Object *[]);
00057 static Scheme_Object *read_char (int, Scheme_Object *[]);
00058 static Scheme_Object *read_char_spec (int, Scheme_Object *[]);
00059 static Scheme_Object *read_byte (int, Scheme_Object *[]);
00060 static Scheme_Object *read_byte_spec (int, Scheme_Object *[]);
00061 static Scheme_Object *read_line (int, Scheme_Object *[]);
00062 static Scheme_Object *read_byte_line (int, Scheme_Object *[]);
00063 static Scheme_Object *sch_read_string (int, Scheme_Object *[]);
00064 static Scheme_Object *sch_read_string_bang (int, Scheme_Object *[]);
00065 static Scheme_Object *sch_peek_string (int, Scheme_Object *[]);
00066 static Scheme_Object *sch_peek_string_bang (int, Scheme_Object *[]);
00067 static Scheme_Object *sch_read_bytes (int, Scheme_Object *[]);
00068 static Scheme_Object *sch_read_bytes_bang (int, Scheme_Object *[]);
00069 static Scheme_Object *sch_peek_bytes (int, Scheme_Object *[]);
00070 static Scheme_Object *sch_peek_bytes_bang (int, Scheme_Object *[]);
00071 static Scheme_Object *read_bytes_bang (int, Scheme_Object *[]);
00072 static Scheme_Object *read_bytes_bang_nonblock (int, Scheme_Object *[]);
00073 static Scheme_Object *read_bytes_bang_break (int, Scheme_Object *[]);
00074 static Scheme_Object *peek_bytes_bang (int, Scheme_Object *[]);
00075 static Scheme_Object *peek_bytes_bang_nonblock (int, Scheme_Object *[]);
00076 static Scheme_Object *peek_bytes_bang_break (int, Scheme_Object *[]);
00077 static Scheme_Object *write_bytes(int argc, Scheme_Object *argv[]);
00078 static Scheme_Object *write_string(int argc, Scheme_Object *argv[]);
00079 static Scheme_Object *write_bytes_avail(int argc, Scheme_Object *argv[]);
00080 static Scheme_Object *write_bytes_avail_nonblock(int argc, Scheme_Object *argv[]);
00081 static Scheme_Object *write_bytes_avail_break(int argc, Scheme_Object *argv[]);
00082 static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[]);
00083 static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[]);
00084 static Scheme_Object *can_write_special(int argc, Scheme_Object *argv[]);
00085 static Scheme_Object *peek_char (int, Scheme_Object *[]);
00086 static Scheme_Object *peek_char_spec (int, Scheme_Object *[]);
00087 static Scheme_Object *peek_byte (int, Scheme_Object *[]);
00088 static Scheme_Object *peek_byte_spec (int, Scheme_Object *[]);
00089 static Scheme_Object *eof_object_p (int, Scheme_Object *[]);
00090 static Scheme_Object *char_ready_p (int, Scheme_Object *[]);
00091 static Scheme_Object *byte_ready_p (int, Scheme_Object *[]);
00092 static Scheme_Object *peeked_read(int argc, Scheme_Object *argv[]);
00093 static Scheme_Object *progress_evt (int argc, Scheme_Object *argv[]);
00094 static Scheme_Object *write_bytes_avail_evt(int argc, Scheme_Object *argv[]);
00095 static Scheme_Object *write_special_evt(int argc, Scheme_Object *argv[]);
00096 static Scheme_Object *sch_write (int, Scheme_Object *[]);
00097 static Scheme_Object *display (int, Scheme_Object *[]);
00098 static Scheme_Object *sch_print (int, Scheme_Object *[]);
00099 static Scheme_Object *newline (int, Scheme_Object *[]);
00100 static Scheme_Object *write_char (int, Scheme_Object *[]);
00101 static Scheme_Object *write_byte (int, Scheme_Object *[]);
00102 static Scheme_Object *load (int, Scheme_Object *[]);
00103 static Scheme_Object *current_load (int, Scheme_Object *[]);
00104 static Scheme_Object *current_load_use_compiled (int, Scheme_Object *[]);
00105 static Scheme_Object *current_load_directory(int argc, Scheme_Object *argv[]);
00106 static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]);
00107 #ifdef LOAD_ON_DEMAND
00108 static Scheme_Object *load_on_demand_enabled(int argc, Scheme_Object *argv[]);
00109 #endif
00110 static Scheme_Object *default_load (int, Scheme_Object *[]);
00111 static Scheme_Object *flush_output (int, Scheme_Object *[]);
00112 static Scheme_Object *open_input_char_string (int, Scheme_Object *[]);
00113 static Scheme_Object *open_input_byte_string (int, Scheme_Object *[]);
00114 static Scheme_Object *open_output_string (int, Scheme_Object *[]);
00115 static Scheme_Object *get_output_char_string (int, Scheme_Object *[]);
00116 static Scheme_Object *get_output_byte_string (int, Scheme_Object *[]);
00117 static Scheme_Object *sch_pipe(int, Scheme_Object **args);
00118 static Scheme_Object *pipe_length(int, Scheme_Object **args);
00119 static Scheme_Object *port_read_handler(int, Scheme_Object **args);
00120 static Scheme_Object *port_display_handler(int, Scheme_Object **args);
00121 static Scheme_Object *port_write_handler(int, Scheme_Object **args);
00122 static Scheme_Object *port_print_handler(int, Scheme_Object **args);
00123 static Scheme_Object *global_port_print_handler(int, Scheme_Object **args);
00124 static Scheme_Object *global_port_count_lines(int, Scheme_Object **args);
00125 static Scheme_Object *port_count_lines(int, Scheme_Object **args);
00126 static Scheme_Object *port_next_location(int, Scheme_Object **args);
00127 
00128 static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Object *argv[]);
00129 static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[]);
00130 static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[]);
00131 static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[]);
00132 static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[]);
00133 
00134 static int pipe_input_p(Scheme_Object *o);
00135 static int pipe_output_p(Scheme_Object *o);
00136 static int pipe_out_ready(Scheme_Output_Port *p);
00137 
00138 #ifdef MZ_PRECISE_GC
00139 static void register_traversers(void);
00140 #endif
00141 
00142 static Scheme_Object *any_symbol;
00143 static Scheme_Object *any_one_symbol;
00144 static Scheme_Object *cr_symbol;
00145 static Scheme_Object *lf_symbol;
00146 static Scheme_Object *crlf_symbol;
00147 static Scheme_Object *module_symbol;
00148 
00149 static Scheme_Object *default_read_handler;
00150 static Scheme_Object *default_display_handler;
00151 static Scheme_Object *default_write_handler;
00152 static Scheme_Object *default_print_handler;
00153 
00154 Scheme_Object *scheme_default_global_print_handler;
00155 
00156 Scheme_Object *scheme_write_proc;
00157 Scheme_Object *scheme_display_proc;
00158 Scheme_Object *scheme_print_proc;
00159 
00160 static Scheme_Object *dummy_input_port;
00161 static Scheme_Object *dummy_output_port;
00162 
00163 #define fail_err_symbol scheme_false
00164 
00165 /*========================================================================*/
00166 /*                             initialization                             */
00167 /*========================================================================*/
00168 
00169 void
00170 scheme_init_port_fun(Scheme_Env *env)
00171 {
00172   Scheme_Object *p;
00173 
00174 #ifdef MZ_PRECISE_GC
00175   register_traversers();
00176 #endif
00177 
00178   REGISTER_SO(default_read_handler);
00179   REGISTER_SO(default_display_handler);
00180   REGISTER_SO(default_write_handler);
00181   REGISTER_SO(default_print_handler);
00182 
00183   REGISTER_SO(scheme_write_proc);
00184   REGISTER_SO(scheme_display_proc);
00185   REGISTER_SO(scheme_print_proc);
00186 
00187   REGISTER_SO(any_symbol);
00188   REGISTER_SO(any_one_symbol);
00189   REGISTER_SO(cr_symbol);
00190   REGISTER_SO(lf_symbol);
00191   REGISTER_SO(crlf_symbol);
00192   REGISTER_SO(module_symbol);
00193 
00194   any_symbol      = scheme_intern_symbol("any");
00195   any_one_symbol  = scheme_intern_symbol("any-one");
00196   cr_symbol       = scheme_intern_symbol("return");
00197   lf_symbol       = scheme_intern_symbol("linefeed");
00198   crlf_symbol     = scheme_intern_symbol("return-linefeed");
00199   module_symbol   = scheme_intern_symbol("module");
00200 
00201   scheme_write_proc   = scheme_make_noncm_prim(sch_write, "write",    1, 2);
00202   scheme_display_proc = scheme_make_noncm_prim(display,   "display",  1, 2);
00203   scheme_print_proc   = scheme_make_noncm_prim(sch_print, "print",    1, 2);
00204 
00205   /* Made as a closed prim so we can get the arity right: */
00206   default_read_handler = scheme_make_closed_prim_w_arity(sch_default_read_handler, NULL, "default-port-read-handler", 1, 2);
00207 
00208   default_display_handler = scheme_make_prim_w_arity(sch_default_display_handler, "default-port-display-handler", 2, 2);
00209   default_write_handler   = scheme_make_prim_w_arity(sch_default_write_handler,   "default-port-write-handler",   2, 2);
00210   default_print_handler   = scheme_make_prim_w_arity(sch_default_print_handler,   "default-port-print-handler",   2, 2);
00211 
00212   scheme_init_port_fun_config();
00213 
00214   scheme_add_global_constant("eof", scheme_eof, env);
00215   
00216   GLOBAL_PARAMETER("current-input-port",                current_input_port,         MZCONFIG_INPUT_PORT,  env);
00217   GLOBAL_PARAMETER("current-output-port",               current_output_port,        MZCONFIG_OUTPUT_PORT, env);
00218   GLOBAL_PARAMETER("current-error-port",                current_error_port,         MZCONFIG_ERROR_PORT,  env); 
00219   GLOBAL_PARAMETER("current-load",                      current_load,               MZCONFIG_LOAD_HANDLER,          env);
00220   GLOBAL_PARAMETER("current-load/use-compiled",         current_load_use_compiled,  MZCONFIG_LOAD_COMPILED_HANDLER, env);
00221   GLOBAL_PARAMETER("current-load-relative-directory",   current_load_directory,     MZCONFIG_LOAD_DIRECTORY,        env);
00222   GLOBAL_PARAMETER("current-write-relative-directory",  current_write_directory,    MZCONFIG_WRITE_DIRECTORY,       env);
00223   GLOBAL_PARAMETER("global-port-print-handler",         global_port_print_handler,  MZCONFIG_PORT_PRINT_HANDLER,    env);
00224 #ifdef LOAD_ON_DEMAND
00225   GLOBAL_PARAMETER("load-on-demand-enabled",            load_on_demand_enabled,     MZCONFIG_LOAD_DELAY_ENABLED,    env);
00226 #endif
00227   GLOBAL_PARAMETER("port-count-lines-enabled",          global_port_count_lines,    MZCONFIG_PORT_COUNT_LINES,      env);
00228 
00229   GLOBAL_FOLDING_PRIM("input-port?",            input_port_p,               1, 1, 1, env);
00230   GLOBAL_FOLDING_PRIM("output-port?",           output_port_p,              1, 1, 1, env); 
00231   GLOBAL_FOLDING_PRIM("file-stream-port?",      scheme_file_stream_port_p,  1, 1, 1, env);
00232   GLOBAL_FOLDING_PRIM("terminal-port?",         scheme_terminal_port_p,     1, 1, 1, env);
00233 
00234   GLOBAL_PRIM_W_ARITY("port-closed?",           port_closed_p,          1, 1, env); 
00235   GLOBAL_PRIM_W_ARITY("open-input-file",        open_input_file,        1, 2, env);
00236   GLOBAL_PRIM_W_ARITY("open-input-bytes",       open_input_byte_string, 1, 2, env);
00237   GLOBAL_PRIM_W_ARITY("open-input-string",      open_input_char_string, 1, 2, env);
00238   GLOBAL_PRIM_W_ARITY("open-output-file",       open_output_file,       1, 3, env);
00239   GLOBAL_PRIM_W_ARITY("open-output-bytes",      open_output_string,     0, 1, env);
00240   GLOBAL_PRIM_W_ARITY("open-output-string",     open_output_string,     0, 1, env);
00241   GLOBAL_PRIM_W_ARITY("get-output-bytes",       get_output_byte_string, 1, 4, env);
00242   GLOBAL_PRIM_W_ARITY("get-output-string",      get_output_char_string, 1, 1, env);
00243   GLOBAL_PRIM_W_ARITY("open-input-output-file", open_input_output_file, 1, 3, env);
00244   GLOBAL_PRIM_W_ARITY("close-input-port",       close_input_port,       1, 1, env);
00245   GLOBAL_PRIM_W_ARITY("close-output-port",      close_output_port,      1, 1, env);
00246   GLOBAL_PRIM_W_ARITY("make-input-port",        make_input_port,        4, 10, env);
00247   GLOBAL_PRIM_W_ARITY("make-output-port",       make_output_port,       4, 11, env);
00248   
00249   GLOBAL_PRIM_W_ARITY2("call-with-output-file", call_with_output_file,  2, 4, 0, -1, env);
00250   GLOBAL_PRIM_W_ARITY2("call-with-input-file",  call_with_input_file,   2, 3, 0, -1, env);
00251   GLOBAL_PRIM_W_ARITY2("with-output-to-file",   with_output_to_file,    2, 4, 0, -1, env);
00252   GLOBAL_PRIM_W_ARITY2("with-input-from-file",  with_input_from_file,   2, 3, 0, -1, env);
00253   GLOBAL_PRIM_W_ARITY2("load",                  load,                   1, 1, 0, -1, env);
00254   GLOBAL_PRIM_W_ARITY2("make-pipe",             sch_pipe,               0, 3, 2,  2, env);
00255   GLOBAL_PRIM_W_ARITY2("port-next-location",    port_next_location,     1, 1, 3,  3, env);
00256 
00257 
00258   GLOBAL_NONCM_PRIM("read",                           read_f,                         0, 1, env);
00259   GLOBAL_NONCM_PRIM("read/recursive",                 read_recur_f,                   0, 4, env);
00260   GLOBAL_NONCM_PRIM("read-syntax",                    read_syntax_f,                  0, 2, env);
00261   GLOBAL_NONCM_PRIM("read-syntax/recursive",          read_syntax_recur_f,            0, 5, env);
00262   GLOBAL_NONCM_PRIM("read-honu",                      read_honu_f,                    0, 1, env);
00263   GLOBAL_NONCM_PRIM("read-honu/recursive",            read_honu_recur_f,              0, 1, env);
00264   GLOBAL_NONCM_PRIM("read-honu-syntax",               read_honu_syntax_f,             0, 2, env);
00265   GLOBAL_NONCM_PRIM("read-honu-syntax/recursive",     read_honu_syntax_recur_f,       0, 2, env);
00266   GLOBAL_NONCM_PRIM("read-language",                  read_language,                  0, 2, env);
00267   GLOBAL_NONCM_PRIM("read-char",                      read_char,                      0, 1, env);
00268   GLOBAL_NONCM_PRIM("read-char-or-special",           read_char_spec,                 0, 1, env);
00269   GLOBAL_NONCM_PRIM("read-byte",                      read_byte,                      0, 1, env);
00270   GLOBAL_NONCM_PRIM("read-byte-or-special",           read_byte_spec,                 0, 1, env);
00271   GLOBAL_NONCM_PRIM("read-bytes-line",                read_byte_line,                 0, 2, env);
00272   GLOBAL_NONCM_PRIM("read-line",                      read_line,                      0, 2, env);
00273   GLOBAL_NONCM_PRIM("read-string",                    sch_read_string,                1, 2, env);
00274   GLOBAL_NONCM_PRIM("read-string!",                   sch_read_string_bang,           1, 4, env);
00275   GLOBAL_NONCM_PRIM("peek-string",                    sch_peek_string,                2, 3, env);
00276   GLOBAL_NONCM_PRIM("peek-string!",                   sch_peek_string_bang,           2, 5, env);
00277   GLOBAL_NONCM_PRIM("read-bytes",                     sch_read_bytes,                 1, 2, env);
00278   GLOBAL_NONCM_PRIM("read-bytes!",                    sch_read_bytes_bang,            1, 4, env);
00279   GLOBAL_NONCM_PRIM("peek-bytes",                     sch_peek_bytes,                 2, 3, env);
00280   GLOBAL_NONCM_PRIM("peek-bytes!",                    sch_peek_bytes_bang,            2, 5, env);
00281   GLOBAL_NONCM_PRIM("read-bytes-avail!",              read_bytes_bang,                1, 4, env);
00282   GLOBAL_NONCM_PRIM("read-bytes-avail!*",             read_bytes_bang_nonblock,       1, 4, env);
00283   GLOBAL_NONCM_PRIM("read-bytes-avail!/enable-break", read_bytes_bang_break,          1, 4, env);
00284   GLOBAL_NONCM_PRIM("peek-bytes-avail!",              peek_bytes_bang,                2, 6, env);
00285   GLOBAL_NONCM_PRIM("peek-bytes-avail!*",             peek_bytes_bang_nonblock,       2, 6, env);
00286   GLOBAL_NONCM_PRIM("peek-bytes-avail!/enable-break", peek_bytes_bang_break,          2, 6, env);
00287   GLOBAL_NONCM_PRIM("port-provides-progress-evts?",   can_provide_progress_evt,       1, 1, env);
00288   GLOBAL_NONCM_PRIM("write-bytes",                    write_bytes,                    1, 4, env);
00289   GLOBAL_NONCM_PRIM("write-string",                   write_string,                   1, 4, env);
00290   GLOBAL_NONCM_PRIM("write-bytes-avail",              write_bytes_avail,              1, 4, env);
00291   GLOBAL_NONCM_PRIM("write-bytes-avail*",             write_bytes_avail_nonblock,     1, 4, env);
00292   GLOBAL_NONCM_PRIM("write-bytes-avail/enable-break", write_bytes_avail_break,        1, 4, env);
00293   GLOBAL_NONCM_PRIM("port-writes-atomic?",            can_write_atomic,               1, 1, env);
00294   GLOBAL_NONCM_PRIM("port-writes-special?",           can_write_special,              1, 1, env);
00295   GLOBAL_NONCM_PRIM("write-special",                  scheme_write_special,           1, 2, env);
00296   GLOBAL_NONCM_PRIM("write-special-avail*",           scheme_write_special_nonblock,  1, 2, env);
00297   GLOBAL_NONCM_PRIM("peek-char",                      peek_char,                      0, 2, env);
00298   GLOBAL_NONCM_PRIM("peek-char-or-special",           peek_char_spec,                 0, 2, env);
00299   GLOBAL_NONCM_PRIM("peek-byte",                      peek_byte,                      0, 2, env);
00300   GLOBAL_NONCM_PRIM("peek-byte-or-special",           peek_byte_spec,                 0, 3, env);
00301   GLOBAL_NONCM_PRIM("byte-ready?",                    byte_ready_p,                   0, 1, env);
00302   GLOBAL_NONCM_PRIM("char-ready?",                    char_ready_p,                   0, 1, env);
00303   GLOBAL_NONCM_PRIM("newline",                        newline,                        0, 1, env);
00304   GLOBAL_NONCM_PRIM("write-char",                     write_char,                     1, 2, env);
00305   GLOBAL_NONCM_PRIM("write-byte",                     write_byte,                     1, 2, env);
00306   GLOBAL_NONCM_PRIM("port-commit-peeked",             peeked_read,                    3, 4, env);
00307   GLOBAL_NONCM_PRIM("port-progress-evt",              progress_evt,                   0, 1, env);
00308   GLOBAL_NONCM_PRIM("write-bytes-avail-evt",          write_bytes_avail_evt,          1, 4, env);
00309   GLOBAL_NONCM_PRIM("write-special-evt",              write_special_evt,              2, 2, env);
00310   GLOBAL_NONCM_PRIM("port-read-handler",              port_read_handler,              1, 2, env);
00311   GLOBAL_NONCM_PRIM("port-display-handler",           port_display_handler,           1, 2, env);
00312   GLOBAL_NONCM_PRIM("port-write-handler",             port_write_handler,             1, 2, env);
00313   GLOBAL_NONCM_PRIM("port-print-handler",             port_print_handler,             1, 2, env);
00314   GLOBAL_NONCM_PRIM("flush-output",                   flush_output,                   0, 1, env);
00315   GLOBAL_NONCM_PRIM("file-position",                  scheme_file_position,           1, 2, env);
00316   GLOBAL_NONCM_PRIM("file-stream-buffer-mode",        scheme_file_buffer,             1, 2, env);
00317   GLOBAL_NONCM_PRIM("port-file-identity",             scheme_file_identity,           1, 1, env);
00318   GLOBAL_NONCM_PRIM("port-count-lines!",              port_count_lines,               1, 1, env);
00319           
00320   p = scheme_make_folding_prim(eof_object_p, "eof-object?", 1, 1, 1);
00321   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00322   scheme_add_global_constant("eof-object?", p, env);
00323 
00324   scheme_add_global_constant("write",   scheme_write_proc,    env);
00325   scheme_add_global_constant("display", scheme_display_proc,  env);
00326   scheme_add_global_constant("print",   scheme_print_proc,    env);
00327 
00328   GLOBAL_IMMED_PRIM("pipe-content-length",              pipe_length,                1, 1, env);
00329 }
00330 
00331 
00332 void scheme_init_port_fun_config(void)
00333 {
00334   scheme_set_root_param(MZCONFIG_LOAD_DIRECTORY, scheme_false);
00335   scheme_set_root_param(MZCONFIG_WRITE_DIRECTORY, scheme_false);
00336   scheme_set_root_param(MZCONFIG_USE_COMPILED_KIND, scheme_make_pair(scheme_make_path("compiled"), scheme_null));
00337   scheme_set_root_param(MZCONFIG_USE_USER_PATHS, (scheme_ignore_user_paths ? scheme_false : scheme_true));
00338 
00339   {
00340     Scheme_Object *dlh;
00341     dlh = scheme_make_prim_w_arity2(default_load, "default-load-handler", 2, 2, 0, -1);
00342     scheme_set_root_param(MZCONFIG_LOAD_HANDLER, dlh);
00343   }
00344 
00345   REGISTER_SO(scheme_default_global_print_handler);
00346   scheme_default_global_print_handler
00347     = scheme_make_prim_w_arity(sch_default_global_port_print_handler, "default-global-port-print-handler", 2, 2);
00348   scheme_set_root_param(MZCONFIG_PORT_PRINT_HANDLER, scheme_default_global_print_handler);
00349 }
00350 
00351 /*========================================================================*/
00352 /*                              port records                              */
00353 /*========================================================================*/
00354 
00355 Scheme_Port *scheme_port_record(Scheme_Object *port)
00356 {
00357   if (scheme_is_input_port(port))
00358     return (Scheme_Port *)scheme_input_port_record(port);
00359   else
00360     return (Scheme_Port *)scheme_output_port_record(port);
00361 }
00362 
00363 static MZ_INLINE Scheme_Input_Port *input_port_record_slow(Scheme_Object *port)
00364 {
00365   Scheme_Object *v;
00366 
00367   while (1) {
00368     if (SCHEME_INPORTP(port))
00369       return (Scheme_Input_Port *)port;
00370 
00371     if (!SCHEME_STRUCTP(port)) {
00372       /* Use dummy port: */
00373       if (!dummy_input_port) {
00374         REGISTER_SO(dummy_input_port);
00375         dummy_input_port = scheme_make_byte_string_input_port("");
00376       }
00377       return (Scheme_Input_Port *)dummy_input_port;
00378     }
00379     
00380     v = scheme_struct_type_property_ref(scheme_input_port_property, port);
00381     if (!v)
00382       v = scheme_false;
00383     else if (SCHEME_INTP(v))
00384       v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
00385     port = v;
00386 
00387     SCHEME_USE_FUEL(1);
00388   }
00389 }
00390 
00391 Scheme_Input_Port *scheme_input_port_record(Scheme_Object *port)
00392 {
00393   /* Avoid MZ_PRECISE_GC instrumentation in the common case: */
00394   if (SCHEME_INPORTP(port))
00395     return (Scheme_Input_Port *)port;
00396   else
00397     return input_port_record_slow(port);
00398 }
00399 
00400 static MZ_INLINE Scheme_Output_Port *output_port_record_slow(Scheme_Object *port)
00401 {
00402   Scheme_Object *v;
00403 
00404   while (1) {
00405     if (SCHEME_OUTPORTP(port))
00406       return (Scheme_Output_Port *)port;
00407 
00408     if (!SCHEME_STRUCTP(port)) {
00409       /* Use dummy port: */
00410       if (!dummy_output_port) {
00411         REGISTER_SO(dummy_output_port);
00412         dummy_output_port = scheme_make_null_output_port(1);
00413       }
00414       return (Scheme_Output_Port *)dummy_output_port;
00415     }
00416     
00417     v = scheme_struct_type_property_ref(scheme_output_port_property, port);
00418     if (!v)
00419       v = scheme_false;
00420     else if (SCHEME_INTP(v))
00421       v = ((Scheme_Structure *)port)->slots[SCHEME_INT_VAL(v)];
00422     port = v;
00423 
00424     SCHEME_USE_FUEL(1);
00425   }
00426 }
00427 
00428 Scheme_Output_Port *scheme_output_port_record(Scheme_Object *port)
00429 {
00430   /* Avoid MZ_PRECISE_GC instrumentation in the common case: */
00431   if (SCHEME_OUTPORTP(port))
00432     return (Scheme_Output_Port *)port;
00433   else
00434     return output_port_record_slow(port);
00435 }
00436 
00437 int scheme_is_input_port(Scheme_Object *port)
00438 {
00439   if (SCHEME_INPORTP(port))
00440     return 1;
00441 
00442   if (SCHEME_STRUCTP(port))
00443     if (scheme_struct_type_property_ref(scheme_input_port_property, port))
00444       return 1;
00445 
00446   return 0;
00447 }
00448 
00449 int scheme_is_output_port(Scheme_Object *port)
00450 {
00451   if (SCHEME_OUTPORTP(port))
00452     return 1;
00453   
00454   if (SCHEME_STRUCTP(port))
00455     if (scheme_struct_type_property_ref(scheme_output_port_property, port))
00456       return 1;
00457 
00458   return 0;
00459 }
00460 
00461 /*========================================================================*/
00462 /*                          string input ports                            */
00463 /*========================================================================*/
00464 
00465 static long
00466 string_get_or_peek_bytes(Scheme_Input_Port *port,
00467                       char *buffer, long offset, long size,
00468                       int peek, long skip,
00469                       Scheme_Object *unless)
00470 {
00471   Scheme_Indexed_String *is;
00472 
00473   if (unless && scheme_unless_ready(unless))
00474     return SCHEME_UNLESS_READY;
00475 
00476   is = (Scheme_Indexed_String *) port->port_data;
00477   if (is->index + skip >= is->size)
00478     return EOF;
00479   else if (size == 1) {
00480     int pos = is->index;
00481     if (buffer)
00482       buffer[offset] = is->string[pos + skip];
00483     if (!peek)
00484       is->index = pos + 1;
00485     return 1;
00486   } else {
00487     long l, delta;
00488 
00489     delta = is->index + skip;
00490 
00491     if (delta + size <= is->size)
00492       l = size;
00493     else
00494       l = (is->size - delta);
00495 
00496     if (buffer)
00497       memcpy(buffer + offset, is->string + delta, l);
00498     if (!peek)
00499       is->index += l;
00500 
00501     return l;
00502   }
00503 }
00504 
00505 static long
00506 string_get_bytes(Scheme_Input_Port *port,
00507                 char *buffer, long offset, long size,
00508                 int nonblock, Scheme_Object *unless)
00509 {
00510   return string_get_or_peek_bytes(port, buffer, offset, size, 0, 0, unless);
00511 }
00512 
00513 static long
00514 string_peek_bytes(Scheme_Input_Port *port,
00515                  char *buffer, long offset, long size,
00516                  Scheme_Object *sskip,
00517                  int nonblock, Scheme_Object *unless)
00518 {
00519   long skip;
00520 
00521   if (SCHEME_INTP(sskip))
00522     skip = SCHEME_INT_VAL(sskip);
00523   else
00524     skip = ((Scheme_Indexed_String *)port->port_data)->size;
00525 
00526   return string_get_or_peek_bytes(port, buffer, offset, size, 1, skip, unless);
00527 }
00528 
00529 static int
00530 string_byte_ready (Scheme_Input_Port *port)
00531 {
00532   return 1;
00533 }
00534 
00535 static void
00536 string_close_in (Scheme_Input_Port *port)
00537 {
00538 }
00539 
00540 static Scheme_Indexed_String *
00541 make_indexed_string (const char *str, long len)
00542 {
00543   Scheme_Indexed_String *is;
00544 
00545   is = MALLOC_ONE_RT(Scheme_Indexed_String);
00546 #ifdef MZTAG_REQUIRED
00547   is->type = scheme_rt_indexed_string;
00548 #endif
00549 
00550   if (str) {
00551     if (len < 0) {
00552       is->string = (char *)str;
00553       is->size = -len;
00554     } else {
00555       char *ca;
00556       ca = (char *)scheme_malloc_atomic(len);
00557       is->string = ca;
00558       memcpy(is->string, str, len);
00559       is->size = len;
00560     }
00561   } else {
00562     char *ca;
00563     is->size = 100;
00564     ca = (char *)scheme_malloc_atomic(is->size + 1);
00565     is->string = ca;
00566   }
00567   is->index = 0;
00568   return (is);
00569 }
00570 
00571 Scheme_Object *
00572 scheme_make_sized_byte_string_input_port(const char *str, long len)
00573 {
00574   Scheme_Input_Port *ip;
00575 
00576   ip = scheme_make_input_port(scheme_string_input_port_type,
00577                            make_indexed_string(str, len),
00578                            scheme_intern_symbol("string"),
00579                            string_get_bytes,
00580                            string_peek_bytes,
00581                            scheme_progress_evt_via_get,
00582                            scheme_peeked_read_via_get,
00583                            string_byte_ready,
00584                            string_close_in,
00585                            NULL,
00586                            0);
00587 
00588   return (Scheme_Object *)ip;
00589 }
00590 
00591 Scheme_Object *
00592 scheme_make_byte_string_input_port(const char *str)
00593 {
00594   return scheme_make_sized_byte_string_input_port(str, strlen(str));
00595 }
00596 
00597 /*========================================================================*/
00598 /*                          string output ports                           */
00599 /*========================================================================*/
00600 
00601 static long
00602 string_write_bytes(Scheme_Output_Port *port,
00603                   const char *str, long d, long len,
00604                   int rarely_block, int enable_break)
00605 {
00606   Scheme_Indexed_String *is;
00607 
00608   is = (Scheme_Indexed_String *) port->port_data;
00609 
00610   if (is->index + len >= is->size) {
00611     char *old;
00612 
00613     old = is->string;
00614 
00615     if (len > is->size)
00616       is->size += 2 * len;
00617     else
00618       is->size *= 2;
00619 
00620     {
00621       char *ca;
00622       ca = (char *)scheme_malloc_atomic(is->size + 1);
00623       is->string = ca;
00624     }
00625     memcpy(is->string, old, is->index);
00626   }
00627 
00628   memcpy(is->string + is->index, str + d, len);
00629   is->index += len;
00630 
00631   return len;
00632 }
00633 
00634 static void
00635 string_close_out (Scheme_Output_Port *port)
00636 {
00637   return;
00638 }
00639 
00640 Scheme_Object *
00641 scheme_make_byte_string_output_port (void)
00642 {
00643   Scheme_Output_Port *op;
00644 
00645   op = scheme_make_output_port (scheme_string_output_port_type,
00646                             make_indexed_string(NULL, 0),
00647                             scheme_intern_symbol("string"),
00648                             scheme_write_evt_via_write,
00649                             string_write_bytes,
00650                             NULL,
00651                             string_close_out,
00652                             NULL,
00653                             NULL,
00654                             NULL,
00655                             0);
00656 
00657   return (Scheme_Object *)op;
00658 }
00659 
00660 char *
00661 scheme_get_reset_sized_byte_string_output(Scheme_Object *port, long *size, int reset, long startpos, long endpos)
00662 {
00663   Scheme_Output_Port *op;
00664   Scheme_Indexed_String *is;
00665   char *v;
00666   long len;
00667 
00668   if (!SCHEME_OUTPUT_PORTP(port))
00669     return NULL;
00670 
00671   op = scheme_output_port_record(port);
00672   if (op->sub_type != scheme_string_output_port_type)
00673     return NULL;
00674 
00675   is = (Scheme_Indexed_String *)op->port_data;
00676 
00677   len = is->index;
00678   if (is->u.hot > len)
00679     len = is->u.hot;
00680 
00681   if (endpos < 0)
00682     endpos = len;
00683 
00684   if (reset) {
00685     char *ca;
00686     v = is->string;
00687     is->size = 31;
00688     ca = (char *)scheme_malloc_atomic((is->size) + 1);
00689     is->string = ca;
00690     is->index = 0;
00691     is->u.hot = 0;
00692     if ((startpos > 0) || (endpos < len)) {
00693       len = endpos - startpos;
00694       ca = (char *)scheme_malloc_atomic(len + 1);
00695       memcpy(ca, v XFORM_OK_PLUS startpos, len);
00696       v = ca;
00697     }
00698   } else {
00699     len = endpos - startpos;
00700     v = (char *)scheme_malloc_atomic(len + 1);
00701     memcpy(v, is->string XFORM_OK_PLUS startpos, len);
00702   }
00703   v[len] = 0;
00704 
00705   if (size)
00706     *size = len;
00707 
00708   return v;
00709 }
00710 
00711 char *
00712 scheme_get_sized_byte_string_output(Scheme_Object *port, long *size)
00713 {
00714   return scheme_get_reset_sized_byte_string_output(port, size, 0, 0, -1);
00715 }
00716 
00717 char *
00718 scheme_get_string_output(Scheme_Object *port)
00719 {
00720   return scheme_get_sized_byte_string_output(port, NULL);
00721 }
00722 
00723 /*========================================================================*/
00724 /*                 "user" input ports (created from Scheme)               */
00725 /*========================================================================*/
00726 
00727 typedef struct User_Input_Port {
00728   MZTAG_IF_REQUIRED
00729   Scheme_Object *evt;
00730   Scheme_Object *read_proc;
00731   Scheme_Object *peek_proc;          /* NULL => implement via read_proc */
00732   Scheme_Object *close_proc;
00733   Scheme_Object *progress_evt_proc;  /* NULL => no support for progress events */
00734   Scheme_Object *peeked_read_proc;   /* NULL => progress_evt_proc is NULL */
00735   Scheme_Object *location_proc;
00736   Scheme_Object *count_lines_proc;
00737   Scheme_Object *buffer_mode_proc;
00738   Scheme_Object *reuse_str;
00739   Scheme_Object *peeked;
00740   Scheme_Object *prefix_pipe;
00741 } User_Input_Port;
00742 
00743 #define MAX_USER_INPUT_REUSE_SIZE 1024
00744 
00745 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00746 /*   Result checking                                             */
00747 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00748 
00749 /* This function is mainly responsible for checking the result of a
00750    read-proc or peek-proc. */
00751 
00752 static long user_read_result(const char *who, Scheme_Input_Port *port,
00753                           Scheme_Object *val, Scheme_Object *bstr,
00754                           int peek, int nonblock, int evt_ok,
00755                           int special_ok, int false_ok,
00756                           Scheme_Schedule_Info *sinfo)
00757 {
00758   Scheme_Object *a[2];
00759 
00760   val_again:
00761 
00762   if (SCHEME_EOFP(val))
00763     return EOF;
00764   else {
00765     int n;
00766 
00767     if (!SCHEME_INTP(val) || (SCHEME_INT_VAL(val) < 0)) {
00768       a[0] = val;
00769       if (SCHEME_BIGNUMP(val) && SCHEME_BIGPOS(val)) {
00770        n = -1;
00771       } else if (peek && SCHEME_FALSEP(val)) {
00772        if (false_ok)
00773          return SCHEME_UNLESS_READY;
00774        scheme_arg_mismatch(who,
00775                          "returned #f when no progress evt was supplied: ",
00776                          val);
00777        return 0;
00778       } else if (SCHEME_PROCP(val)) {
00779        Scheme_Object *orig = val;
00780        a[0] = val;
00781        if (scheme_check_proc_arity(NULL, 4, 0, 1, a)) {
00782          if (!special_ok) {
00783            scheme_arg_mismatch(who,
00784                             "the port has no specific peek procedure, so"
00785                             " a special read result is not allowed: ",
00786                             orig);
00787            return 0;
00788          }
00789          port->special = a[0];
00790          return SCHEME_SPECIAL;
00791        } else
00792          val = NULL;
00793        n = 0;
00794       } else if (evt_ok && pipe_input_p(val)) {
00795         ((User_Input_Port *)port->port_data)->prefix_pipe = val;
00796         return 0;
00797       } else if (evt_ok && scheme_is_evt(val)) {
00798        /* A peek/read failed, and we were given a evt that unblocks
00799           when the read/peek (at some offset) succeeds. */
00800        if (nonblock > 0) {
00801          if (sinfo) {
00802            scheme_set_sync_target(sinfo, val, (Scheme_Object *)port, NULL, 0, 1, NULL);
00803            return 0;
00804          } else {
00805            /* Poll: */
00806            a[0] = scheme_make_integer(0);
00807            a[1] = val;
00808            val = scheme_sync_timeout(2, a);
00809            if (!val)
00810              return 0;
00811            else if (scheme_is_evt(val))
00812              return 0;
00813            goto val_again;
00814          }
00815        } else {
00816          /* Sync on the given evt. */
00817          a[0] = val;
00818          if (nonblock < 0)
00819            val = scheme_sync_enable_break(1, a);
00820          else
00821            val = scheme_sync(1, a);
00822 
00823          /* Port may have been closed while we were syncing: */
00824          if (port->closed) {
00825            /* Another thread closed the input port while we were syncing. */
00826            /* Call scheme_getc to signal the error */
00827            if (peek)
00828              scheme_peek_byte((Scheme_Object *)port);
00829            else
00830              scheme_get_byte((Scheme_Object *)port);
00831            return 0; /* doesn't get here */
00832          }
00833          goto val_again;
00834        }
00835       } else {
00836        val = NULL;
00837        n = 0;
00838       }
00839 
00840       if (!val) {
00841        scheme_wrong_type(who,
00842                        (peek
00843                         ? (evt_ok
00844                            ? (special_ok
00845                              ? "non-negative exact integer, eof, evt, pipe input port, #f, or procedure for special"
00846                              : "non-negative exact integer, eof, evt, pipe input port, or #f")
00847                            : "non-negative exact integer, eof, #f, or procedure for special")
00848                         : (evt_ok
00849                            ? (special_ok
00850                              ? "non-negative exact integer, eof, evt, pipe input port, or procedure for special"
00851                              : "non-negative exact integer, eof, evt, or pipe input port")
00852                            : "non-negative exact integer, eof, or procedure for special")),
00853                        -1, -1, a);
00854        return 0;
00855       }
00856     } else
00857       n = SCHEME_INT_VAL(val);
00858 
00859     if ((n < 0) || (n > SCHEME_BYTE_STRLEN_VAL(bstr))) {
00860       scheme_arg_mismatch(who,
00861                        "result integer is larger than the supplied string: ",
00862                        val);
00863     }
00864 
00865     return n;
00866   }
00867 }
00868 
00869 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00870 /*   Main reader                                                 */
00871 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00872 
00873 /* Call read-proc or peek-proc. */
00874 
00875 static long
00876 user_get_or_peek_bytes(Scheme_Input_Port *port,
00877                      char *buffer, long offset, long size,
00878                      int nonblock,
00879                      int peek, Scheme_Object *peek_skip,
00880                      Scheme_Object *unless,
00881                      Scheme_Schedule_Info *sinfo)
00882 {
00883   Scheme_Object *fun, *val, *a[3], *bstr;
00884   User_Input_Port *uip = (User_Input_Port *)port->port_data;
00885   long r;
00886   Scheme_Cont_Frame_Data cframe;
00887 
00888   val = uip->peeked;
00889   if (val) {
00890     /* Leftover from a read-based peek used to implement `char-ready?'
00891        This can't happen is peek is 1, because in that case we have a
00892        peek_proc, so there's no need for read-based peeks. Also,
00893        SCHEME_CDR(unless) must be NULL. */
00894     uip->peeked = NULL;
00895     if (SCHEME_INTP(val)) {
00896       buffer[offset] = (char)SCHEME_INT_VAL(val);
00897       return 1;
00898     } else if (SCHEME_VOIDP(val)) {
00899       return SCHEME_SPECIAL;
00900     } else
00901       return EOF;
00902   }
00903 
00904   if (unless && SCHEME_PAIRP(unless))
00905     unless = SCHEME_CDR(unless);
00906 
00907   if (peek)
00908     fun = uip->peek_proc;
00909   else
00910     fun = uip->read_proc;
00911 
00912   while (1) {
00913     int nb;
00914 
00915     if (uip->prefix_pipe) {
00916       /* Guarantee: if we call into a client, then we're not using the
00917          pipe anywhere. */
00918       r = scheme_pipe_char_count(uip->prefix_pipe);
00919       if (r && (!peek || (SCHEME_INTP(peek_skip) && (SCHEME_INT_VAL(peek_skip) < r)))) {
00920         /* Need atomic to ensure the guarantee: this thread shouldn't get 
00921            swapped out while it's using the pipe, because another thread might
00922            somehow arrive at the port's procedures. (Pipe reading is probably atomic, 
00923            anyway, due to the way that pipes are implemented.) */
00924         scheme_start_atomic();
00925         r = scheme_get_byte_string_unless("custom-port-pipe-read", uip->prefix_pipe,
00926                                           buffer, offset, size,
00927                                           2, peek, peek_skip,
00928                                           unless);
00929         scheme_end_atomic_no_swap();
00930         return r;
00931       } else {
00932         /* Setting the pipe to NULL ensures that we don't start using it while
00933            we're in the call that we just started. If another thread returns
00934            a pipe before the user's code returns, though, all bets are off. */
00935         uip->prefix_pipe = NULL;
00936       }
00937     }
00938 
00939     if (uip->reuse_str && (size == SCHEME_BYTE_STRLEN_VAL(uip->reuse_str))) {
00940       bstr = uip->reuse_str;
00941       uip->reuse_str = NULL;
00942     } else {
00943       char *vb;
00944       vb = scheme_malloc_atomic(size + 1);
00945       memset(vb, size + 1, 0); /* must initialize for security */
00946       bstr = scheme_make_sized_byte_string(vb, size, 0);
00947     }
00948     a[0] = bstr;
00949     a[1] = peek_skip;
00950     a[2] = unless ? unless : scheme_false;
00951 
00952     nb = nonblock;
00953     if (!nb) {
00954       if (scheme_can_break(scheme_current_thread)) {
00955        nb = -1;
00956       }
00957     }
00958 
00959     /* Disable breaks while calling the port's function: */
00960     scheme_push_break_enable(&cframe, 0, 0);
00961 
00962     /* Call the read/peek function: */
00963     val = scheme_apply(fun, peek ? 3 : 1, a);
00964 
00965     if ((size <= MAX_USER_INPUT_REUSE_SIZE)
00966        && (SCHEME_INTP(val) || SCHEME_EOFP(val) || SCHEME_PROCP(val))) {
00967       uip->reuse_str = bstr;
00968     }
00969 
00970     r = user_read_result(peek ? "user port peek" : "user port read",
00971                       port, val, bstr, peek, nb,
00972                       1, !!uip->peek_proc, !!unless, sinfo);
00973 
00974     scheme_pop_break_enable(&cframe, 1);
00975 
00976     if (r > 0) {
00977       memcpy(buffer + offset, SCHEME_BYTE_STR_VAL(bstr), r);
00978       return r;
00979     } else if (r) {
00980       return r;
00981     }
00982 
00983     scheme_thread_block_enable_break(0.0, nonblock < 0); /* penalty for inaccuracy? */
00984     scheme_current_thread->ran_some = 1;
00985     /* but don't loop forever due to inaccurracy */
00986     if (nonblock > 0) {
00987       if (sinfo)
00988        sinfo->spin = 1;
00989       return 0;
00990     }
00991   }
00992 }
00993 
00994 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00995 /*   Main entry points                                           */
00996 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
00997 
00998 static long
00999 user_get_bytes(Scheme_Input_Port *port,
01000               char *buffer, long offset, long size,
01001               int nonblock, Scheme_Object *unless)
01002 {
01003   return user_get_or_peek_bytes(port, buffer, offset, size,
01004                             nonblock, 0, NULL,
01005                             unless,
01006                             NULL);
01007 }
01008 
01009 static long
01010 user_peek_bytes(Scheme_Input_Port *port,
01011               char *buffer, long offset, long size,
01012               Scheme_Object *skip,
01013               int nonblock, Scheme_Object *unless)
01014 {
01015   return user_get_or_peek_bytes(port, buffer, offset, size,
01016                             nonblock, 1, skip,
01017                             unless,
01018                             NULL);
01019 }
01020 
01021 static int
01022 user_peeked_read(Scheme_Input_Port *port,
01023                long size,
01024                Scheme_Object *unless_evt,
01025                Scheme_Object *target_evt)
01026 {
01027   User_Input_Port *uip = (User_Input_Port *)port->port_data;
01028   Scheme_Object *val, *a[3];
01029   Scheme_Cont_Frame_Data cframe;
01030 
01031   /* FIXME, if possible: the peeked-read procedure should not
01032      synchronize target_evt more than once. There doesn't seem to
01033      be a way to enforce this constraint, however, without extra
01034      machinery in MzScheme's synchronization. */
01035 
01036   a[0] = scheme_make_integer(size);
01037   a[1] = unless_evt;
01038   a[2] = target_evt;
01039 
01040   /* Disable breaks while calling the port's function: */
01041   scheme_push_break_enable(&cframe, 0, 0);
01042 
01043   /* Call the read/peek function: */
01044   val = scheme_apply(uip->peeked_read_proc, 3, a);
01045 
01046   scheme_pop_break_enable(&cframe, 1);
01047 
01048   return SCHEME_TRUEP(val);
01049 }
01050 
01051 static Scheme_Object *
01052 user_progress_evt(Scheme_Input_Port *port)
01053 {
01054   User_Input_Port *uip = (User_Input_Port *)port->port_data;
01055   Scheme_Object *evt, *a[1];
01056 
01057   evt = _scheme_apply(uip->progress_evt_proc, 0, NULL);
01058 
01059   if (!scheme_is_evt(evt)) {
01060     a[0] = evt;
01061     scheme_wrong_type("user port progress-evt", "evt", -1, -1, a);
01062     return 0;
01063   }
01064 
01065   return evt;
01066 }
01067 
01068 static int
01069 user_byte_ready_sinfo(Scheme_Input_Port *port, Scheme_Schedule_Info *sinfo)
01070 {
01071   int c, can_peek;
01072   char s[1];
01073   User_Input_Port *uip = (User_Input_Port *)port->port_data;
01074 
01075   /* We implement char-ready? by a non-blocking peek for a single
01076      character. If the port provides a precise waitable, it
01077      effectively determines the result, because the peek function
01078      checks the waitable. */
01079 
01080   can_peek = (uip->peek_proc ? 1 : 0);
01081 
01082   c = user_get_or_peek_bytes(port, s, 0, 1,
01083                           1, can_peek, scheme_make_integer(0),
01084                           NULL,
01085                           sinfo);
01086 
01087   if (c == EOF) {
01088     if (!can_peek)
01089       uip->peeked = scheme_true;
01090     return 1;
01091   } else if (c) {
01092     if (!can_peek) {
01093       if (c == SCHEME_SPECIAL)
01094        uip->peeked = scheme_void;
01095       else
01096        uip->peeked = scheme_make_integer(s[0]);
01097     }
01098     return 1;
01099   } else
01100     return 0;
01101 }
01102 
01103 static int
01104 user_byte_ready(Scheme_Input_Port *port)
01105 {
01106   return user_byte_ready_sinfo(port, NULL);
01107 }
01108 
01109 int scheme_user_port_byte_probably_ready(Scheme_Input_Port *ip, Scheme_Schedule_Info *sinfo)
01110 {
01111   User_Input_Port *uip = (User_Input_Port *)ip->port_data;
01112 
01113   if (uip->peeked)
01114     return 1;
01115 
01116    if (sinfo->false_positive_ok) {
01117     /* Causes the thread to swap in: */
01118     sinfo->potentially_false_positive = 1;
01119     return 1;
01120   } else {
01121     return user_byte_ready_sinfo(ip, sinfo);
01122   }
01123 }
01124 
01125 static void
01126 user_needs_wakeup_input (Scheme_Input_Port *port, void *fds)
01127 {
01128   /* Nothing... */
01129 }
01130 
01131 static void
01132 user_close_input(Scheme_Input_Port *port)
01133 {
01134   User_Input_Port *uip = (User_Input_Port *)port->port_data;
01135 
01136   scheme_apply_multi(uip->close_proc, 0, NULL);
01137 }
01138 
01139 static Scheme_Object *
01140 user_input_location(Scheme_Port *p)
01141 {
01142   Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
01143   User_Input_Port *uip = (User_Input_Port *)ip->port_data;
01144 
01145   return scheme_apply_multi(uip->location_proc, 0, NULL);
01146 }
01147 
01148 static void
01149 user_input_count_lines(Scheme_Port *p)
01150 {
01151   Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
01152   User_Input_Port *uip = (User_Input_Port *)ip->port_data;
01153 
01154   scheme_apply_multi(uip->count_lines_proc, 0, NULL);
01155 }
01156 
01157 
01158 static int
01159 user_buffer_mode(Scheme_Object *buffer_mode_proc, int mode, int line_ok)
01160 {
01161   Scheme_Object *v, *a[1];
01162 
01163   if (mode < 0) {
01164     v = scheme_apply(buffer_mode_proc, 0, NULL);
01165     if (SCHEME_TRUEP(v)) {
01166       if (SAME_OBJ(v, scheme_block_symbol))
01167        mode = 0;
01168       else if (line_ok && SAME_OBJ(v, scheme_line_symbol))
01169        mode = 1;
01170       else if (SAME_OBJ(v, scheme_none_symbol))
01171        mode = 2;
01172       else {
01173        a[0] = v;
01174        scheme_wrong_type("user port buffer-mode", 
01175                        line_ok ? "'block, 'line, 'none, or #f" : "'block, 'none, or #f", 
01176                        -1, -1, a);
01177        return 0;
01178       }
01179     }
01180   } else {
01181     switch (mode) {
01182     case 0:
01183       a[0] = scheme_block_symbol;
01184       break;
01185     case 1:
01186       a[0] = scheme_line_symbol;
01187       break;
01188     case 2:
01189       a[0] = scheme_none_symbol;
01190       break;
01191     }
01192     scheme_apply_multi(buffer_mode_proc, 1, a);
01193   }
01194 
01195   return mode;
01196 }
01197 
01198 static int
01199 user_input_buffer_mode(Scheme_Port *p, int mode)
01200 {
01201   Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
01202   User_Input_Port *uip = (User_Input_Port *)ip->port_data;
01203 
01204   return user_buffer_mode(uip->buffer_mode_proc, mode, 0);
01205 }
01206 
01207 /*========================================================================*/
01208 /*                 "user" output ports (created from Scheme)              */
01209 /*========================================================================*/
01210 
01211 typedef struct User_Output_Port {
01212   MZTAG_IF_REQUIRED
01213   Scheme_Object *evt;
01214   Scheme_Object *write_evt_proc;
01215   Scheme_Object *write_proc;
01216   Scheme_Object *flush_proc;
01217   Scheme_Object *close_proc;
01218   Scheme_Object *write_special_evt_proc;
01219   Scheme_Object *write_special_proc;
01220   Scheme_Object *location_proc;
01221   Scheme_Object *count_lines_proc;
01222   Scheme_Object *buffer_mode_proc;
01223   Scheme_Object *buffer_pipe;
01224 } User_Output_Port;
01225 
01226 int scheme_user_port_write_probably_ready(Scheme_Output_Port *port, Scheme_Schedule_Info *sinfo)
01227 {
01228   Scheme_Object *val;
01229   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01230 
01231   if (port->closed)
01232     return 1;
01233 
01234   val = uop->evt;
01235 
01236   scheme_set_sync_target(sinfo, val, (Scheme_Object *)port, NULL, 0, 1, NULL);
01237   return 0;
01238 
01239 }
01240 
01241 static int
01242 user_write_ready(Scheme_Output_Port *port)
01243 {
01244   /* This function should never be called. If we are ready-checking as
01245      a evt, then scheme_user_port_write_probably_ready is called,
01246      instead. */
01247   return 1;
01248 }
01249 
01250 static long
01251 user_write_result(const char *who, Scheme_Output_Port *port, int evt_ok,
01252                 Scheme_Object *val, int rarely_block, int enable_break, long len)
01253 {
01254   Scheme_Object *p[2];
01255 
01256   while (1) {
01257     if (SCHEME_FALSEP(val)) {
01258       if (!rarely_block)
01259        return 0; /* #f result is allowed, though not preferred */
01260       else if (rarely_block == 2)
01261        return -1;
01262       else if (!evt_ok)
01263        scheme_arg_mismatch(who,
01264                          "bad result for write event: ",
01265                          val);
01266       else 
01267        return 0;
01268     } else if (SCHEME_INTP(val)
01269               && (SCHEME_INT_VAL(val) >= 0)
01270               && (SCHEME_INT_VAL(val) <= len)) {
01271       int n;
01272 
01273       n = SCHEME_INT_VAL(val);
01274 
01275       if (!n && len) {
01276        scheme_arg_mismatch(who,
01277                          (evt_ok
01278                           ? "bad result for non-flush write: "
01279                           : "bad result for non-flush write event: "),
01280                          val);
01281       }
01282 
01283       if (!len && !rarely_block)
01284        return 1; /* turn 0 into 1 to indicate a successful blocking flush */
01285       else
01286        return n;
01287     } else if (evt_ok && pipe_output_p(val)) {
01288       if (rarely_block || !len) {
01289         scheme_arg_mismatch(who,
01290                          (rarely_block
01291                              ? "bad result for a non-blocking write: "
01292                              : "bad result for a flushing write: "),
01293                          val);
01294       }
01295 
01296       ((User_Output_Port *)port->port_data)->buffer_pipe = val;
01297       
01298       return 0;
01299     } else if (evt_ok && scheme_is_evt(val)) {
01300       /* A write failed, and we were given a evt that unblocks when
01301         the write succeeds. */
01302       if (rarely_block == 2) {
01303        return 0;
01304       } else {
01305        /* Sync on the given evt. */
01306        p[0] = val;
01307        if (enable_break)
01308          val = scheme_sync_enable_break(1, p);
01309        else
01310          val = scheme_sync(1, p);
01311 
01312        /* Port may have been closed while we were syncing: */
01313        if (port->closed)
01314          return 0;
01315       }
01316     } else {
01317       if ((SCHEME_INTP(val) && (SCHEME_INT_VAL(val) > 0))
01318          || (SCHEME_BIGNUMP(val) && SCHEME_BIGPOS(val))) {
01319        scheme_arg_mismatch(who,
01320                          "result integer is larger than the supplied string: ",
01321                          val);
01322       } else {
01323        p[0] = val;
01324        scheme_wrong_type(who,
01325                        "non-negative exact integer, #f, or evt",
01326                        -1, -1, p);
01327       }
01328       return 0;
01329     }
01330   }
01331 }
01332 
01333 static long
01334 user_write_bytes(Scheme_Output_Port *port, const char *str, long offset, long len,
01335                 int rarely_block, int enable_break)
01336 {
01337   /* As always, rarely_block => flush, !len => flush,
01338      rarely_block == 1 => len > 0 */
01339   Scheme_Object *p[5], *to_write, *val;
01340   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01341   int n, re_enable_break;
01342   Scheme_Cont_Frame_Data cframe;
01343 
01344   if (enable_break)
01345     re_enable_break = 1;
01346   else
01347     re_enable_break = scheme_can_break(scheme_current_thread);
01348 
01349   to_write = scheme_make_sized_offset_byte_string((char *)str, offset, len, 1);
01350   p[0] = to_write;
01351   SCHEME_SET_IMMUTABLE(p[0]);
01352   p[1] = scheme_make_integer(0);
01353   p[2] = scheme_make_integer(len);
01354   p[3] = (rarely_block ? scheme_true : scheme_false);
01355   p[4] = (re_enable_break ? scheme_true : scheme_false);
01356 
01357   while (1) {
01358 
01359     if (uop->buffer_pipe) {
01360       if (!rarely_block && len) {
01361         if (pipe_out_ready((Scheme_Output_Port *)uop->buffer_pipe)) {
01362           /* Need atomic for same reason as using prefix_pipe for input. */
01363           scheme_start_atomic();
01364           n = scheme_put_byte_string("user output pipe buffer", uop->buffer_pipe,
01365                                      str, offset, len,
01366                                      1);
01367           scheme_end_atomic_no_swap();
01368           return n;
01369         }
01370       }
01371       uop->buffer_pipe = NULL;
01372     }
01373 
01374     /* Disable breaks while calling the port's function: */
01375     scheme_push_break_enable(&cframe, 0, 0);
01376 
01377     val = scheme_apply(uop->write_proc, 5, p);
01378 
01379     scheme_pop_break_enable(&cframe, 1); /* might break */
01380 
01381     n = user_write_result("user port write", port,
01382                        1, val, rarely_block, enable_break, len);
01383 
01384     if (!n && !rarely_block) {
01385       /* Try blocking write/flush again */
01386     } else {
01387       if (n || (rarely_block != 1)) {
01388        if (!rarely_block && !len)
01389          return 0; /* n == 1 for success, but caller wants 0 */
01390        return n;
01391       }
01392       /* else rarely_block == 1, and we haven't written anything,
01393          or rarely_block == 0 and we haven't written anything but we
01394          received a pipe. */
01395     }
01396 
01397     scheme_thread_block(0.0);
01398     scheme_current_thread->ran_some = 1;
01399   }
01400 }
01401 
01402 static Scheme_Object *user_write_evt_wrapper(void *d, int argc, struct Scheme_Object *argv[])
01403 {
01404   Scheme_Object *val, *port;
01405   long r, len;
01406 
01407   port = (Scheme_Object *)((void **)d)[0];
01408   val = (Scheme_Object *)((void **)d)[1];
01409   len = SCHEME_INT_VAL(val);
01410   val = argv[0];
01411 
01412   r = user_write_result("user port write-evt", (Scheme_Output_Port *)port,
01413                      0, val, 1, 0, len);
01414 
01415   if (!r && len) {
01416     /* Port must have been closed */
01417     scheme_arg_mismatch("user port write-evt",
01418                      "port is closed: ",
01419                      port);
01420   }
01421 
01422   return scheme_make_integer(r);
01423 }
01424 
01425 static Scheme_Object *
01426 user_write_bytes_evt(Scheme_Output_Port *port,
01427                    const char *buffer, long offset, long size)
01428 {
01429   Scheme_Object *to_write, *wrapper;
01430   Scheme_Object *a[3], *val;
01431   void **args;
01432   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01433 
01434   to_write = scheme_make_sized_offset_byte_string((char *)buffer, offset, size, 1);
01435   SCHEME_SET_IMMUTABLE(to_write);
01436   a[0] = to_write;
01437   a[1] = scheme_make_integer(0);
01438   a[2] = scheme_make_integer(size);
01439   val = scheme_apply(uop->write_evt_proc, 3, a);
01440 
01441   if (!scheme_is_evt(val)) {
01442     a[0] = val;
01443     scheme_wrong_type("user port write-evt", "evt", -1, -1, a);
01444     return NULL;
01445   }
01446 
01447   /* Wrap the evt for result checking: */
01448   args = MALLOC_N(void*, 2);
01449   args[0] = port;
01450   args[1] = scheme_make_integer(size);
01451   wrapper = scheme_make_closed_prim(user_write_evt_wrapper, args);
01452 
01453   a[0] = val;
01454   a[1] = wrapper;
01455   return scheme_wrap_evt(2, a);
01456 }
01457 
01458 static void
01459 user_needs_wakeup_output (Scheme_Output_Port *port, void *fds)
01460 {
01461   /* Nothing needed. */
01462 }
01463 
01464 static void
01465 user_close_output (Scheme_Output_Port *port)
01466 {
01467   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01468 
01469   scheme_apply_multi(uop->close_proc, 0, NULL);
01470 }
01471 
01472 static int
01473 user_write_special (Scheme_Output_Port *port, Scheme_Object *v, int nonblock)
01474 {
01475   Scheme_Object *a[3];
01476   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01477   int re_enable_break;
01478   Scheme_Cont_Frame_Data cframe;
01479 
01480   re_enable_break = scheme_can_break(scheme_current_thread);
01481 
01482   a[0] = v;
01483   a[1] = (nonblock ? scheme_true : scheme_false);
01484   a[2] = (re_enable_break ? scheme_true : scheme_false);
01485 
01486   scheme_push_break_enable(&cframe, 0, 0);
01487 
01488   v = scheme_apply(uop->write_special_proc, 3, a);
01489 
01490   while (1) {
01491     if (uop->buffer_pipe)
01492       uop->buffer_pipe = NULL;
01493 
01494     if (scheme_is_evt(v)) {
01495       if (!nonblock) {
01496        a[0] = v;
01497        if (re_enable_break)
01498          v = scheme_sync_enable_break(1, a);
01499        else
01500          v = scheme_sync(1, a);
01501       } else
01502        return 0;
01503     } else
01504       break;
01505   }
01506 
01507   scheme_pop_break_enable(&cframe, 1);
01508 
01509   return SCHEME_TRUEP(v);
01510 }
01511 
01512 static Scheme_Object*
01513 user_write_special_evt (Scheme_Output_Port *port, Scheme_Object *v)
01514 {
01515   Scheme_Object *a[1];
01516   User_Output_Port *uop = (User_Output_Port *)port->port_data;
01517 
01518   a[0] = v;
01519   v = scheme_apply(uop->write_special_evt_proc, 1, a);
01520 
01521   if (!scheme_is_evt(v)) {
01522     a[0] = v;
01523     scheme_wrong_type("user port write-special-evt", "evt", -1, -1, a);
01524   }
01525 
01526   return v;
01527 }
01528 
01529 static Scheme_Object *
01530 user_output_location(Scheme_Port *p)
01531 {
01532   Scheme_Output_Port *op = (Scheme_Output_Port *)p;
01533   User_Output_Port *uop = (User_Output_Port *)op->port_data;
01534 
01535   return scheme_apply_multi(uop->location_proc, 0, NULL);
01536 }
01537 
01538 static void
01539 user_output_count_lines(Scheme_Port *p)
01540 {
01541   Scheme_Output_Port *op = (Scheme_Output_Port *)p;
01542   User_Output_Port *uop = (User_Output_Port *)op->port_data;
01543 
01544   scheme_apply_multi(uop->count_lines_proc, 0, NULL);
01545 }
01546 
01547 static int
01548 user_output_buffer_mode(Scheme_Port *p, int mode)
01549 {
01550   Scheme_Output_Port *op = (Scheme_Output_Port *)p;
01551   User_Output_Port *uop = (User_Output_Port *)op->port_data;
01552 
01553   return user_buffer_mode(uop->buffer_mode_proc, mode, 1);
01554 }
01555 
01556 int scheme_is_user_port(Scheme_Object *port)
01557 {
01558   if (SCHEME_INPUT_PORTP(port)) {
01559     Scheme_Input_Port *ip;
01560     ip = scheme_input_port_record(port);
01561     return SAME_OBJ(scheme_user_input_port_type, ip->sub_type);
01562   } else {
01563     Scheme_Output_Port *op;
01564     op = scheme_output_port_record(port);
01565     return SAME_OBJ(scheme_user_output_port_type, op->sub_type);
01566   }
01567 }
01568 
01569 /*========================================================================*/
01570 /*                               pipe ports                               */
01571 /*========================================================================*/
01572 
01573 static void pipe_did_read(Scheme_Input_Port *port, Scheme_Pipe *pipe)
01574 {
01575   if (port && port->progress_evt) {
01576     scheme_post_sema_all(port->progress_evt);
01577     port->progress_evt = NULL;
01578   }
01579 
01580   while (SCHEME_PAIRP(pipe->wakeup_on_read)) {
01581     Scheme_Object *sema;
01582     sema = SCHEME_CAR(pipe->wakeup_on_read);
01583     pipe->wakeup_on_read = SCHEME_CDR(pipe->wakeup_on_read);
01584     scheme_post_sema(sema);
01585   }
01586 }
01587 
01588 static void pipe_did_write(Scheme_Pipe *pipe)
01589 {
01590   while (SCHEME_PAIRP(pipe->wakeup_on_write)) {
01591     Scheme_Object *sema;
01592     sema = SCHEME_CAR(pipe->wakeup_on_write);
01593     pipe->wakeup_on_write = SCHEME_CDR(pipe->wakeup_on_write);
01594     scheme_post_sema(sema);
01595   }
01596 }
01597 
01598 static long pipe_get_or_peek_bytes(Scheme_Input_Port *p,
01599                                char *buffer, long offset, long size,
01600                                int nonblock,
01601                                int peek, long peek_skip,
01602                                Scheme_Object *unless)
01603 {
01604   Scheme_Pipe *pipe;
01605   long c, skipped = 0;
01606 
01607   pipe = (Scheme_Pipe *)(p->port_data);
01608 
01609   while ((pipe->bufstart == pipe->bufend) && !pipe->eof) {
01610     if (nonblock > 0)
01611       return 0;
01612 
01613     scheme_block_until_unless((Scheme_Ready_Fun)scheme_byte_ready_or_user_port_ready,
01614                            NULL, (Scheme_Object *)p,
01615                            0.0, unless,
01616                            nonblock);
01617 
01618     scheme_wait_input_allowed(p, nonblock);
01619 
01620     if (scheme_unless_ready(unless))
01621       return SCHEME_UNLESS_READY;
01622   }
01623 
01624   if (p->closed) {
01625     /* Another thread closed the input port while we were syncing. */
01626     /* Call scheme_getc to signal the error */
01627     scheme_getc((Scheme_Object *)p);
01628     return 0; /* doesn't get here */
01629   }
01630 
01631   if (pipe->bufstart == pipe->bufend)
01632     c = EOF;
01633   else {
01634     long bs = pipe->bufstart;
01635     c = 0;
01636     if (bs > pipe->bufend) {
01637       int n;
01638 
01639       /* Determine how much to copy: */
01640       n = pipe->buflen - bs;
01641       if (n < peek_skip) {
01642        peek_skip -= n;
01643        bs += n;
01644        skipped += n;
01645        n = 0;
01646       } else {
01647        bs += peek_skip;
01648        n -= peek_skip;
01649        skipped += peek_skip;
01650        peek_skip = 0;
01651       }
01652       if (n > size)
01653        n = size;
01654 
01655       /* Copy it */
01656       if (buffer)
01657        memcpy(buffer + offset, pipe->buf + bs, n);
01658 
01659       /* Fix up indices */
01660       bs += n;
01661       if (bs == pipe->buflen)
01662        bs = 0;
01663       if (!peek)
01664        pipe->bufstart = bs;
01665       size -= n;
01666       c += n;
01667     }
01668     if (bs < pipe->bufend) {
01669       int n;
01670 
01671       /* Determine how much to copy: */
01672       n = pipe->bufend - bs;
01673       if (n < peek_skip) {
01674        peek_skip -= n;
01675        bs += n;
01676        skipped += n;
01677        n = 0;
01678       } else {
01679        bs += peek_skip;
01680        n -= peek_skip;
01681        skipped += peek_skip;
01682        peek_skip = 0;
01683       }
01684       if (n > size)
01685        n = size;
01686 
01687       /* Copy it */
01688       if (buffer)
01689        memcpy(buffer + offset + c, pipe->buf + bs, n);
01690 
01691       /* Fix up indices */
01692       bs += n;
01693       if (!peek)
01694        pipe->bufstart = bs;
01695       size -= n;
01696       c += n;
01697     }
01698   }
01699 
01700   if (!peek && (c > 0)) {
01701     if (pipe->bufmaxextra) {
01702       if (pipe->bufmaxextra > c)
01703        pipe->bufmaxextra -= c;
01704       else
01705        pipe->bufmaxextra = 0;
01706     }
01707     pipe_did_read(p, pipe);
01708   } else {
01709     if (!c) {
01710       if (size && pipe->eof)
01711        return EOF;
01712       if (!nonblock) {
01713        /* must have skipped too far;
01714           need to sleep until chars are ready */
01715        Scheme_Object *my_sema, *wp;
01716        my_sema = scheme_make_sema(0);
01717        wp = scheme_make_pair(my_sema, pipe->wakeup_on_write);
01718        pipe->wakeup_on_write = wp;
01719        scheme_wait_sema(my_sema, (nonblock < 0) ? -1 : 0);
01720       }
01721     } else if (c > 0) {
01722       if (pipe->bufmax) {
01723        if (pipe->bufmaxextra < c + skipped) {
01724          pipe->bufmaxextra = c + skipped;
01725        }
01726       }
01727     }
01728   }
01729 
01730   return c;
01731 }
01732 
01733 static long pipe_get_bytes(Scheme_Input_Port *p,
01734                         char *buffer, long offset, long size,
01735                         int nonblock,
01736                         Scheme_Object *unless)
01737 {
01738   return pipe_get_or_peek_bytes(p, buffer, offset, size, nonblock, 0, 0, unless);
01739 }
01740 
01741 static long pipe_peek_bytes(Scheme_Input_Port *p,
01742                          char *buffer, long offset, long size,
01743                          Scheme_Object *skip,
01744                          int nonblock,
01745                          Scheme_Object *unless)
01746 {
01747   long peek_skip;
01748 
01749   if (SCHEME_INTP(skip))
01750     peek_skip = SCHEME_INT_VAL(skip);
01751   else {
01752 #ifdef SIXTY_FOUR_BIT_INTEGERS
01753     peek_skip = 0x7FFFFFFFFFFFFFFF;
01754 #else
01755     peek_skip = 0x7FFFFFFF;
01756 #endif
01757   }
01758 
01759   return pipe_get_or_peek_bytes(p, buffer, offset, size, nonblock, 1, peek_skip, unless);
01760 }
01761 
01762 static long pipe_write_bytes(Scheme_Output_Port *p,
01763                            const char *str, long d, long len,
01764                            int rarely_block, int enable_break)
01765 {
01766   Scheme_Pipe *pipe;
01767   long avail, firstpos, firstn, secondn, endpos;
01768   long wrote = 0;
01769 
01770   pipe = (Scheme_Pipe *)(p->port_data);
01771 
01772  try_again:
01773 
01774   if (pipe->eof || !len)
01775     return len + wrote;
01776 
01777   if (pipe->bufstart <= pipe->bufend) {
01778     firstn = pipe->buflen - pipe->bufend;
01779     avail = firstn + pipe->bufstart - 1;
01780     if (!pipe->bufstart)
01781       --firstn;
01782   } else {
01783     firstn = avail = pipe->bufstart - pipe->bufend - 1;
01784   }
01785   firstpos = pipe->bufend;
01786 
01787   if (pipe->bufmax) {
01788     /* If we've peek in the past, then buflen might have grown larger
01789        than bufmax. But for consistency, use that extra space only for
01790        peeks. */
01791     long extra;
01792     extra = pipe->buflen - (pipe->bufmax + pipe->bufmaxextra);
01793     if (extra > 0)
01794       avail -= extra;
01795   }
01796 
01797   if (pipe->bufmax && (avail < len)) {
01798     /* Must we block to write it all? */
01799     long xavail = avail;
01800     long can_extra;
01801 
01802     can_extra = ((pipe->bufmax + pipe->bufmaxextra) - pipe->buflen);
01803     if (can_extra > 0)
01804       xavail += can_extra;
01805 
01806     if (xavail < len) {
01807       /* We must block to write it all. */
01808       Scheme_Object *my_sema;
01809 
01810       /* First, write as much as seems immediately possible. */
01811       xavail = pipe_write_bytes(p, str, d, xavail, rarely_block, enable_break);
01812       wrote += xavail;
01813       d += xavail;
01814       len -= xavail;
01815 
01816       /* For non-blocking mode, that might be good enough.
01817         rarely_block == 2 means that even nothing is good enough. */
01818       if ((rarely_block && wrote) || (rarely_block == 2))
01819        return wrote;
01820 
01821       /* Now, wait until we can write more, then start over. */
01822       while (1) {
01823        if (pipe->bufstart <= pipe->bufend) {
01824          avail = (pipe->buflen - pipe->bufend) + pipe->bufstart - 1;
01825        } else {
01826          avail = pipe->bufstart - pipe->bufend - 1;
01827        }
01828        if (pipe->bufmax) {
01829          /* Again, it's possible that the port grew to accomodate
01830             past peeks... */
01831          long extra;
01832          extra = pipe->buflen - (pipe->bufmax + pipe->bufmaxextra);
01833          if (extra > 0)
01834            avail -= extra;
01835        }
01836 
01837        if (avail || pipe->eof || p->closed)
01838          goto try_again;
01839 
01840        my_sema = scheme_make_sema(0);
01841        {
01842          Scheme_Object *wp;
01843          wp = scheme_make_pair(my_sema, pipe->wakeup_on_read);
01844          pipe->wakeup_on_read = wp;
01845        }
01846 
01847        scheme_wait_sema(my_sema, enable_break ? -1 : 0);
01848       }
01849       /* Doesn't get here */
01850     }
01851   }
01852 
01853   if (avail < len) {
01854     unsigned char *old;
01855     int newlen;
01856 
01857     old = pipe->buf;
01858     newlen = 2 * (pipe->buflen + len);
01859     if (pipe->bufmax && (newlen > (pipe->bufmax + pipe->bufmaxextra)))
01860       newlen = pipe->bufmax + pipe->bufmaxextra;
01861 
01862     {
01863       unsigned char *uca;
01864       uca = (unsigned char *)scheme_malloc_atomic(newlen);
01865       pipe->buf = uca;
01866     }
01867 
01868     if (pipe->bufstart <= pipe->bufend) {
01869       memcpy(pipe->buf, old + pipe->bufstart, pipe->bufend - pipe->bufstart);
01870       pipe->bufend -= pipe->bufstart;
01871       pipe->bufstart = 0;
01872     } else {
01873       int slen;
01874       slen = pipe->buflen - pipe->bufstart;
01875       memcpy(pipe->buf, old + pipe->bufstart, slen);
01876       memcpy(pipe->buf + slen, old, pipe->bufend);
01877       pipe->bufstart = 0;
01878       pipe->bufend += slen;
01879     }
01880 
01881     pipe->buflen = newlen;
01882 
01883     firstpos = pipe->bufend;
01884     firstn = len;
01885     endpos = firstpos + firstn;
01886 
01887     secondn = 0;
01888   } else {
01889     if (firstn >= len) {
01890       firstn = len;
01891       endpos = (firstpos + len) % pipe->buflen;
01892       secondn = 0;
01893     } else {
01894       secondn = len - firstn;
01895       endpos = secondn;
01896     }
01897   }
01898 
01899   if (firstn)
01900     memcpy(pipe->buf + firstpos, str + d, firstn);
01901   if (secondn)
01902     memcpy(pipe->buf, str + d + firstn, secondn);
01903 
01904   pipe->bufend = endpos;
01905 
01906   pipe_did_write(pipe);
01907 
01908   return len + wrote;
01909 }
01910 
01911 static int pipe_byte_ready(Scheme_Input_Port *p)
01912 {
01913   Scheme_Pipe *pipe;
01914   int v;
01915 
01916   pipe = (Scheme_Pipe *)(p->port_data);
01917 
01918   v = (pipe->bufstart != pipe->bufend || pipe->eof);
01919 
01920   return v;
01921 }
01922 
01923 static void pipe_in_close(Scheme_Input_Port *p)
01924 {
01925   Scheme_Pipe *pipe;
01926 
01927   pipe = (Scheme_Pipe *)(p->port_data);
01928 
01929   pipe->eof = 1;
01930 
01931   /* to wake up any other threads blocked on pipe I/O: */
01932   pipe_did_read(p, pipe);
01933   pipe_did_write(pipe);
01934 }
01935 
01936 static void pipe_out_close(Scheme_Output_Port *p)
01937 {
01938   Scheme_Pipe *pipe;
01939 
01940   pipe = (Scheme_Pipe *)(p->port_data);
01941 
01942   pipe->eof = 1;
01943 
01944   /* to wake up any other threads blocked on pipe I/O: */
01945   pipe_did_read(NULL, pipe);
01946   pipe_did_write(pipe);
01947 }
01948 
01949 static int pipe_out_ready(Scheme_Output_Port *p)
01950 {
01951   Scheme_Pipe *pipe;
01952   long avail;
01953 
01954   pipe = (Scheme_Pipe *)(p->port_data);
01955 
01956   if (pipe->eof || !pipe->bufmax)
01957     return 1;
01958 
01959   if (pipe->bufend >= pipe->bufstart) {
01960     avail = pipe->bufend - pipe->bufstart;
01961   } else {
01962     avail = pipe->bufend + (pipe->buflen - pipe->bufstart);
01963   }
01964 
01965   avail = pipe->bufmax + pipe->bufmaxextra - 1 - avail;
01966 
01967   return avail > 0;
01968 }
01969 
01970 void scheme_pipe_with_limit(Scheme_Object **read, Scheme_Object **write, int queuelimit)
01971 {
01972   Scheme_Pipe *pipe;
01973   Scheme_Input_Port *readp;
01974   Scheme_Output_Port *writep;
01975   Scheme_Object *name;
01976 
01977   if (queuelimit) queuelimit++; /* need separator in circular buffer */
01978 
01979   pipe = MALLOC_ONE_RT(Scheme_Pipe);
01980 #ifdef MZTAG_REQUIRED
01981   pipe->type = scheme_rt_pipe;
01982 #endif
01983   pipe->buflen = ((queuelimit && (queuelimit < 100)) ? queuelimit : 100);
01984   {
01985     unsigned char *uca;
01986     uca = (unsigned char *)scheme_malloc_atomic(pipe->buflen);
01987     pipe->buf = uca;
01988   }
01989   pipe->bufstart = pipe->bufend = 0;
01990   pipe->eof = 0;
01991   pipe->bufmax = queuelimit;
01992   pipe->wakeup_on_read = scheme_null;
01993   pipe->wakeup_on_write = scheme_null;
01994 
01995   name = scheme_intern_symbol("pipe");
01996 
01997   readp = scheme_make_input_port(scheme_pipe_read_port_type,
01998                              (void *)pipe,
01999                              name,
02000                              pipe_get_bytes,
02001                              pipe_peek_bytes,
02002                              scheme_progress_evt_via_get,
02003                              scheme_peeked_read_via_get,
02004                              pipe_byte_ready,
02005                              pipe_in_close,
02006                              NULL,
02007                              0);
02008 
02009   writep = scheme_make_output_port(scheme_pipe_write_port_type,
02010                                (void *)pipe,
02011                                name,
02012                                scheme_write_evt_via_write,
02013                                pipe_write_bytes,
02014                                pipe_out_ready,
02015                                pipe_out_close,
02016                                NULL,
02017                                NULL,
02018                                NULL,
02019                                0);
02020 
02021   *read = (Scheme_Object *)readp;
02022   *write = (Scheme_Object *)writep;
02023 }
02024 
02025 void scheme_pipe(Scheme_Object **read, Scheme_Object **write)
02026 {
02027   scheme_pipe_with_limit(read, write, 0);
02028 }
02029 
02030 static Scheme_Object *sch_pipe(int argc, Scheme_Object **args)
02031 {
02032   Scheme_Object *v[2];
02033   int bufmax;
02034 
02035   if (argc == 1) {
02036     Scheme_Object *o = args[0];
02037     if (SCHEME_FALSEP(o)) {
02038       bufmax = 0;
02039     } else if ((SCHEME_INTP(o) || SCHEME_BIGNUMP(o))
02040                && scheme_is_positive(o)) {
02041       if (SCHEME_INTP(o))
02042        bufmax = SCHEME_INT_VAL(o);
02043       else
02044        bufmax = 0;
02045     } else {
02046       scheme_wrong_type("make-pipe", "positive exact integer or #f", 0, argc, args);
02047       return NULL;
02048     }
02049   } else
02050     bufmax = 0;
02051 
02052   scheme_pipe_with_limit(&v[0], &v[1], bufmax);
02053 
02054   if (argc > 1)
02055     ((Scheme_Input_Port *)(v[0]))->name = args[1];
02056   if (argc > 2)
02057     ((Scheme_Output_Port *)(v[1]))->name = args[2];
02058 
02059   return scheme_values(2, v);
02060 }
02061 
02062 static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
02063 {
02064   Scheme_Object *o;
02065   Scheme_Pipe *pipe = NULL;
02066   int avail;
02067 
02068   o = argv[0];
02069   if (SCHEME_OUTPUT_PORTP(o)) {
02070     Scheme_Output_Port *op;
02071     op = scheme_output_port_record(o);
02072     if (op->sub_type == scheme_pipe_write_port_type) {
02073       pipe = (Scheme_Pipe *)op->port_data;
02074     }
02075   } else if (SCHEME_INPUT_PORTP(o)) {
02076     Scheme_Input_Port *ip;
02077     ip = scheme_input_port_record(o);
02078     if (ip->sub_type == scheme_pipe_read_port_type) {
02079       pipe = (Scheme_Pipe *)ip->port_data;
02080     }
02081   }
02082 
02083   if (!pipe) {
02084     scheme_wrong_type("pipe-content-length",
02085                     "pipe input port or output port",
02086                     0, argc, argv);
02087     return NULL;
02088   }
02089     
02090   if (pipe->bufend >= pipe->bufstart) {
02091     avail = pipe->bufend - pipe->bufstart;
02092   } else {
02093     avail = pipe->bufend + (pipe->buflen - pipe->bufstart);
02094   }
02095 
02096   return scheme_make_integer(avail);
02097 }
02098 
02099 static int pipe_input_p(Scheme_Object *o)
02100 {
02101   /* Need an immediate pipe: */
02102   if (SAME_TYPE(SCHEME_TYPE(o), scheme_input_port_type)) {
02103     Scheme_Input_Port *ip;
02104     ip = scheme_input_port_record(o);
02105     if (ip->sub_type == scheme_pipe_read_port_type) {
02106       return 1;
02107     }
02108   }
02109 
02110   return 0;
02111 }
02112 
02113 static int pipe_output_p(Scheme_Object *o)
02114 {
02115   /* Need an immediate pipe: */
02116   if (SAME_TYPE(SCHEME_TYPE(o), scheme_output_port_type)) {
02117     Scheme_Output_Port *op;
02118     op = scheme_output_port_record(o);
02119     if (op->sub_type == scheme_pipe_write_port_type) {
02120       return 1;
02121     }
02122   }
02123 
02124   return 0;
02125 }
02126 
02127 /*========================================================================*/
02128 /*                    Scheme functions and helpers                        */
02129 /*========================================================================*/
02130 
02131 static Scheme_Object *
02132 input_port_p (int argc, Scheme_Object *argv[])
02133 {
02134   return (SCHEME_INPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
02135 }
02136 
02137 static Scheme_Object *
02138 output_port_p (int argc, Scheme_Object *argv[])
02139 {
02140   return (SCHEME_OUTPUT_PORTP(argv[0]) ? scheme_true : scheme_false);
02141 }
02142 
02143 static Scheme_Object *port_closed_p (int argc, Scheme_Object *argv[])
02144 {
02145   Scheme_Object *v = argv[0];
02146   if (SCHEME_INPUT_PORTP(v)) {
02147     Scheme_Input_Port *ip;
02148     ip = scheme_input_port_record(v);
02149     return ip->closed ? scheme_true : scheme_false;
02150   } else if (SCHEME_OUTPUT_PORTP(v)) {
02151     Scheme_Output_Port *op;
02152     op = scheme_output_port_record(v);
02153     return op->closed ? scheme_true : scheme_false;
02154   } else {
02155     scheme_wrong_type("port-closed?", "input-port or output-port", 0, argc, argv);
02156     return NULL;
02157   }
02158 }
02159 
02160 static Scheme_Object *current_input_port(int argc, Scheme_Object *argv[])
02161 {
02162   return scheme_param_config("current-input-port", scheme_make_integer(MZCONFIG_INPUT_PORT),
02163                           argc, argv,
02164                           -1, input_port_p, "input-port", 0);
02165 }
02166 
02167 static Scheme_Object *current_output_port(int argc, Scheme_Object *argv[])
02168 {
02169   return scheme_param_config("current-output-port", scheme_make_integer(MZCONFIG_OUTPUT_PORT),
02170                           argc, argv,
02171                           -1, output_port_p, "output-port", 0);
02172 }
02173 
02174 static Scheme_Object *current_error_port(int argc, Scheme_Object *argv[])
02175 {
02176   return scheme_param_config("current-error-port", scheme_make_integer(MZCONFIG_ERROR_PORT),
02177                           argc, argv,
02178                           -1, output_port_p, "output-port", 0);
02179 }
02180 
02181 static Scheme_Object *
02182 make_input_port(int argc, Scheme_Object *argv[])
02183 {
02184   Scheme_Input_Port *ip;
02185   User_Input_Port *uip;
02186   Scheme_Object *name;
02187 
02188   scheme_check_proc_arity("make-input-port", 1, 1, argc, argv); /* read */
02189   scheme_check_proc_arity2("make-input-port", 3, 2, argc, argv, 1); /* peek */
02190   scheme_check_proc_arity("make-input-port", 0, 3, argc, argv); /* close */
02191   if (argc > 4)
02192     scheme_check_proc_arity2("make-input-port", 0, 4, argc, argv, 1); /* progress-evt */
02193   if (argc > 5)
02194     scheme_check_proc_arity2("make-input-port", 3, 5, argc, argv, 1); /* peeked-read */
02195   if (argc > 6)
02196     scheme_check_proc_arity2("make-input-port", 0, 6, argc, argv, 1); /* location */
02197   if (argc > 7)
02198     scheme_check_proc_arity("make-input-port", 0, 7, argc, argv); /* count-lines! */
02199   if (argc > 8) { /* buffer-mode */
02200     if (!((SCHEME_INTP(argv[8]) && SCHEME_INT_VAL(argv[8]) > 0)
02201          || (SCHEME_BIGNUMP(argv[8]) && SCHEME_BIGPOS(argv[8]))))
02202       scheme_wrong_type("make-input-port", "exact, positive integer", 8, argc, argv);
02203   }
02204   if (argc > 9) {
02205     if (SCHEME_TRUEP(argv[9])
02206        && !scheme_check_proc_arity(NULL, 0, 9, argc, argv)
02207        && !scheme_check_proc_arity(NULL, 1, 9, argc, argv))
02208       scheme_wrong_type("make-input-port", "procedure (arities 0 and 1)", 9, argc, argv);
02209   }
02210   name = argv[0];
02211 
02212   /* It makes no sense to supply progress-evt without peek: */
02213   if ((argc > 5) && SCHEME_FALSEP(argv[2]) && !SCHEME_FALSEP(argv[4]))
02214     scheme_arg_mismatch("make-input-port",
02215                      "peek argument is #f, but progress-evt argument is not: ",
02216                      argv[4]);
02217 
02218   /* It makes no sense to supply peeked-read without progress-evt: */
02219   if ((argc > 5) && SCHEME_FALSEP(argv[4]) && !SCHEME_FALSEP(argv[5]))
02220     scheme_arg_mismatch("make-input-port",
02221                      "progress-evt argument is #f, but commit argument is not: ",
02222                      argv[6]);
02223   /* Vice-versa: */
02224   if ((argc > 4) && !SCHEME_FALSEP(argv[4]) && ((argc < 6) || SCHEME_FALSEP(argv[5])))
02225     scheme_arg_mismatch("make-input-port",
02226                      "commit argument is #f, but progress-evt argument is not: ",
02227                      argv[6]);
02228 
02229   uip = MALLOC_ONE_RT(User_Input_Port);
02230 #ifdef MZTAG_REQUIRED
02231   uip->type = scheme_rt_user_input;
02232 #endif
02233 
02234   uip->read_proc = argv[1];
02235   uip->peek_proc = argv[2];
02236   if (SCHEME_FALSEP(uip->peek_proc))
02237     uip->peek_proc = NULL;
02238   uip->close_proc = argv[3];
02239   uip->progress_evt_proc = ((argc > 4) ? argv[4] : scheme_false);
02240   if (SCHEME_FALSEP(uip->progress_evt_proc))
02241     uip->progress_evt_proc = NULL;
02242   uip->peeked_read_proc = ((argc > 5) ? argv[5] : scheme_false);
02243   if (SCHEME_FALSEP(uip->peeked_read_proc))
02244     uip->peeked_read_proc = NULL;
02245   uip->location_proc = ((argc > 6) ? argv[6] : scheme_false);
02246   if (SCHEME_FALSEP(uip->location_proc))
02247     uip->location_proc = NULL;
02248   if (argc > 7)
02249     uip->count_lines_proc = argv[7];
02250   uip->buffer_mode_proc = ((argc > 9) ? argv[9] : scheme_false);
02251   if (SCHEME_FALSEP(uip->buffer_mode_proc))
02252     uip->buffer_mode_proc = NULL;
02253 
02254   ip = scheme_make_input_port(scheme_user_input_port_type,
02255                            uip,
02256                            name,
02257                            user_get_bytes,
02258                            uip->peek_proc ? user_peek_bytes : NULL,
02259                            uip->progress_evt_proc ? user_progress_evt : NULL,
02260                            uip->peeked_read_proc ? user_peeked_read : NULL,
02261                            user_byte_ready,
02262                            user_close_input,
02263                            user_needs_wakeup_input,
02264                            0);
02265 
02266   if (uip->location_proc)
02267     scheme_set_port_location_fun((Scheme_Port *)ip, user_input_location);
02268   if (uip->count_lines_proc)
02269     scheme_set_port_count_lines_fun((Scheme_Port *)ip, user_input_count_lines);
02270 
02271   if (!uip->peek_proc)
02272     ip->pending_eof = 1; /* means that pending EOFs should be tracked */
02273 
02274   if (argc > 8) {
02275     if (SCHEME_INTP(argv[8]))
02276       ip->p.position = (SCHEME_INT_VAL(argv[8]) - 1);
02277     else
02278       ip->p.position = -1;
02279   }
02280 
02281   if (uip->buffer_mode_proc)
02282     ip->p.buffer_mode_fun = user_input_buffer_mode;
02283 
02284   if (ip->p.count_lines && uip->count_lines_proc)
02285     scheme_apply_multi(uip->count_lines_proc, 0, NULL);
02286 
02287   return (Scheme_Object *)ip;
02288 }
02289 
02290 static Scheme_Object *
02291 make_output_port (int argc, Scheme_Object *argv[])
02292 {
02293   Scheme_Output_Port *op;
02294   User_Output_Port *uop;
02295   Scheme_Object *name;
02296 
02297   if (!scheme_is_evt(argv[1])) {
02298     scheme_wrong_type("make-output-port", "evt", 1, argc, argv);
02299   }
02300   scheme_check_proc_arity("make-output-port", 5, 2, argc, argv); /* write */
02301   scheme_check_proc_arity("make-output-port", 0, 3, argc, argv); /* close */
02302   if (argc > 4)
02303     scheme_check_proc_arity2("make-output-port", 3, 4, argc, argv, 1); /* write-special */
02304   if (argc > 5)
02305   scheme_check_proc_arity2("make-output-port", 3, 5, argc, argv, 1); /* write-evt */
02306   if (argc > 6)
02307     scheme_check_proc_arity2("make-output-port", 1, 6, argc, argv, 1); /* write-special-evt */
02308   if (argc > 7)
02309     scheme_check_proc_arity2("make-output-port", 0, 7, argc, argv, 1); /* get-location */
02310   if (argc > 8)
02311     scheme_check_proc_arity("make-output-port", 0, 8, argc, argv); /* count-lines! */
02312   if (argc > 9) {
02313     if (!((SCHEME_INTP(argv[9]) && SCHEME_INT_VAL(argv[9]) > 0)
02314          || (SCHEME_BIGNUMP(argv[9]) && SCHEME_BIGPOS(argv[9]))))
02315       scheme_wrong_type("make-output-port", "exact, positive integer", 9, argc, argv);
02316   }
02317   if (argc > 10) { /* buffer-mode */
02318     if (SCHEME_TRUEP(argv[10])
02319        && !scheme_check_proc_arity(NULL, 0, 10, argc, argv)
02320        && !scheme_check_proc_arity(NULL, 1, 10, argc, argv))
02321       scheme_wrong_type("make-output-port", "procedure (arities 0 and 1)", 10, argc, argv);
02322   }  
02323 
02324   /* It makes no sense to supply write-special-evt without write-special: */
02325   if ((argc > 6) && SCHEME_FALSEP(argv[4]) && !SCHEME_FALSEP(argv[6]))
02326     scheme_arg_mismatch("make-output-port",
02327                      "write-special argument is #f, but write-special-evt argument is not: ",
02328                      argv[6]);
02329 
02330   /* It makes no sense to supply write-special-evt without write-evt: */
02331   if ((argc > 6) && SCHEME_FALSEP(argv[5]) && !SCHEME_FALSEP(argv[6]))
02332     scheme_arg_mismatch("make-output-port",
02333                      "write-evt argument is #f, but write-special-evt argument is not: ",
02334                      argv[6]);
02335 
02336   /* It makes no sense to supply write-evt without write-special-evt when write-special
02337      is provided */
02338   if ((argc > 5) && !SCHEME_FALSEP(argv[5])
02339       && ((argc < 7) || SCHEME_FALSEP(argv[6]))
02340       && !SCHEME_FALSEP(argv[4]))
02341     scheme_arg_mismatch("make-output-port",
02342                      "write-special-evt argument is #f, but write-evt argument is not, and write-special argument is not: ",
02343                      argv[4]);
02344   name = argv[0];
02345 
02346   uop = MALLOC_ONE_RT(User_Output_Port);
02347 #ifdef MZTAG_REQUIRED
02348   uop->type = scheme_rt_user_output;
02349 #endif
02350 
02351   uop->evt = argv[1];
02352   uop->write_proc = argv[2];
02353   uop->close_proc = argv[3];
02354   uop->write_evt_proc = ((argc > 5) ? argv[5] : scheme_false);
02355   if (SCHEME_FALSEP(uop->write_evt_proc))
02356       uop->write_evt_proc = NULL;
02357   if ((argc < 5) || SCHEME_FALSEP(argv[4])) {
02358     uop->write_special_proc = NULL;
02359     uop->write_special_evt_proc = NULL;
02360   } else {
02361     uop->write_special_proc = argv[4];
02362     uop->write_special_evt_proc = ((argc > 6) ? argv[6] : scheme_false);
02363     if (SCHEME_FALSEP(uop->write_special_evt_proc))
02364       uop->write_special_evt_proc = NULL;
02365   }
02366   if ((argc > 7) && SCHEME_TRUEP(argv[7]))
02367     uop->location_proc = argv[7];
02368   if (argc > 8)
02369     uop->count_lines_proc = argv[8];
02370   if ((argc > 10) && SCHEME_TRUEP(argv[10]))
02371     uop->buffer_mode_proc = argv[10];
02372 
02373   op = scheme_make_output_port(scheme_user_output_port_type,
02374                             uop,
02375                             name,
02376                             uop->write_evt_proc ? user_write_bytes_evt : NULL,
02377                             user_write_bytes,
02378                             user_write_ready,
02379                             user_close_output,
02380                             user_needs_wakeup_output,
02381                             uop->write_special_evt_proc ? user_write_special_evt : NULL,
02382                             uop->write_special_proc ? user_write_special : NULL,
02383                             0);
02384 
02385   if (uop->location_proc)
02386     scheme_set_port_location_fun((Scheme_Port *)op, user_output_location);
02387   if (uop->count_lines_proc)
02388     scheme_set_port_count_lines_fun((Scheme_Port *)op, user_output_count_lines);
02389 
02390   if (argc > 9) {
02391     if (SCHEME_INTP(argv[9]))
02392       op->p.position = (SCHEME_INT_VAL(argv[9]) - 1);
02393     else
02394       op->p.position = -1;
02395   }
02396 
02397   if (uop->buffer_mode_proc)
02398     op->p.buffer_mode_fun = user_output_buffer_mode;
02399 
02400   if (op->p.count_lines && uop->count_lines_proc)
02401     scheme_apply_multi(uop->count_lines_proc, 0, NULL);
02402 
02403   return (Scheme_Object *)op;
02404 }
02405 
02406 static Scheme_Object *
02407 open_input_file (int argc, Scheme_Object *argv[])
02408 {
02409   return scheme_do_open_input_file("open-input-file", 0, argc, argv, 0);
02410 }
02411 
02412 static Scheme_Object *
02413 open_input_byte_string (int argc, Scheme_Object *argv[])
02414 {
02415   Scheme_Object *o;
02416 
02417   if (!SCHEME_BYTE_STRINGP(argv[0]))
02418     scheme_wrong_type("open-input-bytes", "byte string", 0, argc, argv);
02419 
02420   o = scheme_make_sized_byte_string_input_port(SCHEME_BYTE_STR_VAL(argv[0]),
02421                                           SCHEME_BYTE_STRTAG_VAL(argv[0]));
02422   if (argc > 1)
02423     ((Scheme_Input_Port *)o)->name = argv[1];
02424 
02425   return o;
02426 }
02427 
02428 static Scheme_Object *
02429 open_input_char_string (int argc, Scheme_Object *argv[])
02430 {
02431   Scheme_Object *o;
02432 
02433   if (!SCHEME_CHAR_STRINGP(argv[0]))
02434     scheme_wrong_type("open-input-string", "string", 0, argc, argv);
02435 
02436   o = scheme_char_string_to_byte_string(argv[0]);
02437 
02438   o = scheme_make_sized_byte_string_input_port(SCHEME_BYTE_STR_VAL(o),
02439                                           SCHEME_BYTE_STRTAG_VAL(o));
02440 
02441   if (argc > 1)
02442     ((Scheme_Input_Port *)o)->name = argv[1];
02443 
02444   return o;
02445 }
02446 
02447 static Scheme_Object *
02448 open_output_file (int argc, Scheme_Object *argv[])
02449 {
02450   return scheme_do_open_output_file("open-output-file", 0, argc, argv, 0);
02451 }
02452 
02453 static Scheme_Object *
02454 open_input_output_file (int argc, Scheme_Object *argv[])
02455 {
02456   return scheme_do_open_output_file("open-input-output-file", 0, argc, argv, 1);
02457 }
02458 
02459 static Scheme_Object *
02460 open_output_string (int argc, Scheme_Object *argv[])
02461 {
02462   Scheme_Object *o;
02463 
02464   o = scheme_make_byte_string_output_port();
02465 
02466   if (argc)
02467     ((Scheme_Output_Port *)o)->name = argv[0];
02468 
02469   return o;
02470 }
02471 
02472 Scheme_Object *do_get_output_string(const char *who, int is_byte,
02473                                 int argc, Scheme_Object *argv[])
02474 {
02475   Scheme_Output_Port *op;
02476   char *s;
02477   long size, startpos, endpos;
02478 
02479   op = scheme_output_port_record(argv[0]);
02480   if (!SCHEME_OUTPUT_PORTP(argv[0])
02481       || (op->sub_type != scheme_string_output_port_type))
02482     scheme_wrong_type(who, "string output port", 0, argc, argv);
02483 
02484   if (argc > 2) {
02485     long len;
02486     Scheme_Indexed_String *is;
02487 
02488     is = (Scheme_Indexed_String *)op->port_data;
02489     len = is->index;
02490     if (is->u.hot > len)
02491       len = is->u.hot;
02492     
02493     startpos = scheme_extract_index(who, 2, argc, argv, len+1, 0);
02494     if (argc > 3) {
02495       if (SCHEME_FALSEP(argv[3]))
02496         endpos = len;
02497       else {
02498         endpos = scheme_extract_index(who, 3, argc, argv, len+1, 1);
02499         if (endpos < 0) 
02500           endpos = len+1;
02501       }
02502       
02503       if (!(startpos <= len)) {
02504         scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02505                          "%s: starting index %V out of range [%d, %d] for port: %V",
02506                          who, 
02507                          argv[2], 0, len,
02508                          argv[0]);
02509         return NULL;
02510       }
02511       if (!(endpos >= startpos && endpos <= len)) {
02512         scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02513                          "%s: ending index %V out of range [%d, %d] for port: %V",
02514                          who, 
02515                          argv[3], startpos, len,
02516                          argv[0]);
02517         return NULL;
02518       }
02519     } else
02520       endpos = -1;
02521   } else {
02522     startpos = 0;
02523     endpos = -1;
02524   }
02525 
02526   s = scheme_get_reset_sized_byte_string_output(argv[0], &size, 
02527                                                 ((argc > 1) && SCHEME_TRUEP(argv[1])), 
02528                                                 startpos, endpos);
02529 
02530   if (is_byte)
02531     return scheme_make_sized_byte_string(s, size, 0);
02532   else
02533     return scheme_make_sized_utf8_string(s, size);
02534 }
02535 
02536 static Scheme_Object *
02537 get_output_byte_string (int argc, Scheme_Object *argv[])
02538 {
02539   return do_get_output_string("get-output-bytes", 1, argc, argv);
02540 }
02541 
02542 static Scheme_Object *
02543 get_output_char_string (int argc, Scheme_Object *argv[])
02544 {
02545   return do_get_output_string("get-output-string", 0, argc, argv);
02546 }
02547 
02548 static Scheme_Object *
02549 close_input_port (int argc, Scheme_Object *argv[])
02550 {
02551   if (!SCHEME_INPUT_PORTP(argv[0]))
02552     scheme_wrong_type("close-input-port", "input-port", 0, argc, argv);
02553 
02554   scheme_close_input_port(argv[0]);
02555   return (scheme_void);
02556 }
02557 
02558 static Scheme_Object *
02559 close_output_port (int argc, Scheme_Object *argv[])
02560 {
02561   if (!SCHEME_OUTPUT_PORTP(argv[0]))
02562     scheme_wrong_type("close-output-port", "output-port", 0, argc, argv);
02563 
02564   scheme_close_output_port(argv[0]);
02565   return (scheme_void);
02566 }
02567 
02568 static Scheme_Object *
02569 call_with_output_file (int argc, Scheme_Object *argv[])
02570 {
02571   Scheme_Thread *p = scheme_current_thread;
02572   Scheme_Object *port, *v, **m;
02573 
02574   scheme_check_proc_arity("call-with-output-file", 1, 1, argc, argv);
02575 
02576   port = scheme_do_open_output_file("call-with-output-file", 1, argc, argv, 0);
02577 
02578   v = _scheme_apply_multi(argv[1], 1, &port);
02579 
02580   m = p->ku.multiple.array;
02581   if (v == SCHEME_MULTIPLE_VALUES) {
02582     if (SAME_OBJ(m, p->values_buffer))
02583       p->values_buffer = NULL;
02584   }
02585 
02586   scheme_close_output_port(port);
02587 
02588   p->ku.multiple.array = m;
02589 
02590   return v;
02591 }
02592 
02593 static Scheme_Object *
02594 call_with_input_file(int argc, Scheme_Object *argv[])
02595 {
02596   Scheme_Thread *p = scheme_current_thread;
02597   Scheme_Object *port, *v, **m;
02598 
02599   scheme_check_proc_arity("call-with-input-file", 1, 1, argc, argv);
02600 
02601   port = scheme_do_open_input_file("call-with-input-file", 1, argc, argv, 0);
02602 
02603   v = _scheme_apply_multi(argv[1], 1, &port);
02604 
02605   m = p->ku.multiple.array;
02606   if (v == SCHEME_MULTIPLE_VALUES) {
02607     if (SAME_OBJ(m, p->values_buffer))
02608       p->values_buffer = NULL;
02609   }
02610 
02611   scheme_close_input_port(port);
02612 
02613   p->ku.multiple.array = m;
02614 
02615   return v;
02616 }
02617 
02618 static Scheme_Object *with_call_thunk(void *d)
02619 {
02620   return _scheme_apply_multi(SCHEME_CAR((Scheme_Object *)d), 0, NULL);
02621 }
02622 
02623 static void with_close_output(void *d)
02624 {
02625   scheme_close_output_port(SCHEME_CDR((Scheme_Object *)d));
02626 }
02627 
02628 
02629 static Scheme_Object *
02630 with_output_to_file (int argc, Scheme_Object *argv[])
02631 {
02632   Scheme_Object *port, *v;
02633   Scheme_Cont_Frame_Data cframe;
02634   Scheme_Config *config;
02635 
02636   scheme_check_proc_arity("with-output-to-file", 0, 1, argc, argv);
02637 
02638   port = scheme_do_open_output_file("with-output-to-file", 1, argc, argv, 0);
02639 
02640   config = scheme_extend_config(scheme_current_config(),
02641                             MZCONFIG_OUTPUT_PORT,
02642                             port);
02643 
02644   scheme_push_continuation_frame(&cframe);
02645   scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
02646 
02647   v = scheme_dynamic_wind(NULL,
02648                        with_call_thunk,
02649                        with_close_output,
02650                        NULL,
02651                        scheme_make_pair(argv[1], port));
02652 
02653   scheme_pop_continuation_frame(&cframe);
02654 
02655   return v;
02656 }
02657 
02658 static void with_close_input(void *d)
02659 {
02660   scheme_close_input_port(SCHEME_CDR((Scheme_Object *)d));
02661 }
02662 
02663 static Scheme_Object *
02664 with_input_from_file(int argc, Scheme_Object *argv[])
02665 {
02666   Scheme_Object *port, *v;
02667   Scheme_Cont_Frame_Data cframe;
02668   Scheme_Config *config;
02669 
02670   scheme_check_proc_arity("with-input-from-file", 0, 1, argc, argv);
02671 
02672   port = scheme_do_open_input_file("with-input-from-file", 1, argc, argv, 0);
02673 
02674   config = scheme_extend_config(scheme_current_config(),
02675                             MZCONFIG_INPUT_PORT,
02676                             port);
02677 
02678   scheme_push_continuation_frame(&cframe);
02679   scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
02680 
02681   v = scheme_dynamic_wind(NULL,
02682                        with_call_thunk,
02683                        with_close_input,
02684                        NULL,
02685                        scheme_make_pair(argv[1], port));
02686 
02687   scheme_pop_continuation_frame(&cframe);
02688 
02689   return v;
02690 }
02691 
02692 static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Object *argv[])
02693 {
02694   Scheme_Object *src;
02695 
02696   if (!SCHEME_INPUT_PORTP(argv[0]))
02697     scheme_wrong_type("default-port-read-handler", "input-port", 0, argc, argv);
02698 
02699   if ((Scheme_Object *)argv[0] == scheme_orig_stdin_port)
02700     scheme_flush_orig_outputs();
02701 
02702   if (argc > 1)
02703     src = argv[1];
02704   else
02705     src = NULL;
02706 
02707   return scheme_internal_read(argv[0], src, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
02708 }
02709 
02710 static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, 
02711                               Scheme_Object **_readtable, int *_recur_graph)
02712 {
02713   int pre_char = -1;
02714 
02715   if (argc > delta + 1) {
02716     if (SCHEME_TRUEP(argv[delta + 1])) {
02717       if (!SCHEME_CHARP(argv[delta + 1]))
02718        scheme_wrong_type(who, "character or #f", delta + 1, argc, argv);
02719       pre_char = SCHEME_CHAR_VAL(argv[delta + 1]);
02720     }
02721     if (argc > delta + 2) {
02722       Scheme_Object *readtable;
02723       readtable = argv[delta + 2];
02724       if (SCHEME_TRUEP(readtable) && !SAME_TYPE(scheme_readtable_type, SCHEME_TYPE(readtable))) {
02725        scheme_wrong_type(who, "readtable or #f", delta + 2, argc, argv);
02726       }
02727       *_readtable = readtable;
02728       if (argc > delta + 3) {
02729         *_recur_graph = SCHEME_TRUEP(argv[delta + 3]);
02730       }
02731     }
02732   }
02733 
02734   return pre_char;
02735 }
02736 
02737 static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[], int honu_mode, int recur)
02738 {
02739   Scheme_Object *port, *readtable = NULL;
02740   int pre_char = -1, recur_graph = recur;
02741   Scheme_Input_Port *ip;
02742 
02743   if (argc && !SCHEME_INPUT_PORTP(argv[0]))
02744     scheme_wrong_type(who, "input-port", 0, argc, argv);
02745 
02746   if (argc)
02747     port = argv[0];
02748   else
02749     port = CURRENT_INPUT_PORT(scheme_current_config());
02750 
02751   if (recur && !honu_mode) {
02752     pre_char = extract_recur_args(who, argc, argv, 0, &readtable, &recur_graph);
02753   }
02754 
02755   ip = scheme_input_port_record(port);
02756 
02757   if (ip->read_handler && !honu_mode && !recur) {
02758     Scheme_Object *o[1];
02759     o[0] = port;
02760     return _scheme_apply(ip->read_handler, 1, o);
02761   } else {
02762     if (port == scheme_orig_stdin_port)
02763       scheme_flush_orig_outputs();
02764 
02765     return scheme_internal_read(port, NULL, -1, 0, honu_mode, 
02766                                 recur_graph, recur, 
02767                                 pre_char, readtable, 
02768                                 NULL, NULL, NULL);
02769   }
02770 }
02771 
02772 static Scheme_Object *read_f(int argc, Scheme_Object *argv[])
02773 {
02774   return do_read_f("read", argc, argv, 0, 0);
02775 }
02776 
02777 static Scheme_Object *read_recur_f(int argc, Scheme_Object *argv[])
02778 {
02779   return do_read_f("read/recursive", argc, argv, 0, 1);
02780 }
02781 
02782 static Scheme_Object *read_honu_f(int argc, Scheme_Object *argv[])
02783 {
02784   return do_read_f("read-honu", argc, argv, 1, 0);
02785 }
02786 
02787 static Scheme_Object *read_honu_recur_f(int argc, Scheme_Object *argv[])
02788 {
02789   return do_read_f("read-honu/recursive", argc, argv, 1, 1);
02790 }
02791 
02792 static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object *argv[], int honu_mode, int recur)
02793 {
02794   Scheme_Object *port, *readtable = NULL;
02795   int pre_char = -1, recur_graph = recur;
02796   Scheme_Input_Port *ip;
02797 
02798   if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1]))
02799     scheme_wrong_type(who, "input-port", 1, argc, argv);
02800 
02801   if (argc > 1)
02802     port = argv[1];
02803   else
02804     port = CURRENT_INPUT_PORT(scheme_current_config());
02805 
02806   if (recur && !honu_mode) {
02807     pre_char = extract_recur_args(who, argc, argv, 1, &readtable, &recur_graph);
02808   }
02809   
02810   ip = scheme_input_port_record(port);
02811 
02812   if (ip->read_handler && !honu_mode && !recur) {
02813     Scheme_Object *o[2], *result;
02814     o[0] = port;
02815     o[1] = (argc ? argv[0] : ip->name);
02816 
02817     result = _scheme_apply(ip->read_handler, 2, o);
02818     if (SCHEME_STXP(result) || SCHEME_EOFP(result))
02819       return result;
02820     else {
02821       o[0] = result;
02822       /* -1 for argument count indicates "result" */
02823       scheme_wrong_type("read handler for read-syntax", "syntax object", 0, -1, o);
02824       return NULL;
02825     }
02826   } else {
02827     Scheme_Object *src;
02828 
02829     src = (argc ? argv[0] : ip->name);
02830 
02831     if (port == scheme_orig_stdin_port)
02832       scheme_flush_orig_outputs();
02833 
02834     return scheme_internal_read(port, src, -1, 0, honu_mode, 
02835                                 recur, recur_graph,
02836                                 pre_char, readtable, 
02837                                 NULL, NULL, NULL);
02838   }
02839 }
02840 
02841 static Scheme_Object *read_syntax_f(int argc, Scheme_Object *argv[])
02842 {
02843   return do_read_syntax_f("read-syntax", argc, argv, 0, 0);
02844 }
02845 
02846 static Scheme_Object *read_syntax_recur_f(int argc, Scheme_Object *argv[])
02847 {
02848   return do_read_syntax_f("read-syntax/recursive", argc, argv, 0, 1);
02849 }
02850 
02851 static Scheme_Object *read_honu_syntax_f(int argc, Scheme_Object *argv[])
02852 {
02853   return do_read_syntax_f("read-honu-syntax", argc, argv, 1, 0);
02854 }
02855 
02856 static Scheme_Object *read_honu_syntax_recur_f(int argc, Scheme_Object *argv[])
02857 {
02858   return do_read_syntax_f("read-honu-syntax/recursive", argc, argv, 1, 1);
02859 }
02860 
02861 static Scheme_Object *read_language(int argc, Scheme_Object **argv)
02862 {
02863   Scheme_Object *port, *v, *fail_thunk = NULL;
02864 
02865   if (argc > 0) {
02866     port = argv[0];
02867     if (!SCHEME_INPUT_PORTP(port))
02868       scheme_wrong_type("read-language", "input-port", 0, argc, argv);
02869     if (argc > 1) {
02870       scheme_check_proc_arity("read-language", 0, 1, argc, argv);
02871       fail_thunk = argv[1];
02872     }
02873   } else {
02874     port = CURRENT_INPUT_PORT(scheme_current_config());
02875   }
02876   
02877   v = scheme_read_language(port, !!fail_thunk);
02878 
02879   if (SCHEME_VOIDP(v))
02880     return _scheme_tail_apply(fail_thunk, 0, NULL);
02881   
02882   return v;
02883 }
02884 
02885 static Scheme_Object *
02886 do_read_char(char *name, int argc, Scheme_Object *argv[], int peek, int spec, int is_byte)
02887 {
02888   Scheme_Object *port;
02889   int ch;
02890 
02891   if (argc && !SCHEME_INPUT_PORTP(argv[0]))
02892     scheme_wrong_type(name, "input-port", 0, argc, argv);
02893 
02894   if (argc)
02895     port = argv[0];
02896   else
02897     port = CURRENT_INPUT_PORT(scheme_current_config());
02898 
02899   if (peek) {
02900     Scheme_Object *skip, *unless_evt = NULL;
02901 
02902     if (argc > 1) {
02903       skip = argv[1];
02904       if (!(SCHEME_INTP(skip) && (SCHEME_INT_VAL(skip) >= 0))
02905          && !(SCHEME_BIGNUMP(skip) && SCHEME_BIGPOS(skip))) {
02906        scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
02907        return NULL;
02908       }
02909       if (argc > 2) {
02910        if (SCHEME_TRUEP(argv[2])) {
02911          unless_evt = argv[2];
02912          if (!SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type)) {
02913            scheme_wrong_type(name, "progress evt", 2, argc, argv);
02914            return NULL;
02915          }
02916          if (!SAME_OBJ(port, SCHEME_PTR1_VAL(unless_evt))) {
02917            scheme_arg_mismatch(name,
02918                             "evt is not a progress evt for the given port: ",
02919                             unless_evt);
02920            return NULL;
02921          }
02922        }
02923       }
02924     } else
02925       skip = NULL;
02926 
02927     if (spec) {
02928       if (is_byte) {
02929        ch = scheme_peek_byte_special_ok_skip(port, skip, unless_evt);
02930       } else
02931        ch = scheme_peekc_special_ok_skip(port, skip);
02932     } else {
02933       if (is_byte)
02934        ch = scheme_peek_byte_skip(port, skip, unless_evt);
02935       else
02936        ch = scheme_peekc_skip(port, skip);
02937     }
02938   } else {
02939     if (spec) {
02940       if (is_byte)
02941        ch = scheme_get_byte_special_ok(port);
02942       else
02943        ch = scheme_getc_special_ok(port);
02944     } else {
02945       if (is_byte)
02946        ch = scheme_get_byte(port);
02947       else
02948        ch = scheme_getc(port);
02949     }
02950   }
02951 
02952   if (ch == SCHEME_SPECIAL) {
02953     return scheme_get_ready_special(port, NULL, peek);
02954   } else if (ch == EOF)
02955     return scheme_eof;
02956   else if (is_byte)
02957     return scheme_make_integer(ch);
02958   else
02959     return _scheme_make_char(ch);
02960 }
02961 
02962 static Scheme_Object *
02963 read_char (int argc, Scheme_Object *argv[])
02964 {
02965   return do_read_char("read-char", argc, argv, 0, 0, 0);
02966 }
02967 
02968 static Scheme_Object *
02969 read_char_spec (int argc, Scheme_Object *argv[])
02970 {
02971   return do_read_char("read-char-or-special", argc, argv, 0, 1, 0);
02972 }
02973 
02974 static Scheme_Object *
02975 peek_char (int argc, Scheme_Object *argv[])
02976 {
02977   return do_read_char("peek-char", argc, argv, 1, 0, 0);
02978 }
02979 
02980 static Scheme_Object *
02981 peek_char_spec (int argc, Scheme_Object *argv[])
02982 {
02983   return do_read_char("peek-char-or-special", argc, argv, 1, 1, 0);
02984 }
02985 
02986 static Scheme_Object *
02987 read_byte (int argc, Scheme_Object *argv[])
02988 {
02989   return do_read_char("read-byte", argc, argv, 0, 0, 1);
02990 }
02991 
02992 static Scheme_Object *
02993 read_byte_spec (int argc, Scheme_Object *argv[])
02994 {
02995   return do_read_char("read-byte-or-special", argc, argv, 0, 1, 1);
02996 }
02997 
02998 static Scheme_Object *
02999 peek_byte (int argc, Scheme_Object *argv[])
03000 {
03001   return do_read_char("peek-byte", argc, argv, 1, 0, 1);
03002 }
03003 
03004 static Scheme_Object *
03005 peek_byte_spec (int argc, Scheme_Object *argv[])
03006 {
03007   return do_read_char("peek-byte-or-special", argc, argv, 1, 1, 1);
03008 }
03009 
03010 static Scheme_Object *
03011 do_read_line (int as_bytes, const char *who, int argc, Scheme_Object *argv[])
03012 {
03013   Scheme_Object *port;
03014   int ch;
03015   int crlf = 0, cr = 0, lf = 1;
03016   char *buf, *oldbuf, onstack[32];
03017   long size = 31, oldsize, i = 0;
03018 
03019   if (argc && !SCHEME_INPUT_PORTP(argv[0]))
03020     scheme_wrong_type(who, "input-port", 0, argc, argv);
03021 
03022   if (argc > 1) {
03023     Scheme_Object *v = argv[1];
03024     if (SAME_OBJ(v, any_symbol)) {
03025       crlf = cr = lf = 1;
03026     } else if (SAME_OBJ(v, any_one_symbol)) {
03027       crlf = 0;
03028       cr = lf = 1;
03029     } else if (SAME_OBJ(v, cr_symbol)) {
03030       crlf = lf = 0;
03031       cr = 1;
03032     } else if (SAME_OBJ(v, lf_symbol)) {
03033       crlf = cr = 0;
03034       lf = 1;
03035     } else if (SAME_OBJ(v, crlf_symbol)) {
03036       lf = cr = 0;
03037       crlf = 1;
03038     } else
03039       scheme_wrong_type(who, "newline specification symbol", 1, argc, argv);
03040   }
03041 
03042   if (argc)
03043     port = argv[0];
03044   else
03045     port = CURRENT_INPUT_PORT(scheme_current_config());
03046 
03047   if ((Scheme_Object *)port == scheme_orig_stdin_port)
03048     scheme_flush_orig_outputs();
03049 
03050   buf = onstack;
03051 
03052   while (1) {
03053     ch = scheme_get_byte(port);
03054     if (ch == EOF) {
03055       if (!i)
03056        return scheme_eof;
03057       break;
03058     }
03059     if (ch == '\r') {
03060       if (crlf) {
03061        int ch2;
03062 
03063        ch2 = scheme_peek_byte_skip(port, scheme_make_integer(0), NULL);
03064        if (ch2 == '\n') {
03065          scheme_get_byte(port);
03066          break;
03067        } else if (cr)
03068          break;
03069       } else {
03070        if (cr)
03071          break;
03072       }
03073     } else if (ch == '\n') {
03074       if (lf)
03075        break;
03076     }
03077 
03078     if (i >= size) {
03079       oldsize = size;
03080       oldbuf = buf;
03081 
03082       size *= 2;
03083       buf = (char *)scheme_malloc_atomic(size + 1);
03084       memcpy(buf, oldbuf, oldsize);
03085     }
03086     buf[i++] = ch;
03087   }
03088 
03089   if (as_bytes) {
03090     buf[i] = '\0';
03091     return scheme_make_sized_byte_string(buf, i, buf == (char *)onstack);
03092   } else {
03093     buf[i] = '\0';
03094     return scheme_make_sized_utf8_string(buf, i);
03095   }
03096 }
03097 
03098 static Scheme_Object *
03099 read_line (int argc, Scheme_Object *argv[])
03100 {
03101   return do_read_line(0, "read-line", argc, argv);
03102 }
03103 
03104 static Scheme_Object *
03105 read_byte_line (int argc, Scheme_Object *argv[])
03106 {
03107   return do_read_line(1, "read-byte-line", argc, argv);
03108 }
03109 
03110 
03111 static Scheme_Object *
03112 do_general_read_bytes(int as_bytes,
03113                     const char *who, int argc, Scheme_Object *argv[],
03114                     int alloc_mode, int only_avail, int peek)
03115 {
03116   Scheme_Object *port, *str, *peek_skip, *unless_evt = NULL;
03117   long size, start, finish, got;
03118   int delta, size_too_big = 0;
03119 
03120   if (alloc_mode) {
03121     if (!SCHEME_INTP(argv[0])) {
03122       if (SCHEME_BIGNUMP(argv[0])) {
03123        size = 1;
03124        size_too_big = 1;
03125       } else
03126        size = -1; /* cause the error message to be printed */
03127     } else
03128       size = SCHEME_INT_VAL(argv[0]);
03129 
03130     if (size < 0) {
03131       scheme_wrong_type(who, "non-negative exact integer", 0, argc, argv);
03132       return NULL;
03133     }
03134     str = NULL; /* allocated later */
03135   } else {
03136     if (as_bytes) {
03137       if (!SCHEME_MUTABLE_BYTE_STRINGP(argv[0])) {
03138        scheme_wrong_type(who, "mutable byte string", 0, argc, argv);
03139        return NULL;
03140       }
03141     } else {
03142       if (!SCHEME_MUTABLE_CHAR_STRINGP(argv[0])) {
03143        scheme_wrong_type(who, "mutable string", 0, argc, argv);
03144        return NULL;
03145       }
03146     }
03147     str = argv[0];
03148     size = 0;
03149   }
03150 
03151   if (peek) {
03152     Scheme_Object *v;
03153     v = argv[1];
03154     if (SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0))
03155       peek_skip = v;
03156     else if (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v))
03157       peek_skip = v;
03158     else {
03159       scheme_wrong_type(who, "non-negative exact integer", 1, argc, argv);
03160       return NULL;
03161     }
03162     if (only_avail) {
03163       if (SCHEME_TRUEP(argv[2])) {
03164        unless_evt = argv[2];
03165        if (!SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type)) {
03166          scheme_wrong_type(who, "progress evt or #f", 2, argc, argv);
03167          return NULL;
03168        }
03169       }
03170       delta = 2;
03171     } else
03172       delta = 1;
03173   } else {
03174     peek_skip = scheme_make_integer(0);
03175     delta = 0;
03176   }
03177 
03178   if ((argc > (1+delta)) && !SCHEME_INPUT_PORTP(argv[1+delta]))
03179     scheme_wrong_type(who, "input-port", 1+delta, argc, argv);
03180 
03181   if (alloc_mode) {
03182     start = 0;
03183     finish = size;
03184   } else {
03185     scheme_get_substring_indices(who, str,
03186                              argc, argv,
03187                              2+delta, 3+delta, &start, &finish);
03188 
03189     size = finish - start;
03190   }
03191 
03192   if (argc > (delta+1))
03193     port = argv[delta+1];
03194   else
03195     port = CURRENT_INPUT_PORT(scheme_current_config());
03196 
03197   if (unless_evt) {
03198     if (!SAME_OBJ(port, SCHEME_PTR1_VAL(unless_evt))) {
03199       scheme_arg_mismatch(who,
03200                        "evt is not a progress evt for the given port: ",
03201                        unless_evt);
03202       return NULL;
03203     }
03204   }
03205 
03206   if ((Scheme_Object *)port == scheme_orig_stdin_port)
03207     scheme_flush_orig_outputs();
03208 
03209   if (!size) {
03210     if (alloc_mode) {
03211       if (as_bytes)
03212        return scheme_make_sized_byte_string("", 0, 0);
03213       else
03214        return scheme_make_sized_char_string((mzchar *)"\0\0\0", 0, 0);
03215     } else
03216       return scheme_make_integer(0);
03217   }
03218 
03219   if (alloc_mode) {
03220     if (size_too_big) {
03221       scheme_raise_out_of_memory(who, "making string of length %s",
03222                              scheme_make_provided_string(argv[0], 0, NULL));
03223       return NULL;
03224     }
03225     if (as_bytes)
03226       str = scheme_alloc_byte_string(size, 0);
03227     else
03228       str = scheme_alloc_char_string(size, 0);
03229   }
03230 
03231   if (as_bytes) {
03232     got = scheme_get_byte_string_special_ok_unless(who, port,
03233                                              SCHEME_BYTE_STR_VAL(str), start, size,
03234                                              only_avail,
03235                                              peek, peek_skip,
03236                                              unless_evt);
03237     if (got == SCHEME_SPECIAL) {
03238       Scheme_Object *res;
03239       res = scheme_get_special_proc(port);
03240       if (!only_avail)
03241        scheme_bad_time_for_special(who, port);
03242       return res;
03243     }
03244   } else {
03245     got = scheme_get_char_string(who, port,
03246                              SCHEME_CHAR_STR_VAL(str), start, size,
03247                              peek, peek_skip);
03248   }
03249 
03250   if (got == EOF)
03251     return scheme_eof;
03252 
03253   if (alloc_mode) {
03254     if (got < size) {
03255       /* Ended up with a shorter string: */
03256       if (as_bytes)
03257        str = scheme_make_sized_byte_string(SCHEME_BYTE_STR_VAL(str), got, 1);
03258       else
03259        str = scheme_make_sized_char_string(SCHEME_CHAR_STR_VAL(str), got, 1);
03260     }
03261     return str;
03262   } else
03263     return scheme_make_integer(got);
03264 }
03265 
03266 static Scheme_Object *
03267 sch_read_bytes(int argc, Scheme_Object *argv[])
03268 {
03269   return do_general_read_bytes(1, "read-bytes", argc, argv, 1, 0, 0);
03270 }
03271 
03272 static Scheme_Object *
03273 sch_read_bytes_bang(int argc, Scheme_Object *argv[])
03274 {
03275   return do_general_read_bytes(1, "read-bytes!", argc, argv, 0, 0, 0);
03276 }
03277 
03278 static Scheme_Object *
03279 sch_peek_bytes(int argc, Scheme_Object *argv[])
03280 {
03281   return do_general_read_bytes(1, "peek-bytes", argc, argv, 1, 0, 1);
03282 }
03283 
03284 static Scheme_Object *
03285 sch_peek_bytes_bang(int argc, Scheme_Object *argv[])
03286 {
03287   return do_general_read_bytes(1, "peek-bytes!", argc, argv, 0, 0, 1);
03288 }
03289 
03290 static Scheme_Object *
03291 read_bytes_bang(int argc, Scheme_Object *argv[])
03292 {
03293   return do_general_read_bytes(1, "read-bytes-avail!", argc, argv, 0, 1, 0);
03294 }
03295 
03296 static Scheme_Object *
03297 read_bytes_bang_nonblock(int argc, Scheme_Object *argv[])
03298 {
03299   return do_general_read_bytes(1, "read-bytes-avail!*", argc, argv, 0, 2, 0);
03300 }
03301 
03302 static Scheme_Object *
03303 peeked_read(int argc, Scheme_Object *argv[])
03304 {
03305   Scheme_Object *port, *unless_evt, *target_evt;
03306   long size;
03307   int v;
03308 
03309   if ((SCHEME_INTP(argv[0]) && (SCHEME_INT_VAL(argv[0]) > 0))
03310       || (SCHEME_BIGNUMP(argv[0]) && SCHEME_BIGPOS(argv[0]))) {
03311     if (SCHEME_INTP(argv[0]))
03312       size = SCHEME_INT_VAL(argv[0]);
03313     else
03314       size = 0x7FFFFFFF;
03315   } else {
03316     scheme_wrong_type("port-commit-peeked", "positive exact integer", 0, argc, argv);
03317     return NULL;
03318   }
03319 
03320   unless_evt = argv[1];
03321   target_evt = argv[2];
03322   if (!SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type))
03323     scheme_wrong_type("port-commit-peeked", "progress evt", 1, argc, argv);
03324   {
03325     Scheme_Type t;
03326     t = SCHEME_TYPE(target_evt);
03327     if (!SAME_TYPE(t, scheme_sema_type)
03328        && !SAME_TYPE(t, scheme_channel_type)
03329        && !SAME_TYPE(t, scheme_channel_put_type)
03330        && !SAME_TYPE(t, scheme_always_evt_type)
03331        && !SAME_TYPE(t, scheme_never_evt_type)
03332        && !SAME_TYPE(t, scheme_semaphore_repost_type))
03333       scheme_wrong_type("port-commit-peeked", "channel-put evt, channel, semaphore, semephore-peek evt, always evt, or never evt",
03334                      2, argc, argv);
03335   }
03336 
03337   if (argc > 3) {
03338     port = argv[3];
03339     if (!SCHEME_INPUT_PORTP(port))
03340       scheme_wrong_type("port-commit-peeked", "input-port", 3, argc, argv);
03341   } else
03342     port = CURRENT_INPUT_PORT(scheme_current_config());
03343 
03344   if (!SAME_OBJ(port, SCHEME_PTR1_VAL(unless_evt))) {
03345     scheme_arg_mismatch("port-commit-peeked",
03346                      "evt is not a progress evt for the given port: ",
03347                      unless_evt);
03348     return NULL;
03349   }
03350 
03351   v = scheme_peeked_read(port, size, unless_evt, target_evt);
03352 
03353   return (v ? scheme_true : scheme_false);
03354 }
03355 
03356 static Scheme_Object *
03357 peek_bytes_bang(int argc, Scheme_Object *argv[])
03358 {
03359   return do_general_read_bytes(1, "peek-bytes-avail!", argc, argv, 0, 1, 1);
03360 }
03361 
03362 static Scheme_Object *
03363 peek_bytes_bang_nonblock(int argc, Scheme_Object *argv[])
03364 {
03365   return do_general_read_bytes(1, "peek-bytes-avail!*", argc, argv, 0, 2, 1);
03366 }
03367 
03368 static Scheme_Object *
03369 sch_read_string(int argc, Scheme_Object *argv[])
03370 {
03371   return do_general_read_bytes(0, "read-string", argc, argv, 1, 0, 0);
03372 }
03373 
03374 static Scheme_Object *
03375 sch_read_string_bang(int argc, Scheme_Object *argv[])
03376 {
03377   return do_general_read_bytes(0, "read-string!", argc, argv, 0, 0, 0);
03378 }
03379 
03380 static Scheme_Object *
03381 sch_peek_string(int argc, Scheme_Object *argv[])
03382 {
03383   return do_general_read_bytes(0, "peek-string", argc, argv, 1, 0, 1);
03384 }
03385 
03386 static Scheme_Object *
03387 sch_peek_string_bang(int argc, Scheme_Object *argv[])
03388 {
03389   return do_general_read_bytes(0, "peek-string!", argc, argv, 0, 0, 1);
03390 }
03391 
03392 static Scheme_Object *
03393 read_bytes_bang_break(int argc, Scheme_Object *argv[])
03394 {
03395   return do_general_read_bytes(1, "read-bytes-avail!/enable-break", argc, argv, 0, -1, 0);
03396 }
03397 
03398 static Scheme_Object *
03399 peek_bytes_bang_break(int argc, Scheme_Object *argv[])
03400 {
03401   return do_general_read_bytes(1, "peek-bytes-avail!/enable-break", argc, argv, 0, -1, 1);
03402 }
03403 
03404 static Scheme_Object *
03405 progress_evt(int argc, Scheme_Object *argv[])
03406 {
03407   Scheme_Object *port, *v;
03408 
03409   if (argc) {
03410     if (!SCHEME_INPUT_PORTP(argv[0])) {
03411       scheme_wrong_type("port-progress-evt", "input-port", 0, argc, argv);
03412       return NULL;
03413     }
03414     port = argv[0];
03415   } else {
03416     port = CURRENT_INPUT_PORT(scheme_current_config());
03417   }
03418 
03419   v = scheme_progress_evt(port);
03420 
03421   if (!v) {
03422     scheme_arg_mismatch("port-progress-evt", "port does not provide progress evts: ", port);
03423     return NULL;
03424   } else
03425     return v;
03426 }
03427 
03428 static Scheme_Object *
03429 do_write_bytes_avail(int as_bytes, const char *who,
03430                    int argc, Scheme_Object *argv[],
03431                    int rarely_block, int get_evt)
03432 {
03433   Scheme_Object *port, *str;
03434   long size, start, finish, putten;
03435 
03436   if (as_bytes && !SCHEME_BYTE_STRINGP(argv[0])) {
03437     scheme_wrong_type(who, "byte string", 0, argc, argv);
03438     return NULL;
03439   } else if (!as_bytes && !SCHEME_CHAR_STRINGP(argv[0])) {
03440     scheme_wrong_type(who, "string", 0, argc, argv);
03441     return NULL;
03442   } else
03443     str = argv[0];
03444   if ((argc > 1) && !SCHEME_OUTPUT_PORTP(argv[1]))
03445     scheme_wrong_type(who, "output-port", 1, argc, argv);
03446 
03447   scheme_get_substring_indices(who, str,
03448                             argc, argv,
03449                             2, 3, &start, &finish);
03450 
03451   size = finish - start;
03452 
03453   if (argc > 1)
03454     port = argv[1];
03455   else
03456     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03457 
03458   if (get_evt)
03459     return scheme_make_write_evt(who, port,
03460                              NULL, SCHEME_BYTE_STR_VAL(str), start, size);
03461   else if (as_bytes)
03462     putten = scheme_put_byte_string(who, port,
03463                                 SCHEME_BYTE_STR_VAL(str), start, size,
03464                                 rarely_block);
03465   else
03466     putten = scheme_put_char_string(who, port,
03467                                 SCHEME_CHAR_STR_VAL(str), start, size);
03468 
03469   if (putten < 0)
03470     return scheme_false;
03471   else
03472     return scheme_make_integer(putten);
03473 }
03474 
03475 static Scheme_Object *
03476 write_bytes(int argc, Scheme_Object *argv[])
03477 {
03478   return do_write_bytes_avail(1, "write-bytes", argc, argv, 0, 0);
03479 }
03480 
03481 static Scheme_Object *
03482 write_bytes_avail(int argc, Scheme_Object *argv[])
03483 {
03484   return do_write_bytes_avail(1, "write-bytes-avail", argc, argv, 1, 0);
03485 }
03486 
03487 static Scheme_Object *
03488 write_bytes_avail_break(int argc, Scheme_Object *argv[])
03489 {
03490   return do_write_bytes_avail(1, "write-bytes-avail", argc, argv, -1, 0);
03491 }
03492 
03493 static Scheme_Object *
03494 write_bytes_avail_nonblock(int argc, Scheme_Object *argv[])
03495 {
03496   return do_write_bytes_avail(1, "write-bytes-avail*", argc, argv, 2, 0);
03497 }
03498 
03499 static Scheme_Object *
03500 write_string(int argc, Scheme_Object *argv[])
03501 {
03502   return do_write_bytes_avail(0, "write-string", argc, argv, 0, 0);
03503 }
03504 
03505 static Scheme_Object *
03506 write_bytes_avail_evt(int argc, Scheme_Object *argv[])
03507 {
03508   return do_write_bytes_avail(1, "write-bytes-avail-evt", argc, argv, 1, 1);
03509 }
03510 
03511 static Scheme_Object *
03512 do_write_special(const char *name, int argc, Scheme_Object *argv[], int nonblock, int get_evt)
03513 {
03514   Scheme_Output_Port *op;
03515   Scheme_Object *port;
03516   int ok;
03517 
03518   if (argc > 1) {
03519     if (!SCHEME_OUTPUT_PORTP(argv[1]))
03520       scheme_wrong_type(name, "output-port", 1, argc, argv);
03521     port = argv[1];
03522   } else
03523     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03524 
03525   op = scheme_output_port_record(port);
03526 
03527   if (op->write_special_fun) {
03528     if (get_evt) {
03529       return scheme_make_write_evt(name, port, argv[0], NULL, 0, 0);
03530     } else {
03531       Scheme_Write_Special_Fun ws = op->write_special_fun;
03532       ok = ws(op, argv[0], nonblock);
03533     }
03534   } else {
03535     scheme_arg_mismatch(name,
03536                      "port does not support special values: ",
03537                      port);
03538     return NULL;
03539   }
03540 
03541   if (ok) {
03542     Scheme_Port *ip;
03543     ip = scheme_port_record(port);
03544     if (ip->position >= 0)
03545       ip->position += 1;
03546     if (ip->count_lines) {
03547       ip->column += 1;
03548       ip->readpos += 1;
03549       ip->charsSinceNewline += 1;
03550       ip->utf8state = 0;
03551     }
03552     return scheme_true;
03553   } else
03554     return scheme_false;
03555 }
03556 
03557 static Scheme_Object *can_write_atomic(int argc, Scheme_Object *argv[])
03558 {
03559   Scheme_Output_Port *op;
03560 
03561   if (!SCHEME_OUTPUT_PORTP(argv[0]))
03562     scheme_wrong_type("port-writes-atomic?", "output-port", 0, argc, argv);
03563   
03564   op = scheme_output_port_record(argv[0]);
03565   if (op->write_string_evt_fun)
03566     return scheme_true;
03567   else
03568     return scheme_false;
03569 }
03570 
03571 static Scheme_Object *can_provide_progress_evt(int argc, Scheme_Object *argv[])
03572 {
03573   Scheme_Input_Port *ip;
03574 
03575   if (!SCHEME_INPUT_PORTP(argv[0]))
03576     scheme_wrong_type("port-provides-progress-evt?", "input-port", 0, argc, argv);
03577 
03578   ip = scheme_input_port_record(argv[0]);
03579 
03580   if (ip->progress_evt_fun)
03581     return scheme_true;
03582   else
03583     return scheme_false;
03584 }
03585 
03586 static Scheme_Object *
03587 can_write_special(int argc, Scheme_Object *argv[])
03588 {
03589   Scheme_Output_Port *op;
03590 
03591   if (!SCHEME_OUTPUT_PORTP(argv[0]))
03592     scheme_wrong_type("port-writes-special?", "output-port", 0, argc, argv);
03593 
03594   op = scheme_output_port_record(argv[0]);
03595 
03596   if (op->write_special_fun)
03597     return scheme_true;
03598   else
03599     return scheme_false;
03600 }
03601 
03602 Scheme_Object *
03603 scheme_write_special(int argc, Scheme_Object *argv[])
03604 {
03605   return do_write_special("write-special", argc, argv, 0, 0);
03606 }
03607 
03608 Scheme_Object *
03609 scheme_write_special_nonblock(int argc, Scheme_Object *argv[])
03610 {
03611   return do_write_special("write-special-avail*", argc, argv, 1, 0);
03612 }
03613 
03614 static Scheme_Object *
03615 write_special_evt(int argc, Scheme_Object *argv[])
03616 {
03617   return do_write_special("write-special-evt", argc, argv, 1, 1);
03618 }
03619 
03620 
03621 Scheme_Object *
03622 scheme_call_enable_break(Scheme_Prim *prim, int argc, Scheme_Object *argv[])
03623 {
03624   Scheme_Cont_Frame_Data cframe;
03625   Scheme_Object *v;
03626 
03627   scheme_push_break_enable(&cframe, 1, 1);
03628 
03629   v = prim(argc, argv);
03630 
03631   scheme_pop_break_enable(&cframe, 0);
03632 
03633   return v;
03634 }
03635 
03636 static Scheme_Object *
03637 eof_object_p (int argc, Scheme_Object *argv[])
03638 {
03639   return (SCHEME_EOFP(argv[0]) ? scheme_true : scheme_false);
03640 }
03641 
03642 static Scheme_Object *
03643 char_ready_p (int argc, Scheme_Object *argv[])
03644 {
03645   Scheme_Object *port;
03646 
03647   if (argc && !SCHEME_INPUT_PORTP(argv[0]))
03648     scheme_wrong_type("char-ready?", "input-port", 0, argc, argv);
03649 
03650   if (argc)
03651     port = argv[0];
03652   else
03653     port = CURRENT_INPUT_PORT(scheme_current_config());
03654 
03655   return (scheme_char_ready(port) ? scheme_true : scheme_false);
03656 }
03657 
03658 static Scheme_Object *
03659 byte_ready_p (int argc, Scheme_Object *argv[])
03660 {
03661   Scheme_Object *port;
03662 
03663   if (argc && !SCHEME_INPUT_PORTP(argv[0]))
03664     scheme_wrong_type("byte-ready?", "input-port", 0, argc, argv);
03665 
03666   if (argc)
03667     port = argv[0];
03668   else
03669     port = CURRENT_INPUT_PORT(scheme_current_config());
03670 
03671   return (scheme_byte_ready(port) ? scheme_true : scheme_false);
03672 }
03673 
03674 static Scheme_Object *sch_default_display_handler(int argc, Scheme_Object *argv[])
03675 {
03676   if (!SCHEME_OUTPUT_PORTP(argv[1]))
03677     scheme_wrong_type("default-port-display-handler", "output-port", 1, argc, argv);
03678 
03679   scheme_internal_display(argv[0], argv[1]);
03680 
03681   return scheme_void;
03682 }
03683 
03684 static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
03685 {
03686   if (!SCHEME_OUTPUT_PORTP(argv[1]))
03687     scheme_wrong_type("default-port-write-handler", "output-port", 1, argc, argv);
03688 
03689   scheme_internal_write(argv[0], argv[1]);
03690 
03691   return scheme_void;
03692 }
03693 
03694 static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[])
03695 {
03696   if (!SCHEME_OUTPUT_PORTP(argv[1]))
03697     scheme_wrong_type("default-port-print-handler", "output-port", 1, argc, argv);
03698 
03699   return _scheme_apply(scheme_get_param(scheme_current_config(),
03700                                    MZCONFIG_PORT_PRINT_HANDLER),
03701                      argc, argv);
03702 }
03703 
03704 static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[])
03705 {
03706   if (!SCHEME_OUTPUT_PORTP(argv[1]))
03707     scheme_wrong_type("default-global-port-print-handler", "output-port", 1, argc, argv);
03708 
03709   scheme_internal_print(argv[0], argv[1]);
03710 
03711   return scheme_void;
03712 }
03713 
03714 static Scheme_Object *
03715 display_write(char *name,
03716              int argc, Scheme_Object *argv[], int escape)
03717 {
03718   Scheme_Object *port;
03719   Scheme_Output_Port *op;
03720 
03721   if (argc > 1) {
03722     if (!SCHEME_OUTPUT_PORTP(argv[1]))
03723       scheme_wrong_type(name, "output-port", 1, argc, argv);
03724     port = argv[1];
03725   } else
03726     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03727 
03728   op = scheme_output_port_record(port);
03729 
03730   if (escape > 0) {
03731     /* display */
03732     if (!op->display_handler) {
03733       Scheme_Object *v = argv[0];
03734       if (SCHEME_BYTE_STRINGP(v)) {
03735        scheme_put_byte_string(name, port,
03736                             SCHEME_BYTE_STR_VAL(v), 0, SCHEME_BYTE_STRLEN_VAL(v),
03737                             0);
03738       } else if (SCHEME_CHAR_STRINGP(v)) {
03739        scheme_put_char_string(name, port,
03740                             SCHEME_CHAR_STR_VAL(v), 0, SCHEME_CHAR_STRLEN_VAL(v));
03741       } else if (SCHEME_SYMBOLP(v)) {
03742        scheme_put_byte_string(name, port,
03743                                (char *)v, ((char *)(SCHEME_SYM_VAL(v))) - ((char *)v), 
03744                                SCHEME_SYM_LEN(v),
03745                             0);
03746       } else 
03747        scheme_internal_display(v, port);
03748     } else {
03749       Scheme_Object *a[2];
03750       a[0] = argv[0];
03751       a[1] = port;
03752       _scheme_apply_multi(op->display_handler, 2, a);
03753     }
03754   } else if (!escape) {
03755     /* write */
03756     Scheme_Object *h;
03757 
03758     h = op->write_handler;
03759 
03760     if (!h)
03761       scheme_internal_write(argv[0], port);
03762     else {
03763       Scheme_Object *a[2];
03764       a[0] = argv[0];
03765       a[1] = port;
03766       _scheme_apply_multi(h, 2, a);
03767     }
03768   } else {
03769     /* print */
03770     Scheme_Object *h;
03771     Scheme_Object *a[2];
03772 
03773     a[0] = argv[0];
03774     a[1] = (Scheme_Object *)port;
03775 
03776     h = op->print_handler;
03777 
03778     if (!h)
03779       sch_default_print_handler(2, a);
03780     else
03781       _scheme_apply_multi(h, 2, a);
03782   }
03783 
03784   return scheme_void;
03785 }
03786 
03787 static Scheme_Object *
03788 sch_write (int argc, Scheme_Object *argv[])
03789 {
03790   return display_write("write", argc, argv, 0);
03791 }
03792 
03793 static Scheme_Object *
03794 display (int argc, Scheme_Object *argv[])
03795 {
03796   return display_write("display", argc, argv, 1);
03797 }
03798 
03799 static Scheme_Object *
03800 sch_print (int argc, Scheme_Object *argv[])
03801 {
03802   return display_write("print", argc, argv, -1);
03803 }
03804 
03805 static Scheme_Object *
03806 newline (int argc, Scheme_Object *argv[])
03807 {
03808   Scheme_Object *port;
03809 
03810   if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
03811     scheme_wrong_type("newline", "output-port", 0, argc, argv);
03812 
03813   if (argc)
03814     port = argv[0];
03815   else
03816     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03817 
03818   (void)scheme_put_byte_string("newline", port, "\n", 0, 1, 0);
03819 
03820   return scheme_void;
03821 }
03822 
03823 static Scheme_Object *
03824 write_byte (int argc, Scheme_Object *argv[])
03825 {
03826   Scheme_Object *port;
03827   int v;
03828   unsigned char buffer[1];
03829 
03830   if (argc && !SCHEME_INTP(argv[0]))
03831     scheme_wrong_type("write-byte", "exact integer in [0,255]", 0, argc, argv);
03832   v = SCHEME_INT_VAL(argv[0]);
03833   if ((v < 0) || (v > 255))
03834     scheme_wrong_type("write-byte", "exact integer in [0,255]", 0, argc, argv);
03835 
03836   if (argc > 1) {
03837     if (!SCHEME_OUTPUT_PORTP(argv[1]))
03838       scheme_wrong_type("write-byte", "output-port", 1, argc, argv);
03839     port = argv[1];
03840   } else
03841     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03842 
03843   buffer[0] = v;
03844 
03845   scheme_put_byte_string("write-byte", port,
03846                       (char *)buffer, 0, 1,
03847                       0);
03848 
03849   return scheme_void;
03850 }
03851 
03852 static Scheme_Object *
03853 write_char (int argc, Scheme_Object *argv[])
03854 {
03855   Scheme_Object *port;
03856   unsigned char buffer[MAX_UTF8_CHAR_BYTES];
03857   unsigned int ubuffer[1];
03858   int len;
03859 
03860   if (argc && !SCHEME_CHARP(argv[0]))
03861     scheme_wrong_type("write-char", "character", 0, argc, argv);
03862   if (argc > 1) {
03863     if (!SCHEME_OUTPUT_PORTP(argv[1]))
03864       scheme_wrong_type("write-char", "output-port", 1, argc, argv);
03865     port = argv[1];
03866   } else
03867     port = CURRENT_OUTPUT_PORT(scheme_current_config());
03868 
03869   ubuffer[0] = SCHEME_CHAR_VAL(argv[0]);
03870   len = scheme_utf8_encode_all(ubuffer, 1, buffer);
03871 
03872   scheme_put_byte_string("write-char", port,
03873                       (char *)buffer, 0, len,
03874                       0);
03875 
03876   return scheme_void;
03877 }
03878 
03879 static Scheme_Object *port_read_handler(int argc, Scheme_Object *argv[])
03880 {
03881   Scheme_Input_Port *ip;
03882 
03883   if (!SCHEME_INPUT_PORTP(argv[0]))
03884     scheme_wrong_type("port-read-handler", "input-port", 0, argc, argv);
03885 
03886   ip = scheme_input_port_record(argv[0]);
03887   if (argc == 1) {
03888     if (ip->read_handler)
03889       return ip->read_handler;
03890     else
03891       return default_read_handler;
03892   } else {
03893     if (argv[1] == default_read_handler)
03894       ip->read_handler = NULL;
03895     else {
03896       if (!scheme_check_proc_arity(NULL, 1, 1, argc, argv)
03897          || !scheme_check_proc_arity(NULL, 2, 1, argc, argv)) {
03898        scheme_wrong_type("port-read-handler", "procedure (arity 1 and 2)", 1, argc, argv);
03899        return NULL;
03900       }
03901 
03902       ip->read_handler = argv[1];
03903     }
03904 
03905     return scheme_void;
03906   }
03907 }
03908 
03909 static Scheme_Object *port_display_handler(int argc, Scheme_Object *argv[])
03910 {
03911   Scheme_Output_Port *op;
03912 
03913   if (!SCHEME_OUTPUT_PORTP(argv[0]))
03914     scheme_wrong_type("port-display-handler", "output-port", 0, argc, argv);
03915 
03916   op = scheme_output_port_record(argv[0]);
03917   if (argc == 1) {
03918     if (op->display_handler)
03919       return op->display_handler;
03920     else
03921       return default_display_handler;
03922   } else {
03923     scheme_check_proc_arity("port-display-handler", 2, 1, argc, argv);
03924     if (argv[1] == default_display_handler)
03925       op->display_handler = NULL;
03926     else
03927       op->display_handler = argv[1];
03928 
03929     return scheme_void;
03930   }
03931 }
03932 
03933 static Scheme_Object *port_write_handler(int argc, Scheme_Object *argv[])
03934 {
03935   Scheme_Output_Port *op;
03936 
03937   if (!SCHEME_OUTPUT_PORTP(argv[0]))
03938     scheme_wrong_type("port-write-handler", "output-port", 0, argc, argv);
03939 
03940   op = scheme_output_port_record(argv[0]);
03941   if (argc == 1) {
03942     if (op->write_handler)
03943       return op->write_handler;
03944     else
03945       return default_write_handler;
03946   } else {
03947     scheme_check_proc_arity("port-write-handler", 2, 1, argc, argv);
03948     if (argv[1] == default_write_handler)
03949       op->write_handler = NULL;
03950     else
03951       op->write_handler = argv[1];
03952 
03953     return scheme_void;
03954   }
03955 }
03956 
03957 static Scheme_Object *port_print_handler(int argc, Scheme_Object *argv[])
03958 {
03959   Scheme_Output_Port *op;
03960 
03961   if (!SCHEME_OUTPUT_PORTP(argv[0]))
03962     scheme_wrong_type("port-print-handler", "output-port", 0, argc, argv);
03963 
03964   op = scheme_output_port_record(argv[0]);
03965   if (argc == 1) {
03966     if (op->print_handler)
03967       return op->print_handler;
03968     else
03969       return default_print_handler;
03970   } else {
03971     scheme_check_proc_arity("port-print-handler", 2, 1, argc, argv);
03972     if (argv[1] == default_print_handler)
03973       op->print_handler = NULL;
03974     else
03975       op->print_handler = argv[1];
03976 
03977     return scheme_void;
03978   }
03979 }
03980 
03981 static Scheme_Object *global_port_print_handler(int argc, Scheme_Object *argv[])
03982 {
03983   return scheme_param_config("global-port-print-handler",
03984                           scheme_make_integer(MZCONFIG_PORT_PRINT_HANDLER),
03985                           argc, argv,
03986                           2, NULL, NULL, 0);
03987 }
03988 
03989 static Scheme_Object *port_count_lines(int argc, Scheme_Object *argv[])
03990 {
03991   if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
03992     scheme_wrong_type("port-count-lines!", "port", 0, argc, argv);
03993 
03994   scheme_count_lines(argv[0]);
03995 
03996   return scheme_void;
03997 }
03998 
03999 static Scheme_Object *global_port_count_lines(int argc, Scheme_Object **argv)
04000 {
04001   return scheme_param_config("port-count-lines-enabled",
04002                           scheme_make_integer(MZCONFIG_PORT_COUNT_LINES),
04003                           argc, argv, -1, NULL, NULL, 1);
04004 }
04005 
04006 static Scheme_Object *port_next_location(int argc, Scheme_Object *argv[])
04007 {
04008   Scheme_Object *a[3];
04009   long line, col, pos;
04010 
04011   if (!SCHEME_INPUT_PORTP(argv[0]) && !SCHEME_OUTPUT_PORTP(argv[0]))
04012     scheme_wrong_type("port-next-location", "port", 0, argc, argv);
04013 
04014   scheme_tell_all(argv[0], &line, &col, &pos);
04015 
04016   a[0] = ((line < 0) ? scheme_false : scheme_make_integer_value(line));
04017   a[1] = ((col < 0) ? scheme_false : scheme_make_integer_value(col));
04018   a[2] = ((pos < 0) ? scheme_false : scheme_make_integer_value(pos+1));
04019 
04020   return scheme_values(3, a);
04021 }
04022 
04023 typedef struct {
04024   MZTAG_IF_REQUIRED
04025   Scheme_Config *config;
04026   Scheme_Object *port;
04027   Scheme_Thread *p;
04028   Scheme_Object *stxsrc;
04029   Scheme_Object *expected_module;
04030   Scheme_Object *delay_load_info;
04031 } LoadHandlerData;
04032 
04033 static void post_load_handler(void *data)
04034 {
04035   LoadHandlerData *lhd = (LoadHandlerData *)data;
04036 
04037   scheme_close_input_port((Scheme_Object *)lhd->port);
04038 }
04039 
04040 static Scheme_Object *do_load_handler(void *data)
04041 {
04042   LoadHandlerData *lhd = (LoadHandlerData *)data;
04043   Scheme_Object *port = lhd->port;
04044   Scheme_Thread *p = lhd->p;
04045   Scheme_Config *config = lhd->config;
04046   Scheme_Object *last_val = scheme_void, *obj, **save_array = NULL;
04047   Scheme_Env *genv;
04048   int save_count = 0, got_one = 0, as_module;
04049 
04050   while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, 0, -1, NULL, 
04051                                      NULL, NULL, lhd->delay_load_info))
04052         && !SCHEME_EOFP(obj)) {
04053     save_array = NULL;
04054     got_one = 1;
04055 
04056     /* ... begin special support for module loading ... */
04057 
04058     genv = scheme_get_env(config);
04059     as_module = 0;
04060 
04061     if (SCHEME_SYMBOLP(lhd->expected_module)) {
04062       /* Must be of the form `(module <expectedname> ...)',possibly compiled. */
04063       /* Also, file should have no more expressions. */
04064       Scheme_Object *a, *d, *other = NULL;
04065       Scheme_Module *m;
04066 
04067       d = obj;
04068 
04069       m = scheme_extract_compiled_module(SCHEME_STX_VAL(d));
04070       if (m) {
04071        if (!SAME_OBJ(SCHEME_PTR_VAL(m->modname), lhd->expected_module)) {
04072          other = m->modname;
04073          d = NULL;
04074        }
04075       } else {
04076        if (!SCHEME_STX_PAIRP(d))
04077          d = NULL;
04078        else {
04079          a = SCHEME_STX_CAR(d);
04080          if (!SAME_OBJ(SCHEME_STX_VAL(a), module_symbol))
04081            d = NULL;
04082          else {
04083            d = SCHEME_STX_CDR(d);
04084            if (!SCHEME_STX_PAIRP(d))
04085              d = NULL;
04086            else {
04087              a = SCHEME_STX_CAR(d);
04088              other = SCHEME_STX_VAL(a);
04089              if (!SAME_OBJ(other, lhd->expected_module))
04090               d = NULL;
04091            }
04092          }
04093        }
04094       }
04095 
04096       /* If d is NULL, shape was wrong */
04097       if (!d) {
04098        if (!other || !SCHEME_SYMBOLP(other))
04099          other = scheme_make_byte_string("something else");
04100        else {
04101          char *s, *t;
04102          long len, slen;
04103 
04104          t = "declaration for `";
04105          len = strlen(t);
04106          slen = SCHEME_SYM_LEN(other);
04107 
04108          s = (char *)scheme_malloc_atomic(len + slen + 2);
04109          memcpy(s, t, len);
04110          memcpy(s + len, SCHEME_SYM_VAL(other), slen);
04111          s[len + slen] = '\'';
04112          s[len + slen + 1]= 0;
04113 
04114          other = scheme_make_sized_byte_string(s, len + slen + 1, 0);
04115        }
04116 
04117         {
04118           Scheme_Input_Port *ip;
04119           ip = scheme_input_port_record(port);
04120           scheme_raise_exn(MZEXN_FAIL,
04121                            "default-load-handler: expected a `module' declaration for `%S', found: %T in: %V",
04122                            lhd->expected_module,
04123                            other,
04124                            ip->name);
04125         }
04126 
04127        return NULL;
04128       }
04129 
04130       /* Check no more expressions: */
04131       d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
04132       if (!SCHEME_EOFP(d)) {
04133         Scheme_Input_Port *ip;
04134         ip = scheme_input_port_record(port);
04135        scheme_raise_exn(MZEXN_FAIL,
04136                       "default-load-handler: expected only a `module' declaration for `%S',"
04137                          " but found an extra expression in: %V",
04138                       lhd->expected_module,
04139                       ip->name);
04140 
04141        return NULL;
04142       }
04143 
04144       if (!m) {
04145        /* Replace `module' in read expression with one bound to #%kernel's `module': */
04146        a = SCHEME_STX_CAR(obj);
04147        d = SCHEME_STX_CDR(obj);
04148        a = scheme_datum_to_syntax(module_symbol, a, 
04149                                    scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), 
04150                                    0, 1);
04151        d = scheme_make_pair(a, d);
04152        obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1);
04153         as_module = 1;
04154       }
04155     } else {
04156       /* Add #%top-interaction, since we're in non-module mode: */
04157       Scheme_Object *a;
04158       a = scheme_make_pair(scheme_intern_symbol("#%top-interaction"), obj);
04159       obj = scheme_datum_to_syntax(a, obj, scheme_false, 0, 0);
04160     }
04161 
04162     /* ... end special support for module loading ... */
04163 
04164     if (!as_module && genv->rename_set)
04165       obj = scheme_add_rename(obj, genv->rename_set);
04166 
04167     last_val = _scheme_apply_multi_with_prompt(scheme_get_param(config, MZCONFIG_EVAL_HANDLER),
04168                                                1, &obj);
04169 
04170     /* If multi, we must save then: */
04171     if (last_val == SCHEME_MULTIPLE_VALUES) {
04172       save_array = p->ku.multiple.array;
04173       save_count = p->ku.multiple.count;
04174 
04175       if (SAME_OBJ(save_array, p->values_buffer))
04176        p->values_buffer = NULL;
04177     }
04178 
04179     if (SCHEME_SYMBOLP(lhd->expected_module))
04180       break;
04181   }
04182 
04183   if (SCHEME_SYMBOLP(lhd->expected_module) && !got_one) {
04184     Scheme_Input_Port *ip;
04185     ip = scheme_input_port_record(port);
04186     scheme_raise_exn(MZEXN_FAIL,
04187                    "default-load-handler: expected a `module' declaration for `%S', but found end-of-file in: %V",
04188                    lhd->expected_module,
04189                    ip->name);
04190 
04191     return NULL;
04192   }
04193 
04194   if (save_array) {
04195     p->ku.multiple.array = save_array;
04196     p->ku.multiple.count = save_count;
04197   }
04198 
04199   return last_val;
04200 }
04201 
04202 static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
04203 {
04204   Scheme_Object *port, *name, *expected_module, *v;
04205   int use_delay_load;
04206   Scheme_Thread *p = scheme_current_thread;
04207   Scheme_Config *config;
04208   LoadHandlerData *lhd;
04209   Scheme_Cont_Frame_Data cframe;
04210 
04211   if (!SCHEME_PATH_STRINGP(argv[0]))
04212     scheme_wrong_type("default-load-handler", SCHEME_PATH_STRING_STR, 0, argc, argv);
04213   expected_module = argv[1];
04214   if (!SCHEME_FALSEP(expected_module) && !SCHEME_SYMBOLP(expected_module))
04215     scheme_wrong_type("default-load-handler", "symbol or #f", 1, argc, argv);
04216 
04217   port = scheme_do_open_input_file("default-load-handler", 0, 1, argv, 0);
04218 
04219   /* Turn on line/column counting, unless it's a .zo file: */
04220   if (SCHEME_PATHP(argv[0])) {
04221     long len;
04222 
04223     len = SCHEME_BYTE_STRLEN_VAL(argv[0]);
04224     if ((len < 3)
04225        || (SCHEME_BYTE_STR_VAL(argv[0])[len - 3] != '.')
04226        || (SCHEME_BYTE_STR_VAL(argv[0])[len - 2] != 'z')
04227        || (SCHEME_BYTE_STR_VAL(argv[0])[len - 1] != 'o'))
04228       scheme_count_lines(port);
04229   } else {
04230     long len;
04231 
04232     len = SCHEME_CHAR_STRLEN_VAL(argv[0]);
04233     if ((len < 3)
04234        || (SCHEME_CHAR_STR_VAL(argv[0])[len - 3] != '.')
04235        || (SCHEME_CHAR_STR_VAL(argv[0])[len - 2] != 'z')
04236        || (SCHEME_CHAR_STR_VAL(argv[0])[len - 1] != 'o'))
04237       scheme_count_lines(port);
04238   }
04239 
04240   config = scheme_current_config();
04241 
04242   v = scheme_get_param(config, MZCONFIG_LOAD_DELAY_ENABLED);
04243   use_delay_load = SCHEME_TRUEP(v);
04244 
04245   if (SCHEME_TRUEP(expected_module)) {
04246     config = scheme_extend_config(config, MZCONFIG_CASE_SENS, 
04247                                   (scheme_case_sensitive ? scheme_true : scheme_false)); /* for legacy code */
04248     config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, scheme_true);
04249     config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_PARENS, scheme_true);
04250     config = scheme_extend_config(config, MZCONFIG_CAN_READ_GRAPH, scheme_true);
04251     config = scheme_extend_config(config, MZCONFIG_CAN_READ_COMPILED, scheme_true);
04252     config = scheme_extend_config(config, MZCONFIG_CAN_READ_BOX, scheme_true);
04253     config = scheme_extend_config(config, MZCONFIG_CAN_READ_PIPE_QUOTE, scheme_true);
04254     config = scheme_extend_config(config, MZCONFIG_CAN_READ_DOT, scheme_true);
04255     config = scheme_extend_config(config, MZCONFIG_CAN_READ_INFIX_DOT, scheme_true);
04256     config = scheme_extend_config(config, MZCONFIG_CAN_READ_QUASI, scheme_true);
04257     config = scheme_extend_config(config, MZCONFIG_CAN_READ_READER, scheme_true);
04258     config = scheme_extend_config(config, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true);
04259     config = scheme_extend_config(config, MZCONFIG_READTABLE, scheme_false);
04260   }
04261 
04262   lhd = MALLOC_ONE_RT(LoadHandlerData);
04263 #ifdef MZTAG_REQUIRED
04264   lhd->type = scheme_rt_load_handler_data;
04265 #endif
04266   lhd->p = p;
04267   lhd->config = config;
04268   lhd->port = port;
04269   name = scheme_input_port_record(port)->name;
04270   lhd->stxsrc = name;
04271   lhd->expected_module = expected_module;
04272   if (use_delay_load) {
04273     v = scheme_path_to_complete_path(argv[0], NULL);
04274     lhd->delay_load_info = v;
04275   }
04276 
04277   if (SCHEME_TRUEP(expected_module)) {
04278     scheme_push_continuation_frame(&cframe);
04279     scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
04280   }
04281 
04282   v = scheme_dynamic_wind(NULL, do_load_handler, post_load_handler,
04283                        NULL, (void *)lhd);
04284 
04285   if (SCHEME_TRUEP(expected_module)) {
04286     scheme_pop_continuation_frame(&cframe);
04287   }
04288 
04289   return v;
04290 }
04291 
04292 Scheme_Object *scheme_load_with_clrd(int argc, Scheme_Object *argv[],
04293                                  char *who, int handler_param)
04294 {
04295   const char *filename;
04296   Scheme_Object *load_dir, *a[2], *filename_path, *v;
04297   Scheme_Cont_Frame_Data cframe;
04298   Scheme_Config *config;
04299 
04300   if (!SCHEME_PATH_STRINGP(argv[0]))
04301     scheme_wrong_type(who, SCHEME_PATH_STRING_STR, 0, argc, argv);
04302 
04303   filename = scheme_expand_string_filename(argv[0],
04304                                       who,
04305                                       NULL,
04306                                       SCHEME_GUARD_FILE_READ);
04307 
04308   /* Calculate load directory */
04309   load_dir = scheme_get_file_directory(filename);
04310 
04311   filename_path = scheme_make_sized_path((char *)filename, -1, 0);
04312 
04313   config = scheme_extend_config(scheme_current_config(),
04314                             MZCONFIG_LOAD_DIRECTORY,
04315                             load_dir);
04316 
04317   scheme_push_continuation_frame(&cframe);
04318   scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
04319 
04320   a[0] = filename_path;
04321   a[1] = scheme_false;
04322   v = _scheme_apply_multi(scheme_get_param(config, handler_param), 2, a);
04323 
04324   scheme_pop_continuation_frame(&cframe);
04325 
04326   return v;
04327 }
04328 
04329 static Scheme_Object *load(int argc, Scheme_Object *argv[])
04330 {
04331   return scheme_load_with_clrd(argc, argv, "load", MZCONFIG_LOAD_HANDLER);
04332 }
04333 
04334 static Scheme_Object *
04335 current_load(int argc, Scheme_Object *argv[])
04336 {
04337   return scheme_param_config("current-load",
04338                           scheme_make_integer(MZCONFIG_LOAD_HANDLER),
04339                           argc, argv,
04340                           2, NULL, NULL, 0);
04341 }
04342 
04343 static Scheme_Object *
04344 current_load_use_compiled(int argc, Scheme_Object *argv[])
04345 {
04346   return scheme_param_config("current-load/use-compiled",
04347                           scheme_make_integer(MZCONFIG_LOAD_COMPILED_HANDLER),
04348                           argc, argv,
04349                           2, NULL, NULL, 0);
04350 }
04351 
04352 static Scheme_Object *abs_directory_p(const char *name, int argc, Scheme_Object **argv)
04353 {
04354   Scheme_Object *d = argv[0];
04355 
04356   if (!SCHEME_FALSEP(d)) {
04357     char *expanded;
04358     Scheme_Object *ed;
04359     char *s;
04360     int len;
04361 
04362     if (!SCHEME_PATH_STRINGP(d))
04363       return NULL;
04364 
04365     ed = (SCHEME_PATHP(d) ? d : scheme_char_string_to_path(d));
04366     s = SCHEME_BYTE_STR_VAL(ed);
04367     len = SCHEME_BYTE_STRTAG_VAL(ed);
04368 
04369     if (!scheme_is_complete_path(s, len, SCHEME_PLATFORM_PATH_KIND))
04370       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04371                      "%s: not a complete path: \"%q\"",
04372                      name,
04373                      s);
04374 
04375     expanded = scheme_expand_string_filename(d, name, NULL,
04376                                         SCHEME_GUARD_FILE_EXISTS);
04377     ed = scheme_make_sized_path(expanded, strlen(expanded), 1);
04378 
04379     return ed;
04380   }
04381 
04382   return scheme_false;
04383 }
04384 
04385 static Scheme_Object *lr_abs_directory_p(int argc, Scheme_Object **argv)
04386 {
04387   return abs_directory_p("current-load-relative-directory", argc, argv);
04388 }
04389 
04390 static Scheme_Object *
04391 current_load_directory(int argc, Scheme_Object *argv[])
04392 {
04393   return scheme_param_config("current-load-relative-directory",
04394                           scheme_make_integer(MZCONFIG_LOAD_DIRECTORY),
04395                           argc, argv,
04396                           -1, lr_abs_directory_p, "path, string, or #f", 1);
04397 }
04398 
04399 static Scheme_Object *wr_abs_directory_p(int argc, Scheme_Object **argv)
04400 {
04401   return abs_directory_p("current-write-relative-directory", argc, argv);
04402 }
04403 
04404 static Scheme_Object *
04405 current_write_directory(int argc, Scheme_Object *argv[])
04406 {
04407   return scheme_param_config("current-write-relative-directory",
04408                           scheme_make_integer(MZCONFIG_WRITE_DIRECTORY),
04409                           argc, argv,
04410                           -1, wr_abs_directory_p, "path, string, or #f", 1);
04411 }
04412 
04413 #ifdef LOAD_ON_DEMAND
04414 static Scheme_Object *
04415 load_on_demand_enabled(int argc, Scheme_Object *argv[])
04416 {
04417   return scheme_param_config("load-on-demand-enabled", 
04418                              scheme_make_integer(MZCONFIG_LOAD_DELAY_ENABLED), 
04419                              argc, argv, -1, NULL, NULL, 1);
04420 }
04421 #endif
04422 
04423 Scheme_Object *scheme_load(const char *file)
04424 {
04425   Scheme_Object *p[1];
04426   mz_jmp_buf newbuf, * volatile savebuf;
04427   Scheme_Object * volatile val;
04428 
04429   p[0] = scheme_make_path(file);
04430   savebuf = scheme_current_thread->error_buf;
04431   scheme_current_thread->error_buf = &newbuf;
04432   if (scheme_setjmp(newbuf)) {
04433     val = NULL;
04434   } else {
04435     val = scheme_apply_multi(scheme_make_prim((Scheme_Prim *)load),
04436                              1, p);
04437   }
04438   scheme_current_thread->error_buf = savebuf;
04439 
04440   return val;
04441 }
04442 
04443 static Scheme_Object *
04444 flush_output(int argc, Scheme_Object *argv[])
04445 {
04446   Scheme_Object *op;
04447 
04448   if (argc && !SCHEME_OUTPUT_PORTP(argv[0]))
04449     scheme_wrong_type("flush-output", "output-port", 0, argc, argv);
04450 
04451   if (argc)
04452     op = argv[0];
04453   else
04454     op = CURRENT_OUTPUT_PORT(scheme_current_config());
04455 
04456   scheme_flush_output(op);
04457 
04458   return (scheme_void);
04459 }
04460 
04461 /*========================================================================*/
04462 /*                       precise GC traversers                            */
04463 /*========================================================================*/
04464 
04465 #ifdef MZ_PRECISE_GC
04466 
04467 START_XFORM_SKIP;
04468 
04469 #define MARKS_FOR_PORTFUN_C
04470 #include "mzmark.c"
04471 
04472 static void register_traversers(void)
04473 {
04474   GC_REG_TRAV(scheme_rt_indexed_string, mark_indexed_string);
04475   GC_REG_TRAV(scheme_rt_load_handler_data, mark_load_handler_data);
04476   GC_REG_TRAV(scheme_rt_user_input, mark_user_input);
04477   GC_REG_TRAV(scheme_rt_user_output, mark_user_output);
04478 }
04479 
04480 END_XFORM_SKIP;
04481 
04482 #endif