Back to index

plt-scheme  4.2.1
port.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-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 most platform-specific aspects of MzScheme
00027    port types, which means it deals with all the messy FILE and file
00028    descriptor issues, as well as implementing TCP. Also, `subprocess'
00029    is implemented here, since much of the work has to do with
00030    ports. */
00031 
00032 #include "schpriv.h"
00033 #include "schmach.h"
00034 #ifdef UNISTD_INCLUDE
00035 # include <unistd.h>
00036 #endif
00037 #ifdef USE_ULIMIT
00038 # include <ulimit.h>
00039 #endif
00040 #ifdef FILES_HAVE_FDS
00041 # include <fcntl.h>
00042 # include <sys/types.h>
00043 # include <sys/time.h>
00044 # ifdef BSTRING_INCLUDE
00045 #  include <bstring.h>
00046 # endif
00047 # ifdef SELECT_INCLUDE
00048 #  include <sys/select.h>
00049 # endif
00050 #endif
00051 #ifdef USE_ITIMER
00052 # include <sys/types.h>
00053 # include <sys/time.h>
00054 # include <signal.h>
00055 #endif
00056 #if defined(UNIX_PROCESSES)
00057 # include <signal.h>
00058 # include <sys/types.h>
00059 # include <sys/wait.h>
00060 #endif
00061 #ifdef IO_INCLUDE
00062 # include <io.h>
00063 #endif
00064 #ifdef NO_ERRNO_GLOBAL
00065 static int mzerrno = 0;
00066 # define errno mzerrno
00067 #else
00068 # include <errno.h>
00069 #endif
00070 #ifndef DONT_IGNORE_PIPE_SIGNAL
00071 # include <signal.h>
00072 #endif
00073 #ifdef USE_OSKIT_CONSOLE
00074 # ifndef OSKIT_TEST
00075 #  include <x86/pc/direct_cons.h>
00076 # endif
00077 extern int osk_not_console; /* set by cmd-line flag */
00078 #endif
00079 #include <math.h> /* for fmod , used by default_sleep */
00080 #include "schfd.h"
00081 
00082 #ifndef MZ_BINARY
00083 # define MZ_BINARY 0
00084 #endif
00085 
00086 #define mzAssert(x) /* if (!(x)) abort() */
00087 
00088 /******************** Generic FILEs ********************/
00089 
00090 typedef struct {
00091   MZTAG_IF_REQUIRED
00092   FILE *f;
00093 } Scheme_Input_File;
00094 
00095 typedef struct {
00096   MZTAG_IF_REQUIRED
00097   FILE *f;
00098 } Scheme_Output_File;
00099 
00100 /******************** Windows I/O and Subprocesses ********************/
00101 
00102 #if defined(WINDOWS_PROCESSES) || defined(WINDOWS_FILE_HANDLES)
00103 
00104 static void init_thread_memory();
00105 
00106 # define WIN32_FD_HANDLES
00107 # include <winsock2.h>
00108 # include <windows.h>
00109 # include <process.h>
00110 # include <signal.h>
00111 # include <io.h>
00112 # include <fcntl.h>
00113 # define OS_SEMAPHORE_TYPE HANDLE
00114 # define OS_MUTEX_TYPE CRITICAL_SECTION
00115 # define OS_THREAD_TYPE HANDLE
00116 #endif
00117 
00118 #ifdef WINDOWS_FILE_HANDLES
00119 
00120 # define MZ_FDS
00121 
00122 typedef struct Win_FD_Input_Thread {
00123   /* This is malloced for use in a Win32 thread */
00124   HANDLE fd;
00125   volatile int avail, err, checking;
00126   int *refcount;
00127   HANDLE eof;
00128   unsigned char *buffer;
00129   HANDLE checking_sema, ready_sema, you_clean_up_sema;
00130   HANDLE thread;
00131 } Win_FD_Input_Thread;
00132 
00133 static HANDLE refcount_sema;
00134 
00135 typedef struct Win_FD_Output_Thread {
00136   /* This is malloced for use in a Win32 thread */
00137   HANDLE fd;
00138   int nonblocking;  /* non-zero => an NT pipe where non-blocking WriteFile
00139                      works. We still use a thread to detect when the
00140                      write has ben flushed, which in turn is needed to
00141                      know whether future writes will immediately succeed. */
00142   volatile flushed, needflush; /* Used for non-blocking, only. The flushed
00143                               flag communicates from the flush-testing thread
00144                               to the main thread. For efficiency, we request
00145                               flush checking only when needed (instead of
00146                               after every write); needflush indicates that
00147                               a flush check is currently needed, but hasn't
00148                               been started. */
00149   volatile int done, err_no;
00150   volatile unsigned int buflen, bufstart, bufend; /* used for blocking, only */
00151   unsigned char *buffer; /* used for blocking, only */
00152   int *refcount;
00153   HANDLE lock_sema, work_sema, ready_sema, you_clean_up_sema;
00154   /* lock_sema protects the fields, work_sema starts the flush or
00155      flush-checking thread to work, ready_sema indicates that a flush
00156      finished, and you_clean_up_sema is essentially a reference
00157      count */
00158   HANDLE thread;
00159 } Win_FD_Output_Thread;
00160 
00161 int scheme_stupid_windows_machine;
00162 
00163 #endif
00164 
00165 #if defined(WINDOWS_PROCESSES)
00166 # include <ctype.h>
00167 #endif
00168 
00169 /******************** Unix Subprocesses ********************/
00170 
00171 #if defined(UNIX_PROCESSES)
00172 /* For process & system: */
00173 typedef struct System_Child {
00174   MZTAG_IF_REQUIRED
00175   pid_t id;
00176   short done;
00177   int status;
00178   struct System_Child *next;
00179 } System_Child;
00180 
00181 System_Child *scheme_system_children;
00182 #endif
00183 
00184 typedef struct Scheme_Subprocess {
00185   Scheme_Object so;
00186   void *handle;
00187   int pid;
00188 } Scheme_Subprocess;
00189 
00190 #ifdef USE_FD_PORTS
00191 # include <fcntl.h>
00192 # include <sys/stat.h>
00193 # define MZ_FDS
00194 #endif
00195 
00196 /******************** refcounts ********************/
00197 
00198 #ifdef WINDOWS_FILE_HANDLES
00199 
00200 static int *malloc_refcount()
00201 {
00202   if (!refcount_sema)
00203     refcount_sema = CreateSemaphore(NULL, 1, 1, NULL);
00204 
00205   return (int *)malloc(sizeof(int));
00206 }
00207 
00208 #ifdef MZ_XFORM
00209 START_XFORM_SKIP;
00210 #endif
00211 
00212 static int dec_refcount(int *refcount)
00213 {
00214   int rc;
00215 
00216   if (!refcount)
00217     return 0;
00218 
00219   WaitForSingleObject(refcount_sema, INFINITE);
00220   *refcount -= 1;
00221   rc = *refcount;
00222   ReleaseSemaphore(refcount_sema, 1, NULL);
00223 
00224   if (!rc) free(refcount);
00225 
00226   return rc;
00227 }
00228 
00229 #ifdef MZ_XFORM
00230 END_XFORM_SKIP;
00231 #endif
00232 
00233 #else
00234 
00235 static int *malloc_refcount()
00236 {
00237   return (int *)scheme_malloc_atomic(sizeof(int));
00238 }
00239 
00240 static int dec_refcount(int *refcount)
00241 {
00242   if (!refcount)
00243     return 0;
00244   *refcount -= 1;
00245   return *refcount;
00246 }
00247 
00248 #endif
00249 
00250 /******************** file-descriptor I/O ********************/
00251 
00252 /* Windows/Mac I/O is piggy-backed on Unix file-descriptor I/O.  Making
00253    Windows file HANDLEs behave as nicely as file descriptors for
00254    non-blocking I/O requires a lot of work, and often a separate
00255    thread. The "th" and "oth" fields of Scheme_FD point to malloced
00256    (non-GCed) records that mediate the threads. */
00257 
00258 #ifdef MZ_FDS
00259 
00260 # define MZPORT_FD_BUFFSIZE 4096
00261 # define MZPORT_FD_DIRECT_THRESHOLD MZPORT_FD_BUFFSIZE
00262 
00263 /* The Scheme_FD type is used for both input and output */
00264 typedef struct Scheme_FD {
00265   MZTAG_IF_REQUIRED
00266   long fd;                   /* fd is really a HANDLE in Windows */
00267   long bufcount, buffpos;
00268   char flushing, regfile, flush;
00269   char textmode; /* Windows: textmode => CRLF conversion; SOME_FDS_... => select definitely works */
00270   unsigned char *buffer;
00271   int *refcount;
00272 
00273 # ifdef WINDOWS_FILE_HANDLES
00274   Win_FD_Input_Thread *th;   /* input mode */
00275   Win_FD_Output_Thread *oth; /* output mode */
00276 # endif
00277 } Scheme_FD;
00278 
00279 # define MZ_FLUSH_NEVER 0
00280 # define MZ_FLUSH_BY_LINE 1
00281 # define MZ_FLUSH_ALWAYS 2
00282 
00283 #endif
00284 
00285 #ifdef SOME_FDS_ARE_NOT_SELECTABLE
00286 # include <fcntl.h>
00287 #endif
00288 
00289 #if defined(WINDOWS_FILE_HANDLES)
00290 # define FILENAME_EXN_E "%E"
00291 #else
00292 # define FILENAME_EXN_E "%e"
00293 #endif
00294 
00295 #if defined(DOS_FILE_SYSTEM)
00296 # define fseeko _fseeki64
00297 # define ftello _ftelli64
00298 #endif
00299 
00300 
00301 /******************** Globals and Prototypes ********************/
00302 
00303 /* globals */
00304 Scheme_Object scheme_eof[1];
00305 THREAD_LOCAL Scheme_Object *scheme_orig_stdout_port;
00306 THREAD_LOCAL Scheme_Object *scheme_orig_stderr_port;
00307 THREAD_LOCAL Scheme_Object *scheme_orig_stdin_port;
00308 
00309 Scheme_Object *(*scheme_make_stdin)(void) = NULL;
00310 Scheme_Object *(*scheme_make_stdout)(void) = NULL;
00311 Scheme_Object *(*scheme_make_stderr)(void) = NULL;
00312 
00313 int scheme_file_open_count;
00314 
00315 MZ_DLLSPEC int scheme_binary_mode_stdio;
00316 void scheme_set_binary_mode_stdio(int v) { scheme_binary_mode_stdio =  v; }
00317 
00318 static int special_is_ok;
00319 
00320 /* locals */
00321 #ifdef MZ_FDS
00322 static Scheme_Object *fd_input_port_type;
00323 #endif
00324 #ifdef USE_OSKIT_CONSOLE
00325 static Scheme_Object *oskit_console_input_port_type;
00326 #endif
00327 static Scheme_Object *file_input_port_type;
00328 Scheme_Object *scheme_string_input_port_type;
00329 #ifdef USE_TCP
00330 Scheme_Object *scheme_tcp_input_port_type;
00331 Scheme_Object *scheme_tcp_output_port_type;
00332 #endif
00333 #ifdef MZ_FDS
00334 static Scheme_Object *fd_output_port_type;
00335 #endif
00336 static Scheme_Object *file_output_port_type;
00337 Scheme_Object *scheme_string_output_port_type;
00338 Scheme_Object *scheme_user_input_port_type;
00339 Scheme_Object *scheme_user_output_port_type;
00340 Scheme_Object *scheme_pipe_read_port_type;
00341 Scheme_Object *scheme_pipe_write_port_type;
00342 Scheme_Object *scheme_null_output_port_type;
00343 Scheme_Object *scheme_redirect_output_port_type;
00344 
00345 int scheme_force_port_closed;
00346 
00347 static int flush_out;
00348 static int flush_err;
00349 
00350 static THREAD_LOCAL Scheme_Custodian *new_port_cust; /* back-door argument */
00351 
00352 #if defined(FILES_HAVE_FDS)
00353 static int external_event_fd, put_external_event_fd;
00354 #endif
00355 
00356 static void register_port_wait();
00357 
00358 #ifdef MZ_FDS
00359 static long flush_fd(Scheme_Output_Port *op,
00360                    const char * volatile bufstr, volatile unsigned long buflen,
00361                    volatile unsigned long offset, int immediate_only, int enable_break);
00362 static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data);
00363 #endif
00364 
00365 static Scheme_Object *subprocess(int c, Scheme_Object *args[]);
00366 static Scheme_Object *subprocess_status(int c, Scheme_Object *args[]);
00367 static Scheme_Object *subprocess_kill(int c, Scheme_Object *args[]);
00368 static Scheme_Object *subprocess_pid(int c, Scheme_Object *args[]);
00369 static Scheme_Object *subprocess_p(int c, Scheme_Object *args[]);
00370 static Scheme_Object *subprocess_wait(int c, Scheme_Object *args[]);
00371 static Scheme_Object *sch_shell_execute(int c, Scheme_Object *args[]);
00372 static void register_subprocess_wait();
00373 
00374 typedef struct Scheme_Read_Write_Evt {
00375   Scheme_Object so;
00376   Scheme_Object *port;
00377   Scheme_Object *v; /* peek skip or writeable special */
00378   char *str;
00379   long start, size;
00380 } Scheme_Read_Write_Evt;
00381 
00382 static int rw_evt_ready(Scheme_Object *rww, Scheme_Schedule_Info *sinfo);
00383 static void rw_evt_wakeup(Scheme_Object *rww, void *fds);
00384 
00385 static int progress_evt_ready(Scheme_Object *rww, Scheme_Schedule_Info *sinfo);
00386 
00387 static Scheme_Object *
00388 _scheme_make_named_file_input_port(FILE *fp, Scheme_Object *name, int regfile);
00389 static void default_sleep(float v, void *fds);
00390 #ifdef MZ_PRECISE_GC
00391 static void register_traversers(void);
00392 #endif
00393 
00394 #if defined(WIN32_FD_HANDLES)
00395 OS_SEMAPHORE_TYPE scheme_break_semaphore;
00396 #endif
00397 
00398 #ifdef MZ_FDS
00399 static Scheme_Object *make_fd_input_port(int fd, Scheme_Object *name, int regfile, int textmode, int *refcount, int internal);
00400 static Scheme_Object *make_fd_output_port(int fd, Scheme_Object *name, int regfile, int textmode, int read_too, int flush_mode);
00401 #endif
00402 #ifdef USE_OSKIT_CONSOLE
00403 static Scheme_Object *make_oskit_console_input_port();
00404 #endif
00405 
00406 static void force_close_output_port(Scheme_Object *port);
00407 static void force_close_input_port(Scheme_Object *port);
00408 
00409 static Scheme_Object *text_symbol, *binary_symbol;
00410 static Scheme_Object *append_symbol, *error_symbol, *update_symbol, *can_update_symbol;
00411 static Scheme_Object *replace_symbol, *truncate_symbol, *truncate_replace_symbol;
00412 static Scheme_Object *must_truncate_symbol;
00413 
00414 Scheme_Object *scheme_none_symbol, *scheme_line_symbol, *scheme_block_symbol;
00415 
00416 static Scheme_Object *exact_symbol;
00417 
00418 #define READ_STRING_BYTE_BUFFER_SIZE 1024
00419 static char *read_string_byte_buffer;
00420 
00421 #define fail_err_symbol scheme_false
00422 
00423 #include "schwinfd.h"
00424 
00425 /*========================================================================*/
00426 /*                             initialization                             */
00427 /*========================================================================*/
00428 
00429 void
00430 scheme_init_port (Scheme_Env *env)
00431 {
00432 #ifdef MZ_PRECISE_GC
00433   register_traversers();
00434 #endif
00435 
00436   REGISTER_SO(text_symbol);
00437   REGISTER_SO(binary_symbol);
00438   REGISTER_SO(append_symbol);
00439   REGISTER_SO(error_symbol);
00440   REGISTER_SO(replace_symbol);
00441   REGISTER_SO(truncate_symbol);
00442   REGISTER_SO(truncate_replace_symbol);
00443   REGISTER_SO(update_symbol);
00444   REGISTER_SO(can_update_symbol);
00445   REGISTER_SO(must_truncate_symbol);
00446 
00447   text_symbol = scheme_intern_symbol("text");
00448   binary_symbol = scheme_intern_symbol("binary");
00449   append_symbol = scheme_intern_symbol("append");
00450   error_symbol = scheme_intern_symbol("error");
00451   replace_symbol = scheme_intern_symbol("replace");
00452   truncate_symbol = scheme_intern_symbol("truncate");
00453   truncate_replace_symbol = scheme_intern_symbol("truncate/replace");
00454   update_symbol = scheme_intern_symbol("update");
00455   can_update_symbol = scheme_intern_symbol("can-update");
00456   must_truncate_symbol = scheme_intern_symbol("must-truncate");
00457 
00458   REGISTER_SO(scheme_none_symbol);
00459   REGISTER_SO(scheme_line_symbol);
00460   REGISTER_SO(scheme_block_symbol);
00461 
00462   scheme_none_symbol = scheme_intern_symbol("none");
00463   scheme_line_symbol = scheme_intern_symbol("line");
00464   scheme_block_symbol = scheme_intern_symbol("block");
00465 
00466   REGISTER_SO(exact_symbol);
00467 
00468   exact_symbol = scheme_intern_symbol("exact");
00469 
00470 #ifdef MZ_FDS
00471   REGISTER_SO(fd_input_port_type);
00472   REGISTER_SO(fd_output_port_type);
00473 #endif
00474 #ifdef USE_OSKIT_CONSOLE
00475   REGISTER_SO(oskit_console_input_port_type);
00476 #endif
00477   REGISTER_SO(file_input_port_type);
00478   REGISTER_SO(scheme_string_input_port_type);
00479 #ifdef USE_TCP
00480   REGISTER_SO(scheme_tcp_input_port_type);
00481   REGISTER_SO(scheme_tcp_output_port_type);
00482 #endif
00483   REGISTER_SO(file_output_port_type);
00484   REGISTER_SO(scheme_string_output_port_type);
00485   REGISTER_SO(scheme_user_input_port_type);
00486   REGISTER_SO(scheme_user_output_port_type);
00487   REGISTER_SO(scheme_pipe_read_port_type);
00488   REGISTER_SO(scheme_pipe_write_port_type);
00489   REGISTER_SO(scheme_null_output_port_type);
00490   REGISTER_SO(scheme_redirect_output_port_type);
00491 
00492 #if defined(UNIX_PROCESSES)
00493   REGISTER_SO(scheme_system_children);
00494 #endif
00495 
00496 #ifndef DONT_IGNORE_PIPE_SIGNAL
00497   START_XFORM_SKIP;
00498   MZ_SIGSET(SIGPIPE, SIG_IGN);
00499   END_XFORM_SKIP;
00500 #endif
00501 
00502   if (!scheme_sleep)
00503     scheme_sleep = default_sleep;
00504 
00505   scheme_eof->type = scheme_eof_type;
00506 
00507   scheme_string_input_port_type = scheme_make_port_type("<string-input-port>");
00508   scheme_string_output_port_type = scheme_make_port_type("<string-output-port>");
00509 
00510 #ifdef MZ_FDS
00511   fd_input_port_type = scheme_make_port_type("<stream-input-port>");
00512   fd_output_port_type = scheme_make_port_type("<stream-output-port>");
00513 #endif
00514 #ifdef USE_OSKIT_CONSOLE
00515   oskit_console_input_port_type = scheme_make_port_type("<console-input-port>");
00516 #endif
00517 
00518   file_input_port_type = scheme_make_port_type("<file-input-port>");
00519   file_output_port_type = scheme_make_port_type("<file-output-port>");
00520 
00521   scheme_user_input_port_type = scheme_make_port_type("<user-input-port>");
00522   scheme_user_output_port_type = scheme_make_port_type("<user-output-port>");
00523 
00524   scheme_pipe_read_port_type = scheme_make_port_type("<pipe-input-port>");
00525   scheme_pipe_write_port_type = scheme_make_port_type("<pipe-output-port>");
00526 
00527 #ifdef USE_TCP
00528   scheme_tcp_input_port_type = scheme_make_port_type("<tcp-input-port>");
00529   scheme_tcp_output_port_type = scheme_make_port_type("<tcp-output-port>");
00530 #endif
00531 
00532   scheme_null_output_port_type = scheme_make_port_type("<null-output-port>");
00533   scheme_redirect_output_port_type = scheme_make_port_type("<redirect-output-port>");
00534 
00535 #ifdef WIN32_FD_HANDLES
00536   scheme_break_semaphore = CreateSemaphore(NULL, 0, 1, NULL);
00537 
00538   /* We'll need to know whether this is Win95 or WinNT: */
00539   {
00540     OSVERSIONINFO info;
00541     info.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
00542     GetVersionEx(&info);
00543     if (info.dwPlatformId == VER_PLATFORM_WIN32_NT)
00544       scheme_stupid_windows_machine = -1; /* not as stupid */
00545     else
00546       scheme_stupid_windows_machine = 1;
00547   }
00548 #endif
00549 
00550   scheme_init_port_places();
00551 
00552   flush_out = SCHEME_TRUEP(scheme_terminal_port_p(1, &scheme_orig_stdout_port));
00553   flush_err = SCHEME_TRUEP(scheme_terminal_port_p(1, &scheme_orig_stderr_port));
00554 
00555 #ifdef MZ_FDS
00556   scheme_add_atexit_closer(flush_if_output_fds);
00557   /* Note: other threads might continue to write even after
00558      the flush completes, but that's the threads' problem.
00559      All writing by the main thread will get flushed on exit
00560      (but not, of course, if the thread is shutdown via a
00561      custodian). */
00562 #endif
00563 
00564 #if defined(FILES_HAVE_FDS)
00565 # ifndef USE_OSKIT_CONSOLE
00566   /* Set up a pipe for signalling external events: */
00567   {
00568     int fds[2];
00569     if (!pipe(fds)) {
00570       external_event_fd = fds[0];
00571       put_external_event_fd = fds[1];
00572       fcntl(external_event_fd, F_SETFL, MZ_NONBLOCKING);
00573       fcntl(put_external_event_fd, F_SETFL, MZ_NONBLOCKING);
00574     }
00575   }
00576 # endif
00577 #endif
00578 
00579   register_port_wait();
00580 
00581   scheme_add_global_constant("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env);
00582   scheme_add_global_constant("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env);
00583   scheme_add_global_constant("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env);
00584   scheme_add_global_constant("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env);
00585   scheme_add_global_constant("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env);
00586   scheme_add_global_constant("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env);
00587 
00588 
00589   register_subprocess_wait();
00590 
00591   scheme_add_global_constant("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env);
00592 
00593   REGISTER_SO(read_string_byte_buffer);
00594 
00595   scheme_add_evt(scheme_progress_evt_type, (Scheme_Ready_Fun)progress_evt_ready, NULL, NULL, 1);
00596   scheme_add_evt(scheme_write_evt_type, (Scheme_Ready_Fun)rw_evt_ready, rw_evt_wakeup, NULL, 1);
00597 }
00598 
00599 void scheme_init_port_places(void)
00600 {
00601   REGISTER_SO(scheme_orig_stdout_port);
00602   REGISTER_SO(scheme_orig_stderr_port);
00603   REGISTER_SO(scheme_orig_stdin_port);
00604   scheme_orig_stdin_port = (scheme_make_stdin
00605                          ? scheme_make_stdin()
00606 #ifdef USE_OSKIT_CONSOLE
00607                          : (osk_not_console
00608                             ? scheme_make_named_file_input_port(stdin, scheme_intern_symbol("stdin"))
00609                             : make_oskit_console_input_port())
00610 #else
00611 # ifdef MZ_FDS
00612 #  ifdef WINDOWS_FILE_HANDLES
00613                          : make_fd_input_port((int)GetStdHandle(STD_INPUT_HANDLE), scheme_intern_symbol("stdin"), 0, 0, NULL, 0)
00614 #  else
00615                          : make_fd_input_port(0, scheme_intern_symbol("stdin"), 0, 0, NULL, 0)
00616 #  endif
00617 # else
00618                          : scheme_make_named_file_input_port(stdin, scheme_intern_symbol("stdin"))
00619 # endif
00620 #endif
00621                          );
00622 
00623   scheme_orig_stdout_port = (scheme_make_stdout
00624                           ? scheme_make_stdout()
00625 #ifdef MZ_FDS
00626 # ifdef WINDOWS_FILE_HANDLES
00627                           : make_fd_output_port((int)GetStdHandle(STD_OUTPUT_HANDLE), 
00628                                              scheme_intern_symbol("stdout"), 0, 0, 0,
00629                                                    -1)
00630 # else
00631                           : make_fd_output_port(1, scheme_intern_symbol("stdout"), 0, 0, 0, -1)
00632 # endif
00633 #else
00634                           : scheme_make_file_output_port(stdout)
00635 #endif
00636                           );
00637 
00638   scheme_orig_stderr_port = (scheme_make_stderr
00639                           ? scheme_make_stderr()
00640 #ifdef MZ_FDS
00641 # ifdef WINDOWS_FILE_HANDLES
00642                           : make_fd_output_port((int)GetStdHandle(STD_ERROR_HANDLE), 
00643                                              scheme_intern_symbol("stderr"), 0, 0, 0,
00644                                                    MZ_FLUSH_ALWAYS)
00645 # else
00646                           : make_fd_output_port(2, scheme_intern_symbol("stderr"), 0, 0, 0,
00647                                                    MZ_FLUSH_ALWAYS)
00648 # endif
00649 #else
00650                           : scheme_make_file_output_port(stderr)
00651 #endif
00652                           );
00653 }
00654 
00655 void scheme_init_port_config(void)
00656 {
00657   Scheme_Config *config;
00658 
00659   config = scheme_current_config();
00660 
00661   scheme_set_param(config, MZCONFIG_INPUT_PORT,   scheme_orig_stdin_port);
00662   scheme_set_param(config, MZCONFIG_OUTPUT_PORT,  scheme_orig_stdout_port);
00663   scheme_set_param(config, MZCONFIG_ERROR_PORT,   scheme_orig_stderr_port);
00664 }
00665 
00666 Scheme_Object * scheme_make_eof (void)
00667 {
00668   return scheme_eof;
00669 }
00670 
00671 /*========================================================================*/
00672 /*                                fd arrays                               */
00673 /*========================================================================*/
00674 
00675 /* Implement fd arrays (FD_SET, etc) with a runtime-determined size.
00676    Also implement special hooks for Windows "descriptors", like
00677    even queues and semaphores. */
00678 
00679 #ifdef USE_DYNAMIC_FDSET_SIZE
00680 static int dynamic_fd_size;
00681 
00682 # define STORED_ACTUAL_FDSET_LIMIT
00683 # define FDSET_LIMIT(fd) (*(int *)((char *)fd XFORM_OK_PLUS dynamic_fd_size))
00684 
00685 #ifdef MZ_XFORM
00686 START_XFORM_SKIP;
00687 #endif
00688 
00689 void *scheme_alloc_fdset_array(int count, int permanent)
00690 {
00691   /* Note: alloc only at the end, because this function
00692      isn't annotated. We skip annotation so that it's
00693      ok with OS X use from default_sleep() */
00694 
00695   if (!dynamic_fd_size) {
00696 #ifdef USE_ULIMIT
00697     dynamic_fd_size = ulimit(4, 0);
00698 #else
00699     dynamic_fd_size = getdtablesize();
00700 #endif
00701     /* divide by bits-per-byte: */
00702     dynamic_fd_size = (dynamic_fd_size + 7) >> 3;
00703     /* word-align: */
00704     if (dynamic_fd_size % sizeof(void*))
00705       dynamic_fd_size += sizeof(void*) - (dynamic_fd_size % sizeof(void*));
00706   }
00707 
00708   if (permanent)
00709     return scheme_malloc_eternal(count * (dynamic_fd_size + sizeof(long)));
00710   else
00711     return scheme_malloc_atomic(count * (dynamic_fd_size + sizeof(long)));
00712 }
00713 
00714 #ifdef MZ_XFORM
00715 END_XFORM_SKIP;
00716 #endif
00717 
00718 void *scheme_init_fdset_array(void *fdarray, int count)
00719 {
00720   return fdarray;
00721 }
00722 
00723 void *scheme_get_fdset(void *fdarray, int pos)
00724 {
00725   return ((char *)fdarray) + (pos * (dynamic_fd_size + sizeof(long)));
00726 }
00727 
00728 void scheme_fdzero(void *fd)
00729 {
00730   memset(fd, 0, dynamic_fd_size + sizeof(long));
00731 }
00732 
00733 #else
00734 
00735 #if defined(WIN32_FD_HANDLES)
00736 # define fdset_type win_extended_fd_set
00737 #else
00738 # define fdset_type fd_set
00739 #endif
00740 
00741 void *scheme_alloc_fdset_array(int count, int permanent)
00742 {
00743 #if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP) || defined(WIN32_FD_HANDLES)
00744   void *fdarray;
00745 # if defined(WIN32_FD_HANDLES)
00746   if (count) {
00747     fdarray = scheme_malloc_allow_interior(count * sizeof(fdset_type));
00748     if (permanent)
00749       scheme_dont_gc_ptr(fdarray);
00750     
00751     scheme_init_fdset_array(fdarray, count);
00752   } else
00753     fdarray = NULL;
00754 # else
00755   if (permanent)
00756     fdarray = scheme_malloc_eternal(count * sizeof(fdset_type));
00757   else
00758     fdarray = scheme_malloc_atomic(count * sizeof(fdset_type));
00759 # endif
00760   return fdarray;
00761 #else
00762   return NULL;
00763 #endif
00764 }
00765 
00766 #if defined(WIN32_FD_HANDLES)
00767 static void reset_wait_array(win_extended_fd_set *efd)
00768 {
00769   /* Allocate an array that may be big enough to hold all events
00770      when we eventually call WaitForMultipleObjects. One of the three
00771      arrays will be big enough. */
00772   int sz = (3 * (SCHEME_INT_VAL(efd->alloc) + SCHEME_INT_VAL(efd->num_handles))) + 2;
00773   HANDLE *wa;
00774   wa = MALLOC_N_ATOMIC(HANDLE, sz);
00775   efd->wait_array = wa;
00776 }
00777 #endif
00778 
00779 void *scheme_init_fdset_array(void *fdarray, int count)
00780 {
00781 #if defined(WIN32_FD_HANDLES)
00782   if (count) {
00783     int i;
00784     win_extended_fd_set *fd;
00785     for (i = 0; i < count; i++) {
00786       fd = (win_extended_fd_set *)scheme_get_fdset(fdarray, i);
00787       fd->sockets = NULL;
00788       fd->added = scheme_make_integer(0);
00789       fd->alloc = scheme_make_integer(0);
00790       fd->handles = NULL;
00791       fd->num_handles = scheme_make_integer(0);
00792       fd->no_sleep = NULL;
00793       fd->wait_event_mask = scheme_make_integer(0);
00794       fd->wait_array = NULL;
00795       reset_wait_array(fdarray);
00796     }
00797   }
00798 #endif
00799   return fdarray;
00800 }
00801 
00802 void *scheme_get_fdset(void *fdarray, int pos)
00803 {
00804 #if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP) || defined(WIN32_FD_HANDLES)
00805   return ((fdset_type *)fdarray) + pos;
00806 #else
00807   return NULL;
00808 #endif
00809 }
00810 
00811 void scheme_fdzero(void *fd)
00812 {
00813 #if defined(WIN32_FD_HANDLES)
00814   scheme_init_fdset_array(fd, 1);
00815 #else
00816 # if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
00817   FD_ZERO((fd_set *)fd);
00818 # endif
00819 #endif
00820 }
00821 
00822 #endif
00823 
00824 void scheme_fdclr(void *fd, int n)
00825 {
00826 #if defined(WIN32_FD_HANDLES)
00827   win_extended_fd_set *efd = (win_extended_fd_set *)fd;
00828   int i;
00829   for (i = SCHEME_INT_VAL(efd->added); i--; ) {
00830     if (efd->sockets[i] == n)
00831       efd->sockets[i] = INVALID_SOCKET;
00832   }
00833 #else
00834 # if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
00835   FD_CLR((unsigned)n, ((fd_set *)fd));
00836 # endif
00837 #endif
00838 }
00839 
00840 void scheme_fdset(void *fd, int n)
00841 {
00842 #if defined(WIN32_FD_HANDLES)
00843   win_extended_fd_set *efd = (win_extended_fd_set *)fd;
00844   if (SCHEME_INT_VAL(efd->added) >= SCHEME_INT_VAL(efd->alloc)) {
00845     SOCKET *naya;
00846     int na;
00847     na = (SCHEME_INT_VAL(efd->alloc) * 2) + 10;
00848     naya = (SOCKET *)scheme_malloc_atomic(na * sizeof(SOCKET));
00849     memcpy(naya, efd->sockets, SCHEME_INT_VAL(efd->alloc) * sizeof(SOCKET));
00850     efd->sockets = naya;
00851     efd->alloc = scheme_make_integer(na);
00852     reset_wait_array(efd);
00853   }
00854   efd->sockets[SCHEME_INT_VAL(efd->added)] = n;
00855   efd->added = scheme_make_integer(1 + SCHEME_INT_VAL(efd->added));
00856 #else
00857 # if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
00858 #  ifdef STORED_ACTUAL_FDSET_LIMIT
00859   int mx;
00860   mx = FDSET_LIMIT(fd);
00861   if (n > mx)
00862     FDSET_LIMIT(fd) = n;
00863 #  endif
00864   FD_SET(n, ((fd_set *)fd));
00865 # endif
00866 #endif
00867 }
00868 
00869 int scheme_fdisset(void *fd, int n)
00870 {
00871 #if defined(WIN32_FD_HANDLES)
00872   win_extended_fd_set *efd = (win_extended_fd_set *)fd;
00873   int i;
00874   for (i = SCHEME_INT_VAL(efd->added); i--; ) {
00875     if (efd->sockets[i] == n)
00876       return 1;
00877   }
00878   return 0;
00879 #else
00880 # if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
00881   return FD_ISSET(n, ((fd_set *)fd));
00882 # else
00883   return 0;
00884 # endif
00885 #endif
00886 }
00887 
00888 void scheme_add_fd_handle(void *h, void *fds, int repost)
00889 {
00890 #if defined(WIN32_FD_HANDLES)
00891   win_extended_fd_set *efd = (win_extended_fd_set *)fds;
00892   OS_SEMAPHORE_TYPE *hs;
00893   int i, *rps;
00894 
00895   i = SCHEME_INT_VAL(efd->num_handles);
00896   hs = MALLOC_N_ATOMIC(OS_SEMAPHORE_TYPE, i + 1);
00897   rps = MALLOC_N_ATOMIC(int, i + 1);
00898   hs[i] = (OS_SEMAPHORE_TYPE)h;
00899   rps[i] = repost;
00900   while (i--) {
00901     hs[i] = efd->handles[i];
00902     rps[i] = efd->repost_sema[i];
00903   }
00904   efd->num_handles = scheme_make_integer(1 + SCHEME_INT_VAL(efd->num_handles));
00905   efd->handles = hs;
00906   efd->repost_sema = rps;
00907   reset_wait_array(efd);
00908 #else
00909   /* Do nothing. */
00910 #endif
00911 }
00912 
00913 void scheme_add_fd_nosleep(void *fds)
00914 {
00915 #if defined(WIN32_FD_HANDLES)
00916   win_extended_fd_set *efd = (win_extended_fd_set *)fds;
00917   efd->no_sleep = scheme_true;
00918 #else
00919 #endif
00920 }
00921 
00922 void scheme_add_fd_eventmask(void *fds, int mask)
00923 {
00924 #if defined(WIN32_FD_HANDLES)
00925   win_extended_fd_set *efd = (win_extended_fd_set *)fds;
00926   efd->wait_event_mask = scheme_make_integer(mask | SCHEME_INT_VAL(efd->wait_event_mask));
00927 #endif
00928 }
00929 
00930 #if defined(WIN32_FD_HANDLES)
00931 void WSAEventSelect_plus_check(SOCKET s, WSAEVENT e, long mask)
00932 {
00933   fd_set rd[1], wr[1], ex[1];
00934   struct timeval t = {0, 0};
00935 
00936   WSAEventSelect(s, e, mask);
00937   
00938   /* double-check with select(), because WSAEventSelect only
00939      handles new activity (I think) */
00940   FD_ZERO(rd);
00941   FD_ZERO(wr);
00942   FD_ZERO(ex);
00943 
00944   if (mask & FD_READ)
00945     FD_SET(s, rd);
00946   if (mask & FD_WRITE)
00947     FD_SET(s, wr);
00948   if (mask & FD_OOB)
00949     FD_SET(s, ex);
00950 
00951   if (select(1, rd, wr, ex, &t)) {
00952     /* already ready */
00953     WSAEventSelect(s, NULL, 0);
00954     SetEvent(e);
00955   }
00956 }
00957 #endif
00958 
00959 void scheme_collapse_win_fd(void *fds)
00960 {
00961 #if defined(WIN32_FD_HANDLES)
00962   win_extended_fd_set *rfd, *wfd, *efd;
00963   HANDLE *wa, e;
00964   int i, p = 0, mask, j;
00965   SOCKET s;
00966 
00967   rfd = (win_extended_fd_set *)fds;
00968   wfd = (win_extended_fd_set *)scheme_get_fdset(fds, 1);
00969   efd = (win_extended_fd_set *)scheme_get_fdset(fds, 2);
00970 
00971   if (rfd->combined_wait_array) {
00972     /* clean up */
00973     for (i = SCHEME_INT_VAL(rfd->added); i--; ) {
00974       if (rfd->sockets[i] != INVALID_SOCKET)
00975        WSAEventSelect(rfd->sockets[i], NULL, 0);
00976     }
00977     for (i = SCHEME_INT_VAL(wfd->added); i--; ) {
00978       if (wfd->sockets[i] != INVALID_SOCKET)
00979        WSAEventSelect(wfd->sockets[i], NULL, 0);
00980     }
00981     for (i = SCHEME_INT_VAL(efd->added); i--; ) {
00982       if (efd->sockets[i] != INVALID_SOCKET)
00983        WSAEventSelect(efd->sockets[i], NULL, 0);
00984     }
00985     p = SCHEME_INT_VAL(rfd->num_handles);
00986     for (i = SCHEME_INT_VAL(rfd->combined_len); i-- > p; ) {
00987       WSACloseEvent(rfd->combined_wait_array[i]);
00988     }
00989     rfd->combined_wait_array = NULL;
00990   } else {
00991     /* merge */
00992     if (SCHEME_INT_VAL(rfd->alloc) < SCHEME_INT_VAL(wfd->alloc)) {
00993       if (SCHEME_INT_VAL(wfd->alloc) < SCHEME_INT_VAL(efd->alloc))
00994        wa = efd->wait_array;
00995       else
00996        wa = wfd->wait_array;
00997     } else {
00998       if (SCHEME_INT_VAL(rfd->alloc) < SCHEME_INT_VAL(efd->alloc))
00999        wa = efd->wait_array;
01000       else
01001        wa = rfd->wait_array;
01002     }
01003 
01004     rfd->combined_wait_array = wa;
01005 
01006     p = SCHEME_INT_VAL(rfd->num_handles);
01007     for (i = 0; i < p; i++) {
01008       wa[i] = rfd->handles[i];
01009     }
01010   
01011     for (i = SCHEME_INT_VAL(rfd->added); i--; ) {
01012       s = rfd->sockets[i];
01013       if (s != INVALID_SOCKET) {
01014        mask = FD_READ | FD_ACCEPT | FD_CLOSE;
01015        
01016        for (j = SCHEME_INT_VAL(wfd->added); j--; ) {
01017          if (wfd->sockets[j] == s) {
01018            mask |= FD_WRITE;
01019            break;
01020          }
01021        }
01022 
01023        for (j = SCHEME_INT_VAL(efd->added); j--; ) {
01024          if (efd->sockets[j] == s) {
01025            mask |= FD_OOB;
01026            break;
01027          }
01028        }
01029 
01030        e = WSACreateEvent();
01031        wa[p++] = e;
01032        WSAEventSelect_plus_check(s, e, mask);
01033       }
01034     }
01035 
01036     for (i = SCHEME_INT_VAL(wfd->added); i--; ) {
01037       s = wfd->sockets[i];
01038       if (s != INVALID_SOCKET) {
01039        mask = FD_WRITE | FD_CONNECT | FD_CLOSE;
01040        
01041        for (j = SCHEME_INT_VAL(rfd->added); j--; ) {
01042          if (rfd->sockets[j] == s) {
01043            mask = 0;
01044            break;
01045          }
01046        }
01047 
01048        if (mask) {
01049          for (j = SCHEME_INT_VAL(efd->added); j--; ) {
01050            if (efd->sockets[j] == s) {
01051              mask |= FD_OOB;
01052              break;
01053            }
01054          }
01055          
01056          e = WSACreateEvent();
01057          wa[p++] = e;
01058          WSAEventSelect_plus_check(s, e, mask);
01059        }
01060       }
01061     }
01062 
01063     for (i = SCHEME_INT_VAL(efd->added); i--; ) {
01064       s = efd->sockets[i];
01065       if (s != INVALID_SOCKET) {
01066        mask = FD_OOB | FD_CLOSE;
01067        
01068        for (j = SCHEME_INT_VAL(rfd->added); j--; ) {
01069          if (rfd->sockets[j] == s) {
01070            mask = 0;
01071            break;
01072          }
01073        }
01074 
01075        if (mask) {
01076          for (j = SCHEME_INT_VAL(wfd->added); j--; ) {
01077            if (wfd->sockets[j] == s) {
01078              mask = 0;
01079              break;
01080            }
01081          }
01082          
01083          if (mask) {
01084            e = WSACreateEvent();
01085            wa[p++] = e;
01086            WSAEventSelect_plus_check(s, e, mask);
01087          }
01088        }
01089       }
01090     }
01091 
01092     rfd->combined_len = scheme_make_integer(p);
01093   }
01094 #endif
01095 }
01096 
01097 /*========================================================================*/
01098 /*                      Windows thread suspension                         */
01099 /*========================================================================*/
01100 
01101 /* MzScheme creates Windows threads for various purposes, including
01102    non-blocking FILE reads. Unfortunately, these threads can confuse
01103    the GC if they move virtual pages around while its marking. So we
01104    remember each created thread and suspend it during GC.
01105 
01106    This work is not necessary if GC_use_registered_statics is set. */
01107 
01108 
01109 #ifdef WINDOWS_PROCESSES
01110 typedef struct Scheme_Thread_Memory {
01111   MZTAG_IF_REQUIRED
01112   void *handle;
01113   void *subhandle;
01114   int autoclose;
01115   struct Scheme_Thread_Memory *prev;
01116   struct Scheme_Thread_Memory *next;
01117 } Scheme_Thread_Memory;
01118 
01119 Scheme_Thread_Memory *tm_start, *tm_next;
01120 
01121 void scheme_init_thread_memory()
01122 {
01123 #ifndef MZ_PRECISE_GC
01124   REGISTER_SO(tm_start);
01125   REGISTER_SO(tm_next);
01126 #endif
01127 
01128   /* We start with a pre-allocated tm because we
01129      want to register a thread before performing any
01130      allocations. */
01131 #ifdef MZ_PRECISE_GC
01132   tm_next = (Scheme_Thread_Memory *)malloc(sizeof(Scheme_Thread_Memory));
01133 #else
01134   tm_next = MALLOC_ONE_RT(Scheme_Thread_Memory);
01135 #endif
01136 #ifdef MZTAG_REQUIRED
01137   tm_next->type = scheme_rt_thread_memory;
01138 #endif
01139 
01140   /* scheme_init_thread() will replace these: */
01141   GC_set_collect_start_callback(scheme_suspend_remembered_threads);
01142   GC_set_collect_end_callback(scheme_resume_remembered_threads);
01143 }
01144 
01145 Scheme_Thread_Memory *scheme_remember_thread(void *t, int autoclose)
01146 {
01147   Scheme_Thread_Memory *tm = tm_next;
01148 
01149   tm->handle = t;
01150   tm->subhandle = NULL;
01151   tm->autoclose = autoclose;
01152 
01153   tm->prev = NULL;
01154   tm->next = tm_start;
01155   if (tm->next)
01156     tm->next->prev = tm;
01157   tm_start = tm;
01158 
01159 #ifdef MZ_PRECISE_GC
01160   tm_next = (Scheme_Thread_Memory *)malloc(sizeof(Scheme_Thread_Memory));
01161 #else
01162   tm_next = MALLOC_ONE_RT(Scheme_Thread_Memory);
01163 #endif
01164 #ifdef MZTAG_REQUIRED
01165   tm_next->type = scheme_rt_thread_memory;
01166 #endif
01167 
01168   return tm;
01169 }
01170 
01171 void scheme_remember_subthread(struct Scheme_Thread_Memory *tm, void *t)
01172 {
01173   tm->subhandle = t;
01174 }
01175 
01176 #ifdef MZ_XFORM
01177 START_XFORM_SKIP;
01178 #endif
01179 
01180 void scheme_forget_thread(struct Scheme_Thread_Memory *tm)
01181 {
01182   if (tm->prev)
01183     tm->prev->next = tm->next;
01184   else
01185     tm_start = tm->next;
01186 
01187   if (tm->next)
01188     tm->next->prev = tm->prev;
01189 
01190   tm->next = NULL;
01191   tm->prev = NULL;
01192 
01193 #ifdef MZ_PRECISE_GC
01194   free(tm);
01195 #endif
01196 }
01197 
01198 void scheme_forget_subthread(struct Scheme_Thread_Memory *tm)
01199 {
01200   tm->subhandle = NULL;
01201 }
01202 
01203 void scheme_suspend_remembered_threads(void)
01204 {
01205   Scheme_Thread_Memory *tm, *next, *prev = NULL;
01206   int keep;
01207 
01208   for (tm = tm_start; tm; tm = next) {
01209     next = tm->next;
01210 
01211     keep = 1;
01212     if (tm->autoclose) {
01213       if (WaitForSingleObject(tm->handle, 0) == WAIT_OBJECT_0) {
01214        CloseHandle((HANDLE)tm->handle);
01215        tm->handle = NULL;
01216        if (prev)
01217          prev->next = tm->next;
01218        else
01219          tm_start = tm->next;
01220        if (tm->next)
01221          tm->next->prev = prev;
01222        tm->next = NULL;
01223        tm->prev = NULL;
01224 #ifdef MZ_PRECISE_GC
01225        free(tm);
01226 #endif
01227        keep = 0;
01228       }
01229     }
01230 
01231     if (keep) {
01232       SuspendThread((HANDLE)tm->handle);
01233       if (tm->subhandle)
01234        SuspendThread((HANDLE)tm->subhandle);
01235       prev = tm;
01236     }
01237   }
01238 }
01239 
01240 void scheme_resume_remembered_threads(void)
01241 {
01242   Scheme_Thread_Memory *tm;
01243 
01244   for (tm = tm_start; tm; tm = tm->next) {
01245     if (tm->subhandle)
01246       ResumeThread((HANDLE)tm->subhandle);
01247     ResumeThread((HANDLE)tm->handle);
01248   }
01249 }
01250 
01251 #ifdef MZ_XFORM
01252 END_XFORM_SKIP;
01253 #endif
01254 
01255 #endif
01256 
01257 /*========================================================================*/
01258 /*                        Generic port support                            */
01259 /*========================================================================*/
01260 
01261 
01262 Scheme_Object *scheme_make_port_type(const char *name)
01263 {
01264   return scheme_make_symbol(name);
01265 }
01266 
01267 static void init_port_locations(Scheme_Port *ip)
01268 {
01269   int cl;
01270 
01271   ip->position = 0;
01272   ip->readpos = 0; /* like position, but post UTF-8 decoding, collapses CRLF, etc. */
01273   ip->lineNumber = 1;
01274   ip->oldColumn = 0;
01275   ip->column = 0;
01276   ip->charsSinceNewline = 1;
01277   cl = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_COUNT_LINES));
01278   ip->count_lines = cl;
01279 }
01280 
01281 void scheme_set_next_port_custodian(Scheme_Custodian *c)
01282 {
01283   new_port_cust = c;
01284 }
01285 
01286 Scheme_Input_Port *
01287 scheme_make_input_port(Scheme_Object *subtype,
01288                      void *data,
01289                      Scheme_Object *name,
01290                      Scheme_Get_String_Fun get_string_fun,
01291                      Scheme_Peek_String_Fun peek_string_fun,
01292                      Scheme_Progress_Evt_Fun progress_evt_fun,
01293                      Scheme_Peeked_Read_Fun peeked_read_fun,
01294                      Scheme_In_Ready_Fun byte_ready_fun,
01295                      Scheme_Close_Input_Fun close_fun,
01296                      Scheme_Need_Wakeup_Input_Fun need_wakeup_fun,
01297                      int must_close)
01298 {
01299   Scheme_Input_Port *ip;
01300   Scheme_Custodian *cust = new_port_cust;
01301 
01302   new_port_cust = NULL;
01303 
01304   ip = MALLOC_ONE_TAGGED(Scheme_Input_Port);
01305   ip->p.so.type = scheme_input_port_type;
01306   ip->sub_type = subtype;
01307   ip->port_data = data;
01308   ip->get_string_fun = get_string_fun;
01309   ip->peek_string_fun = peek_string_fun;
01310   ip->progress_evt_fun = progress_evt_fun;
01311   ip->peeked_read_fun = peeked_read_fun;
01312   ip->byte_ready_fun = byte_ready_fun;
01313   ip->need_wakeup_fun = need_wakeup_fun;
01314   ip->close_fun = close_fun;
01315   ip->name = name;
01316   ip->ungotten_count = 0;
01317   ip->closed = 0;
01318   ip->read_handler = NULL;
01319   init_port_locations((Scheme_Port *)ip);
01320 
01321   if (progress_evt_fun == scheme_progress_evt_via_get)
01322     ip->unless_cache = scheme_false;
01323 
01324   if (must_close) {
01325     Scheme_Custodian_Reference *mref;
01326     mref = scheme_add_managed(cust,
01327                            (Scheme_Object *)ip,
01328                            (Scheme_Close_Custodian_Client *)force_close_input_port,
01329                            NULL, must_close);
01330     ip->mref = mref;
01331   } else
01332     ip->mref = NULL;
01333 
01334   return (ip);
01335 }
01336 
01337 void scheme_set_port_location_fun(Scheme_Port *port,
01338                               Scheme_Location_Fun location_fun)
01339 {
01340   port->location_fun = location_fun;
01341 }
01342 
01343 void scheme_set_port_count_lines_fun(Scheme_Port *port,
01344                                  Scheme_Count_Lines_Fun count_lines_fun)
01345 {
01346   port->count_lines_fun = count_lines_fun;
01347 }
01348 
01349 static int evt_input_port_p(Scheme_Object *p)
01350 {
01351   return 1;
01352 }
01353 
01354 Scheme_Output_Port *
01355 scheme_make_output_port(Scheme_Object *subtype,
01356                      void *data,
01357                      Scheme_Object *name,
01358                      Scheme_Write_String_Evt_Fun write_string_evt_fun,
01359                      Scheme_Write_String_Fun write_string_fun,
01360                      Scheme_Out_Ready_Fun ready_fun,
01361                      Scheme_Close_Output_Fun close_fun,
01362                      Scheme_Need_Wakeup_Output_Fun need_wakeup_fun,
01363                      Scheme_Write_Special_Evt_Fun write_special_evt_fun,
01364                      Scheme_Write_Special_Fun write_special_fun,
01365                      int must_close)
01366 {
01367   Scheme_Output_Port *op;
01368   Scheme_Custodian *cust = new_port_cust;
01369 
01370   new_port_cust = NULL;
01371 
01372   op = MALLOC_ONE_TAGGED(Scheme_Output_Port);
01373   op->p.so.type = scheme_output_port_type;
01374   op->sub_type = subtype;
01375   op->port_data = data;
01376   op->name = name;
01377   op->write_string_evt_fun = write_string_evt_fun;
01378   op->write_string_fun = write_string_fun;
01379   op->close_fun = close_fun;
01380   op->ready_fun = ready_fun;
01381   op->need_wakeup_fun = need_wakeup_fun;
01382   op->write_special_evt_fun = write_special_evt_fun;
01383   op->write_special_fun = write_special_fun;
01384   op->closed = 0;
01385   op->display_handler = NULL;
01386   op->write_handler = NULL;
01387   op->print_handler = NULL;
01388   init_port_locations((Scheme_Port *)op);
01389 
01390   if (must_close) {
01391     Scheme_Custodian_Reference *mref;
01392     mref = scheme_add_managed(cust,
01393                            (Scheme_Object *)op,
01394                            (Scheme_Close_Custodian_Client *)force_close_output_port,
01395                            NULL, must_close);
01396     op->mref = mref;
01397   } else
01398     op->mref = NULL;
01399 
01400   return op;
01401 }
01402 
01403 static int evt_output_port_p(Scheme_Object *p)
01404 {
01405   return 1;
01406 }
01407 
01408 static int output_ready(Scheme_Object *port, Scheme_Schedule_Info *sinfo)
01409 {
01410   Scheme_Output_Port *op;
01411 
01412   op = scheme_output_port_record(port);
01413 
01414   if (op->closed)
01415     return 1;
01416 
01417   if (SAME_OBJ(scheme_user_output_port_type, op->sub_type)) {
01418     /* We can't call the normal ready because that might run Scheme
01419        code, and this function is called by the scheduler when
01420        false_pos_ok is true. So, in that case, we asume that if the
01421        port's evt is ready, then the port is ready. (After
01422        all, false positives are ok in that mode.) Even when the
01423        scheduler isn't requesting the status, we need sinfo. */
01424     return scheme_user_port_write_probably_ready(op, sinfo);
01425   }
01426 
01427   if (op->ready_fun) {
01428     Scheme_Out_Ready_Fun rf;
01429     rf = op->ready_fun;
01430     return rf(op);
01431   }
01432 
01433   return 1;
01434 }
01435 
01436 static void output_need_wakeup (Scheme_Object *port, void *fds)
01437 {
01438   Scheme_Output_Port *op;
01439 
01440   /* If this is a user output port and its evt needs a wakeup, we
01441      shouldn't get here. The target use above will take care of it. */
01442 
01443   op = scheme_output_port_record(port);
01444   if (op->need_wakeup_fun) {
01445     Scheme_Need_Wakeup_Output_Fun f;
01446     f = op->need_wakeup_fun;
01447     f(op, fds);
01448   }
01449 }
01450 
01451 int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo)
01452 {
01453   Scheme_Input_Port *ip;
01454 
01455   ip = scheme_input_port_record(p);
01456 
01457   if (ip->closed)
01458     return 1;
01459 
01460   if (SAME_OBJ(scheme_user_input_port_type, ip->sub_type)) {
01461     /* We can't call the normal byte_ready because that runs Scheme
01462        code, and this function is called by the scheduler when
01463        false_pos_ok is true. So, in that case, we asume that if the
01464        port's evt is ready, then the port is ready. (After
01465        all, false positives are ok in that mode.) Even when the
01466        scheduler isn't requesting the status, we need sinfo. */
01467     return scheme_user_port_byte_probably_ready(ip, sinfo);
01468   } else
01469     return scheme_byte_ready(p);
01470 }
01471 
01472 static void register_port_wait()
01473 {
01474   scheme_add_evt(scheme_input_port_type,
01475                 (Scheme_Ready_Fun)scheme_byte_ready_or_user_port_ready, scheme_need_wakeup,
01476                 evt_input_port_p, 1);
01477   scheme_add_evt(scheme_output_port_type,
01478                 (Scheme_Ready_Fun)output_ready, output_need_wakeup,
01479                 evt_output_port_p, 1);
01480 }
01481 
01482 XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
01483 {
01484   if (p) {
01485     Scheme_Pipe *pipe;
01486     Scheme_Input_Port *ip;
01487 
01488     ip = (Scheme_Input_Port *)p;
01489     pipe = (Scheme_Pipe *)ip->port_data;
01490 
01491     if (pipe->bufstart <= pipe->bufend)
01492       return pipe->bufend - pipe->bufstart;
01493     else
01494       return (pipe->buflen - pipe->bufstart) + pipe->bufend;
01495   } else
01496     return 0;
01497 }
01498 
01499 int scheme_pipe_char_count(Scheme_Object *p)
01500 {
01501   return pipe_char_count(p);
01502 }
01503 
01504 /****************************** main input reader ******************************/
01505 
01506 static void post_progress(Scheme_Input_Port *ip)
01507 {
01508   scheme_post_sema_all(ip->progress_evt);
01509   ip->progress_evt = NULL;
01510 }
01511 
01512 XFORM_NONGCING static void inc_pos(Scheme_Port *ip, int a)
01513 {
01514   ip->column += a;
01515   ip->readpos += a;
01516   ip->charsSinceNewline += a;
01517   ip->utf8state = 0;
01518 }
01519 
01520 static Scheme_Object *quick_plus(Scheme_Object *s, long v)
01521 {
01522   if (SCHEME_INTP(s)) {
01523     int k;
01524     k = SCHEME_INT_VAL(s);
01525     if ((k < 0x1000000) && (v < 0x1000000)) {
01526       k += v;
01527       return scheme_make_integer(k);
01528     }
01529   }
01530 
01531   /* Generic addition, but we might not be in a position to allow
01532      thread swaps */
01533   scheme_start_atomic();
01534   s = scheme_bin_plus(s, scheme_make_integer(v));
01535   scheme_end_atomic_no_swap();
01536 
01537   return s;
01538 }
01539 
01540 #define state_len(state) ((state >> 3) & 0x7)
01541 
01542 XFORM_NONGCING static void do_count_lines(Scheme_Port *ip, const char *buffer, long offset, long got)
01543 {
01544   long i;
01545   int c, degot = 0;
01546 
01547   mzAssert(ip->lineNumber >= 0);
01548   mzAssert(ip->column >= 0);
01549   mzAssert(ip->position >= 0);
01550 
01551   ip->oldColumn = ip->column; /* works for a single-char read, like `read' */
01552 
01553   ip->readpos += got; /* add for CR LF below */
01554 
01555   /* Find start of last line: */
01556   for (i = got, c = 0; i--; c++) {
01557     if (buffer[offset + i] == '\n' || buffer[offset + i] == '\r') {
01558       break;
01559     }
01560   }
01561 
01562   /* Count UTF-8-decoded chars, up to last line: */
01563   if (i >= 0) {
01564     int state = ip->utf8state;
01565     int n;
01566     degot += state_len(state);
01567     n = scheme_utf8_decode_count((const unsigned char *)buffer, offset, offset + i + 1, &state, 0, 0xFFFD);
01568     degot += (i + 1 - n);
01569     ip->utf8state = 0; /* assert: state == 0, because we ended with a newline */
01570   }
01571        
01572   if (i >= 0) {
01573     int n = 0;
01574     ip->charsSinceNewline = c + 1;
01575     i++;
01576     /* Continue walking, back over the previous lines, to find
01577        out how many there were: */
01578     while (i--) {
01579       if (buffer[offset + i] == '\n') {
01580        if (!(i && (buffer[offset + i - 1] == '\r'))
01581            && !(!i && ip->was_cr)) {
01582          n++;
01583        } else
01584          degot++; /* adjust positions for CRLF -> LF conversion */
01585       } else if (buffer[offset + i] == '\r') {
01586        n++;
01587       }
01588     }
01589                 
01590     mzAssert(n > 0);
01591     ip->lineNumber += n;
01592     ip->was_cr = (buffer[offset + got - 1] == '\r');
01593     /* Now reset column to 0: */
01594     ip->column = 0;
01595   } else {
01596     ip->charsSinceNewline += c;
01597   }
01598 
01599   /* Do the last line to get the column count right and to
01600      further adjust positions for UTF-8 decoding: */
01601   {
01602     int col = ip->column, n;
01603     int prev_i = got - c;
01604     int state = ip->utf8state;
01605     n = state_len(state);
01606     degot += n;
01607     col -= n;
01608     for (i = prev_i; i < got; i++) {
01609       if (buffer[offset + i] == '\t') {
01610        n = scheme_utf8_decode_count((const unsigned char *)buffer, offset + prev_i, offset + i, &state, 0, 0xFFFD);
01611        degot += ((i - prev_i) - n);
01612        col += n;
01613        col = col - (col & 0x7) + 8;
01614        prev_i = i + 1;
01615       }
01616     }
01617     if (prev_i < i) {
01618       n = scheme_utf8_decode_count((const unsigned char *)buffer, offset + prev_i, offset + i, &state, 1, 0xFFFD);
01619       n += state_len(state);
01620       col += n;
01621       degot += ((i - prev_i) - n);
01622     }
01623     ip->column = col;
01624     ip->utf8state = state;
01625   }
01626 
01627   ip->readpos -= degot;
01628 
01629   mzAssert(ip->lineNumber >= 0);
01630   mzAssert(ip->column >= 0);
01631   mzAssert(ip->position >= 0);
01632 }
01633 
01634 long scheme_get_byte_string_unless(const char *who,
01635                                Scheme_Object *port,
01636                                char *buffer, long offset, long size,
01637                                int only_avail,
01638                                int peek, Scheme_Object *peek_skip,
01639                                Scheme_Object *unless_evt)
01640 {
01641   Scheme_Input_Port *ip;
01642   long got = 0, total_got = 0, gc;
01643   int special_ok = special_is_ok, check_special;
01644   Scheme_Get_String_Fun gs;
01645   Scheme_Peek_String_Fun ps;
01646 
01647   /* See also get_one_byte, below. Any change to this function
01648      may require a change to 1-byte specialization of get_one_byte. */
01649 
01650   /* back-door argument: */
01651   special_is_ok = 0;
01652 
01653   if (!size) {
01654     if (only_avail == -1) {
01655       /* We might need to break. */
01656       if (scheme_current_thread->external_break) {
01657        scheme_thread_block_enable_break(0.0, 1);
01658        scheme_current_thread->ran_some = 1;
01659       }
01660     }
01661     return 0;
01662   }
01663   if (!peek_skip)
01664     peek_skip = scheme_make_integer(0);
01665 
01666   ip = scheme_input_port_record(port);
01667 
01668   gs = ip->get_string_fun;
01669   ps = ip->peek_string_fun;
01670 
01671   while (1) {
01672     SCHEME_USE_FUEL(1);
01673 
01674     CHECK_PORT_CLOSED(who, "input", port, ip->closed);
01675 
01676     if (ip->input_lock)
01677       scheme_wait_input_allowed(ip, only_avail);
01678 
01679     if (only_avail == -1) {
01680       /* We might need to break. */
01681       if (scheme_current_thread->external_break) {
01682        scheme_thread_block_enable_break(0.0, 1);
01683        scheme_current_thread->ran_some = 1;
01684       }
01685     }
01686 
01687     if ((ip->ungotten_count || pipe_char_count(ip->peeked_read))
01688        && (!total_got || !peek)) {
01689       long l, i;
01690       unsigned char *s;
01691 
01692       i = ip->ungotten_count;
01693       /* s will be in reverse order */
01694 
01695       if (peek) {
01696        if (!SCHEME_INTP(peek_skip) || (i < SCHEME_INT_VAL(peek_skip))) {
01697          peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(i));
01698          i = 0;
01699        } else {
01700          i -= SCHEME_INT_VAL(peek_skip);
01701          peek_skip = scheme_make_integer(0);
01702        }
01703       }
01704 
01705       if (i < size)
01706        l = i;
01707       else
01708        l = size;
01709 
01710       size -= l;
01711       s = (unsigned char *)ip->ungotten; /* Not GC-safe! */
01712       while (l--) {
01713        buffer[offset + got++] = s[--i];
01714       }
01715       s = NULL;
01716 
01717       if (!peek)
01718        ip->ungotten_count = i;
01719 
01720       l = pipe_char_count(ip->peeked_read);
01721       if (size && l) {
01722        if (SCHEME_INTP(peek_skip) && (l > SCHEME_INT_VAL(peek_skip))) {
01723          l -= SCHEME_INT_VAL(peek_skip);
01724 
01725          if (l > size)
01726            l = size;
01727 
01728          if (l) {
01729            scheme_get_byte_string("depipe", ip->peeked_read,
01730                                buffer, offset + got, l,
01731                                1, peek, peek_skip);
01732            size -= l;
01733            got += l;
01734            peek_skip = scheme_make_integer(0);
01735            if (!peek && ip->progress_evt)
01736              post_progress(ip);
01737          }
01738        } else
01739          peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(l));
01740       }
01741       check_special = (!got || peek);
01742     } else
01743       check_special = 1;
01744 
01745     if (check_special && ip->ungotten_special) {
01746       if (!special_ok) {
01747        if (!peek) {
01748          if (ip->progress_evt)
01749            post_progress(ip);
01750          ip->ungotten_special = NULL;
01751        }
01752        scheme_bad_time_for_special(who, port);
01753       }
01754       if (!peek) {
01755        ip->special = ip->ungotten_special;
01756        ip->ungotten_special = NULL;
01757       } else {
01758        if (peek_skip != scheme_make_integer(0))
01759          scheme_bad_time_for_special(who, port);
01760       }
01761 
01762       if (!peek) {
01763        if (ip->p.position >= 0)
01764          ip->p.position++;
01765        if (ip->p.count_lines)
01766          inc_pos((Scheme_Port *)ip, 1);
01767       }
01768 
01769       if (!peek && ip->progress_evt)
01770        post_progress(ip);
01771 
01772       return SCHEME_SPECIAL;
01773     }
01774 
01775     if (got && ((only_avail == 1) || (only_avail == -1)))
01776       only_avail = 2;
01777 
01778     /* If we get this far in peek mode, ps is NULL, peek_skip is non-zero, and
01779        we haven't gotten anything so far, it means that we need to read before we
01780        can actually peek. Handle this case with a recursive peek that starts
01781        from the current position, then set peek_skip to 0 and go on. */
01782     while (peek && !ps && (peek_skip != scheme_make_integer(0)) && !total_got && !got
01783           && (ip->pending_eof < 2)) {
01784       char *tmp;
01785       int v, pcc;
01786       long skip;
01787       Scheme_Cont_Frame_Data cframe;
01788 
01789 
01790 #     define MAX_SKIP_TRY_AMOUNT 65536
01791 
01792       if (SCHEME_INTP(peek_skip)) {
01793        skip = SCHEME_INT_VAL(peek_skip);
01794        if (skip > MAX_SKIP_TRY_AMOUNT)
01795          skip = MAX_SKIP_TRY_AMOUNT;
01796       } else
01797        skip = MAX_SKIP_TRY_AMOUNT;
01798 
01799       tmp = (char *)scheme_malloc_atomic(skip);
01800       pcc = pipe_char_count(ip->peeked_read);
01801 
01802       if (only_avail == -1) {
01803        /* To implement .../enable-break, we enable
01804           breaks during the skip-ahead peek. */
01805        scheme_push_break_enable(&cframe, 1, 1);
01806       }
01807 
01808       v = scheme_get_byte_string_unless(who, port, tmp, 0, skip,
01809                                    (only_avail == 2) ? 2 : 0,
01810                                    1, scheme_make_integer(ip->ungotten_count + pcc),
01811                                    unless_evt);
01812 
01813       if (only_avail == -1) {
01814        scheme_pop_break_enable(&cframe, 0);
01815       }
01816 
01817       if (v == EOF) {
01818        ip->p.utf8state = 0;
01819        return EOF;
01820       } else if (v == SCHEME_SPECIAL) {
01821        ip->special = NULL;
01822        scheme_bad_time_for_special(who, port);
01823       } else if (v == skip) {
01824        peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(skip));
01825        /* Ok... ready to continue (if skip == peek_skip) */
01826       } else
01827        return 0;
01828     }
01829 
01830     if (size) {
01831       int nonblock;
01832 
01833       if (only_avail == 2) {
01834        if (got)
01835          nonblock = 2;
01836        else
01837          nonblock = 1;
01838       } else if (only_avail == -1)
01839        nonblock = -1;
01840       else
01841        nonblock = 0;
01842 
01843       if (unless_evt && SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type))
01844        unless_evt = SCHEME_PTR2_VAL(unless_evt);
01845 
01846       if (ip->pending_eof > 1) {
01847        ip->pending_eof = 1;
01848        gc = EOF;
01849       } else {
01850        /* Call port's get or peek function. But first, set up
01851           an "unless" to detect other accesses of the port
01852           if we block. */
01853        Scheme_Object *unless;
01854          
01855        if (nonblock > 0) {
01856          if (ip->unless)
01857            unless = ip->unless;
01858          else
01859            unless = NULL;
01860        } else if (ip->unless_cache) {
01861          if (ip->unless) {
01862            unless = ip->unless;
01863            /* Setting car to #f means that it can't be recycled */
01864            SCHEME_CAR(unless) = scheme_false;
01865          } else if (SCHEME_TRUEP(ip->unless_cache)) {
01866            unless = ip->unless_cache;
01867            ip->unless_cache = scheme_false;
01868            ip->unless = unless;
01869          } else {
01870            unless = scheme_make_raw_pair(NULL, NULL);
01871            ip->unless = unless;
01872          }
01873          if (unless_evt)
01874            SCHEME_CDR(unless) = unless_evt;
01875        } else
01876          unless = unless_evt;
01877 
01878        /* Finally, call port's get or peek: */
01879        if (peek && ps)
01880          gc = ps(ip, buffer, offset + got, size, peek_skip, nonblock, unless);
01881        else {
01882          gc = gs(ip, buffer, offset + got, size, nonblock, unless);
01883 
01884          if (!peek && gc && ip->progress_evt
01885              && (gc != EOF) 
01886              && (gc != SCHEME_UNLESS_READY))
01887            post_progress(ip);
01888        }
01889 
01890        /* Let other threads know that something happened,
01891           and/or deregister this thread's request for information. */
01892        if (unless && ip->unless_cache) {
01893          if (!SCHEME_CAR(unless)) {
01894            /* Recycle "unless", since we were the only user */
01895            ip->unless_cache = unless;
01896            SCHEME_CDR(unless) = NULL;
01897          } else {
01898            if (SCHEME_TRUEP(SCHEME_CAR(unless))) {
01899              /* gc should be SCHEME_UNLESS_READY; only a user
01900                port without a peek can incorrectly produce something 
01901                else */
01902              if (gc == SCHEME_UNLESS_READY) {
01903               gc = 0;
01904              }
01905            } else if (gc) {
01906              /* Notify other threads that something happened */
01907              SCHEME_CAR(unless) = scheme_true;
01908            }
01909          }
01910          ip->unless = NULL;
01911        }
01912       }
01913 
01914       if (gc == SCHEME_SPECIAL) {
01915        if (!got && !total_got && special_ok) {
01916          if (!peek) {
01917            if (ip->p.position >= 0)
01918              ip->p.position++;
01919            if (ip->p.count_lines)
01920              inc_pos((Scheme_Port *)ip, 1);
01921          }
01922          
01923          return SCHEME_SPECIAL;
01924        }
01925 
01926        if ((got || total_got) && only_avail) {
01927          ip->ungotten_special = ip->special;
01928          ip->special = NULL;
01929          gc = 0;
01930        } else {
01931          ip->special = NULL;
01932          scheme_bad_time_for_special(who, port);
01933          return 0;
01934        }
01935       } else if (gc == EOF) {
01936        ip->p.utf8state = 0;
01937        if (!got && !total_got) {
01938          if (peek && ip->pending_eof)
01939            ip->pending_eof = 2;
01940          return EOF;
01941        }
01942        /* remember the EOF for next time */
01943        if (ip->pending_eof)
01944          ip->pending_eof = 2;
01945        gc = 0;
01946        size = 0; /* so that we stop */
01947       } else if (gc == SCHEME_UNLESS_READY) {
01948        gc = 0;
01949        size = 0; /* so that we stop */
01950       }
01951       mzAssert(gc >= 0);
01952     } else
01953       gc = 0;
01954 
01955     got += gc;
01956     if (peek)
01957       peek_skip = quick_plus(peek_skip, gc);
01958     size -= gc;
01959 
01960     if (!peek) {
01961       /****************************************************/
01962       /* Adjust position information for chars got so far */
01963       /****************************************************/
01964 
01965       /* We don't get here if SCHEME_SPECIAL is returned, so
01966         the positions are updated separately in the two
01967         returning places above. */
01968 
01969       if (ip->p.position >= 0)
01970        ip->p.position += got;
01971       if (ip->p.count_lines)
01972        do_count_lines((Scheme_Port *)ip, buffer, offset, got);
01973     } else if (!ps) {
01974       /***************************************************/
01975       /* save newly peeked string for future peeks/reads */
01976       /***************************************************/
01977       if (gc) {
01978        if ((gc == 1) && !ip->ungotten_count && !ip->peeked_write) {
01979          ip->ungotten[ip->ungotten_count++] = buffer[offset];
01980        } else {
01981          if (!ip->peeked_write) {
01982            Scheme_Object *rd, *wt;
01983            scheme_pipe(&rd, &wt);
01984            ip->peeked_read = rd;
01985            ip->peeked_write = wt;
01986          }
01987 
01988          scheme_put_byte_string("peek", ip->peeked_write,
01989                              buffer, offset + got - gc, gc, 0);
01990        }
01991       }
01992     }
01993 
01994     offset += got;
01995     total_got += got;
01996     got = 0; /* for next round, if any */
01997 
01998     if (!size
01999        || (total_got && ((only_avail == 1) || (only_avail == -1)))
02000        || (only_avail == 2))
02001       break;
02002 
02003     /* Need to try to get more. */
02004   }
02005   
02006   return total_got;
02007 }
02008 
02009 long scheme_get_byte_string_special_ok_unless(const char *who,
02010                                          Scheme_Object *port,
02011                                          char *buffer, long offset, long size,
02012                                          int only_avail,
02013                                          int peek, Scheme_Object *peek_skip,
02014                                          Scheme_Object *unless_evt)
02015 {
02016   special_is_ok = 1;
02017   return scheme_get_byte_string_unless(who, port, buffer, offset, size, 
02018                                    only_avail, peek, peek_skip, unless_evt);
02019 }
02020 
02021 long scheme_get_byte_string(const char *who,
02022                          Scheme_Object *port,
02023                          char *buffer, long offset, long size,
02024                          int only_avail,
02025                          int peek, Scheme_Object *peek_skip)
02026 {
02027   return scheme_get_byte_string_unless(who, port,
02028                                    buffer, offset, size,
02029                                    only_avail,
02030                                    peek, peek_skip,
02031                                    NULL);
02032 }
02033 
02034 int scheme_unless_ready(Scheme_Object *unless)
02035 {
02036   if (!unless)
02037     return 0;
02038 
02039   if (SCHEME_CAR(unless) && SCHEME_TRUEP(SCHEME_CAR(unless)))
02040     return 1;
02041 
02042   if (SCHEME_CDR(unless))
02043     return scheme_try_plain_sema(SCHEME_CDR(unless));
02044 
02045   return 0;
02046 }
02047 
02048 
02049 void scheme_wait_input_allowed(Scheme_Input_Port *ip, int nonblock)
02050 {
02051   while (ip->input_lock) {
02052     scheme_post_sema_all(ip->input_giveup);
02053     scheme_wait_sema(ip->input_lock, nonblock ? -1 : 0);
02054   }
02055 }
02056 
02057 static void release_input_lock(Scheme_Input_Port *ip)
02058 {
02059   scheme_post_sema_all(ip->input_lock);
02060   ip->input_lock = NULL;
02061   ip->input_giveup = NULL;
02062 
02063   if (scheme_current_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP)
02064     scheme_current_thread->running -= MZTHREAD_NEED_SUSPEND_CLEANUP;
02065 }
02066 
02067 static void elect_new_main(Scheme_Input_Port *ip)
02068 {
02069   if (ip->input_extras_ready) {
02070     scheme_post_sema_all(ip->input_extras_ready);
02071     ip->input_extras = NULL;
02072     ip->input_extras_ready = NULL;
02073   }
02074 }
02075 
02076 static void release_input_lock_and_elect_new_main(void *_ip)
02077 {
02078   Scheme_Input_Port *ip;
02079 
02080   ip = scheme_input_port_record(_ip);
02081 
02082   release_input_lock(ip);
02083   elect_new_main(ip);
02084 }
02085 
02086 static void check_suspended()
02087 {
02088   if (scheme_current_thread->running & MZTHREAD_USER_SUSPENDED)
02089     scheme_thread_block(0.0);
02090 }
02091 
02092 static void remove_extra(void *ip_v)
02093 {
02094   Scheme_Input_Port *ip;
02095   Scheme_Object *v = SCHEME_CDR(ip_v), *ll, *prev;
02096 
02097   ip = scheme_input_port_record(SCHEME_CAR(ip_v));
02098 
02099   prev = NULL;
02100   for (ll = ip->input_extras; ll; prev = ll, ll = SCHEME_CDR(ll)) {
02101     if (SAME_OBJ(ll, SCHEME_CDR(v))) {
02102       if (prev)
02103        SCHEME_CDR(prev) = SCHEME_CDR(ll);
02104       else
02105        ip->input_extras = SCHEME_CDR(ll);
02106       SCHEME_CDR(ll) = NULL;
02107       break;
02108     }
02109   }
02110 
02111   /* Tell the main commit thread (if any) to reset */
02112   if (ip->input_giveup)
02113     scheme_post_sema_all(ip->input_giveup);
02114 }
02115 
02116 static int complete_peeked_read_via_get(Scheme_Input_Port *ip,
02117                                    long size)
02118 {
02119   Scheme_Get_String_Fun gs;
02120   int did;
02121   
02122   did = 0;
02123   
02124   /* Target event is ready, so commit must succeed */
02125   
02126   /* First remove ungotten_count chars */
02127   if (ip->ungotten_count) {
02128     if (ip->ungotten_count > size)
02129       ip->ungotten_count -= size;
02130     else {
02131       size -= ip->ungotten_count;
02132       ip->ungotten_count = 0;
02133     }
02134     if (ip->progress_evt)
02135       post_progress(ip);
02136     did = 1;
02137   }
02138   
02139   if (size) {
02140     Scheme_Input_Port *pip;
02141 
02142     if (ip->peek_string_fun) {
02143       /* If the port supplies its own peek, then we don't
02144         have peeked_r, so pass NULL as a buffer to the port's
02145         read proc. The read proc must not block. */
02146       gs = ip->get_string_fun;
02147       pip = ip;
02148     } else {
02149       /* Otherwise, peek was implemented through peeked_{w,r}: */
02150       if (ip->peeked_read) {
02151        int cnt;
02152        cnt = pipe_char_count(ip->peeked_read);
02153        if ((cnt < size) && (ip->pending_eof == 2))
02154          ip->pending_eof = 1;
02155        pip = (Scheme_Input_Port *)ip->peeked_read;
02156        gs = pip->get_string_fun;
02157       } else {
02158        gs = NULL;
02159        pip = NULL;
02160       }
02161     }
02162       
02163     if (gs) {
02164       size = gs(pip, NULL, 0, size, 1, NULL);
02165       if (size > 0) {
02166        if (ip->progress_evt)
02167          post_progress(ip);
02168        did = 1;
02169       }
02170     }
02171   }
02172    
02173   return did;
02174 }
02175 
02176 static Scheme_Object *return_data(void *data, int argc, Scheme_Object **argv)
02177 {
02178   return (Scheme_Object *)data;
02179 }
02180 
02181 int scheme_peeked_read_via_get(Scheme_Input_Port *ip,
02182                             long _size,
02183                             Scheme_Object *unless_evt,
02184                             Scheme_Object *_target_evt)
02185 {
02186   Scheme_Object * volatile v, *sema, *a[3], ** volatile aa, * volatile l;
02187   volatile long size = _size;
02188   volatile int n, current_leader = 0;
02189   volatile Scheme_Type t;
02190   Scheme_Object * volatile target_evt = _target_evt;
02191 
02192   /* Check whether t's event value is known to be always itself: */
02193   t = SCHEME_TYPE(target_evt);
02194   if (!SAME_TYPE(t, scheme_sema_type)
02195       && !SAME_TYPE(t, scheme_channel_put_type)
02196       && !SAME_TYPE(t, scheme_always_evt_type)
02197       && !SAME_TYPE(t, scheme_never_evt_type)
02198       && !SAME_TYPE(t, scheme_semaphore_repost_type)) {
02199     /* Make an event whose value is itself */
02200     a[0] = target_evt;
02201     v = scheme_make_closed_prim(return_data, target_evt);
02202     a[1] = v;
02203     target_evt = scheme_wrap_evt(2, a);
02204     ((Scheme_Closed_Primitive_Proc *)v)->data = target_evt;
02205   }
02206 
02207   /* This commit implementation is essentially CML style, but we avoid
02208      actually allocating a manager thread. Instead the various
02209      committing threads elect a leader, and we rely on being in the
02210      kernel to detect when the leader is killed or suspended, in which
02211      case we elect a new leader. */
02212 
02213   while (1) {
02214     if (scheme_wait_sema(unless_evt, 1)) {
02215       if (current_leader)
02216        elect_new_main(ip);
02217       return 0;
02218     }
02219 
02220     if (!current_leader && ip->input_giveup) {
02221       /* Some other thread is already trying to commit.
02222         Ask it to sync on our target, too */
02223       v = scheme_make_pair(scheme_make_integer(_size), target_evt);
02224       l = scheme_make_raw_pair(v, ip->input_extras);
02225       ip->input_extras = l;
02226 
02227       scheme_post_sema_all(ip->input_giveup);
02228 
02229       if (!ip->input_extras_ready) {
02230        sema = scheme_make_sema(0);
02231        ip->input_extras_ready = sema;
02232       }
02233 
02234       a[0] = ip->input_extras_ready;
02235       l = scheme_make_pair((Scheme_Object *)ip, v);
02236       BEGIN_ESCAPEABLE(remove_extra, l);
02237       scheme_sync(1, a);
02238       END_ESCAPEABLE();
02239 
02240       if (!SCHEME_CDR(v)) {
02241        /* We were selected, so the commit succeeded. */
02242        return SCHEME_TRUEP(SCHEME_CAR(v)) ? 1 : 0;
02243       }
02244     } else {
02245       /* No other thread is trying to commit. This one is hereby
02246         elected "main" if multiple threads try to commit. */
02247 
02248       if (SAME_TYPE(t, scheme_always_evt_type)) {
02249        /* Fast path: always-evt is ready */
02250        return complete_peeked_read_via_get(ip, size);
02251       }
02252 
02253       /* This sema makes other threads wait before reading: */
02254       sema = scheme_make_sema(0);
02255       ip->input_lock = sema;
02256       
02257       /* This sema lets other threads try to make progress,
02258         if the current target doesn't work out */
02259       sema = scheme_make_sema(0);
02260       ip->input_giveup = sema;
02261       
02262       if (ip->input_extras) {
02263        /* There are other threads trying to commit, and
02264           as main thread, we'll help them out. */
02265        n = 3;
02266        for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
02267          n++;
02268        }
02269        aa = MALLOC_N(Scheme_Object *, n);
02270        n = 3;
02271        for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
02272          aa[n++] = SCHEME_CDR(SCHEME_CAR(l));
02273        }
02274       } else {
02275        /* This is the only thread trying to commit */
02276        n = 3;
02277        aa = a;
02278       }
02279 
02280       /* Suspend here is a problem if another thread
02281         tries to commit, because this thread will be
02282         responsible for multiplexing the commits. That's
02283         why the thread waits on its own suspend event. */
02284       
02285       aa[0] = target_evt;
02286       aa[1] = ip->input_giveup;
02287       v = scheme_get_thread_suspend(scheme_current_thread);
02288       aa[2] = v;
02289 
02290       scheme_current_thread->running |= MZTHREAD_NEED_SUSPEND_CLEANUP;
02291       BEGIN_ESCAPEABLE(release_input_lock_and_elect_new_main, ip);
02292       v = scheme_sync(n, aa);
02293       END_ESCAPEABLE();
02294 
02295       release_input_lock(ip);
02296       
02297       if (SAME_OBJ(v, target_evt)) {
02298        int r;
02299        elect_new_main(ip);
02300        r = complete_peeked_read_via_get(ip, size);
02301        check_suspended();
02302        return r;
02303       }
02304 
02305       if (n > 3) {
02306        /* Check whether one of the others was selected: */
02307        for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
02308          if (SAME_OBJ(v, SCHEME_CDR(SCHEME_CAR(l)))) {
02309            /* Yep. Clear the cdr to tell the relevant thread
02310               that it was selected, and reset the extras. */
02311            v = SCHEME_CAR(l);
02312            SCHEME_CDR(v) = NULL;
02313            size = SCHEME_INT_VAL(SCHEME_CAR(v));
02314            elect_new_main(ip);
02315            if (complete_peeked_read_via_get(ip, size))
02316              SCHEME_CAR(v) = scheme_true;
02317            else
02318              SCHEME_CAR(v) = scheme_false;
02319            check_suspended();
02320            return 0;
02321          }
02322        }
02323       }
02324 
02325       if (scheme_current_thread->running & MZTHREAD_USER_SUSPENDED) {
02326        elect_new_main(ip);
02327        current_leader = 0;
02328        check_suspended();
02329       } else {
02330        current_leader = 1;
02331        
02332        /* Technically redundant, but avoid a thread swap
02333           if we know the commit isn't going to work: */
02334        if (scheme_wait_sema(unless_evt, 1)) {
02335          elect_new_main(ip);
02336          return 0;
02337        }
02338       
02339        scheme_thread_block(0.0);
02340       }
02341     }
02342   }
02343 }
02344 
02345 int scheme_peeked_read(Scheme_Object *port,
02346                      long size,
02347                      Scheme_Object *unless_evt,
02348                      Scheme_Object *target_evt)
02349 {
02350   Scheme_Input_Port *ip;
02351   Scheme_Peeked_Read_Fun pr;
02352   
02353   ip = scheme_input_port_record(port);
02354 
02355   unless_evt = SCHEME_PTR2_VAL(unless_evt);
02356 
02357   pr = ip->peeked_read_fun;
02358 
02359   return pr(ip, size, unless_evt, target_evt);
02360 }
02361 
02362 Scheme_Object *scheme_progress_evt_via_get(Scheme_Input_Port *port)
02363 {
02364   Scheme_Object *sema;
02365 
02366   if (port->progress_evt)
02367     return port->progress_evt;
02368 
02369   sema = scheme_make_sema(0);
02370 
02371   port->progress_evt = sema;
02372 
02373   return sema;
02374 }
02375 
02376 Scheme_Object *scheme_progress_evt(Scheme_Object *port)
02377 {  
02378   Scheme_Input_Port *ip;
02379   
02380   ip = scheme_input_port_record(port);
02381   
02382   if (ip->progress_evt_fun) {
02383     Scheme_Progress_Evt_Fun ce;
02384     Scheme_Object *evt, *o;
02385 
02386     ce = ip->progress_evt_fun;
02387 
02388     evt = ce(ip);
02389 
02390     o = scheme_alloc_object();
02391     o->type = scheme_progress_evt_type;
02392     SCHEME_PTR1_VAL(o) = (Scheme_Object *)port;
02393     SCHEME_PTR2_VAL(o) = evt;
02394 
02395     return o;
02396   }
02397 
02398   return NULL;
02399 }
02400 
02401 static int progress_evt_ready(Scheme_Object *evt, Scheme_Schedule_Info *sinfo)
02402 {
02403   scheme_set_sync_target(sinfo, SCHEME_PTR2_VAL(evt), evt, NULL, 0, 1, NULL);
02404   return 0;
02405 }
02406 
02407 long scheme_get_char_string(const char *who,
02408                          Scheme_Object *port,
02409                          mzchar *buffer, long offset, long size,
02410                          int peek, Scheme_Object *peek_skip)
02411 {
02412   int ahead_skip = 0;
02413   char *s;
02414   int total_got = 0, bsize, leftover = 0, got;
02415 
02416   /* read_string_byte_buffer helps avoid allocation */
02417   if (read_string_byte_buffer) {
02418     s = read_string_byte_buffer;
02419     read_string_byte_buffer = NULL;
02420   } else
02421     s = (char *)scheme_malloc_atomic(READ_STRING_BYTE_BUFFER_SIZE);
02422 
02423   while (1) {
02424     /* Since we want "size" more chars and we don't have leftovers, we
02425        need at least "size" more bytes.
02426 
02427        "leftover" is the number of bytes (<< READ_STRING_BYTE_BUFFER_SIZE) that
02428        we already have toward the first character. If the next
02429        character doesn't continue a leftover sequence, the next
02430        character actually belongs to a (leftover+1)th character. Thus,
02431        if leftover is positive and we're not merely peeking, ask for
02432        at leat one byte, but otherwise no more than size - leftover
02433        bytes. If size is 1, then we are forced to peek in all cases.
02434 
02435        Overall, if the size is big enough, we only read as many
02436        characters as our buffer holds. */
02437 
02438     bsize = size;
02439     if (leftover) {
02440       bsize -= leftover;
02441       if (bsize < 1) {
02442        /* This is the complex case. Need to peek a byte to see
02443           whether it continues the leftover sequence or ends it an in
02444           an error. */
02445        if (!peek_skip)
02446          peek_skip = scheme_make_integer(0);
02447        special_is_ok = 1;
02448        got = scheme_get_byte_string_unless(who, port,
02449                                        s, leftover, 1,
02450                                        0, 1 /* => peek */, 
02451                                        quick_plus(peek_skip, ahead_skip),
02452                                        NULL);
02453        if (got > 0) {
02454          long ulen, glen;
02455          glen = scheme_utf8_decode_as_prefix((const unsigned char *)s, 0, got + leftover,
02456                                          buffer, offset, offset + size,
02457                                          &ulen, 0, 0xFFFD);
02458          if (glen && (ulen < got + leftover)) {
02459            /* Got one, with a decoding error. If we weren't peeking,
02460               don't read the lookahead bytes after all, yet. */
02461            total_got++;
02462            bsize = 0;
02463            ahead_skip++;
02464            size--;
02465            offset++;
02466            /* leftover stays the same */
02467            memmove(s, s + 1, leftover);
02468          } else {
02469            /* Either we got one character, or we're still continuing. */
02470            ahead_skip++;
02471            if (!glen) {
02472              /* Continuing */
02473              leftover++;
02474            } else {
02475              /* Got one (no encoding error) */
02476              leftover = 0;
02477              offset++;
02478              --size;
02479              total_got++;
02480              if (!peek) {
02481               /* Read the lookahead bytes and discard them */
02482               scheme_get_byte_string_unless(who, port,
02483                                          s, 0, ahead_skip,
02484                                          0, 0, scheme_make_integer(0),
02485                                          NULL);
02486              } else {
02487               peek_skip = quick_plus(peek_skip, ahead_skip);
02488              }
02489              ahead_skip = 0;
02490            }
02491            /* Continue with the normal decoing process (but get 0
02492               more characters this time around) */
02493            bsize = 0;
02494          }
02495        } else {
02496          /* Either EOF or SPECIAL -- either one ends the leftover
02497             sequence in an error. We may have more leftover chars
02498             than we need, but they haven't been read, yet. */
02499          while (leftover && size) {
02500            buffer[offset++] = 0xFFFD;
02501            total_got++;
02502            --leftover;
02503            --size;
02504          }
02505          return total_got;
02506        }
02507       }
02508     }
02509 
02510     if (bsize) {
02511       /* Read bsize bytes */
02512       if (bsize + leftover > READ_STRING_BYTE_BUFFER_SIZE)
02513        bsize = READ_STRING_BYTE_BUFFER_SIZE - leftover;
02514       
02515       got = scheme_get_byte_string_unless(who, port,
02516                                      s, leftover, bsize,
02517                                      0, peek, peek_skip,
02518                                      NULL);
02519     } else
02520       got = 0;
02521 
02522     if (got >= 0) {
02523       long ulen, glen;
02524 
02525       glen = scheme_utf8_decode_as_prefix((const unsigned char *)s, 0, got + leftover,
02526                                      buffer, offset, offset + size,
02527                                      &ulen, 0, 0xFFFD);
02528       
02529       total_got += glen;
02530       if (glen == size) {
02531        /* Got enough */
02532        read_string_byte_buffer = s;
02533        return total_got;
02534       }
02535       offset += glen;
02536       size -= glen;
02537       leftover = (got + leftover) - ulen;
02538       memmove(s, s + ulen, leftover);
02539       if (peek) {
02540        peek_skip = quick_plus(peek_skip, got);
02541       }
02542     } else {
02543       read_string_byte_buffer = s;
02544 
02545       /* Leftover bytes must be decoding-error bytes: */
02546       while (leftover) {
02547        buffer[offset++] = 0xFFFD;
02548        total_got++;
02549        --leftover;
02550       }
02551 
02552       if (!total_got)
02553        return got; /* must be EOF */
02554       else
02555        return total_got;
02556     }
02557   }
02558 }
02559 
02560 static MZ_INLINE
02561 long get_one_byte(const char *who,
02562                 Scheme_Object *port,
02563                 char *buffer, long offset,
02564                 int only_avail)
02565 {
02566   Scheme_Input_Port *ip;
02567   long gc;
02568   int special_ok = special_is_ok;
02569   Scheme_Get_String_Fun gs;
02570 
02571   special_is_ok = 0;
02572 
02573   ip = scheme_input_port_record(port);
02574 
02575   CHECK_PORT_CLOSED(who, "input", port, ip->closed);
02576 
02577   if (ip->input_lock)
02578     scheme_wait_input_allowed(ip, only_avail);
02579 
02580   if (ip->ungotten_count) {
02581     buffer[offset] = ip->ungotten[--ip->ungotten_count];
02582     gc = 1;
02583   } else if (ip->peeked_read && pipe_char_count(ip->peeked_read)) {
02584     int ch;
02585     ch = scheme_get_byte(ip->peeked_read);
02586     buffer[offset] = ch;
02587     gc = 1;
02588   } else if (ip->ungotten_special) {
02589     if (ip->progress_evt)
02590       post_progress(ip);
02591     if (!special_ok) {
02592       ip->ungotten_special = NULL;
02593       scheme_bad_time_for_special(who, port);
02594       return 0;
02595     }
02596     ip->special = ip->ungotten_special;
02597     ip->ungotten_special = NULL;
02598     if (ip->p.position >= 0)
02599       ip->p.position++;
02600     if (ip->p.count_lines)
02601       inc_pos((Scheme_Port *)ip, 1);
02602     return SCHEME_SPECIAL;
02603   } else {
02604     if (ip->pending_eof > 1) {
02605       ip->pending_eof = 1;
02606       return EOF;
02607     } else {
02608       /* Call port's get function. */
02609       gs = ip->get_string_fun;
02610 
02611       gc = gs(ip, buffer, offset, 1, 0, NULL);
02612        
02613       if (ip->progress_evt && (gc > 0))
02614        post_progress(ip);
02615 
02616       if (gc < 1) {
02617        if (gc == SCHEME_SPECIAL) {
02618          if (special_ok) {
02619            if (ip->p.position >= 0)
02620              ip->p.position++;
02621            if (ip->p.count_lines)
02622              inc_pos((Scheme_Port *)ip, 1);
02623            return SCHEME_SPECIAL;
02624          } else {
02625            scheme_bad_time_for_special(who, port);
02626            return 0;
02627          }
02628        } else if (gc == EOF) {
02629          ip->p.utf8state = 0;
02630          return EOF;
02631        } else {
02632          /* didn't get anything the first try, so use slow path: */
02633          special_is_ok = special_ok;
02634          return scheme_get_byte_string_unless(who, port,
02635                                           buffer, offset, 1,
02636                                           0, 0, NULL, NULL);
02637        }
02638       }
02639     }
02640   }
02641 
02642   /****************************************************/
02643   /* Adjust position information for chars got so far */
02644   /****************************************************/
02645   
02646   if (ip->p.position >= 0)
02647     ip->p.position++;
02648   if (ip->p.count_lines)
02649     do_count_lines((Scheme_Port *)ip, buffer, offset, 1);
02650   
02651   return gc;
02652 }
02653 
02654 int
02655 scheme_getc(Scheme_Object *port)
02656 {
02657   char s[MAX_UTF8_CHAR_BYTES];
02658   unsigned int r[1];
02659   int v, delta = 0;
02660 
02661   while(1) {
02662     if (delta) {
02663       v = scheme_get_byte_string_unless("read-char", port,
02664                                    s, delta, 1,
02665                                    0,
02666                                    delta > 0, scheme_make_integer(delta-1),
02667                                    NULL);
02668     } else {
02669       v = get_one_byte("read-char", port,
02670                      s, 0, 
02671                      0);
02672     }
02673 
02674     if ((v == EOF) || (v == SCHEME_SPECIAL)) {
02675       if (!delta)
02676        return v;
02677       else {
02678        /* This counts as a decoding error. The high bit
02679           on the first character must be set. */
02680        return 0xFFFD;
02681       }
02682     } else {
02683       v = scheme_utf8_decode_prefix((const unsigned char *)s, delta + 1, r, 0);
02684       if (v > 0) {
02685        if (delta) {
02686          /* Need to read the peeked bytes (will ignore) */
02687          v = scheme_get_byte_string_unless("read-char", port,
02688                                        s, 0, delta,
02689                                        0,
02690                                        0, 0,
02691                                        NULL);
02692        }
02693        return r[0];
02694       } else if (v == -2) {
02695        /* -2 => decoding error */
02696        return 0xFFFD;
02697       } else if (v == -1) {
02698        /* In middle of sequence; start/continue peeking bytes */
02699        delta++;
02700       }
02701     }
02702   }
02703 }
02704 
02705 int
02706 scheme_get_byte(Scheme_Object *port)
02707 {
02708   char s[1];
02709   int v;
02710 
02711   v = get_one_byte("read-byte", port,
02712                  s, 0,
02713                  0);
02714 
02715   if ((v == EOF) || (v == SCHEME_SPECIAL))
02716     return v;
02717   else
02718     return ((unsigned char *)s)[0];
02719 }
02720 
02721 int
02722 scheme_getc_special_ok(Scheme_Object *port)
02723 {
02724   special_is_ok = 1;
02725   return scheme_getc(port);
02726 }
02727 
02728 int
02729 scheme_get_byte_special_ok(Scheme_Object *port)
02730 {
02731   special_is_ok = 1;
02732   return scheme_get_byte(port);
02733 }
02734 
02735 long scheme_get_bytes(Scheme_Object *port, long size, char *buffer, int offset)
02736 {
02737   int n;
02738   int only_avail = 0;
02739 
02740   if (size < 0) {
02741     size = -size;
02742     only_avail = 1;
02743   }
02744 
02745   n = scheme_get_byte_string_unless("read-bytes", port,
02746                                 buffer, offset, size,
02747                                 only_avail,
02748                                 0, 0,
02749                                 NULL);
02750 
02751   if (n == EOF)
02752     n = 0;
02753 
02754   mzAssert(n >= 0);
02755 
02756   return n;
02757 }
02758 
02759 int scheme_peek_byte_skip(Scheme_Object *port, Scheme_Object *skip, Scheme_Object *unless_evt)
02760 {
02761   char s[1];
02762   int v;
02763 
02764   v = scheme_get_byte_string_unless("peek-byte", port,
02765                                 s, 0, 1,
02766                                 0,
02767                                 1, skip,
02768                                 unless_evt);
02769 
02770   if ((v == EOF) || (v == SCHEME_SPECIAL))
02771     return v;
02772   else
02773     return ((unsigned char *)s)[0];
02774 }
02775 
02776 int scheme_peek_byte(Scheme_Object *port)
02777 {
02778   return scheme_peek_byte_skip(port, NULL, NULL);
02779 }
02780 
02781 int
02782 scheme_peek_byte_special_ok_skip(Scheme_Object *port, Scheme_Object *skip, Scheme_Object *unless_evt)
02783 {
02784   special_is_ok = 1;
02785   return scheme_peek_byte_skip(port, skip, unless_evt);
02786 }
02787 
02788 static int do_peekc_skip(Scheme_Object *port, Scheme_Object *skip, 
02789                       int only_avail, int *unavail)
02790 {
02791   char s[MAX_UTF8_CHAR_BYTES];
02792   unsigned int r[1];
02793   int v, delta = 0;
02794   Scheme_Object *skip2;
02795 
02796   if (unavail)
02797     *unavail = 0;
02798 
02799   while(1) {
02800     if (delta) {
02801       if (!skip)
02802        skip = scheme_make_integer(0);
02803       skip2 = quick_plus(skip, delta);
02804     } else
02805       skip2 = skip;
02806 
02807     v = scheme_get_byte_string_unless("peek-char", port,
02808                                   s, delta, 1,
02809                                   only_avail,
02810                                   1, skip2,
02811                                   NULL);
02812 
02813     if (!v) {
02814       if (unavail)
02815         *unavail = 1;
02816       return 0;
02817     }
02818 
02819     if ((v == EOF) || (v == SCHEME_SPECIAL)) {
02820       if (!delta)
02821        return v;
02822       else {
02823        /* This counts as a decoding error, so return 0xFFFD */
02824        return 0xFFFD;
02825       }
02826     } else {
02827       v = scheme_utf8_decode_prefix((const unsigned char *)s, delta + 1, r, 0);
02828       if (v > 0)
02829        return r[0];
02830       else if (v == -2) {
02831        /* -2 => decoding error */
02832        return 0xFFFD;
02833       } else if (v == -1) {
02834        /* In middle of sequence - keep getting bytes. */
02835        delta++;
02836       }
02837     }
02838   }
02839 }
02840 
02841 int scheme_peekc_skip(Scheme_Object *port, Scheme_Object *skip)
02842 {
02843   return do_peekc_skip(port, skip, 0, NULL);
02844 }
02845 
02846 int scheme_peekc(Scheme_Object *port)
02847 {
02848   return scheme_peekc_skip(port, scheme_make_integer(0));
02849 }
02850 
02851 int
02852 scheme_peekc_special_ok_skip(Scheme_Object *port, Scheme_Object *skip)
02853 {
02854   special_is_ok = 1;
02855   return scheme_peekc_skip(port, skip);
02856 }
02857 
02858 int
02859 scheme_peekc_special_ok(Scheme_Object *port)
02860 {
02861   return scheme_peekc_special_ok_skip(port, scheme_make_integer(0));
02862 }
02863 
02864 int scheme_peekc_is_ungetc(Scheme_Object *port)
02865 {
02866   Scheme_Input_Port *ip;
02867 
02868   ip = scheme_input_port_record(port);
02869 
02870   return !ip->peek_string_fun;
02871 }
02872 
02873 Scheme_Object *make_read_write_evt(Scheme_Type type, 
02874                                Scheme_Object *port, Scheme_Object *skip, 
02875                                char *str, long start, long size)
02876 {
02877   Scheme_Read_Write_Evt *rww;
02878 
02879   rww = MALLOC_ONE_TAGGED(Scheme_Read_Write_Evt);
02880   rww->so.type = type;
02881   rww->port = port;
02882   rww->v = skip;
02883   rww->str = str;
02884   rww->start = start;
02885   rww->size = size;
02886 
02887   return (Scheme_Object *)rww;
02888 }
02889 
02890 static int rw_evt_ready(Scheme_Object *_rww, Scheme_Schedule_Info *sinfo)
02891 {
02892   Scheme_Read_Write_Evt *rww = (Scheme_Read_Write_Evt *)_rww;
02893   long v;
02894 
02895   if (sinfo->false_positive_ok) {
02896     /* Causes the thread to swap in, which we need in case there's an
02897        exception: */
02898     sinfo->potentially_false_positive = 1;
02899     return 1;
02900   }
02901   
02902   if (rww->v) {
02903     Scheme_Output_Port *op;
02904     Scheme_Write_Special_Fun ws;
02905 
02906     op = scheme_output_port_record(rww->port);
02907     ws = op->write_special_fun;
02908 
02909     v = ws(op, rww->v, 1);
02910     if (v) {
02911       scheme_set_sync_target(sinfo, scheme_true, NULL, NULL, 0, 0, NULL);
02912       return 1;
02913     } else    
02914       return 0;
02915   } else {
02916     v = scheme_put_byte_string("write-evt", rww->port,
02917                             rww->str, rww->start, rww->size,
02918                             2);
02919     if (v < 1)
02920       return 0;
02921     else if (!v && rww->size)
02922       return 0;
02923     else {
02924       scheme_set_sync_target(sinfo, scheme_make_integer(v), NULL, NULL, 0, 0, NULL);
02925       return 1;
02926     }
02927   }
02928 }
02929 
02930 static void rw_evt_wakeup(Scheme_Object *_rww, void *fds)
02931 {
02932   Scheme_Read_Write_Evt *rww = (Scheme_Read_Write_Evt *)_rww;
02933 
02934   if (rww->port) {
02935     if (rww->so.type == scheme_write_evt_type)
02936       output_need_wakeup(rww->port, fds);
02937     else
02938       scheme_need_wakeup(rww->port, fds);
02939   }
02940 }
02941 
02942 Scheme_Object *scheme_write_evt_via_write(Scheme_Output_Port *port,
02943                                      const char *str, long offset, long size)
02944 {
02945   return make_read_write_evt(scheme_write_evt_type, (Scheme_Object *)port, NULL, 
02946                           (char *)str, offset, size);
02947 }
02948 
02949 Scheme_Object *scheme_write_special_evt_via_write_special(Scheme_Output_Port *port, 
02950                                                    Scheme_Object *special)
02951 {
02952   return make_read_write_evt(scheme_write_evt_type, (Scheme_Object *)port, special, 
02953                           NULL, 0, 1);
02954 }
02955        
02956 Scheme_Object *scheme_make_write_evt(const char *who, Scheme_Object *port,
02957                                  Scheme_Object *special, char *str, long start, long size)
02958 {
02959   Scheme_Output_Port *op;
02960 
02961   op = scheme_output_port_record(port);
02962 
02963   if (!special) {
02964     if (op->write_string_evt_fun) {
02965       Scheme_Write_String_Evt_Fun wse;
02966       wse = op->write_string_evt_fun;
02967       return wse(op, str, start, size);
02968     }
02969   } else {
02970     if (op->write_special_evt_fun) {
02971       Scheme_Write_Special_Evt_Fun wse = op->write_special_evt_fun;
02972       return wse(op, special);
02973     }
02974   }
02975 
02976   scheme_arg_mismatch("write-bytes-avail-evt",
02977                     "port does not support atomic writes: ",
02978                     port);
02979   return NULL;
02980 }
02981 
02982 void
02983 scheme_ungetc (int ch, Scheme_Object *port)
02984 {
02985   Scheme_Input_Port *ip;
02986 
02987   ip = scheme_input_port_record(port);
02988 
02989   CHECK_PORT_CLOSED("#<primitive:peek-port-char>", "input", port, ip->closed);
02990 
02991   if (ch == EOF) {
02992     if (ip->pending_eof) /* non-zero means that EOFs are tracked */
02993       ip->pending_eof = 2;
02994     return;
02995   } else if (ch == SCHEME_SPECIAL) {
02996     ip->ungotten_special = ip->special;
02997     ip->special = NULL;
02998   } else if (ch > 127) {
02999     unsigned char e[MAX_UTF8_CHAR_BYTES];
03000     unsigned int us[1];
03001     int len;
03002 
03003     us[0] = ch;
03004     len = scheme_utf8_encode_all(us, 1, e);
03005 
03006     if (ip->ungotten_count + len >= 24)
03007       scheme_signal_error("ungetc overflow");
03008     while (len) {
03009       ip->ungotten[ip->ungotten_count++] = e[--len];
03010     }
03011   } else {
03012     if (ip->ungotten_count == 24)
03013       scheme_signal_error("ungetc overflow");
03014     ip->ungotten[ip->ungotten_count++] = ch;
03015   }
03016 
03017   if (ip->p.position > 0)
03018     --ip->p.position;
03019   if (ip->p.count_lines) {
03020     --ip->p.column;
03021     --ip->p.readpos;
03022     if (!(--ip->p.charsSinceNewline)) {
03023       mzAssert(ip->p.lineNumber > 0);
03024       --ip->p.lineNumber;
03025       ip->p.column = ip->p.oldColumn;
03026     } else if (ch == '\t')
03027       ip->p.column = ip->p.oldColumn;
03028   }
03029 }
03030 
03031 int
03032 scheme_byte_ready (Scheme_Object *port)
03033 {
03034   Scheme_Input_Port *ip;
03035   int retval;
03036 
03037   ip = scheme_input_port_record(port);
03038 
03039   CHECK_PORT_CLOSED("char-ready?", "input", port, ip->closed);
03040 
03041   if (ip->ungotten_count || ip->ungotten_special
03042       || (ip->pending_eof > 1)
03043       || pipe_char_count(ip->peeked_read))
03044     retval = 1;
03045   else {
03046     Scheme_In_Ready_Fun f = ip->byte_ready_fun;
03047     retval = f(ip);
03048   }
03049 
03050   return retval;
03051 }
03052 
03053 int
03054 scheme_char_ready (Scheme_Object *port)
03055 {
03056   int unavail;
03057 
03058   if (!scheme_byte_ready(port))
03059     return 0;
03060 
03061   do_peekc_skip(port, scheme_make_integer(0), 2, &unavail);
03062   
03063   return !unavail;
03064 }
03065 
03066 Scheme_Object *scheme_get_special(Scheme_Object *port,
03067                               Scheme_Object *src, long line, long col, long pos,
03068                               int peek, Scheme_Hash_Table **for_read)
03069 {
03070   int cnt;
03071   Scheme_Object *a[4], *special;
03072   Scheme_Input_Port *ip;
03073   Scheme_Cont_Frame_Data cframe;
03074 
03075   SCHEME_USE_FUEL(1);
03076 
03077   ip = scheme_input_port_record(port);
03078 
03079   /* Only `read' and similar internals should call this function. A
03080      caller must should ensure that there are no ungotten
03081      characters. */
03082 
03083   if (ip->ungotten_count) {
03084     scheme_signal_error("ungotten characters at get-special");
03085     return NULL;
03086   }
03087   if (!ip->special) {
03088     scheme_signal_error("no ready special");
03089     return NULL;
03090   }
03091 
03092   CHECK_PORT_CLOSED("#<primitive:get-special>", "input", port, ip->closed);
03093 
03094   special = ip->special;
03095   ip->special = NULL;
03096 
03097   if (peek) {
03098     /* do location increment, since read didn't */
03099     if (line > 0)
03100       line++;
03101     if (col >= 0)
03102       col++;
03103     if (pos > 0)
03104       pos++;
03105   }
03106 
03107   a[0] = special;
03108   if (!src && scheme_check_proc_arity(NULL, 2, 0, 1, a))
03109     cnt = 0;
03110   else {
03111     cnt = 4;
03112     a[0] = (src ? src : scheme_false);
03113     a[1] = (line > 0) ? scheme_make_integer(line) : scheme_false;
03114     a[2] = (col > 0) ? scheme_make_integer(col-1) : scheme_false;
03115     a[3] = (pos > 0) ? scheme_make_integer(pos) : scheme_false;
03116   }
03117 
03118   scheme_push_continuation_frame(&cframe);
03119   scheme_set_in_read_mark(src, for_read);
03120 
03121   special = scheme_apply(special, cnt, a);
03122 
03123   scheme_pop_continuation_frame(&cframe);
03124 
03125   return special;
03126 }
03127 
03128 static Scheme_Object *do_get_ready_special(Scheme_Object *port, 
03129                                       Scheme_Object *stxsrc,
03130                                       int peek,
03131                                       Scheme_Hash_Table **ht)
03132 {
03133   long line, col, pos;
03134 
03135   if (!stxsrc) {
03136     Scheme_Input_Port *ip;
03137     ip = scheme_input_port_record(port);
03138     stxsrc = ip->name;
03139   }
03140 
03141   /* Don't use scheme_tell_all(), because we always want the
03142      MzScheme-computed values here. */
03143   line = scheme_tell_line(port);
03144   col = scheme_tell_column(port);
03145   pos = scheme_tell(port);
03146 
03147   return scheme_get_special(port, stxsrc, line, col, pos, peek, ht);
03148 }
03149 
03150 Scheme_Object *scheme_get_ready_read_special(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht)
03151 {
03152   return do_get_ready_special(port, stxsrc, 0, ht);
03153 }
03154 
03155 Scheme_Object *scheme_get_ready_special(Scheme_Object *port, 
03156                                    Scheme_Object *stxsrc,
03157                                    int peek)
03158 {
03159   return do_get_ready_special(port, stxsrc, peek, NULL);
03160 }
03161 
03162 void scheme_bad_time_for_special(const char *who, Scheme_Object *port)
03163 {
03164   scheme_arg_mismatch(who, "non-character in an unsupported context, from port: ", port);
03165 }
03166 
03167 static Scheme_Object *check_special_args(void *sbox, int argc, Scheme_Object **argv)
03168 {
03169   Scheme_Object *special;
03170   Scheme_Cont_Frame_Data cframe;
03171 
03172   if (SCHEME_TRUEP(argv[1]))
03173     if (!scheme_nonneg_exact_p(argv[1]) || (SAME_OBJ(argv[1], scheme_make_integer(0))))
03174       scheme_wrong_type("read-special", "positive exact integer or #f", 1, argc, argv);
03175   if (SCHEME_TRUEP(argv[2]))
03176     if (!scheme_nonneg_exact_p(argv[2]))
03177       scheme_wrong_type("read-special", "non-negative exact integer or #f", 2, argc, argv);
03178   if (SCHEME_TRUEP(argv[3]))
03179     if (!scheme_nonneg_exact_p(argv[3]) || (SAME_OBJ(argv[3], scheme_make_integer(0))))
03180       scheme_wrong_type("read-special", "positive exact integer or #f", 3, argc, argv);
03181 
03182   special = *(Scheme_Object **)sbox;
03183   if (!special)
03184     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03185                    "read-special: cannot be called a second time");
03186   *(Scheme_Object **)sbox = NULL;
03187 
03188   scheme_push_continuation_frame(&cframe);
03189   scheme_set_in_read_mark(NULL, NULL);
03190 
03191   special = _scheme_apply(special, 4, argv);
03192 
03193   scheme_pop_continuation_frame(&cframe);
03194 
03195   return special;
03196 }
03197 
03198 Scheme_Object *scheme_get_special_proc(Scheme_Object *inport)
03199 {
03200   Scheme_Object *special, **sbox;
03201   Scheme_Input_Port *ip;
03202 
03203   ip = scheme_input_port_record(inport);
03204   special = ip->special;
03205   ip->special = NULL;
03206   
03207   sbox = MALLOC_ONE(Scheme_Object *);
03208   *sbox = special;
03209   return scheme_make_closed_prim_w_arity(check_special_args, 
03210                                     sbox, "read-special",
03211                                     4, 4);
03212 }
03213 
03214 void
03215 scheme_need_wakeup (Scheme_Object *port, void *fds)
03216 {
03217   Scheme_Input_Port *ip;
03218 
03219   ip = scheme_input_port_record(port);
03220 
03221   if (ip->need_wakeup_fun) {
03222     Scheme_Need_Wakeup_Input_Fun f = ip->need_wakeup_fun;
03223     f(ip, fds);
03224   }
03225 }
03226 
03227 #define CHECK_IOPORT_CLOSED(who, port) \
03228         if (SCHEME_INPORTP((Scheme_Object *)port)) {                          \
03229           CHECK_PORT_CLOSED(who, "input", port, ((Scheme_Input_Port *)port)->closed); \
03230         } else { \
03231           CHECK_PORT_CLOSED(who, "output", port, ((Scheme_Output_Port *)port)->closed); \
03232         }
03233 
03234 long
03235 scheme_tell (Scheme_Object *port)
03236 {
03237   Scheme_Port *ip;
03238   long pos;
03239 
03240   ip = scheme_port_record(port);
03241   
03242   CHECK_IOPORT_CLOSED("get-file-position", ip);
03243 
03244   if (!ip->count_lines || (ip->position < 0))
03245     pos = ip->position;
03246   else
03247     pos = ip->readpos;
03248 
03249   return pos;
03250 }
03251 
03252 long
03253 scheme_tell_line (Scheme_Object *port)
03254 {
03255   Scheme_Port *ip;
03256   long line;
03257 
03258   ip = scheme_port_record(port);
03259 
03260   if (!ip->count_lines || (ip->position < 0))
03261     return -1;
03262 
03263   CHECK_IOPORT_CLOSED("get-file-line", ip);
03264 
03265   line = ip->lineNumber;
03266 
03267   return line;
03268 }
03269 
03270 long
03271 scheme_tell_column (Scheme_Object *port)
03272 {
03273   Scheme_Port *ip;
03274   long col;
03275 
03276   ip = scheme_port_record(port);
03277 
03278   if (!ip->count_lines || (ip->position < 0))
03279     return -1;
03280   
03281   CHECK_IOPORT_CLOSED("get-file-column", ip);
03282 
03283   col = ip->column;
03284 
03285   return col;
03286 }
03287 
03288 void
03289 scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
03290 {
03291   Scheme_Port *ip;
03292   long line = -1, col = -1, pos = -1;
03293   
03294   ip = scheme_port_record(port);
03295 
03296   if (ip->count_lines && ip->location_fun) {
03297     Scheme_Location_Fun location_fun;
03298     Scheme_Object *r, *a[3];
03299     long v;
03300     int got, i;
03301     
03302     location_fun = ip->location_fun;
03303     r = location_fun(ip);
03304 
03305     got = (SAME_OBJ(r, SCHEME_MULTIPLE_VALUES) ? scheme_multiple_count : 1);
03306     if (got != 3) {
03307       scheme_wrong_return_arity("user port next-location",
03308                             3, got, 
03309                             (got == 1) ? (Scheme_Object **)r : scheme_multiple_array,
03310                             "calling port-next-location procedure");
03311       return;
03312     }
03313 
03314     a[0] = scheme_multiple_array[0];
03315     a[1] = scheme_multiple_array[1];
03316     a[2] = scheme_multiple_array[2];
03317 
03318     for (i = 0; i < 3; i++) {
03319       v = -1;
03320       if (SCHEME_TRUEP(a[i])) {
03321        if (scheme_nonneg_exact_p(a[i])) {
03322          if (SCHEME_INTP(a[i])) {
03323            v = SCHEME_INT_VAL(a[i]);
03324            if ((i != 1) && !v) {
03325              a[0] = a[i];
03326              scheme_wrong_type("user port next-location", 
03327                             ((i == 1) ? "non-negative exact integer or #f" : "positive exact integer or #f"),
03328                             -1, -1, a);
03329              return;
03330            }
03331          }
03332        }
03333       }
03334       switch(i) {
03335       case 0:
03336        line = v;
03337        break;
03338       case 1:
03339        col = v;
03340        break;
03341       case 2:
03342        pos = v;
03343        break;
03344       }
03345     }
03346 
03347     /* Internally, positions count from 0 instead of 1 */
03348     if (pos > -1)
03349       pos--;
03350   } else {
03351     line = scheme_tell_line(port);
03352     col = scheme_tell_column(port);
03353     pos = scheme_tell(port);
03354   }
03355 
03356   if (_line) *_line = line;
03357   if (_col) *_col = col;
03358   if (_pos) *_pos = pos;  
03359 }
03360 
03361 void
03362 scheme_count_lines (Scheme_Object *port)
03363 {
03364   Scheme_Port *ip;
03365 
03366   ip = scheme_port_record(port);
03367 
03368   if (!ip->count_lines) {
03369     ip->count_lines = 1;
03370     if (ip->count_lines_fun) {
03371       Scheme_Count_Lines_Fun cl = ip->count_lines_fun;
03372       cl(ip);
03373     }
03374   }
03375 }
03376 
03377 void
03378 scheme_close_input_port (Scheme_Object *port)
03379 {
03380   Scheme_Input_Port *ip;
03381 
03382   ip = scheme_input_port_record(port);
03383 
03384   if (!ip->closed) {
03385     if (ip->close_fun) {
03386       Scheme_Close_Input_Fun f = ip->close_fun;
03387       f(ip);
03388     }
03389 
03390     if (ip->progress_evt) {
03391       scheme_post_sema_all(ip->progress_evt);
03392       ip->progress_evt = NULL;
03393     }
03394 
03395     if (ip->mref) {
03396       scheme_remove_managed(ip->mref, (Scheme_Object *)ip);
03397       ip->mref = NULL;
03398     }
03399 
03400     ip->closed = 1;
03401     ip->ungotten_count = 0;
03402     ip->ungotten_special = NULL;
03403   }
03404 }
03405 
03406 static void
03407 force_close_input_port(Scheme_Object *port)
03408 {
03409   scheme_force_port_closed = 1;
03410   scheme_close_input_port(port);
03411   scheme_force_port_closed = 0;
03412 }
03413 
03414 int scheme_close_should_force_port_closed()
03415 {
03416   return scheme_force_port_closed;
03417 }
03418 
03419 /****************************** main output writer ******************************/
03420 
03421 long
03422 scheme_put_byte_string(const char *who, Scheme_Object *port,
03423                      const char *str, long d, long len,
03424                      int rarely_block)
03425 {
03426   /* Unlike the main reader, the main writer is simple. It doesn't
03427      have to deal with peeks and specials, so it's a thin wrapper on
03428      the port's function. */
03429 
03430   Scheme_Output_Port *op;
03431   Scheme_Write_String_Fun ws;
03432   long out, llen, oout;
03433   int enable_break;
03434 
03435   op = scheme_output_port_record(port);
03436 
03437   CHECK_PORT_CLOSED(who, "output", port, op->closed);
03438 
03439   ws = op->write_string_fun;
03440 
03441   if (rarely_block == -1) {
03442     enable_break = 1;
03443     rarely_block = 1;
03444   } else
03445     enable_break = 0;
03446 
03447   if (enable_break) {
03448     if (scheme_current_thread->external_break) {
03449       scheme_thread_block_enable_break(0.0, 1);
03450       scheme_current_thread->ran_some = 1;
03451     }
03452   }
03453 
03454   if ((rarely_block == 1) && !len)
03455     /* By definition, a partial-progress write on a 0-length string is
03456        the same as a blocking flush */
03457     rarely_block = 0;
03458 
03459   llen = len;
03460   oout = 0;
03461   while (llen || !len) {
03462     out = ws(op, str, d, llen, rarely_block, enable_break);
03463     
03464     /* If out is 0, it might be because the port got closed: */
03465     if (!out) {
03466       CHECK_PORT_CLOSED(who, "output", port, op->closed);
03467     }
03468     
03469     if (out > 0) {
03470       op->p.position += out;
03471       oout += out;
03472       if (op->p.count_lines)
03473        do_count_lines((Scheme_Port *)op, str, d, out);
03474     }
03475 
03476     if (rarely_block || !len)
03477       break;
03478 
03479     llen -= out;
03480     d += out;
03481   }
03482 
03483   mzAssert(!rarely_block ? (oout == len) : 1);
03484   mzAssert((oout < 0) ? (rarely_block == 2) : 1);
03485 
03486   return oout;
03487 }
03488 
03489 void scheme_write_byte_string(const char *str, long len, Scheme_Object *port)
03490 {
03491   (void)scheme_put_byte_string("write-string", port, str, 0, len, 0);
03492 }
03493 
03494 void scheme_write_char_string(const mzchar *str, long len, Scheme_Object *port)
03495 {
03496   long blen;
03497   char *bstr, buf[64];
03498 
03499   bstr = scheme_utf8_encode_to_buffer_len(str, len, buf, 64, &blen);
03500   
03501   scheme_write_byte_string(bstr, blen, port);
03502 }
03503 
03504 long
03505 scheme_put_char_string(const char *who, Scheme_Object *port,
03506                      const mzchar *str, long d, long len)
03507 {
03508   long blen;
03509   char *bstr, buf[64];
03510 
03511   blen = scheme_utf8_encode(str, d, d + len, NULL, 0, 0);
03512   if (blen < 64)
03513     bstr = buf;
03514   else
03515     bstr = (char *)scheme_malloc_atomic(blen);
03516   scheme_utf8_encode(str, d, d + len, (unsigned char *)bstr, 0, 0);
03517 
03518   return scheme_put_byte_string(who, port, bstr, 0, blen, 0);
03519 }
03520 
03521 long
03522 scheme_output_tell(Scheme_Object *port)
03523 {
03524   return scheme_tell(port);
03525 }
03526 
03527 void
03528 scheme_close_output_port(Scheme_Object *port)
03529 {
03530   Scheme_Output_Port *op;
03531 
03532   op = scheme_output_port_record(port);
03533 
03534   if (!op->closed) {
03535     /* call close function first; it might raise an exception */
03536     if (op->close_fun) {
03537       Scheme_Close_Output_Fun f = op->close_fun;
03538       f(op);
03539     }
03540 
03541     /* NOTE: Allow the possibility that some other thread finishes the
03542        close while f blocks. */
03543 
03544     if (op->mref) {
03545       scheme_remove_managed(op->mref, (Scheme_Object *)op);
03546       op->mref = NULL;
03547     }
03548     
03549     op->closed = 1;
03550   }
03551 }
03552 
03553 static void
03554 force_close_output_port(Scheme_Object *port)
03555 {
03556   scheme_force_port_closed = 1;
03557   scheme_close_output_port(port);
03558   scheme_force_port_closed = 0;
03559 }
03560 
03561 /*========================================================================*/
03562 /*                           File port utils                              */
03563 /*========================================================================*/
03564 
03565 void scheme_flush_orig_outputs(void)
03566 {
03567   /* Flush original output ports: */
03568   if (flush_out)
03569     scheme_flush_output(scheme_orig_stdout_port);
03570   if (flush_err)
03571     scheme_flush_output(scheme_orig_stderr_port);
03572 }
03573 
03574 void scheme_flush_output(Scheme_Object *o)
03575 {
03576   scheme_put_byte_string("flush-output", o,
03577                       NULL, 0, 0,
03578                       0);
03579 }
03580 
03581 Scheme_Object *
03582 scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
03583 {
03584   Scheme_Object *p = argv[0];
03585 
03586   if (SCHEME_INPUT_PORTP(p)) {
03587     Scheme_Input_Port *ip;
03588 
03589     ip = scheme_input_port_record(p);
03590 
03591     if (SAME_OBJ(ip->sub_type, file_input_port_type))
03592       return scheme_true;
03593 #ifdef MZ_FDS
03594     else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
03595       return scheme_true;
03596 #endif
03597   } else if (SCHEME_OUTPUT_PORTP(p)) {
03598     Scheme_Output_Port *op;
03599 
03600     op = scheme_output_port_record(p);
03601 
03602     if (SAME_OBJ(op->sub_type, file_output_port_type))
03603       return scheme_true;
03604 #ifdef MZ_FDS
03605     else if (SAME_OBJ(op->sub_type, fd_output_port_type))
03606       return scheme_true;
03607 #endif
03608   } else {
03609     scheme_wrong_type("file-stream-port?", "port", 0, argc, argv);
03610   }
03611 
03612   return scheme_false;
03613 }
03614 
03615 int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
03616 {
03617   long fd = 0;
03618   int fd_ok = 0;
03619 
03620   if (SCHEME_INPUT_PORTP(p)) {
03621     Scheme_Input_Port *ip;
03622 
03623     ip = scheme_input_port_record(p);
03624 
03625     if (!ip->closed) {
03626       if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
03627        fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
03628        fd_ok = 1;
03629       }
03630 #ifdef MZ_FDS
03631       else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
03632        fd = ((Scheme_FD *)ip->port_data)->fd;
03633        fd_ok = 1;
03634       }
03635 #endif
03636     }
03637   } else if (SCHEME_OUTPUT_PORTP(p)) {
03638     Scheme_Output_Port *op;
03639 
03640     op = scheme_output_port_record(p);
03641 
03642     if (!op->closed) {
03643       if (SAME_OBJ(op->sub_type, file_output_port_type))  {
03644        fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
03645        fd_ok = 1;
03646       }
03647 #ifdef MZ_FDS
03648       else if (SAME_OBJ(op->sub_type, fd_output_port_type))  {
03649        fd = ((Scheme_FD *)op->port_data)->fd;
03650        fd_ok = 1;
03651       }
03652 #endif
03653     }
03654   }
03655 
03656   if (!fd_ok)
03657     return 0;
03658 
03659   *_fd = fd;
03660   return 1;
03661 }
03662 
03663 long scheme_get_port_fd(Scheme_Object *p)
03664 {
03665   long fd;
03666 
03667   if (scheme_get_port_file_descriptor(p, &fd))
03668     return fd;
03669   else
03670     return -1;
03671 }
03672 
03673 Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
03674 {
03675   long fd = 0;
03676   int fd_ok = 0;
03677   Scheme_Object *p;
03678 
03679   p = argv[0];
03680 
03681   fd_ok = scheme_get_port_file_descriptor(p, &fd);
03682 
03683   if (!fd_ok) {
03684     /* Maybe failed because it was closed... */
03685     if (SCHEME_INPUT_PORTP(p)) {
03686       Scheme_Input_Port *ip;
03687 
03688       ip = scheme_input_port_record(p);
03689       
03690       CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
03691     } else if (SCHEME_OUTPUT_PORTP(p)) {
03692       Scheme_Output_Port *op;
03693       
03694       op = scheme_output_port_record(p);
03695       
03696       CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
03697     }
03698 
03699     /* Otherwise, it's just the wrong type: */
03700     scheme_wrong_type("port-file-identity", "file-stream-port", 0, argc, argv);
03701     return NULL;
03702   }
03703 
03704   return scheme_get_fd_identity(p, fd);
03705 }
03706 
03707 static int is_fd_terminal(int fd)
03708 {
03709 #if defined(WIN32_FD_HANDLES)
03710   if (GetFileType((HANDLE)fd) == FILE_TYPE_CHAR) {
03711     DWORD mode;
03712     if (GetConsoleMode((HANDLE)fd, &mode))
03713       return 1;
03714     else
03715       return 0;
03716   } else
03717     return 0;
03718 #else
03719   return isatty(fd);
03720 #endif
03721 }
03722 
03723 Scheme_Object *scheme_terminal_port_p(int argc, Scheme_Object *argv[])
03724 {
03725   long fd = 0;
03726   int fd_ok = 0;
03727   Scheme_Object *p;
03728 
03729   p = argv[0];
03730 
03731   if (SCHEME_INPUT_PORTP(p)) {
03732     Scheme_Input_Port *ip;
03733 
03734     ip = scheme_input_port_record(p);
03735 
03736     if (ip->closed)
03737       return scheme_false;
03738 
03739     if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
03740       fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
03741       fd_ok = 1;
03742     }
03743 #ifdef MZ_FDS
03744     else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
03745       fd = ((Scheme_FD *)ip->port_data)->fd;
03746       fd_ok = 1;
03747     }
03748 #endif
03749   } else if (SCHEME_OUTPUT_PORTP(p)) {
03750     Scheme_Output_Port *op;
03751 
03752     op = scheme_output_port_record(p);
03753 
03754     if (op->closed)
03755       return scheme_false;
03756 
03757     if (SAME_OBJ(op->sub_type, file_output_port_type))  {
03758       fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
03759       fd_ok = 1;
03760     }
03761 #ifdef MZ_FDS
03762     else if (SAME_OBJ(op->sub_type, fd_output_port_type))  {
03763       fd = ((Scheme_FD *)op->port_data)->fd;
03764       fd_ok = 1;
03765     }
03766 #endif
03767   }
03768 
03769   if (!fd_ok)
03770     return scheme_false;
03771 
03772   return is_fd_terminal(fd) ? scheme_true : scheme_false;
03773 }
03774 
03775 static void filename_exn(char *name, char *msg, char *filename, int err)
03776 {
03777   char *dir, *drive;
03778   int len;
03779   char *pre, *rel, *post;
03780 
03781   len = strlen(filename);
03782 
03783   if (scheme_is_relative_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
03784     dir = scheme_os_getcwd(NULL, 0, NULL, 1);
03785     drive = NULL;
03786   } else if (scheme_is_complete_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
03787     dir = NULL;
03788     drive = NULL;
03789   } else {
03790     dir = NULL;
03791     drive = scheme_getdrive();
03792   }
03793 
03794   pre = dir ? " in directory \"" : (drive ? " on drive " : "");
03795   rel = dir ? dir : (drive ? drive : "");
03796   post = dir ? "\"" : "";
03797 
03798   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
03799                  "%s: %s: \"%q\"%s%q%s (" FILENAME_EXN_E ")",
03800                  name, msg, filename,
03801                  pre, rel, post,
03802                  err);
03803 }
03804 
03805 Scheme_Object *
03806 scheme_do_open_input_file(char *name, int offset, int argc, Scheme_Object *argv[], int internal)
03807 {
03808 #ifdef USE_FD_PORTS
03809   int fd;
03810   struct stat buf;
03811 #else
03812 # ifdef WINDOWS_FILE_HANDLES
03813   HANDLE fd;
03814 # else
03815   FILE *fp;
03816 # endif
03817 #endif
03818   char *mode = "rb";
03819   char *filename;
03820   int regfile, i;
03821   int m_set = 0;
03822   Scheme_Object *result;
03823 
03824   if (!SCHEME_PATH_STRINGP(argv[0]))
03825     scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 0, argc, argv);
03826 
03827   for (i = 1 + offset; argc > i; i++) {
03828     if (!SCHEME_SYMBOLP(argv[i]))
03829       scheme_wrong_type(name, "symbol", i, argc, argv);
03830 
03831     if (SAME_OBJ(argv[i], text_symbol)) {
03832       mode = "rt";
03833       m_set++;
03834     } else if (SAME_OBJ(argv[i], binary_symbol)) {
03835       /* This is the default */
03836       m_set++;
03837     } else {
03838       char *astr;
03839       long alen;
03840 
03841       astr = scheme_make_args_string("other ", i, argc, argv, &alen);
03842       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03843                      "%s: bad mode: %s%t", name,
03844                      scheme_make_provided_string(argv[i], 1, NULL),
03845                      astr, alen);
03846     }
03847 
03848     if (m_set > 1) {
03849       char *astr;
03850       long alen;
03851 
03852       astr = scheme_make_args_string("", -1, argc, argv, &alen);
03853       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03854                      "%s: conflicting or redundant "
03855                      "file modes given%t", name,
03856                      astr, alen);
03857     }
03858   }
03859 
03860   filename = scheme_expand_string_filename(argv[0],
03861                                       name,
03862                                       NULL,
03863                                       (internal ? 0 : SCHEME_GUARD_FILE_READ));
03864 
03865   if (!internal)
03866     scheme_custodian_check_available(NULL, name, "file-stream");
03867 
03868 #ifdef USE_FD_PORTS
03869   /* Note: assuming there's no difference between text and binary mode */
03870   do {
03871     fd = open(filename, O_RDONLY | MZ_NONBLOCKING | MZ_BINARY);
03872   } while ((fd == -1) && (errno == EINTR));
03873 
03874   if (fd == -1) {
03875     filename_exn(name, "cannot open input file", filename, errno);
03876     return NULL;
03877   } else {
03878     int ok;
03879 
03880     do {
03881       ok = fstat(fd, &buf);
03882     } while ((ok == -1) && (errno == EINTR));
03883 
03884     if (S_ISDIR(buf.st_mode)) {
03885       int cr;
03886       do {
03887        cr = close(fd);
03888       } while ((cr == -1) && (errno == EINTR));
03889       filename_exn(name, "cannot open directory as a file", filename, 0);
03890       return NULL;
03891     } else {
03892       regfile = S_ISREG(buf.st_mode);
03893       scheme_file_open_count++;
03894       result = make_fd_input_port(fd, scheme_make_path(filename), regfile, 0, NULL, internal);
03895     }
03896   }
03897 #else
03898 # ifdef WINDOWS_FILE_HANDLES
03899   fd = CreateFileW(WIDE_PATH(filename),
03900                  GENERIC_READ,
03901                  FILE_SHARE_READ | FILE_SHARE_WRITE,
03902                  NULL,
03903                  OPEN_EXISTING,
03904                  0,
03905                  NULL);
03906 
03907   if (fd == INVALID_HANDLE_VALUE) {
03908     filename_exn(name, "cannot open input file", filename, GetLastError());
03909     return NULL;
03910   } else
03911     regfile = (GetFileType(fd) == FILE_TYPE_DISK);
03912 
03913   if ((mode[1] == 't') && !regfile) {
03914     CloseHandle(fd);
03915     filename_exn(name, "cannot use text-mode on a non-file device", filename, 0);
03916     return NULL;
03917   }
03918 
03919   result = make_fd_input_port((int)fd, scheme_make_path(filename), regfile, mode[1] == 't', NULL, internal);
03920 # else
03921   if (scheme_directory_exists(filename)) {
03922     filename_exn(name, "cannot open directory as a file", filename, 0);
03923     return NULL;
03924   }
03925 
03926   regfile = scheme_is_regular_file(filename);
03927 
03928   fp = fopen(filename, mode);
03929   if (!fp) {
03930     filename_exn(name, "cannot open input file", filename, errno);
03931     return NULL;
03932   }
03933   scheme_file_open_count++;
03934 
03935   result = scheme_make_named_file_input_port(fp, scheme_make_path(filename));
03936 # endif
03937 #endif
03938 
03939   return result;
03940 }
03941 
03942 Scheme_Object *
03943 scheme_do_open_output_file(char *name, int offset, int argc, Scheme_Object *argv[], int and_read)
03944 {
03945 #ifdef USE_FD_PORTS
03946   int fd;
03947   int flags, regfile;
03948   struct stat buf;
03949   int ok;
03950 #else
03951 # ifdef WINDOWS_FILE_HANDLES
03952   HANDLE fd;
03953   int hmode, regfile;
03954   BY_HANDLE_FILE_INFORMATION info;
03955 # else
03956   FILE *fp;
03957 # endif
03958 #endif
03959   int e_set = 0, m_set = 0, i;
03960   int existsok = 0, must_exist = 0;
03961   char *filename;
03962   char mode[4];
03963   int typepos;
03964 
03965   mode[0] = 'w';
03966   mode[1] = 'b';
03967   mode[2] = 0;
03968   mode[3] = 0;
03969   typepos = 1;
03970 
03971   if (!SCHEME_PATH_STRINGP(argv[0]))
03972     scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 0, argc, argv);
03973 
03974   for (i = 1 + offset; argc > i; i++) {
03975     if (!SCHEME_SYMBOLP(argv[i]))
03976       scheme_wrong_type(name, "symbol", i, argc, argv);
03977 
03978     if (SAME_OBJ(argv[i], append_symbol)) {
03979       mode[0] = 'a';
03980       existsok = -1;
03981       e_set++;
03982     } else if (SAME_OBJ(argv[i], replace_symbol)) {
03983       existsok = 1;
03984       e_set++;
03985     } else if (SAME_OBJ(argv[i], truncate_symbol)) {
03986       existsok = -1;
03987       e_set++;
03988     } else if (SAME_OBJ(argv[i], must_truncate_symbol)) {
03989       existsok = -1;
03990       must_exist = 1;
03991       e_set++;
03992     } else if (SAME_OBJ(argv[i], truncate_replace_symbol)) {
03993       existsok = -2;
03994       e_set++;
03995     } else if (SAME_OBJ(argv[i], update_symbol)) {
03996       existsok = 2;
03997       must_exist = 1;
03998       if (typepos == 1) {
03999        mode[2] = mode[1];
04000        typepos = 2;
04001       }
04002       mode[0] = 'r';
04003       mode[1] = '+';
04004       e_set++;
04005     } else if (SAME_OBJ(argv[i], can_update_symbol)) {
04006       existsok = 3;
04007       if (typepos == 1) {
04008        mode[2] = mode[1];
04009        typepos = 2;
04010       }
04011       mode[0] = 'r';
04012       mode[1] = '+';
04013       e_set++;
04014     } else if (SAME_OBJ(argv[i], error_symbol)) {
04015       /* This is the default */
04016       e_set++;
04017     } else if (SAME_OBJ(argv[i], text_symbol)) {
04018       mode[typepos] = 't';
04019       m_set++;
04020     } else if (SAME_OBJ(argv[i], binary_symbol)) {
04021       /* This is the default */
04022       m_set++;
04023     } else {
04024       char *astr;
04025       long alen;
04026 
04027       astr = scheme_make_args_string("other ", i, argc, argv, &alen);
04028       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04029                      "%s: bad mode: %s%s", name,
04030                      scheme_make_provided_string(argv[i], 1, NULL),
04031                      astr, alen);
04032     }
04033 
04034     if (m_set > 1 || e_set > 1) {
04035       char *astr;
04036       long alen;
04037 
04038       astr = scheme_make_args_string("", -1, argc, argv, &alen);
04039       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04040                      "%s: conflicting or redundant "
04041                      "file modes given%t", name,
04042                      astr, alen);
04043     }
04044   }
04045 
04046   filename = scheme_expand_string_filename(argv[0],
04047                                       name, NULL,
04048                                       (SCHEME_GUARD_FILE_WRITE
04049                                        | ((existsok && ((existsok == 1) || (existsok == -2)))
04050                                           ? SCHEME_GUARD_FILE_DELETE
04051                                           : 0)
04052                                        /* append mode: */
04053                                        | ((mode[0] == 'a')
04054                                           ? SCHEME_GUARD_FILE_READ
04055                                           : 0)
04056                                        /* update mode: */
04057                                        | ((existsok > 1)
04058                                           ? SCHEME_GUARD_FILE_READ
04059                                           : 0)));
04060 
04061   scheme_custodian_check_available(NULL, name, "file-stream");
04062 
04063 #ifdef USE_FD_PORTS
04064   /* Note: assuming there's no difference between text and binary mode */
04065 
04066   flags = (and_read ? O_RDWR : O_WRONLY) | (must_exist ? 0 : O_CREAT);
04067 
04068   if (mode[0] == 'a')
04069     flags |= O_APPEND;
04070   else if (existsok < 0)
04071     flags |= O_TRUNC;
04072 
04073   if ((existsok <= 1) && (existsok > -1))
04074     flags |= O_EXCL;
04075 
04076   do {
04077     fd = open(filename, flags | MZ_NONBLOCKING | MZ_BINARY, 0666);
04078   } while ((fd == -1) && (errno == EINTR));
04079 
04080   if (errno == ENXIO) {
04081     /* FIFO with no reader? Try opening in RW mode: */
04082     flags -= O_WRONLY;
04083     flags |= O_RDWR;
04084     do {
04085       fd = open(filename, flags | MZ_NONBLOCKING | MZ_BINARY, 0666);
04086     } while ((fd == -1) && (errno == EINTR));
04087   }
04088 
04089   if (fd == -1) {
04090     if (errno == EISDIR) {
04091       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04092                      "%s: \"%q\" exists as a directory",
04093                      name, filename);
04094     } else if (errno == EEXIST) {
04095       if (!existsok)
04096        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04097                       "%s: file \"%q\" exists", name, filename);
04098       else {
04099        do {
04100          ok = unlink(filename);
04101        } while ((ok == -1) && (errno == EINTR));
04102 
04103        if (ok)
04104          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04105                         "%s: error deleting \"%q\"",
04106                         name, filename);
04107        do {
04108          fd = open(filename, flags | MZ_BINARY, 0666);
04109        } while ((fd == -1) && (errno == EINTR));
04110       }
04111     }
04112 
04113     if (fd == -1) {
04114       filename_exn(name, "cannot open output file", filename, errno);
04115       return NULL; /* shouldn't get here */
04116     }
04117   }
04118 
04119   do {
04120     ok = fstat(fd, &buf);
04121   } while ((ok == -1) && (errno == EINTR));
04122 
04123   regfile = S_ISREG(buf.st_mode);
04124   scheme_file_open_count++;
04125   return make_fd_output_port(fd, scheme_make_path(filename), regfile, 0, and_read, -1);
04126 #else
04127 # ifdef WINDOWS_FILE_HANDLES
04128   if (!existsok)
04129     hmode = CREATE_NEW;
04130   else if (existsok < 0) {
04131     if (must_exist)
04132       hmode = TRUNCATE_EXISTING;
04133     else
04134       hmode = OPEN_ALWAYS;
04135   } else if (existsok  == 1) {
04136     /* assert: !must_exist */
04137     hmode = CREATE_ALWAYS;
04138   } else if (existsok == 2) {
04139     hmode = OPEN_EXISTING;
04140   } else if (existsok == 3) {
04141     hmode = OPEN_ALWAYS;
04142   }
04143 
04144   fd = CreateFileW(WIDE_PATH(filename),
04145                  GENERIC_WRITE | (and_read ? GENERIC_READ : 0),
04146                  FILE_SHARE_READ | FILE_SHARE_WRITE,
04147                  NULL,
04148                  hmode,
04149                  FILE_FLAG_BACKUP_SEMANTICS, /* lets us detect directories in NT */
04150                  NULL);
04151 
04152   if (fd == INVALID_HANDLE_VALUE) {
04153     int err;
04154     err = GetLastError();
04155     if ((err == ERROR_ACCESS_DENIED) && (existsok < -1)) {
04156       /* Delete and try again... */
04157       if (DeleteFile(filename)) {
04158        fd = CreateFile(filename,
04159                      GENERIC_WRITE,
04160                      FILE_SHARE_READ | FILE_SHARE_WRITE,
04161                      NULL,
04162                      hmode,
04163                      0,
04164                      NULL);
04165        if (fd == INVALID_HANDLE_VALUE)
04166          err = GetLastError();
04167       } else {
04168        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04169                       "%s: error deleting \"%q\" (%E)",
04170                       name, filename, GetLastError());
04171        return NULL;
04172       }
04173     } else if (err == ERROR_FILE_EXISTS) {
04174       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04175                      "%s: file \"%q\" exists", name, filename);
04176       return NULL;
04177     }
04178 
04179     if (fd == INVALID_HANDLE_VALUE) {
04180       filename_exn(name, "cannot open output file", filename, err);
04181       return NULL;
04182     }
04183   }
04184 
04185   if (GetFileInformationByHandle(fd, &info)) {
04186     if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
04187       CloseHandle(fd);
04188       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04189                      "%s: \"%q\" exists as a directory",
04190                      name, filename);
04191       return NULL;
04192     }
04193   }
04194 
04195   regfile = (GetFileType(fd) == FILE_TYPE_DISK);
04196 
04197   if ((mode[1] == 't') && !regfile) {
04198     CloseHandle(fd);
04199     filename_exn(name, "cannot use text-mode on a non-file device", filename, 0);
04200     return NULL;
04201   }
04202 
04203   if (regfile && (existsok < 0)) {
04204     if (mode[0] == 'a')
04205       SetFilePointer(fd, 0, NULL, FILE_END);
04206     else
04207       SetEndOfFile(fd);
04208   }
04209 
04210   scheme_file_open_count++;
04211   return make_fd_output_port((int)fd, scheme_make_path(filename), regfile, mode[1] == 't', and_read, -1);
04212 # else
04213   if (scheme_directory_exists(filename)) {
04214     if (!existsok)
04215       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04216                      "%s: \"%q\" exists as a directory",
04217                      name, filename);
04218     else
04219       filename_exn(name, "cannot open directory as a file", filename, errno);
04220     return scheme_void;
04221   }
04222 
04223 
04224   if (and_read) {
04225     scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
04226                    "%s: not supported on this platform",
04227                    name);
04228     return NULL;
04229   }
04230 
04231   if (scheme_file_exists(filename)) {
04232     int uok;
04233 
04234     if (!existsok)
04235       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04236                      "%s: file \"%q\" exists", name, filename);
04237     do {
04238       uok = MSC_IZE(unlink)(filename);
04239     } while ((uok == -1) && (errno == EINTR));
04240 
04241     if (uok)
04242       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04243                      "%s: error deleting \"%q\" (%e)",
04244                      name, filename, errno);
04245   }
04246 
04247   fp = fopen(filename, mode);
04248   if (!fp) {
04249     if (existsok < -1) {
04250       /* Can't truncate; try to replace */
04251       if (scheme_file_exists(filename)) {
04252        int uok;
04253 
04254        do {
04255          uok = MSC_IZE(unlink)(filename);
04256        } while ((uok == -1) && (errno == EINTR));
04257 
04258        if (uok)
04259          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
04260                         "%s: error deleting \"%q\"",
04261                         name, filename);
04262        else {
04263          fp = fopen(filename, mode);
04264        }
04265       }
04266     }
04267     if (!fp)
04268       filename_exn(name, "cannot open output file", filename, errno);
04269   }
04270   scheme_file_open_count++;
04271 
04272   return scheme_make_file_output_port(fp);
04273 # endif
04274 #endif
04275 }
04276 
04277 Scheme_Object *scheme_open_input_file(const char *name, const char *who)
04278 {
04279   Scheme_Object *a[1];
04280 
04281   a[0]= scheme_make_path(name);
04282   return scheme_do_open_input_file((char *)who, 0, 1, a, 0);
04283 }
04284 
04285 Scheme_Object *scheme_open_output_file(const char *name, const char *who)
04286 {
04287   Scheme_Object *a[2];
04288 
04289   a[0]= scheme_make_path(name);
04290   a[1] = truncate_replace_symbol;
04291   return scheme_do_open_output_file((char *)who, 0, 2, a, 0);
04292 }
04293 
04294 Scheme_Object *scheme_open_input_output_file(const char *name, const char *who, Scheme_Object **oport)
04295 {
04296   Scheme_Object *a[2];
04297 
04298   a[0]= scheme_make_path(name);
04299   a[1] = truncate_replace_symbol;
04300   scheme_do_open_output_file((char *)who, 0, 2, a, 1);
04301   *oport = scheme_multiple_array[1];
04302   return scheme_multiple_array[0];
04303 }
04304 
04305 Scheme_Object *scheme_open_output_file_with_mode(const char *name, const char *who, int text)
04306 {
04307   Scheme_Object *a[3];
04308 
04309   a[0]= scheme_make_path(name);
04310   a[1] = truncate_replace_symbol;
04311   a[2] = (text ? text_symbol : binary_symbol);
04312   return scheme_do_open_output_file((char *)who, 0, 3, a, 0);
04313 }
04314 
04315 Scheme_Object *
04316 scheme_file_position(int argc, Scheme_Object *argv[])
04317 {
04318   FILE *f;
04319   Scheme_Indexed_String *is;
04320   int fd;
04321 #ifdef MZ_FDS
04322   int had_fd;
04323 #endif
04324   int wis;
04325 
04326   if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
04327     scheme_wrong_type("file-position", "port", 0, argc, argv);
04328   if (argc == 2) {
04329     if (!SCHEME_EOFP(argv[1])) {
04330       int ok = 0;
04331 
04332       if (SCHEME_INTP(argv[1])) {
04333        ok = (SCHEME_INT_VAL(argv[1]) >= 0);
04334       }
04335       
04336       if (SCHEME_BIGNUMP(argv[1])) {
04337        ok = SCHEME_BIGPOS(argv[1]);
04338       }
04339       
04340       if (!ok)
04341        scheme_wrong_type("file-position", "non-negative exact integer or eof", 1, argc, argv);
04342     }
04343   }
04344 
04345   f = NULL;
04346   is = NULL;
04347   wis = 0;
04348   fd = 0;
04349 #ifdef MZ_FDS
04350   had_fd = 0;
04351 #endif
04352 
04353   if (!SCHEME_INPUT_PORTP(argv[0])) {
04354     Scheme_Output_Port *op;
04355 
04356     op = scheme_output_port_record(argv[0]);
04357 
04358     if (SAME_OBJ(op->sub_type, file_output_port_type)) {
04359       f = ((Scheme_Output_File *)op->port_data)->f;
04360 #ifdef MZ_FDS
04361     } else if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
04362       fd = ((Scheme_FD *)op->port_data)->fd;
04363       had_fd = 1;
04364 #endif
04365     } else if (SAME_OBJ(op->sub_type, scheme_string_output_port_type)) {
04366       is = (Scheme_Indexed_String *)op->port_data;
04367       wis = 1;
04368     } else if (argc < 2)
04369       return scheme_make_integer(scheme_output_tell(argv[0]));
04370   } else {
04371     Scheme_Input_Port *ip;
04372 
04373     ip = scheme_input_port_record(argv[0]);
04374 
04375     if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
04376       f = ((Scheme_Input_File *)ip->port_data)->f;
04377 #ifdef MZ_FDS
04378     } else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
04379       fd = ((Scheme_FD *)ip->port_data)->fd;
04380       had_fd = 1;
04381 #endif
04382     } else if (SAME_OBJ(ip->sub_type, scheme_string_input_port_type))
04383       is = (Scheme_Indexed_String *)ip->port_data;
04384     else if (argc < 2) {
04385       long pos;
04386       pos = ip->p.position;
04387       if (pos < 0) {
04388        scheme_raise_exn(MZEXN_FAIL,
04389                       "the port's current position is not known: %v",
04390                       ip);
04391       }
04392       return scheme_make_integer_value(pos);
04393     }
04394   }
04395 
04396   if (!f
04397 #ifdef MZ_FDS
04398       && !had_fd
04399 #endif
04400       && !is)
04401     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04402                    "file-position: setting position allowed for file-stream and string ports only;"
04403                    " given %s and position %s",
04404                    scheme_make_provided_string(argv[0], 2, NULL),
04405                    scheme_make_provided_string(argv[1], 2, NULL));
04406 
04407   if (argc > 1) {
04408     mzlonglong nll;
04409     int whence;
04410 
04411     if (SCHEME_EOFP(argv[1])) {
04412       nll = 0;
04413       whence = SEEK_END;
04414     } else if (scheme_get_long_long_val(argv[1], &nll)) {
04415       whence = SEEK_SET;
04416       if ((mzlonglong)(mz_off_t)nll != nll) {
04417        nll = -1;
04418       }
04419     } else {
04420       whence = SEEK_SET; /* not used */
04421       nll = -1;
04422     }
04423 
04424     if (nll < 0) {
04425       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
04426                        "file-position: new position is too large: %s for port: %s",
04427                        scheme_make_provided_string(argv[1], 2, NULL),
04428                        scheme_make_provided_string(argv[0], 2, NULL));
04429       return NULL;
04430     }
04431       
04432     if (f) {
04433       if (BIG_OFF_T_IZE(fseeko)(f, nll, whence)) {
04434        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04435                       "file-position: position change failed on file (%e)",
04436                       errno);
04437       }
04438 #ifdef MZ_FDS
04439     } else if (had_fd) {
04440       long lv;
04441       
04442       if (!SCHEME_INPUT_PORTP(argv[0])) {
04443        flush_fd(scheme_output_port_record(argv[0]), NULL, 0, 0, 0, 0);
04444       }
04445       
04446 # ifdef WINDOWS_FILE_HANDLES
04447       {
04448        DWORD r;
04449        LONG lo_w, hi_w;
04450        lo_w = (LONG)(nll & 0xFFFFFFFF);
04451        hi_w = (LONG)(nll >> 32);
04452         r = SetFilePointer((HANDLE)fd, lo_w, &hi_w,
04453                         ((whence == SEEK_SET) ? FILE_BEGIN : FILE_END));
04454        if ((r == INVALID_SET_FILE_POINTER)
04455            && GetLastError() != NO_ERROR)
04456           lv = -1;
04457        else
04458          lv = 0;
04459       }
04460 # else
04461       lv = BIG_OFF_T_IZE(lseek)(fd, nll, whence);
04462 # endif
04463 
04464       if (lv < 0) {
04465 # ifdef WINDOWS_FILE_HANDLES
04466        int errid;
04467        errid = GetLastError();
04468        errno = errid;
04469 # endif
04470        scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04471                       "file-position: position change failed on stream (" FILENAME_EXN_E ")",
04472                       errno);
04473       }
04474 
04475       if (SCHEME_INPUT_PORTP(argv[0])) {
04476        /* Get rid of buffered data: */
04477        Scheme_FD *sfd;
04478         Scheme_Input_Port *ip;
04479         ip = scheme_input_port_record(argv[0]);
04480        sfd = (Scheme_FD *)ip->port_data;
04481        sfd->bufcount = 0;
04482        sfd->buffpos = 0;
04483        /* 1 means no pending eof, but can set: */
04484        ip->pending_eof = 1;
04485       }
04486 #endif
04487     } else {
04488       long n;
04489 
04490       if (whence == SEEK_SET) {
04491         if (!scheme_get_int_val(argv[1], &n)) {
04492           scheme_raise_out_of_memory(NULL, NULL);
04493         }
04494       } else {
04495         n = 0;
04496       }
04497 
04498       if (whence == SEEK_END) {
04499         if (wis)
04500           n = is->u.hot;
04501         else
04502           n = is->size;
04503       }
04504       if (wis) {
04505        if (is->index > is->u.hot)
04506          is->u.hot = is->index;
04507        if (is->size < n) {
04508          /* Expand string up to n: */
04509          char *old;
04510 
04511          old = is->string;
04512          {
04513            char *ca;
04514            ca = (char *)scheme_malloc_fail_ok(scheme_malloc_atomic, n + 1);
04515            is->string = ca;
04516           }
04517          is->size = n;
04518          memcpy(is->string, old, is->u.hot);
04519        }
04520        if (n > is->u.hot) {
04521          memset(is->string + is->u.hot, 0, n - is->u.hot);
04522           is->u.hot = n;
04523         }
04524       } else {
04525        /* Can't really move past end of read string, but pretend we do: */
04526        if (n > is->size) {
04527          is->u.pos = n;
04528          n = is->size;
04529        } else
04530          is->u.pos = 0;
04531       }
04532       is->index = n;
04533     }
04534 
04535     /* Remove any chars saved from peeks: */
04536     if (SCHEME_INPUT_PORTP(argv[0])) {
04537       Scheme_Input_Port *ip;
04538       ip = scheme_input_port_record(argv[0]);
04539       ip->ungotten_count = 0;
04540       if (pipe_char_count(ip->peeked_read)) {
04541        ip->peeked_read = NULL;
04542        ip->peeked_write = NULL;
04543       }
04544     }
04545 
04546     return scheme_void;
04547   } else {
04548     mzlonglong pll;
04549     if (f) {
04550       pll = BIG_OFF_T_IZE(ftello)(f);
04551 #ifdef MZ_FDS
04552     } else if (had_fd) {
04553 # ifdef WINDOWS_FILE_HANDLES
04554       {
04555        DWORD lo_w, hi_w;
04556        hi_w = 0;
04557         lo_w = SetFilePointer((HANDLE)fd, 0, &hi_w, FILE_CURRENT);
04558        if ((lo_w == INVALID_SET_FILE_POINTER)
04559            && GetLastError() != NO_ERROR)
04560           pll = -1;
04561         else
04562           pll = ((mzlonglong)hi_w << 32) | lo_w;
04563       }
04564 # else
04565       pll = BIG_OFF_T_IZE(lseek)(fd, 0, 1);
04566 # endif
04567       if (pll < 0) {
04568        if (SCHEME_INPUT_PORTP(argv[0])) {
04569          pll = scheme_tell(argv[0]);
04570        } else {
04571          pll = scheme_output_tell(argv[0]);
04572        }
04573       } else {
04574        if (SCHEME_INPUT_PORTP(argv[0])) {          
04575           Scheme_Input_Port *ip;
04576           ip = scheme_input_port_record(argv[0]);
04577          pll -= ((Scheme_FD *)ip->port_data)->bufcount;
04578        } else {
04579           Scheme_Output_Port *op;
04580           op = scheme_output_port_record(argv[0]);
04581          pll += ((Scheme_FD *)op->port_data)->bufcount;
04582        }
04583       }
04584 #endif
04585     } else if (wis)
04586       pll = is->index;
04587     else {
04588       /* u.pos > index implies we previously moved past the end with file-position */
04589       if (is->u.pos > is->index)
04590        pll = is->u.pos;
04591       else
04592        pll = is->index;
04593     }
04594 
04595     /* Back up for un-gotten & peeked chars: */
04596     if (SCHEME_INPUT_PORTP(argv[0])) {
04597       Scheme_Input_Port *ip;
04598       ip = scheme_input_port_record(argv[0]);
04599       pll -= ip->ungotten_count;
04600       pll -= pipe_char_count(ip->peeked_read);
04601     }
04602 
04603     return scheme_make_integer_value_from_long_long(pll);
04604   }
04605 }
04606 
04607 long scheme_set_file_position(Scheme_Object *port, long pos)
04608 {
04609   if (pos >= 0) {
04610     Scheme_Object *a[2];
04611 
04612     a[0] = port;
04613     a[1] = scheme_make_integer(pos);
04614     (void)scheme_file_position(2, a);
04615     return 0;
04616   } else {
04617     Scheme_Object *n;
04618     n = scheme_file_position(1, &port);
04619     return SCHEME_INT_VAL(n);
04620   }
04621 }
04622 
04623 Scheme_Object *
04624 scheme_file_buffer(int argc, Scheme_Object *argv[])
04625 {
04626   Scheme_Port *p = NULL;
04627 
04628   if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
04629     scheme_wrong_type("file-stream-buffer-mode", "port", 0, argc, argv);
04630 
04631   p = scheme_port_record(argv[0]);
04632 
04633   if (argc == 1) {
04634     Scheme_Buffer_Mode_Fun bm;
04635 
04636     bm = p->buffer_mode_fun;
04637     if (bm) {
04638       switch (bm(p, -1)) {
04639       case MZ_FLUSH_NEVER:
04640        return scheme_block_symbol;
04641       case MZ_FLUSH_BY_LINE:
04642        return scheme_line_symbol;
04643       case MZ_FLUSH_ALWAYS:
04644        return scheme_none_symbol;
04645       }
04646     }
04647 
04648     return scheme_false;
04649   } else {
04650     Scheme_Object *s = argv[1];
04651     Scheme_Buffer_Mode_Fun bm;
04652 
04653     if (!SAME_OBJ(s, scheme_block_symbol)
04654        && !SAME_OBJ(s, scheme_line_symbol)
04655        && !SAME_OBJ(s, scheme_none_symbol))
04656       scheme_wrong_type("file-stream-buffer-mode", "'none, 'line, or 'block", 1, argc, argv);
04657 
04658     if (SCHEME_INPUT_PORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
04659       scheme_arg_mismatch("file-stream-buffer-mode", 
04660                        "'line buffering not supported for an input port: ",
04661                        argv[0]);
04662 
04663     bm = p->buffer_mode_fun;
04664     if (bm) {
04665       int mode;
04666       if (SAME_OBJ(s, scheme_block_symbol))
04667        mode = MZ_FLUSH_NEVER;
04668       else if (SAME_OBJ(s, scheme_line_symbol))
04669        mode = MZ_FLUSH_BY_LINE;
04670       else
04671        mode = MZ_FLUSH_ALWAYS;
04672 
04673       bm(p, mode);
04674     } else {
04675       scheme_arg_mismatch("file-stream-buffer-mode", 
04676                        "cannot set buffer mode on port: ",
04677                        argv[0]);
04678     }
04679 
04680     return scheme_void;
04681   }
04682 }
04683 
04684 /*========================================================================*/
04685 /*                          FILE input ports                              */
04686 /*========================================================================*/
04687 
04688 static int
04689 file_byte_ready (Scheme_Input_Port *port)
04690 {
04691   return 1;
04692 }
04693 
04694 static long file_get_string(Scheme_Input_Port *port,
04695                          char *buffer, long offset, long size,
04696                          int nonblock,
04697                          Scheme_Object *unless_evt)
04698 {
04699   FILE *fp;
04700   Scheme_Input_File *fip;
04701   int c;
04702 
04703   fip = (Scheme_Input_File *)port->port_data;
04704   fp = fip->f;
04705 
04706   c = fread(buffer XFORM_OK_PLUS offset, 1, size, fp);
04707 
04708   if (c <= 0) {
04709     if (!feof(fp)) {
04710       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04711                      "error reading from file port %V (%e)",
04712                      port->name, errno);
04713       return 0;
04714     } else
04715       c = EOF;
04716 #ifndef DONT_CLEAR_FILE_EOF
04717     clearerr(fp);
04718 #endif
04719   }
04720 
04721   return c;
04722 }
04723 
04724 static void
04725 file_close_input(Scheme_Input_Port *port)
04726 {
04727   Scheme_Input_File *fip;
04728 
04729   fip = (Scheme_Input_File *)port->port_data;
04730 
04731   fclose(fip->f);
04732   --scheme_file_open_count;
04733 }
04734 
04735 static void
04736 file_need_wakeup(Scheme_Input_Port *port, void *fds)
04737 {
04738 }
04739 
04740 static int
04741 file_buffer_mode(Scheme_Port *p, int mode)
04742 {
04743   FILE *f;
04744   int bad;
04745 
04746   if (mode < 0)
04747     return -1; /* unknown mode */
04748 
04749   if (SCHEME_INPORTP((Scheme_Object *)p)) {
04750     Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
04751     f = ((Scheme_Output_File *)ip->port_data)->f;
04752   } else {
04753     Scheme_Output_Port *op = (Scheme_Output_Port *)p;
04754     f = ((Scheme_Output_File *)op->port_data)->f;
04755   }
04756   
04757   if (mode == MZ_FLUSH_NEVER)
04758     bad = setvbuf(f, NULL, _IOFBF, 0);
04759   else if (mode == MZ_FLUSH_BY_LINE)
04760     bad = setvbuf(f, NULL, _IOLBF, 0);
04761   else
04762     bad = setvbuf(f, NULL, _IONBF, 0);
04763   
04764   if (bad) {
04765     scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04766                    "file-stream-buffer-mode: error changing buffering (%e)",
04767                    errno);
04768   }
04769 
04770   return mode;
04771 }
04772 
04773 
04774 static Scheme_Object *
04775 _scheme_make_named_file_input_port(FILE *fp, Scheme_Object *name, int regfile)
04776 {
04777   Scheme_Input_Port *ip;
04778   Scheme_Input_File *fip;
04779 
04780   if (!fp)
04781     scheme_signal_error("make-file-input-port(internal): "
04782                      "null file pointer");
04783 
04784   fip = MALLOC_ONE_RT(Scheme_Input_File);
04785 #ifdef MZTAG_REQUIRED
04786   fip->type = scheme_rt_input_file;
04787 #endif
04788 
04789   fip->f = fp;
04790 
04791   ip = scheme_make_input_port(file_input_port_type,
04792                            fip,
04793                            name,
04794                            file_get_string,
04795                            NULL,
04796                            scheme_progress_evt_via_get,
04797                            scheme_peeked_read_via_get,
04798                            file_byte_ready,
04799                            file_close_input,
04800                            file_need_wakeup,
04801                            1);
04802   ip->p.buffer_mode_fun = file_buffer_mode;
04803 
04804   return (Scheme_Object *)ip;
04805 }
04806 
04807 Scheme_Object *
04808 scheme_make_named_file_input_port(FILE *fp, Scheme_Object *name)
04809 {
04810   return _scheme_make_named_file_input_port(fp, name, 0);
04811 }
04812 
04813 Scheme_Object *
04814 scheme_make_file_input_port(FILE *fp)
04815 {
04816   return scheme_make_named_file_input_port(fp, scheme_intern_symbol("file"));
04817 }
04818 
04819 /*========================================================================*/
04820 /*                           fd input ports                               */
04821 /*========================================================================*/
04822 
04823 #ifdef MZ_FDS
04824 
04825 # ifdef WINDOWS_FILE_HANDLES
04826 static long WindowsFDReader(Win_FD_Input_Thread *th);
04827 static void WindowsFDICleanup(Win_FD_Input_Thread *th);
04828 typedef BOOL (WINAPI* CSI_proc)(HANDLE);
04829 
04830 static CSI_proc get_csi(void)
04831 {
04832   static int tried_csi = 0;
04833   static CSI_proc csi;
04834   
04835   START_XFORM_SKIP;      
04836   if (!tried_csi) {
04837     HMODULE hm;
04838     hm = LoadLibrary("kernel32.dll");
04839     if (hm)
04840       csi = (CSI_proc)GetProcAddress(hm, "CancelSynchronousIo");
04841     else
04842       csi = NULL;
04843     tried_csi = 1;
04844   }
04845   END_XFORM_SKIP;
04846   return csi;
04847 }
04848 
04849 # endif
04850 
04851 /* forward decl: */
04852 static void fd_need_wakeup(Scheme_Input_Port *port, void *fds);
04853 
04854 #ifdef SOME_FDS_ARE_NOT_SELECTABLE
04855 static int try_get_fd_char(int fd, int *ready)
04856 {
04857   int old_flags, c;
04858   unsigned char buf[1];
04859 
04860   old_flags = fcntl(fd, F_GETFL, 0);
04861   fcntl(fd, F_SETFL, old_flags | MZ_NONBLOCKING);
04862   do {
04863     c = read(fd, buf, 1);
04864   } while ((c == -1) && errno == EINTR);
04865   fcntl(fd, F_SETFL, old_flags);
04866 
04867   if (c < 0) {
04868     *ready = 0;
04869     return 0;
04870   } else {
04871     *ready = 1;
04872     if (!c)
04873       return EOF;
04874     else
04875       return buf[0];
04876   }
04877 }
04878 #endif
04879 
04880 static int
04881 fd_byte_ready (Scheme_Input_Port *port)
04882 {
04883   Scheme_FD *fip;
04884 
04885   fip = (Scheme_FD *)port->port_data;
04886 
04887   if (fip->regfile || port->closed)
04888     return 1;
04889 
04890   if (fip->bufcount)
04891     return 1;
04892   else {
04893 #ifdef WINDOWS_FILE_HANDLES
04894     if (!fip->th) {
04895       /* No thread -- so wait works. This case isn't actually used
04896         right now, because wait doesn't seem to work reliably for
04897         anything that we can recognize other than regfiles, which are
04898         handled above. */
04899       if (WaitForSingleObject((HANDLE)fip->fd, 0) == WAIT_OBJECT_0)
04900        return 1;
04901     } else {
04902       /* Has the reader thread pulled in data? */
04903       if (fip->th->checking) {
04904        /* The thread is still trying, last we knew. Check the
04905           data-is-ready sema: */
04906        if (WaitForSingleObject(fip->th->ready_sema, 0) == WAIT_OBJECT_0) {
04907          fip->th->checking = 0;
04908          return 1;
04909        }
04910       } else if (fip->th->avail || fip->th->err || fip->th->eof)
04911        return 1; /* other thread found data */
04912       else {
04913        /* Doesn't have anything, and it's not even looking. Tell it
04914           to look: */
04915        fip->th->checking = 1;
04916        ReleaseSemaphore(fip->th->checking_sema, 1, NULL);
04917       }
04918     }
04919 
04920     return 0;
04921 #else
04922     int r;
04923     DECL_FDSET(readfds, 1);
04924     DECL_FDSET(exnfds, 1);
04925     struct timeval time = {0, 0};
04926 
04927     INIT_DECL_FDSET(readfds, 1);
04928     INIT_DECL_FDSET(exnfds, 1);
04929 
04930     MZ_FD_ZERO(readfds);
04931     MZ_FD_ZERO(exnfds);
04932     MZ_FD_SET(fip->fd, readfds);
04933     MZ_FD_SET(fip->fd, exnfds);
04934 
04935     do {
04936       r = select(fip->fd + 1, readfds, NULL, exnfds, &time);
04937     } while ((r == -1) && (errno == EINTR));
04938 
04939 # ifdef SOME_FDS_ARE_NOT_SELECTABLE
04940     /* Try a non-blocking read: */
04941     if (!r && !fip->textmode) {
04942       int c, ready;
04943 
04944       c = try_get_fd_char(fip->fd, &ready);
04945       if (ready) {
04946        if (c != EOF) {
04947          fip->buffpos = 0;
04948          fip->buffer[0] = (unsigned char)c;
04949          fip->bufcount = 1;
04950        }
04951        r = 1;
04952       }
04953     }
04954 # endif
04955 
04956     return r;
04957 #endif
04958   }
04959 }
04960 
04961 static long fd_get_string_slow(Scheme_Input_Port *port,
04962                                char *buffer, long offset, long size,
04963                                int nonblock,
04964                                Scheme_Object *unless)
04965 {
04966   Scheme_FD *fip;
04967   long bc;
04968 
04969   fip = (Scheme_FD *)port->port_data;
04970 
04971   while (1) {
04972     /* Loop until a read succeeds. */
04973     int none_avail = 0;
04974     int target_size, target_offset, ext_target;
04975     char *target;
04976 
04977     /* If no chars appear to be ready, go to sleep. */
04978     while (!fd_byte_ready(port)) {
04979       if (nonblock > 0)
04980         return 0;
04981 
04982       scheme_block_until_unless((Scheme_Ready_Fun)fd_byte_ready,
04983                                 (Scheme_Needs_Wakeup_Fun)fd_need_wakeup,
04984                                 (Scheme_Object *)port,
04985                                 0.0, unless,
04986                                 nonblock);
04987 
04988       scheme_wait_input_allowed(port, nonblock);
04989 
04990       if (scheme_unless_ready(unless))
04991         return SCHEME_UNLESS_READY;
04992     }
04993 
04994     if (port->closed) {
04995       /* Another thread closed the input port while we were waiting. */
04996       /* Call scheme_getc to signal the error */
04997       scheme_get_byte((Scheme_Object *)port);
04998     }
04999 
05000     /* Another thread might have filled the buffer, or
05001        if SOME_FDS_ARE_NOT_SELECTABLE is set,
05002        fd_byte_ready might have read one character. */
05003     if (fip->bufcount) {
05004       bc = ((size <= fip->bufcount)
05005             ? size
05006             : fip->bufcount);
05007 
05008       memcpy(buffer + offset, fip->buffer + fip->buffpos, bc);
05009       fip->buffpos += bc;
05010       fip->bufcount -= bc;
05011 
05012       return bc;
05013     }
05014 
05015     if ((size >= MZPORT_FD_DIRECT_THRESHOLD) && (fip->flush != MZ_FLUSH_ALWAYS)) {
05016       ext_target = 1;
05017       target = buffer;
05018       target_offset = offset;
05019       target_size = size;
05020     } else {
05021       ext_target = 0;
05022       target = (char *)fip->buffer;
05023       target_offset = 0;
05024       if (fip->flush == MZ_FLUSH_ALWAYS)
05025         target_size = 1;
05026       else
05027         target_size = MZPORT_FD_BUFFSIZE;
05028     }
05029 
05030 #ifdef WINDOWS_FILE_HANDLES
05031     if (!fip->th) {
05032       /* We can read directly. This must be a regular file, where
05033          reading never blocks. */
05034       DWORD rgot, delta;
05035 
05036       if (fip->textmode) {
05037         ext_target = 0;
05038         target = fip->buffer;
05039         target_offset = 0;
05040         if (fip->flush == MZ_FLUSH_ALWAYS)
05041           target_size = 1;
05042         else
05043           target_size = MZPORT_FD_BUFFSIZE;
05044       }
05045 
05046       rgot = target_size;
05047 
05048       /* Pending CR in text mode? */
05049       if (fip->textmode == 2) {
05050         delta = 1;
05051         if (rgot > 1)
05052           rgot--;
05053         fip->buffer[0] = '\r';
05054       } else
05055         delta = 0;
05056 
05057       if (ReadFile((HANDLE)fip->fd, target XFORM_OK_PLUS target_offset + delta, rgot, &rgot, NULL)) {
05058         bc = rgot;
05059       } else {
05060         int errid;
05061         bc = -1;
05062         errid = GetLastError();
05063         errno = errid;
05064       }
05065 
05066       /* bc == 0 and no err => EOF */
05067 
05068       /* Finish text-mode handling: */
05069       if (fip->textmode && (bc >= 0)) {
05070         int i, j;
05071         unsigned char *buf;
05072 
05073         if (fip->textmode == 2) {
05074           /* we had added a CR */
05075           bc++;
05076           fip->textmode = 1;
05077         }
05078 
05079         /* If bc is only 1, then we've reached the end, and
05080            any leftover CR there should stay. */
05081         if (bc > 1) {
05082           /* Collapse CR-LF: */
05083           buf = fip->buffer;
05084           for (i = 0, j = 0; i < bc - 1; i++) {
05085             if ((buf[i] == '\r')
05086                 && (buf[i+1] == '\n')) {
05087               buf[j++] = '\n';
05088               i++;
05089             } else
05090               buf[j++] = buf[i];
05091           }
05092           if (i < bc) /* common case: didn't end with CRLF */
05093             buf[j++] = buf[i];
05094           bc = j;
05095           /* Check for CR at end; if there, save it to maybe get a
05096              LF on the next read: */
05097           if (buf[bc - 1] == '\r') {
05098             bc--;
05099             fip->textmode = 2; /* 2 indicates a leftover CR */
05100           }
05101         }
05102       }
05103 
05104     } else {
05105       ext_target = 0;
05106 
05107       /* If we get this far, there's definitely data available.
05108          Extract data made available by the reader thread. */
05109       if (fip->th->eof) {
05110         bc = 0;
05111         if (fip->th->eof != INVALID_HANDLE_VALUE) {
05112           ReleaseSemaphore(fip->th->eof, 1, NULL);
05113           fip->th->eof = NULL;
05114         }
05115       } else if (fip->th->err) {
05116         bc = -1;
05117         errno = fip->th->err;
05118       } else {
05119         bc = fip->th->avail;
05120         fip->th->avail = 0;
05121       }
05122     }
05123 #else
05124     if (fip->regfile) {
05125       do {
05126         bc = read(fip->fd, target + target_offset, target_size);
05127       } while ((bc == -1) && (errno == EINTR));
05128     } else {
05129       /* We use a non-blocking read here, even though we've waited
05130          for input above, because an external process might have
05131          gobbled the characters that we expected to get. */
05132       int old_flags;
05133 
05134       old_flags = fcntl(fip->fd, F_GETFL, 0);
05135       fcntl(fip->fd, F_SETFL, old_flags | MZ_NONBLOCKING);
05136       do {
05137         bc = read(fip->fd, target + target_offset, target_size);
05138       } while ((bc == -1) && errno == EINTR);
05139       fcntl(fip->fd, F_SETFL, old_flags);
05140 
05141       if ((bc == -1) && (errno == EAGAIN)) {
05142         none_avail = 1;
05143         bc = 0;
05144       }
05145     }
05146 #endif
05147 
05148     if (!none_avail) {
05149       if (ext_target && (bc > 0)) {
05150         return bc;
05151       }
05152 
05153       fip->bufcount = bc;
05154 
05155       if (fip->bufcount < 0) {
05156         fip->bufcount = 0;
05157         fip->buffpos = 0;
05158         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05159                          "error reading from stream port %V (" FILENAME_EXN_E ")",
05160                          port->name, errno);
05161         return 0;
05162       }
05163 
05164       if (!fip->bufcount) {
05165         fip->buffpos = 0;
05166         return EOF;
05167       } else {
05168         bc = ((size <= fip->bufcount)
05169               ? size
05170               : fip->bufcount);
05171 
05172         memcpy(buffer + offset, fip->buffer, bc);
05173         fip->buffpos = bc;
05174         fip->bufcount -= bc;
05175 
05176         return bc;
05177       }
05178     } else if (nonblock > 0) {
05179       return 0;
05180     }
05181   }
05182 }
05183 
05184 static long fd_get_string(Scheme_Input_Port *port,
05185                        char *buffer, long offset, long size,
05186                        int nonblock,
05187                        Scheme_Object *unless)
05188 {
05189   Scheme_FD *fip;
05190   long bc;
05191 
05192   /* Buffer-reading fast path is designed to avoid GC, 
05193      and thus avoid MZ_PRECISE_GC instrumentation. */
05194 
05195   if (unless && scheme_unless_ready(unless))
05196     return SCHEME_UNLESS_READY;
05197 
05198   fip = (Scheme_FD *)port->port_data;
05199 
05200   if (fip->bufcount) {
05201     if (size == 1) {
05202       buffer[offset] = fip->buffer[fip->buffpos++];
05203       --fip->bufcount;
05204       return 1;
05205     } else {
05206       bc = ((size <= fip->bufcount)
05207            ? size
05208            : fip->bufcount);
05209 
05210       memcpy(buffer + offset, fip->buffer + fip->buffpos, bc);
05211       fip->buffpos += bc;
05212       fip->bufcount -= bc;
05213 
05214       return bc;
05215     }
05216   } else {
05217     if ((nonblock == 2) && (fip->flush == MZ_FLUSH_ALWAYS))
05218       return 0;
05219 
05220     return fd_get_string_slow(port, buffer, offset, size, nonblock, unless);
05221   }
05222 }
05223 
05224 static void
05225 fd_close_input(Scheme_Input_Port *port)
05226 {
05227   Scheme_FD *fip;
05228 
05229   fip = (Scheme_FD *)port->port_data;
05230 
05231 #ifdef WINDOWS_FILE_HANDLES
05232   if (fip->th) {
05233     CSI_proc csi;
05234 
05235     /* -1 for checking means "shut down" */
05236     fip->th->checking = -1;
05237     ReleaseSemaphore(fip->th->checking_sema, 1, NULL);
05238 
05239     if (fip->th->eof && (fip->th->eof != INVALID_HANDLE_VALUE)) {
05240       ReleaseSemaphore(fip->th->eof, 1, NULL);
05241       fip->th->eof = NULL;
05242     }
05243 
05244     csi = get_csi();
05245     if (csi) {
05246       /* Helps thread wake up. Otherwise, it's possible for the
05247          thread to stay stuck trying to read, in which case the
05248          file handle (probably a pipe) doesn't get closed. */
05249       csi(fip->th->thread);
05250     }
05251 
05252     /* Try to get out of cleaning up the records (since they can't be
05253        cleaned until the thread is also done: */
05254     if (WaitForSingleObject(fip->th->you_clean_up_sema, 0) != WAIT_OBJECT_0) {
05255       /* The other thread exited and left us with clean-up: */
05256       WindowsFDICleanup(fip->th);
05257     } /* otherwise, thread is responsible for clean-up */
05258   } else {
05259     int rc;
05260     rc = dec_refcount(fip->refcount);
05261     if (!rc) {
05262       CloseHandle((HANDLE)fip->fd);
05263       --scheme_file_open_count;
05264     }
05265   }
05266 #else
05267  {
05268    int rc;
05269    rc = dec_refcount(fip->refcount);
05270    if (!rc) {
05271      int cr;
05272      do {
05273        cr = close(fip->fd);
05274      } while ((cr == -1) && (errno == EINTR));
05275      --scheme_file_open_count;
05276    }
05277  }
05278 #endif
05279 }
05280 
05281 static void
05282 fd_need_wakeup(Scheme_Input_Port *port, void *fds)
05283 {
05284   Scheme_FD *fip;
05285 
05286 #ifdef WINDOWS_FILE_HANDLES
05287 #else
05288   void *fds2;
05289   int n;
05290 #endif
05291 
05292   fip = (Scheme_FD *)port->port_data;
05293 
05294 #ifdef WINDOWS_FILE_HANDLES
05295   if (fip->th) {
05296     /* See fd_byte_ready */
05297     if (!fip->th->checking) {
05298       if (fip->th->avail || fip->th->err || fip->th->eof) {
05299        /* Data is ready. We shouldn't be trying to sleep, so force an
05300           immediate wake-up: */
05301        scheme_add_fd_nosleep(fds);
05302       } else {
05303        fip->th->checking = 1;
05304        ReleaseSemaphore(fip->th->checking_sema, 1, NULL);
05305        scheme_add_fd_handle((void *)fip->th->ready_sema, fds, 1);
05306       }
05307     } else
05308       scheme_add_fd_handle((void *)fip->th->ready_sema, fds, 1);
05309   } else if (fip->regfile) {
05310     /* regular files never block */
05311     scheme_add_fd_nosleep(fds);
05312   } else {
05313     /* This case is not currently used. See fd_byte_ready. */
05314     scheme_add_fd_handle((void *)fip->fd, fds, 0);
05315   }
05316 #else
05317   n = fip->fd;
05318   MZ_FD_SET(n, (fd_set *)fds);
05319   fds2 = MZ_GET_FDSET(fds, 2);
05320   MZ_FD_SET(n, (fd_set *)fds2);
05321 #endif
05322 }
05323 
05324 static int fd_input_buffer_mode(Scheme_Port *p, int mode)
05325 {
05326   Scheme_FD *fd;
05327   Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
05328     
05329   fd = (Scheme_FD *)ip->port_data;
05330 
05331   if (mode < 0) {
05332     return fd->flush;
05333   } else {
05334     fd->flush = mode;
05335     return mode;
05336   }
05337 }
05338 
05339 static Scheme_Object *
05340 make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, int *refcount, int internal)
05341 {
05342   Scheme_Input_Port *ip;
05343   Scheme_FD *fip;
05344   unsigned char *bfr;
05345 
05346   fip = MALLOC_ONE_RT(Scheme_FD);
05347 #ifdef MZTAG_REQUIRED
05348   fip->type = scheme_rt_input_fd;
05349 #endif
05350 
05351   bfr = (unsigned char *)scheme_malloc_atomic(MZPORT_FD_BUFFSIZE);
05352   fip->buffer = bfr;
05353 
05354   fip->fd = fd;
05355   fip->bufcount = 0;
05356 
05357   fip->regfile = regfile;
05358 #ifdef SOME_FDS_ARE_NOT_SELECTABLE
05359   if (regfile || isatty(fd))
05360     fip->textmode = 1;
05361 #else
05362   fip->textmode = win_textmode;  
05363 #endif
05364 
05365   fip->refcount = refcount;
05366 
05367   fip->flush = MZ_FLUSH_NEVER;
05368 
05369   ip = scheme_make_input_port(fd_input_port_type,
05370                            fip,
05371                            name,
05372                            fd_get_string,
05373                            NULL,
05374                            scheme_progress_evt_via_get,
05375                            scheme_peeked_read_via_get,
05376                            fd_byte_ready,
05377                            fd_close_input,
05378                            fd_need_wakeup,
05379                            !internal);
05380   ip->p.buffer_mode_fun = fd_input_buffer_mode;
05381 
05382   ip->pending_eof = 1; /* means that pending EOFs should be tracked */
05383 
05384 #ifdef WINDOWS_FILE_HANDLES
05385   if (!regfile) {
05386     /* To get non-blocking I/O for anything that can block, we create
05387        a separate reader thread.
05388 
05389        Yes, Windows NT pipes support non-blocking reads, but there
05390        doesn't seem to be any way to use WaitForSingleObject to sleep
05391        until characters are ready. PeekNamedPipe can be used for
05392        polling, but not sleeping. */
05393 
05394     Win_FD_Input_Thread *th;
05395     DWORD id;
05396     HANDLE h;
05397     OS_SEMAPHORE_TYPE sm;
05398 
05399     th = (Win_FD_Input_Thread *)malloc(sizeof(Win_FD_Input_Thread));
05400     fip->th = th;
05401 
05402     /* Replace buffer with a malloced one: */
05403     bfr = (unsigned char *)malloc(MZPORT_FD_BUFFSIZE);
05404     fip->buffer = bfr;
05405     th->buffer = bfr;
05406 
05407     th->fd = (HANDLE)fd;
05408     th->avail = 0;
05409     th->err = 0;
05410     th->eof = NULL;
05411     th->checking = 0;
05412     
05413     sm = CreateSemaphore(NULL, 0, 1, NULL);
05414     th->checking_sema = sm;
05415     sm = CreateSemaphore(NULL, 0, 1, NULL);
05416     th->ready_sema = sm;
05417     sm = CreateSemaphore(NULL, 1, 1, NULL);
05418     th->you_clean_up_sema = sm;
05419     th->refcount = refcount;
05420 
05421     h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id);
05422 
05423     th->thread = h;
05424 
05425     scheme_remember_thread(h, 1);
05426   }
05427 #endif
05428 
05429   return (Scheme_Object *)ip;
05430 }
05431 
05432 # ifdef WINDOWS_FILE_HANDLES
05433 
05434 #ifdef MZ_XFORM
05435 START_XFORM_SKIP;
05436 #endif
05437 
05438 static long WindowsFDReader(Win_FD_Input_Thread *th)
05439 {
05440   DWORD toget, got;
05441   int perma_eof = 0;
05442   HANDLE eof_wait = NULL;
05443 
05444   if (GetFileType((HANDLE)th->fd) == FILE_TYPE_PIPE) {
05445     /* Reading from a pipe will return early when data is available. */
05446     toget = MZPORT_FD_BUFFSIZE;
05447   } else {
05448     /* Non-pipe: get one char at a time: */
05449     toget = 1;
05450   }
05451 
05452   while (!perma_eof && !th->err) {
05453     /* Wait until we're supposed to look for input: */
05454     WaitForSingleObject(th->checking_sema, INFINITE);
05455 
05456     if (th->checking < 0)
05457       break;
05458 
05459     if (ReadFile(th->fd, th->buffer, toget, &got, NULL)) {
05460       th->avail = got;
05461       if (!got) {
05462        /* We interpret a send of 0 bytes as a mid-stream EOF. */
05463        eof_wait = CreateSemaphore(NULL, 0, 1, NULL);
05464        th->eof = eof_wait;
05465       }
05466     } else {
05467       int err;
05468       err = GetLastError();
05469       if (err == ERROR_BROKEN_PIPE) {
05470        th->eof = INVALID_HANDLE_VALUE;
05471        perma_eof = 1;
05472       } else
05473        th->err = err;
05474     }
05475 
05476     /* Notify main program that we found something: */
05477     ReleaseSemaphore(th->ready_sema, 1, NULL);
05478 
05479     if (eof_wait) {
05480       WaitForSingleObject(eof_wait, INFINITE);
05481       eof_wait = NULL;
05482     }
05483   }
05484 
05485   /* We have to clean up if the main program has abandoned us: */
05486   if (WaitForSingleObject(th->you_clean_up_sema, 0) != WAIT_OBJECT_0) {
05487     WindowsFDICleanup(th);
05488   } /* otherwise, main program is responsible for clean-up */
05489 
05490   return 0;
05491 }
05492 
05493 static void WindowsFDICleanup(Win_FD_Input_Thread *th)
05494 {
05495   int rc;
05496 
05497   CloseHandle(th->checking_sema);
05498   CloseHandle(th->ready_sema);
05499   CloseHandle(th->you_clean_up_sema);
05500 
05501   rc = dec_refcount(th->refcount);
05502   if (!rc) CloseHandle(th->fd);
05503 
05504   free(th->buffer);
05505   free(th);
05506 }
05507 
05508 #ifdef MZ_XFORM
05509 END_XFORM_SKIP;
05510 #endif
05511 
05512 # endif
05513 
05514 #endif
05515 
05516 Scheme_Object *
05517 scheme_make_fd_input_port(int fd, Scheme_Object *name, int regfile, int textmode)
05518 {
05519 #ifdef MZ_FDS
05520   return make_fd_input_port(fd, name, regfile, textmode, NULL, 0);
05521 #else
05522   return NULL;
05523 #endif
05524 }
05525 
05526 /*========================================================================*/
05527 /*                    OSKit console input ports                           */
05528 /*========================================================================*/
05529 
05530 #ifdef USE_OSKIT_CONSOLE
05531 
05532 # ifdef OSKIT_TEST
05533 static Scheme_Object *normal_stdin;
05534 static int direct_cons_trygetchar() { return scheme_byte_ready(normal_stdin) ? scheme_get_byte(normal_stdin) : -1; }
05535 static void direct_cons_putchar(int c) { }
05536 # define convert_scan_code(x) x
05537 # else
05538 #  include "pc_keys.inc"
05539 # endif
05540 
05541 typedef struct osk_console_input {
05542   MZTAG_IF_REQUIRED
05543   int count, size, ready;
05544   unsigned char *buffer;
05545   struct osk_console_input *next; /* typeahead */
05546 } osk_console_input;
05547 
05548 static int
05549 osk_byte_ready (Scheme_Input_Port *port)
05550 {
05551   osk_console_input *osk, *orig;
05552   int k;
05553 
05554   if (port->closed)
05555     return 1;
05556 
05557   osk = orig = (osk_console_input *)port->port_data;
05558 
05559   while (osk->ready) {
05560     if (osk->next)
05561       osk = osk->next;
05562     else {
05563       osk->next = MALLOC_ONE_RT(osk_console_input);
05564 #ifdef MZTAG_REQUIRED
05565       osk->type = scheme_rt_oskit_console_input;
05566 #endif
05567       osk = osk->next;
05568       osk->count = osk->size = osk->ready = 0;
05569       osk->buffer = NULL;
05570       osk->next = NULL;
05571     }
05572   }
05573 
05574   k = direct_cons_trygetchar();
05575   k = convert_scan_code(k); /* defined in pc_keys.inc; handles ctl-alt-del */
05576   if (k > 0) {
05577     if (k == 3) { /* Ctl-C */
05578       scheme_break_thread(NULL);
05579     } else if (k == 4) { /* Ctl-D */
05580       if (!osk->count)
05581        /* ready with !count => EOF */
05582        osk->ready = 1;
05583     } else if (k == 8) { /* Backspace */
05584       if (osk->count) {
05585        direct_cons_putchar(8);
05586        direct_cons_putchar(' '); /* space erases old letter */
05587        direct_cons_putchar(8);
05588        --osk->count;
05589       }
05590     } else {
05591       if (osk->count == osk->size) {
05592        char *naya;
05593        osk->size = osk->size ? 2 * osk->size : 256;
05594        naya = scheme_malloc_atomic(osk->size);
05595        memcpy(naya, osk->buffer, osk->count);
05596        osk->buffer = naya;
05597       }
05598       osk->buffer[osk->count++] = k;
05599       if (k == 13 || k == 10) { /* Return/newline */
05600        direct_cons_putchar(13);
05601        direct_cons_putchar(10);
05602        osk->ready = 1;
05603       } else
05604        direct_cons_putchar(k);
05605     }
05606   }
05607 
05608   if (orig->ready)
05609     return 1;
05610   else
05611     return 0;
05612 }
05613 
05614 static int osk_get_string(Scheme_Input_Port *port,
05615                        char *buffer, int offset, int size,
05616                        int nonblock, Scheme_Object *unless)
05617 {
05618   int c;
05619   osk_console_input *osk;
05620 
05621   while (!osk_byte_ready(port)) {
05622     if (nonblock > 0) {
05623       return 0;
05624     }
05625     
05626     scheme_block_until_unless(osk_byte_ready, NULL, (Scheme_Object *)port, 0.0,
05627                            unless,
05628                            nonblock);
05629 
05630     scheme_wait_input_allowed(port, nonblock);
05631     
05632     if (scheme_unless_ready(unless))
05633       return SCHEME_UNLESS_READY;
05634   }
05635 
05636   if (port->closed) {
05637     /* Another thread closed the input port while we were waiting. */
05638     /* Call scheme_getc to signal the error */
05639     scheme_getc((Scheme_Object *)port);
05640   }
05641 
05642   osk = (osk_console_input *)port->port_data;
05643 
05644   if (!osk->count) {
05645     /* EOF */
05646     osk->ready = 0;
05647     return EOF;
05648   }
05649 
05650   c = osk->buffer[osk->ready - 1];
05651   osk->ready++;
05652   if (osk->ready > osk->count) {
05653     if (osk->next) {
05654       /* Copy typeahead to here */
05655       osk_console_input *next = osk->next;
05656       memcpy(osk, next, sizeof(osk_console_input));
05657     } else
05658       osk->ready = osk->count = 0;
05659   }
05660 
05661   buffer[offset] = c;
05662   return 1;
05663 }
05664 
05665 static void
05666 osk_close_input(Scheme_Input_Port *port)
05667 {
05668 }
05669 
05670 static void
05671 osk_need_wakeup(Scheme_Input_Port *port, void *fds)
05672 {
05673 # ifdef OSKIT_TEST
05674   /* for testing, write to stdout is almost certainly ready: */
05675   void *fdw;
05676   fdw = MZ_GET_FDSET(fds, 1);
05677   MZ_FD_SET(1, (fd_set *)fdw);
05678 # endif
05679 
05680   /* In OSKit, makes select() return immediately */
05681   MZ_FD_SET(0, (fd_set *)fds);
05682 }
05683 
05684 static Scheme_Object *
05685 make_oskit_console_input_port()
05686 {
05687   Scheme_Input_Port *ip;
05688   osk_console_input *osk;
05689 
05690   osk = MALLOC_ONE_RT(osk_console_input);
05691 #ifdef MZTAG_REQUIRED
05692   osk->type = scheme_rt_oskit_console_input;
05693 #endif
05694 
05695   osk->count = osk->size = osk->ready = 0;
05696   osk->buffer = NULL;
05697   osk->next = NULL;
05698 
05699 # ifdef OSKIT_TEST
05700   REGISTER_SO(normal_stdin);
05701   normal_stdin = scheme_make_named_file_input_port(stdin, scheme_intern_symbol("stdin"));
05702 # endif
05703 
05704   ip = scheme_make_input_port(oskit_console_input_port_type,
05705                            osk,
05706                            scheme_intern_symbol("stdin"),
05707                            osk_get_string,
05708                            NULL,
05709                            scheme_progress_evt_via_get,
05710                            scheme_get_string_unless_via_get,
05711                            osk_byte_ready,
05712                            osk_close_input,
05713                            osk_need_wakeup,
05714                            1);
05715 
05716   return (Scheme_Object *)ip;
05717 }
05718 
05719 void scheme_check_keyboard_input(void)
05720 {
05721   if (!osk_not_console)
05722     osk_byte_ready((Scheme_Input_Port *)scheme_orig_stdin_port);
05723 }
05724 
05725 #endif
05726 
05727 /*========================================================================*/
05728 /*                           FILE output ports                            */
05729 /*========================================================================*/
05730 
05731 /* Note that we don't try to implement non-blocking writes on FILE
05732    objects. In Unix, a program could conceiveably open a named pipe
05733    and block on it. */
05734 
05735 static void file_flush(Scheme_Output_Port *port)
05736 {
05737   if (fflush(((Scheme_Output_File *)port->port_data)->f)) {
05738     scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05739                    "error flushing file port (%e)",
05740                    errno);
05741   }
05742 }
05743 
05744 static long
05745 file_write_string(Scheme_Output_Port *port,
05746                 const char *str, long d, long llen,
05747                 int rarely_block, int enable_break)
05748 {
05749   FILE *fp;
05750   long len = llen;
05751 
05752   fp = ((Scheme_Output_File *)port->port_data)->f;
05753 
05754   if (!len) {
05755     file_flush(port);
05756     return 0;
05757   }
05758 
05759   if (fwrite(str XFORM_OK_PLUS d, len, 1, fp) != 1) {
05760     scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05761                    "error writing to file port (%e)",
05762                    errno);
05763     return 0;
05764   }
05765 
05766   if (rarely_block) {
05767     file_flush(port);
05768   } else {
05769     while (len--) {
05770       if (str[d] == '\n' || str[d] == '\r') {
05771        file_flush(port);
05772        break;
05773       }
05774       d++;
05775     }
05776   }
05777 
05778   return llen;
05779 }
05780 
05781 static void
05782 file_close_output(Scheme_Output_Port *port)
05783 {
05784   Scheme_Output_File *fop = (Scheme_Output_File *)port->port_data;
05785   FILE *fp = fop->f;
05786 
05787   fclose(fp);
05788   --scheme_file_open_count;
05789 }
05790 
05791 Scheme_Object *
05792 scheme_make_file_output_port(FILE *fp)
05793 {
05794   Scheme_Output_File *fop;
05795   Scheme_Output_Port *op;
05796 
05797   if (!fp)
05798     scheme_signal_error("make-file-out-port(internal): "
05799                      "null file pointer");
05800 
05801   fop = MALLOC_ONE_RT(Scheme_Output_File);
05802 #ifdef MZTAG_REQUIRED
05803   fop->type = scheme_rt_output_file;
05804 #endif
05805 
05806   fop->f = fp;
05807 
05808   op = scheme_make_output_port(file_output_port_type,
05809                             fop,
05810                             scheme_intern_symbol("file"),
05811                             scheme_write_evt_via_write,
05812                             file_write_string,
05813                             NULL,
05814                             file_close_output,
05815                             NULL,
05816                             NULL,
05817                             NULL,
05818                             1);
05819   op->p.buffer_mode_fun = file_buffer_mode;
05820 
05821   return (Scheme_Object *)op;
05822 }
05823 
05824 /*========================================================================*/
05825 /*                             fd output ports                            */
05826 /*========================================================================*/
05827 
05828 #ifdef MZ_FDS
05829 
05830 #ifdef WINDOWS_FILE_HANDLES
05831 static long WindowsFDWriter(Win_FD_Output_Thread *oth);
05832 static void WindowsFDOCleanup(Win_FD_Output_Thread *oth);
05833 #endif
05834 
05835 static int
05836 fd_flush_done(Scheme_Object *port)
05837 {
05838   Scheme_FD *fop;
05839   Scheme_Output_Port *op;
05840 
05841   op = scheme_output_port_record(port);
05842 
05843   fop = (Scheme_FD *)op->port_data;
05844 
05845   return !fop->flushing;
05846 }
05847 
05848 static void wait_until_fd_flushed(Scheme_Output_Port *op, int enable_break)
05849 {
05850   scheme_block_until_enable_break(fd_flush_done, NULL, (Scheme_Object *)op, 
05851                               0.0, enable_break);
05852 }
05853 
05854 #ifdef WINDOWS_FILE_HANDLES
05855 static int win_fd_flush_done(Scheme_Object *_oth)
05856 {
05857   /* For checking whether the output thread has finished a flush. */
05858 
05859   Win_FD_Output_Thread *oth = (Win_FD_Output_Thread *)_oth;
05860   int done;
05861 
05862   WaitForSingleObject(oth->lock_sema, INFINITE);
05863   if (oth->nonblocking) {
05864     if (oth->needflush) {
05865       oth->needflush = 0;
05866       oth->flushed = 0;
05867       ReleaseSemaphore(oth->work_sema, 1, NULL); /* start trying to flush */
05868       done = 0;
05869     } else
05870       done = oth->flushed;
05871   } else
05872     done = (oth->err_no || !oth->buflen);
05873   ReleaseSemaphore(oth->lock_sema, 1, NULL);
05874 
05875   return done;
05876 }
05877 
05878 static void win_fd_flush_needs_wakeup(Scheme_Object *_oth, void *fds)
05879 {
05880   /* For sleping until the output thread has finished a flush. */
05881 
05882   /* Double-check that we're not already done: */
05883   if (win_fd_flush_done(_oth))
05884     scheme_add_fd_nosleep(fds);
05885   else {
05886     /* Not done. Thread will notify us through ready_sema: */
05887     Win_FD_Output_Thread *oth = (Win_FD_Output_Thread *)_oth;
05888 
05889     scheme_add_fd_handle(oth->ready_sema, fds, 1);
05890   }
05891 }
05892 #endif
05893 
05894 static int
05895 fd_write_ready (Scheme_Object *port)
05896 {
05897   /* As always, the result of this function is only meaningful when
05898      the port has been flushed. */
05899 
05900   Scheme_FD *fop;
05901   Scheme_Output_Port *op;
05902 
05903   op = scheme_output_port_record(port);
05904   fop = (Scheme_FD *)op->port_data;
05905 
05906   if (fop->regfile || op->closed)
05907     return 1;
05908 
05909 #ifdef WINDOWS_FILE_HANDLES
05910   if (fop->oth) {
05911     /* Pipe output that can block... */
05912     int retval;
05913     Win_FD_Output_Thread *oth = fop->oth;
05914 
05915     WaitForSingleObject(oth->lock_sema, INFINITE);
05916     if (oth->nonblocking) {
05917       if (oth->needflush) {
05918        oth->needflush = 0;
05919        oth->flushed = 0;
05920        ReleaseSemaphore(oth->work_sema, 1, NULL); /* start trying to flush */
05921        retval = 0;
05922       } else
05923        retval = oth->flushed;
05924     } else
05925       retval = (oth->err_no || (oth->buflen < MZPORT_FD_BUFFSIZE));
05926     if (!retval)
05927       WaitForSingleObject(oth->ready_sema, 0); /* clear any leftover state */
05928     ReleaseSemaphore(oth->lock_sema, 1, NULL);
05929 
05930     return retval;
05931   } else
05932     return 1; /* non-blocking output, such as a console, or haven't written yet */
05933 #else
05934   {
05935     DECL_FDSET(writefds, 1);
05936     DECL_FDSET(exnfds, 1);
05937     struct timeval time = {0, 0};
05938     int sr;
05939 
05940     INIT_DECL_FDSET(writefds, 1);
05941     INIT_DECL_FDSET(exnfds, 1);
05942 
05943     MZ_FD_ZERO(writefds);
05944     MZ_FD_ZERO(exnfds);
05945     MZ_FD_SET(fop->fd, writefds);
05946     MZ_FD_SET(fop->fd, exnfds);
05947 
05948     do {
05949       sr = select(fop->fd + 1, NULL, writefds, exnfds, &time);
05950     } while ((sr == -1) && (errno == EINTR));
05951 
05952     return sr;
05953   }
05954 #endif
05955 }
05956 
05957 
05958 static void
05959 fd_write_need_wakeup(Scheme_Object *port, void *fds)
05960 {
05961   Scheme_Output_Port *op;
05962   Scheme_FD *fop;
05963 
05964 #ifdef WINDOWS_FILE_HANDLES
05965 #else
05966   void *fds2;
05967   int n;
05968 #endif
05969 
05970   op = scheme_output_port_record(port);
05971   fop = (Scheme_FD *)op->port_data;
05972 
05973 #ifdef WINDOWS_FILE_HANDLES
05974   if (fop->oth && !fd_write_ready(port))
05975     scheme_add_fd_handle(fop->oth->ready_sema, fds, 1);
05976   else
05977     scheme_add_fd_nosleep(fds);
05978 #else
05979   n = fop->fd;
05980   fds2 = MZ_GET_FDSET(fds, 1);
05981   MZ_FD_SET(n, (fd_set *)fds2);
05982   fds2 = MZ_GET_FDSET(fds, 2);
05983   MZ_FD_SET(n, (fd_set *)fds2);
05984 #endif
05985 }
05986 
05987 static void release_flushing_lock(void *_fop)
05988 {
05989   Scheme_FD *fop;
05990 
05991   fop = (Scheme_FD *)_fop;
05992 
05993   fop->flushing = 0;
05994 }
05995 
05996 static long flush_fd(Scheme_Output_Port *op,
05997                    const char * volatile bufstr, volatile unsigned long buflen, volatile unsigned long offset,
05998                    int immediate_only, int enable_break)
05999      /* immediate_only == 1 => write at least one character, then give up;
06000        immediate_only == 2 => never block */
06001 {
06002   Scheme_FD * volatile fop = (Scheme_FD *)op->port_data;
06003   volatile long wrote = 0;
06004 
06005   if (fop->flushing) {
06006     if (scheme_force_port_closed) {
06007       /* Give up */
06008       return 0;
06009     }
06010 
06011     if (immediate_only == 2)
06012       return 0;
06013 
06014     wait_until_fd_flushed(op, enable_break);
06015 
06016     if (op->closed)
06017       return 0;
06018   }
06019 
06020   if (!bufstr) {
06021     bufstr = (char *)fop->buffer;
06022     buflen = fop->bufcount;
06023   }
06024 
06025   if (buflen) {
06026     fop->flushing = 1;
06027     fop->bufcount = 0;
06028     /* If write is interrupted, we drop chars on the floor.
06029        Not ideal, but we'll go with it for now.
06030        Note that write_string_avail supports break-reliable
06031        output through `immediate_only'. */
06032 
06033     while (1) {
06034       long len;
06035       int errsaved, full_write_buffer;
06036 
06037 #ifdef WINDOWS_FILE_HANDLES
06038       DWORD winwrote;
06039 
06040       full_write_buffer = 0;
06041 
06042       if (fop->regfile) {
06043        /* Regular files never block, so this code looks like the Unix
06044           code.  We've cheated in the make_fd proc and called
06045           consoles regular files, because they cannot block, either. */
06046        int orig_len;
06047 
06048        if (fop->textmode) {
06049          /* Convert LF to CRLF. We're relying on the fact that WriteFile
06050             will write everything. */
06051          int c = 0;
06052          unsigned int i;
06053 
06054          for (i = offset; i < buflen; i++) {
06055            if (bufstr[i] == '\n')
06056              c++;
06057          }
06058 
06059          orig_len = buflen - offset;
06060 
06061          if (c) {
06062            char *naya;
06063            int j;
06064 
06065            naya = scheme_malloc_atomic(orig_len + c);
06066 
06067            for (i = offset, j = 0; i < buflen; i++) {
06068              if (bufstr[i] == '\n') {
06069               naya[j++] = '\r';
06070               naya[j++] = '\n';
06071              } else
06072               naya[j++] = bufstr[i];
06073            }
06074 
06075            bufstr = naya;
06076            offset = 0;
06077            buflen = orig_len + c;
06078          }
06079        } else
06080          orig_len = 0; /* not used */
06081 
06082        /* Write bytes. If we try to write too much at once, the result
06083           is ERROR_NOT_ENOUGH_MEMORY (as opposed to a partial write). */
06084        {
06085          int ok;
06086          long towrite = buflen - offset;
06087 
06088          while (1) {
06089            ok = WriteFile((HANDLE)fop->fd, bufstr XFORM_OK_PLUS offset, towrite, &winwrote, NULL);
06090            if (!ok)
06091              errsaved = GetLastError();
06092            
06093            if (!ok && (errsaved == ERROR_NOT_ENOUGH_MEMORY)) {
06094              towrite = towrite >> 1;
06095              if (!towrite)
06096               break;
06097            } else
06098              break;
06099          }
06100 
06101          if (ok) {
06102            if (fop->textmode) {
06103              if (winwrote != buflen) {
06104               /* Trouble! This shouldn't happen. We pick an random error msg. */
06105               errsaved = ERROR_NEGATIVE_SEEK;
06106               len = -1;
06107              } else {
06108               len = orig_len;
06109               buflen = orig_len; /* so we don't loop! */
06110              }
06111            } else
06112              len = winwrote;
06113          } else {
06114            len = -1;
06115          }
06116        }
06117       } else {
06118        errsaved = 0;
06119        len = -1;
06120 
06121        /* If we don't have a thread yet, we'll need to start it. If
06122           we have a non-blocking pipe, we can try the write (and
06123           we'll still need the thread to determine when the data is
06124           flushed). */
06125        if (!fop->oth || fop->oth->nonblocking) {
06126          int nonblocking;
06127 
06128          /* If we don't have a thread, this is our first write attempt.
06129             Determine whether this is a non-blocking pipe: */
06130          if (!fop->oth) {
06131            /* The FILE_TYPE_PIPE test is currently redundant, I think,
06132               but better safe than sorry. */
06133            nonblocking = ((scheme_stupid_windows_machine < 0)
06134                         && (GetFileType((HANDLE)fop->fd) == FILE_TYPE_PIPE));
06135          } else
06136            nonblocking = 1; /* must be, or we would not have gotten here */
06137 
06138          if (nonblocking) {
06139            /* Unless we're still trying to flush old data, write to the
06140               pipe and have the other thread start flushing it. */
06141            DWORD old, nonblock = PIPE_NOWAIT;
06142            int ok, flushed;
06143 
06144            if (fop->oth) {
06145              if (fop->oth->needflush) {
06146               /* Not flushed, but we haven't promised not to block: */
06147               flushed = 1;
06148              } else {
06149               WaitForSingleObject(fop->oth->lock_sema, INFINITE);
06150               flushed = fop->oth->flushed;
06151               ReleaseSemaphore(fop->oth->lock_sema, 1, NULL);
06152              }
06153            } else
06154              flushed = 1; /* haven't written anything before */
06155 
06156            if (flushed) {
06157              /* Put the pipe in non-blocking mode and write. */
06158 
06159              int towrite;
06160 
06161              towrite = buflen - offset;
06162 
06163              /* Apparently, the semantics of non-blocking pipe writes
06164                 is not partial writes, but giving up entirely when
06165                 the other end isn't being read. In other words, if we
06166                 try to write too much and nothing is being pulled
06167                 from the pipe, winwrote will be set to 0. Also, if
06168                we try to write too much at once, the result is a
06169                ERROR_NOT_ENOUGH_MEMORY error. Account for these
06170                 behaviors by trying to write less each iteration when the
06171                 write fails. (Yuck.) */
06172              while (1) {
06173               GetNamedPipeHandleState((HANDLE)fop->fd, &old, NULL, NULL, NULL, NULL, 0);
06174               SetNamedPipeHandleState((HANDLE)fop->fd, &nonblock, NULL, NULL);
06175               ok = WriteFile((HANDLE)fop->fd, bufstr XFORM_OK_PLUS offset, towrite, &winwrote, NULL);
06176               if (!ok)
06177                 errsaved = GetLastError();
06178               SetNamedPipeHandleState((HANDLE)fop->fd, &old, NULL, NULL);
06179 
06180               if ((ok && !winwrote)
06181                   || (!ok && (errsaved == ERROR_NOT_ENOUGH_MEMORY))) {
06182                 towrite = towrite >> 1;
06183                 if (!towrite) {
06184                   break;
06185                 }
06186               } else
06187                 break;
06188              }
06189            } else {
06190              /* Don't try to write while flushing. */
06191              ok = 1;
06192              winwrote = 0;
06193            }
06194 
06195            if (ok) {
06196              if (!winwrote) {
06197               full_write_buffer = 1;
06198              } else {
06199               len = winwrote;
06200              }
06201            }
06202          } else
06203            full_write_buffer = 0; /* and create the writer thread... */
06204 
06205          if (!fop->oth) {
06206            /* We create a thread even for pipes that can be put in
06207               non-blocking mode, because that seems to be the only
06208               way to get evt behavior. */
06209            Win_FD_Output_Thread *oth;
06210            HANDLE h;
06211            DWORD id;
06212            unsigned char *bfr;
06213            OS_SEMAPHORE_TYPE sm;
06214 
06215            oth = malloc(sizeof(Win_FD_Output_Thread));
06216            fop->oth = oth;
06217 
06218            oth->nonblocking = nonblocking;
06219 
06220            if (!nonblocking) {
06221              bfr = (unsigned char *)malloc(MZPORT_FD_BUFFSIZE);
06222              oth->buffer = bfr;
06223              oth->flushed = 0;
06224              oth->needflush = 0;
06225            } else {
06226              oth->buffer = NULL;
06227              oth->flushed = (len <= 0);
06228              oth->needflush = 1;
06229            }
06230 
06231            oth->buflen = 0;
06232            oth->bufstart = 0;
06233            oth->bufend = 0;
06234 
06235            oth->fd = (HANDLE)fop->fd;
06236            oth->err_no = 0;
06237            oth->done = 0;
06238            sm = CreateSemaphore(NULL, 1, 1, NULL);
06239            oth->lock_sema = sm;
06240            sm = CreateSemaphore(NULL, 0, 1, NULL);
06241            oth->work_sema = sm;
06242            sm = CreateSemaphore(NULL, 1, 1, NULL);
06243            oth->ready_sema = sm;
06244            sm = CreateSemaphore(NULL, 1, 1, NULL);
06245            oth->you_clean_up_sema = sm;
06246            oth->refcount = fop->refcount;
06247             
06248            h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDWriter, oth, 0, &id);
06249 
06250            scheme_remember_thread(h, 1);
06251 
06252            /* scheme_remember_thread() is in charge of releasing h, so
06253               duplicate it for use in closing: */
06254            DuplicateHandle(GetCurrentProcess(), 
06255                          h,
06256                          GetCurrentProcess(),
06257                          &h, 
06258                          0,
06259                          FALSE,
06260                          DUPLICATE_SAME_ACCESS);
06261 
06262            oth->thread = h;
06263 
06264          }
06265        }
06266 
06267        /* We have a thread, if only to watch when the flush is
06268           done... */
06269 
06270        if (!fop->oth->nonblocking) {
06271          /* This case is for Win 95/98/Me anonymous pipes and
06272             character devices.  We haven't written anything yet! We
06273             write to a buffer read by the other thread, and return --
06274             the other thread takes care of writing. Thus, as long as
06275             there's room in the buffer, we don't block, and we can
06276             tell whether there's room. Technical problem: if multiple
06277             ports are attched to the same underlying pipe (different
06278             handle, same "device"), the port writes can get out of
06279             order. We try to avoid the problem by sleeping. */
06280 
06281          Win_FD_Output_Thread *oth = fop->oth;
06282 
06283          WaitForSingleObject(oth->lock_sema, INFINITE);
06284          if (oth->err_no)
06285            errsaved = oth->err_no;
06286          else if (oth->buflen == MZPORT_FD_BUFFSIZE) {
06287            full_write_buffer = 1;
06288            WaitForSingleObject(oth->ready_sema, 0); /* clear any leftover state */
06289          } else {
06290            long topp;
06291            int was_pre;
06292 
06293            if (!oth->buflen) {
06294              /* Avoid fragmenting in circular buffer: */
06295              oth->bufstart = 0;
06296              oth->bufend = 0;
06297            }
06298 
06299            /* Write to top part of circular buffer, then bottom part
06300               if anything's left. */
06301 
06302            if (oth->bufstart <= oth->bufend) {
06303              was_pre = 1;
06304              topp = MZPORT_FD_BUFFSIZE;
06305            } else {
06306              was_pre = 0;
06307              topp = oth->bufstart;
06308            }
06309 
06310            winwrote = topp - oth->bufend;
06311            if (winwrote > buflen - offset)
06312              winwrote = buflen - offset;
06313 
06314            memcpy(oth->buffer + oth->bufend, bufstr + offset, winwrote);
06315            oth->buflen += winwrote;
06316            len = winwrote;
06317 
06318            oth->bufend += winwrote;
06319            if (oth->bufend == MZPORT_FD_BUFFSIZE)
06320              oth->bufend = 0;
06321 
06322            if (was_pre) {
06323              if (winwrote < buflen - offset) {
06324               /* Try continuing with a wrap-around: */
06325               winwrote = oth->bufstart - oth->bufend;
06326               if (winwrote > buflen - offset - len)
06327                 winwrote = buflen - offset - len;
06328 
06329               memcpy(oth->buffer + oth->bufend, bufstr + offset + len, winwrote);
06330               oth->buflen += winwrote;
06331               oth->bufend += winwrote;
06332               len += winwrote;
06333              }
06334            }
06335            /* Let the other thread know that it should start trying
06336               to write, if it isn't already: */
06337            ReleaseSemaphore(oth->work_sema, 1, NULL);
06338            Sleep(0); /* to decrease the chance of re-ordering flushes */
06339          }
06340          ReleaseSemaphore(oth->lock_sema, 1, NULL);
06341        } else if (len > 0) {
06342          /* We've already written, which implies that no flush is
06343             in progress. We'll need a flush check in the future. */
06344          fop->oth->needflush = 1;
06345        }
06346       }
06347 #else
06348       int flags;
06349 
06350       flags = fcntl(fop->fd, F_GETFL, 0);
06351       fcntl(fop->fd, F_SETFL, flags | MZ_NONBLOCKING);
06352 
06353       do {
06354        len = write(fop->fd, bufstr + offset, buflen - offset);
06355       } while ((len == -1) && (errno == EINTR));
06356 
06357       errsaved = errno;
06358       fcntl(fop->fd, F_SETFL, flags);
06359 
06360       full_write_buffer = (errsaved == EAGAIN);
06361 #endif
06362 
06363       if (len < 0) {
06364        if (scheme_force_port_closed) {
06365          /* Don't signal exn or wait. Just give up. */
06366          return wrote;
06367        } else if (full_write_buffer) {
06368          /* Need to block; remember that we're holding a lock. */
06369          if (immediate_only == 2) {
06370            fop->flushing = 0;
06371            return wrote;
06372          }
06373 
06374          BEGIN_ESCAPEABLE(release_flushing_lock, fop);
06375          scheme_block_until_enable_break(fd_write_ready,
06376                                      fd_write_need_wakeup,
06377                                      (Scheme_Object *)op, 0.0,
06378                                      enable_break);
06379          END_ESCAPEABLE();
06380        } else {
06381          fop->flushing = 0;
06382          scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
06383                         "error writing to stream port (" FILENAME_EXN_E ")",
06384                         errsaved);
06385          return 0; /* doesn't get here */
06386        }
06387       } else if ((len + offset == buflen) || immediate_only) {
06388        fop->flushing = 0;
06389        return wrote + len;
06390       } else {
06391        offset += len;
06392        wrote += len;
06393       }
06394     }
06395   }
06396 
06397   return wrote;
06398 }
06399 
06400 static long
06401 fd_write_string(Scheme_Output_Port *port,
06402               const char *str, long d, long len,
06403               int rarely_block, int enable_break)
06404 {
06405   /* Note: !flush => !rarely_block, !len => flush */
06406 
06407   Scheme_FD *fop;
06408   long l;
06409   int flush = (!len || rarely_block);
06410 
06411   fop = (Scheme_FD *)port->port_data;
06412 
06413   if (!len) {
06414     if (fop->bufcount)
06415       flush_fd(port, NULL, 0, 0, rarely_block, enable_break);
06416 
06417     if (fop->bufcount)
06418       return -1;
06419     else
06420       return 0;
06421   }
06422 
06423   if (!fop->bufcount && flush) {
06424     /* Nothing buffered. Write directly. */
06425     return flush_fd(port, str, d + len, d, rarely_block, enable_break);
06426   }
06427 
06428   if (fop->flushing) {
06429     if (rarely_block == 2)
06430       return -1; /* -1 means 0 written && still have unflushed */
06431     wait_until_fd_flushed(port, enable_break);
06432   }
06433 
06434   /* Might have been closed while we waited */
06435   if (port->closed)
06436     return 0;
06437 
06438   l = MZPORT_FD_BUFFSIZE - fop->bufcount;
06439   if ((len <= l) && (!flush || !rarely_block)) {
06440     memcpy(fop->buffer + fop->bufcount, str + d, len);
06441     fop->bufcount += len;
06442   } else {
06443     if (fop->bufcount) {
06444       flush_fd(port, NULL, 0, 0, (rarely_block == 2) ? 2 : 0, enable_break);
06445       if (rarely_block && fop->bufcount)
06446        return -1; /* -1 means 0 written && still have unflushed */
06447     }
06448 
06449     if (!flush && (len <= MZPORT_FD_BUFFSIZE)) {
06450       memcpy(fop->buffer, str + d, len);
06451       fop->bufcount = len;
06452     } else
06453       return flush_fd(port, str, len + d, d, rarely_block, enable_break);
06454   }
06455 
06456   /* If we got this far, !rarely_block. */
06457 
06458   if ((flush || (fop->flush == MZ_FLUSH_ALWAYS)) && fop->bufcount) {
06459     flush_fd(port, NULL, 0, 0, 0, enable_break);
06460   } else if (fop->flush == MZ_FLUSH_BY_LINE) {
06461     long i;
06462 
06463     for (i = len; i--; ) {
06464       if (str[d] == '\n' || str[d] == '\r') {
06465        flush_fd(port, NULL, 0, 0, 0, enable_break);
06466        break;
06467       }
06468       d++;
06469     }
06470   }
06471 
06472   return len;
06473 }
06474 
06475 static void
06476 fd_close_output(Scheme_Output_Port *port)
06477 {
06478   Scheme_FD *fop = (Scheme_FD *)port->port_data;
06479 
06480   if (fop->bufcount)
06481     flush_fd(port, NULL, 0, 0, 0, 0);
06482 
06483   if (fop->flushing && !scheme_force_port_closed)
06484     wait_until_fd_flushed(port, 0);
06485 
06486 #ifdef WINDOWS_FILE_HANDLES
06487   if (fop->oth) {
06488     if (!scheme_force_port_closed) {
06489       /* If there's a work thread, wait until the port
06490         is *really* flushed! */
06491       scheme_block_until(win_fd_flush_done, win_fd_flush_needs_wakeup, (Scheme_Object *)fop->oth, 0.0);
06492     }
06493   }
06494 #endif
06495 
06496   /* Make sure no close happened while we blocked above! */
06497   if (port->closed)
06498     return;
06499 
06500 #ifdef WINDOWS_FILE_HANDLES
06501   if (fop->oth) {
06502     CSI_proc csi;
06503 
06504     csi = get_csi();
06505 
06506     if (csi) {
06507       /* See also call to csi in fd_close_input */
06508       csi(fop->oth->thread);
06509     }
06510     CloseHandle(fop->oth->thread);
06511     fop->oth->done = 1;
06512     ReleaseSemaphore(fop->oth->work_sema, 1, NULL);
06513 
06514     /* Try to leave clean-up to the other thread: */
06515     if (WaitForSingleObject(fop->oth->you_clean_up_sema, 0) != WAIT_OBJECT_0) {
06516       /* Other thread is already done, so we're stuck with clean-up: */
06517       WindowsFDOCleanup(fop->oth);
06518     } /* otherwise, thread is responsible for clean-up */
06519     fop->oth = NULL;
06520   } else {
06521     int rc;
06522     rc = dec_refcount(fop->refcount);
06523     if (!rc) {
06524       CloseHandle((HANDLE)fop->fd);
06525       --scheme_file_open_count;
06526     }
06527   }
06528 #else
06529  {
06530    int rc;
06531    rc = dec_refcount(fop->refcount);
06532 
06533    if (!rc) {
06534      int cr;
06535      do {
06536        cr = close(fop->fd);
06537      } while ((cr == -1) && (errno == EINTR));
06538      --scheme_file_open_count;
06539    }
06540  }
06541 #endif
06542 }
06543 
06544 static int fd_output_buffer_mode(Scheme_Port *p, int mode)
06545 {
06546   Scheme_FD *fd;
06547   Scheme_Output_Port *op = (Scheme_Output_Port *)p;
06548 
06549   fd = (Scheme_FD *)op->port_data;
06550   
06551   if (mode < 0) {
06552     return fd->flush;
06553   } else {
06554     int go;
06555     go = (mode > fd->flush);
06556     fd->flush = mode;
06557     if (go)
06558       flush_fd(op, NULL, 0, 0, 0, 0);
06559     return mode;
06560   }
06561 }
06562 
06563 static Scheme_Object *
06564 make_fd_output_port(int fd, Scheme_Object *name, int regfile, int win_textmode, int and_read,
06565                     int flush_mode)
06566 {
06567   Scheme_FD *fop;
06568   unsigned char *bfr;
06569   Scheme_Object *the_port;
06570 
06571   fop = MALLOC_ONE_RT(Scheme_FD);
06572 #ifdef MZTAG_REQUIRED
06573   fop->type = scheme_rt_input_fd;
06574 #endif
06575 
06576   bfr = (unsigned char *)scheme_malloc_atomic(MZPORT_FD_BUFFSIZE);
06577   fop->buffer = bfr;
06578 
06579   fop->fd = fd;
06580   fop->bufcount = 0;
06581 
06582 #ifdef WINDOWS_FILE_HANDLES
06583   /* Character devices can't block output, right? */
06584   if (is_fd_terminal(fop->fd))
06585     regfile = 1;
06586   /* The work thread is created on demand in fd_flush. */
06587 #endif
06588 
06589   fop->regfile = regfile;
06590   fop->textmode = win_textmode;
06591 
06592   if (flush_mode > -1) {
06593     fop->flush = flush_mode;
06594   } else if (is_fd_terminal(fd)) {
06595     /* Line-buffering for terminal: */
06596     fop->flush = MZ_FLUSH_BY_LINE;
06597   } else {
06598     /* Block-buffering for everything else: */
06599     fop->flush = MZ_FLUSH_NEVER;
06600   }
06601 
06602   the_port = (Scheme_Object *)scheme_make_output_port(fd_output_port_type,
06603                                                 fop,
06604                                                 name,
06605                                                 scheme_write_evt_via_write,
06606                                                 fd_write_string,
06607                                                 (Scheme_Out_Ready_Fun)fd_write_ready,
06608                                                 fd_close_output,
06609                                                 (Scheme_Need_Wakeup_Output_Fun)fd_write_need_wakeup,
06610                                                 NULL,
06611                                                 NULL,
06612                                                 1);
06613   ((Scheme_Port *)the_port)->buffer_mode_fun = fd_output_buffer_mode;
06614 
06615   if (and_read) {
06616     int *rc;
06617     Scheme_Object *a[2];
06618     rc = malloc_refcount();
06619     *rc = 2;
06620     fop->refcount = rc;
06621     a[1] = the_port;
06622     a[0] = make_fd_input_port(fd, name, regfile, win_textmode, rc, 0);
06623     return scheme_values(2, a);
06624   } else
06625     return the_port;
06626 }
06627 
06628 static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data)
06629 {
06630   if (SCHEME_OUTPUT_PORTP(o)) {
06631     Scheme_Output_Port *op;
06632     op = scheme_output_port_record(o);
06633     if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
06634       scheme_flush_output(o);
06635     }
06636   }
06637 }
06638 
06639 #ifdef WINDOWS_FILE_HANDLES
06640 
06641 #ifdef MZ_XFORM
06642 START_XFORM_SKIP;
06643 #endif
06644 
06645 static long WindowsFDWriter(Win_FD_Output_Thread *oth)
06646 {
06647   DWORD towrite, wrote, start;
06648   int ok, more_work = 0, err_no;
06649 
06650   if (oth->nonblocking) {
06651     /* Non-blocking mode (Win NT pipes). Just flush. */
06652     while (!oth->done) {
06653       WaitForSingleObject(oth->work_sema, INFINITE);
06654 
06655       FlushFileBuffers(oth->fd);
06656 
06657       WaitForSingleObject(oth->lock_sema, INFINITE);
06658       oth->flushed = 1;
06659       ReleaseSemaphore(oth->ready_sema, 1, NULL);
06660       ReleaseSemaphore(oth->lock_sema, 1, NULL);
06661     }
06662   } else {
06663     /* Blocking mode. We do the writing work.  This case is for
06664        Win 95/98/Me anonymous pipes and character devices (such 
06665        as LPT1). */
06666     while (!oth->err_no) {
06667       if (!more_work)
06668        WaitForSingleObject(oth->work_sema, INFINITE);
06669 
06670       if (oth->done)
06671        break;
06672 
06673       WaitForSingleObject(oth->lock_sema, INFINITE);
06674       towrite = oth->buflen;
06675       if (towrite > (MZPORT_FD_BUFFSIZE - oth->bufstart))
06676        towrite = MZPORT_FD_BUFFSIZE - oth->bufstart;
06677       start = oth->bufstart;
06678       ReleaseSemaphore(oth->lock_sema, 1, NULL);
06679 
06680       ok = WriteFile(oth->fd, oth->buffer + start, towrite, &wrote, NULL);
06681       if (!ok)
06682        err_no = GetLastError();
06683       else
06684        err_no = 0;
06685 
06686       WaitForSingleObject(oth->lock_sema, INFINITE);
06687       if (!ok)
06688        oth->err_no = err_no;
06689       else {
06690        oth->bufstart += wrote;
06691        oth->buflen -= wrote;
06692        if (oth->bufstart == MZPORT_FD_BUFFSIZE)
06693          oth->bufstart = 0;
06694        more_work = oth->buflen > 0;
06695       }
06696       if ((oth->buflen < MZPORT_FD_BUFFSIZE) || oth->err_no)
06697        ReleaseSemaphore(oth->ready_sema, 1, NULL);
06698       ReleaseSemaphore(oth->lock_sema, 1, NULL);
06699     }
06700   }
06701   if (WaitForSingleObject(oth->you_clean_up_sema, 0) != WAIT_OBJECT_0) {
06702     WindowsFDOCleanup(oth);
06703   } /* otherwise, main thread is responsible for clean-up */
06704 
06705   return 0;
06706 }
06707 
06708 static void WindowsFDOCleanup(Win_FD_Output_Thread *oth)
06709 {
06710   int rc;
06711 
06712   CloseHandle(oth->lock_sema);
06713   CloseHandle(oth->work_sema);
06714   CloseHandle(oth->you_clean_up_sema);
06715   
06716   rc = dec_refcount(oth->refcount);
06717   if (!rc) CloseHandle(oth->fd);
06718 
06719   if (oth->buffer)
06720     free(oth->buffer);
06721   free(oth);
06722 }
06723 
06724 #ifdef MZ_XFORM
06725 END_XFORM_SKIP;
06726 #endif
06727 
06728 #endif
06729 
06730 #endif
06731 
06732 Scheme_Object *
06733 scheme_make_fd_output_port(int fd, Scheme_Object *name, int regfile, int textmode, int read_too)
06734 {
06735 #ifdef MZ_FDS
06736   return make_fd_output_port(fd, name, regfile, textmode, read_too, -1);
06737 #else
06738   return NULL;
06739 #endif
06740 }
06741 
06742 /*========================================================================*/
06743 /*                        system/process/execute                          */
06744 /*========================================================================*/
06745 
06746 /* Unix, and Windows support --- all mixed together */
06747 
06748 #define MZ_FAILURE_STATUS -1
06749 
06750 #ifdef PROCESS_FUNCTION
06751 
06752 # define USE_CREATE_PIPE
06753 
06754 #ifdef WINDOWS_PROCESSES
06755 # ifdef USE_CREATE_PIPE
06756 #  define _EXTRA_PIPE_ARGS
06757 static int MyPipe(int *ph, int near_index) {
06758   HANDLE r, w;
06759   SECURITY_ATTRIBUTES saAttr;
06760 
06761   /* Set the bInheritHandle flag so pipe handles are inherited. */
06762   saAttr.nLength = sizeof(SECURITY_ATTRIBUTES);
06763   saAttr.bInheritHandle = TRUE;
06764   saAttr.lpSecurityDescriptor = NULL;
06765 
06766   if (CreatePipe(&r, &w, &saAttr, 0)) {
06767     HANDLE a[2], naya;
06768 
06769     a[0] = r;
06770     a[1] = w;
06771 
06772     /* Change the near end to make it non-inheritable, then
06773        close the inheritable one: */
06774     if (!DuplicateHandle(GetCurrentProcess(), a[near_index],
06775                       GetCurrentProcess(), &naya, 0,
06776                       0, /* not inherited */
06777                       DUPLICATE_SAME_ACCESS)) {
06778       CloseHandle(a[0]);
06779       CloseHandle(a[1]);
06780       return 1;
06781     } else {
06782       CloseHandle(a[near_index]);
06783       a[near_index] = naya;
06784     }
06785 
06786     ph[0] = (long)a[0];
06787     ph[1] = (long)a[1];
06788 
06789     return 0;
06790   } else
06791     return 1;
06792 }
06793 #  define PIPE_FUNC MyPipe
06794 # else
06795 #  include <Process.h>
06796 #  include <fcntl.h>
06797 # define PIPE_FUNC(pa, nearh) MSC_IZE(pipe)(pa)
06798 #  define _EXTRA_PIPE_ARGS , 256, _O_BINARY
06799 # endif
06800 #else
06801 # define _EXTRA_PIPE_ARGS
06802 # define PIPE_FUNC(pa, nearh) MSC_IZE(pipe)(pa)
06803 #endif
06804 
06805 #endif
06806 
06807 /**************** Unix: signal stuff ******************/
06808 
06809 #if defined(UNIX_PROCESSES)
06810 
06811 # define WAITANY(s) waitpid((pid_t)-1, s, WNOHANG)
06812 
06813 #ifndef MZ_PRECISE_GC
06814 # define GC_write_barrier(x) /* empty */
06815 #endif
06816 
06817 #ifdef MZ_XFORM
06818 START_XFORM_SKIP;
06819 #endif
06820 
06821 void scheme_block_child_signals(int block)
06822 {
06823   sigset_t sigs;
06824 
06825   sigemptyset(&sigs);
06826   sigaddset(&sigs, SIGCHLD);
06827 #ifdef USE_ITIMER
06828   sigaddset(&sigs, SIGPROF);
06829 #endif
06830   sigprocmask(block ? SIG_BLOCK : SIG_UNBLOCK, &sigs, NULL);
06831 }
06832 
06833 static void child_done(int ingored)
06834 {
06835   scheme_signal_received();
06836 
06837 # ifdef SIGSET_NEEDS_REINSTALL
06838   MZ_SIGSET(SIGCHLD, child_done);
06839 # endif
06840 }
06841 
06842 #ifdef MZ_XFORM
06843 END_XFORM_SKIP;
06844 #endif
06845 
06846 static int sigchld_installed = 0;
06847 
06848 static void init_sigchld(void)
06849 {
06850   if (!sigchld_installed) {
06851     /* Catch child-done signals */
06852     START_XFORM_SKIP;
06853     MZ_SIGSET(SIGCHLD, child_done);
06854     END_XFORM_SKIP;
06855 
06856     sigchld_installed = 1;
06857   }
06858 }
06859 
06860 static void check_child_done()
06861 {
06862   pid_t result;
06863   int status;
06864   System_Child *sc, *prev;
06865 
06866   if (scheme_system_children) {
06867     do {
06868       do {
06869         START_XFORM_SKIP;
06870         result = WAITANY(&status);
06871         END_XFORM_SKIP;
06872       } while ((result == -1) && (errno == EINTR));
06873 
06874       if (result > 0) {
06875         START_XFORM_SKIP;
06876         if (WIFEXITED(status))
06877           status = WEXITSTATUS(status);
06878         else
06879           status = MZ_FAILURE_STATUS;
06880         END_XFORM_SKIP;
06881 
06882         prev = NULL;
06883         for (sc = scheme_system_children; sc; prev = sc, sc = sc->next) {
06884           if (sc->id == result) {
06885             sc->done = 1;
06886             sc->status = status;
06887 
06888             if (prev) {
06889               prev->next = sc->next;
06890             } else
06891               scheme_system_children = sc->next;
06892           }
06893         }
06894       }
06895     } while (result > 0);
06896   }
06897 }
06898 
06899 #endif
06900 
06901 /*========================================================================*/
06902 /*                           null output ports                            */
06903 /*========================================================================*/
06904 
06905 static long
06906 null_write_bytes(Scheme_Output_Port *port,
06907                const char *str, long d, long len,
06908                int rarely_block, int enable_break)
06909 {
06910   return len;
06911 }
06912 
06913 static void
06914 null_close_out (Scheme_Output_Port *port)
06915 {
06916 }
06917 
06918 static Scheme_Object *
06919 null_write_evt(Scheme_Output_Port *op, const char *str, long offset, long size)
06920 {
06921   Scheme_Object *a[2];
06922   a[0] = scheme_always_ready_evt;
06923   a[1] = scheme_make_closed_prim(return_data, scheme_make_integer(size));
06924   return scheme_wrap_evt(2, a);
06925 }
06926 
06927 static Scheme_Object *
06928 null_write_special_evt(Scheme_Output_Port *op, Scheme_Object *v)
06929 {
06930   Scheme_Object *a[2];
06931   a[0] = scheme_always_ready_evt;
06932   a[1] = scheme_make_closed_prim(return_data, scheme_true);
06933   return scheme_wrap_evt(2, a);
06934 }
06935 
06936 static int 
06937 null_write_special(Scheme_Output_Port *op, Scheme_Object *v, int nonblock)
06938 {
06939   return 1;
06940 }
06941 
06942 Scheme_Object *
06943 scheme_make_null_output_port(int can_write_special)
06944 {
06945   Scheme_Output_Port *op;
06946 
06947   op = scheme_make_output_port(scheme_null_output_port_type,
06948                             NULL,
06949                             scheme_intern_symbol("null"),
06950                             null_write_evt,
06951                             null_write_bytes,
06952                             NULL,
06953                             null_close_out,
06954                             NULL,
06955                             (can_write_special
06956                             ? null_write_special_evt
06957                             : NULL),
06958                             (can_write_special
06959                             ? null_write_special
06960                             : NULL),
06961                             0);
06962 
06963   return (Scheme_Object *)op;
06964 }
06965 
06966 /*========================================================================*/
06967 /*                         redirect output ports                          */
06968 /*========================================================================*/
06969 
06970 static Scheme_Object *redirect_write_bytes_k(void);
06971 
06972 static long
06973 redirect_write_bytes(Scheme_Output_Port *op,
06974                    const char *str, long d, long len,
06975                    int rarely_block, int enable_break)
06976 {
06977   /* arbitrary nesting means we can overflow the stack */
06978 #ifdef DO_STACK_CHECK
06979 # include "mzstkchk.h"
06980   {
06981     Scheme_Thread *p = scheme_current_thread;
06982     Scheme_Object *n;
06983 
06984     p->ku.k.p1 = (void *)op;
06985     p->ku.k.p2 = (void *)str;
06986     p->ku.k.i1 = d;
06987     p->ku.k.i2 = len;
06988     p->ku.k.i3 = rarely_block;
06989     p->ku.k.i4 = enable_break;
06990 
06991     n = scheme_handle_stack_overflow(redirect_write_bytes_k);
06992     return SCHEME_INT_VAL(n);
06993   }
06994 #endif
06995 
06996   return scheme_put_byte_string("redirect-output",
06997                             (Scheme_Object *)op->port_data,
06998                             str, d, len,
06999                             rarely_block);
07000 }
07001 
07002 static Scheme_Object *redirect_write_bytes_k(void)
07003 {
07004   Scheme_Thread *p = scheme_current_thread;
07005   Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1;
07006   const char *str = (const char *)p->ku.k.p2;
07007   long d = p->ku.k.i1;
07008   long len = p->ku.k.i2;
07009   int rarely_block = p->ku.k.i3;
07010   int enable_break = p->ku.k.i4;
07011   long n;
07012 
07013   p->ku.k.p1 = NULL;
07014   p->ku.k.p2 = NULL;
07015 
07016   n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break);
07017 
07018   return scheme_make_integer(n);
07019 }
07020 
07021 static void
07022 redirect_close_out (Scheme_Output_Port *port)
07023 {
07024 }
07025 
07026 static Scheme_Object *
07027 redirect_write_evt(Scheme_Output_Port *op, const char *str, long offset, long size)
07028 {
07029   return scheme_make_write_evt("redirect-write-evt", 
07030                             (Scheme_Object *)op->port_data,
07031                             NULL, (char *)str, offset, size);
07032 }
07033 
07034 static Scheme_Object *
07035 redirect_write_special_evt(Scheme_Output_Port *op, Scheme_Object *special)
07036 {
07037   return scheme_make_write_evt("redirect-write-evt", 
07038                             (Scheme_Object *)op->port_data,
07039                             special, NULL, 0, 0);
07040 }
07041 
07042 static int 
07043 redirect_write_special(Scheme_Output_Port *op, Scheme_Object *special, int nonblock)
07044 {
07045   Scheme_Object *v, *a[2];
07046 
07047   a[0] = (Scheme_Object *)op->port_data;
07048   a[1] = special;
07049 
07050   if (nonblock)
07051     v = scheme_write_special(2, a);
07052   else
07053     v = scheme_write_special(2, a);
07054   
07055   return SCHEME_TRUEP(v);
07056 }
07057 
07058 Scheme_Object *
07059 scheme_make_redirect_output_port(Scheme_Object *port)
07060 {
07061   Scheme_Output_Port *op;
07062   int can_write_special;
07063 
07064   op = scheme_output_port_record(port);
07065   can_write_special = !!op->write_special_fun;
07066 
07067   op = scheme_make_output_port(scheme_redirect_output_port_type,
07068                             port,
07069                             scheme_intern_symbol("redirect"),
07070                             redirect_write_evt,
07071                             redirect_write_bytes,
07072                             NULL,
07073                             redirect_close_out,
07074                             NULL,
07075                             (can_write_special
07076                             ? redirect_write_special_evt
07077                             : NULL),
07078                             (can_write_special
07079                             ? redirect_write_special
07080                             : NULL),
07081                             0);
07082 
07083   return (Scheme_Object *)op;
07084 }
07085 
07086 /*********** Unix/Windows: process status stuff *************/
07087 
07088 #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
07089 
07090 static int subp_done(Scheme_Object *sp)
07091 {
07092   void *sci = ((Scheme_Subprocess *)sp)->handle;
07093 
07094 #if defined(UNIX_PROCESSES)
07095   System_Child *sc = (System_Child *)sci;
07096   check_child_done();
07097   return sc->done;
07098 #endif
07099 #ifdef WINDOWS_PROCESSES
07100   DWORD w;
07101   if (sci) {
07102     if (GetExitCodeProcess((HANDLE)sci, &w))
07103       return w != STILL_ACTIVE;
07104     else
07105       return 1;
07106   } else
07107     return 1;
07108 #endif
07109 }
07110 
07111 static void subp_needs_wakeup(Scheme_Object *sp, void *fds)
07112 {
07113 #ifdef WINDOWS_PROCESSES
07114   void *sci = ((Scheme_Subprocess *)sp)->handle;
07115   scheme_add_fd_handle((void *)(HANDLE)sci, fds, 0);
07116 #endif
07117 }
07118 
07119 #endif
07120 
07121 static Scheme_Object *subprocess_status(int argc, Scheme_Object **argv)
07122 {
07123   Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];
07124 
07125   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
07126     scheme_wrong_type("subprocess-status", "subprocess", 0, argc, argv);
07127 
07128 #if defined(PROCESS_FUNCTION) && !defined(MAC_CLASSIC_PROCESS_CONTROL)
07129   {
07130     int going = 0, status = MZ_FAILURE_STATUS;
07131 
07132 #if defined(UNIX_PROCESSES)
07133     System_Child *sc = (System_Child *)sp->handle;
07134 
07135     check_child_done();
07136 
07137     if (sc->done)
07138       status = sc->status;
07139     else
07140       going = 1;
07141 #else
07142 # ifdef WINDOWS_PROCESSES
07143     DWORD w;
07144     if (sp->handle) {
07145       if (GetExitCodeProcess((HANDLE)sp->handle, &w)) {
07146        if (w == STILL_ACTIVE)
07147          going = 1;
07148        else
07149          status = w;
07150       }
07151     }
07152 # endif
07153 #endif
07154 
07155     if (going)
07156       return scheme_intern_symbol("running");
07157     else
07158       return scheme_make_integer_value(status);
07159   }
07160 #else
07161   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
07162                  "%s: not supported on this platform",
07163                  "subprocess-status");
07164 #endif
07165 }
07166 
07167 
07168 static void register_subprocess_wait()
07169 {
07170 #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
07171   scheme_add_evt(scheme_subprocess_type, subp_done,
07172                 subp_needs_wakeup, NULL, 0);
07173 #endif
07174 }
07175 
07176 static Scheme_Object *subprocess_wait(int argc, Scheme_Object **argv)
07177 {
07178   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
07179     scheme_wrong_type("subprocess-wait", "subprocess", 0, argc, argv);
07180 
07181 #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
07182   {
07183     Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];
07184 
07185     scheme_block_until(subp_done, subp_needs_wakeup, (Scheme_Object *)sp, (float)0.0);
07186 
07187     return scheme_void;
07188   }
07189 #else
07190   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
07191                  "%s: not supported on this platform",
07192                  "subprocess-wait");
07193 #endif
07194 }
07195 
07196 static Scheme_Object *subprocess_kill(int argc, Scheme_Object **argv)
07197 {
07198   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
07199     scheme_wrong_type("subprocess-kill", "subprocess", 0, argc, argv);
07200 
07201 #if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
07202   {
07203     Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];
07204 
07205 #if defined(UNIX_PROCESSES)
07206     {
07207       System_Child *sc = (System_Child *)sp->handle;
07208 
07209       check_child_done();
07210 
07211       while (1) {
07212        if (sc->done)
07213          return scheme_void;
07214 
07215        if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT))
07216          return scheme_void;
07217 
07218        if (errno != EINTR)
07219          break;
07220        /* Otherwise we were interrupted. Try `kill' again. */
07221       }
07222     }
07223 #else
07224     if (SCHEME_TRUEP(argv[1])) {
07225       DWORD w;
07226       int errid;
07227 
07228       if (!sp->handle)
07229        return scheme_void;
07230 
07231       if (GetExitCodeProcess((HANDLE)sp->handle, &w)) {
07232        if (w != STILL_ACTIVE)
07233          return scheme_void;
07234        if (TerminateProcess((HANDLE)sp->handle, 1))
07235          return scheme_void;
07236       }
07237       errid = GetLastError();
07238       errno = errid;
07239     } else
07240       return scheme_void;
07241 #endif
07242 
07243     scheme_raise_exn(MZEXN_FAIL, "subprocess-kill: failed (%E)", errno);
07244 
07245     return NULL;
07246   }
07247 #else
07248   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
07249                  "%s: not supported on this platform",
07250                  "subprocess-wait");
07251 #endif
07252 }
07253 
07254 static Scheme_Object *subprocess_pid(int argc, Scheme_Object **argv)
07255 {
07256   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
07257     scheme_wrong_type("subprocess-pid", "subprocess", 0, argc, argv);
07258 
07259   return scheme_make_integer_value(((Scheme_Subprocess *)argv[0])->pid);
07260 }
07261 
07262 static Scheme_Object *subprocess_p(int argc, Scheme_Object **argv)
07263 {
07264   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type)
07265          ? scheme_true
07266          : scheme_false);
07267 }
07268 
07269 /*********** Windows: command-line construction *************/
07270 
07271 #ifdef WINDOWS_PROCESSES
07272 static char *cmdline_protect(char *s)
07273 {
07274   char *naya;
07275   int ds;
07276   int has_space = 0, has_quote = 0, was_slash = 0;
07277 
07278   for (ds = 0; s[ds]; ds++) {
07279     if (isspace(s[ds]) || (s[ds] == '\'')) {
07280       has_space = 1;
07281       was_slash = 0;
07282     } else if (s[ds] == '"') {
07283       has_quote += 1 + (2 * was_slash);
07284       was_slash = 0;
07285     } else if (s[ds] == '\\') {
07286       was_slash++;
07287     } else
07288       was_slash = 0;
07289   }
07290 
07291   if (has_space || has_quote) {
07292     char *p;
07293     int wrote_slash = 0;
07294 
07295     naya = scheme_malloc_atomic(strlen(s) + 3 + 3*has_quote + was_slash);
07296     naya[0] = '"';
07297     for (p = naya + 1; *s; s++) {
07298       if (*s == '"') {
07299        while (wrote_slash--) {
07300          *(p++) = '\\';
07301        }
07302        *(p++) = '"'; /* endquote */
07303        *(p++) = '\\';
07304        *(p++) = '"'; /* protected */
07305        *(p++) = '"'; /* start quote again */
07306        wrote_slash = 0;
07307       } else if (*s == '\\') {
07308        *(p++) = '\\';
07309        wrote_slash++;
07310       } else {
07311        *(p++) = *s;
07312        wrote_slash = 0;
07313       }
07314     }
07315     while (wrote_slash--) {
07316       *(p++) = '\\';
07317     }
07318     *(p++) = '"';
07319     *p = 0;
07320 
07321     return naya;
07322   }
07323 
07324   return s;
07325 }
07326 
07327 static long mz_spawnv(char *command, const char * const *argv,
07328                     int exact_cmdline, int sin, int sout, int serr, int *pid)
07329 {
07330   int i, l, len = 0;
07331   long cr_flag;
07332   char *cmdline;
07333   STARTUPINFOW startup;
07334   PROCESS_INFORMATION info;
07335 
07336   if (exact_cmdline) {
07337     cmdline = (char *)argv[1];
07338   } else {
07339     for (i = 0; argv[i]; i++) {
07340       len += strlen(argv[i]) + 1;
07341     }
07342 
07343     cmdline = (char *)scheme_malloc_atomic(len);
07344 
07345     len = 0;
07346     for (i = 0; argv[i]; i++) {
07347       l = strlen(argv[i]);
07348       memcpy(cmdline + len, argv[i], l);
07349       cmdline[len + l] = ' ';
07350       len += l + 1;
07351     }
07352     --len;
07353     cmdline[len] = 0;
07354   }
07355 
07356   memset(&startup, 0, sizeof(startup));
07357   startup.cb = sizeof(startup);
07358   startup.dwFlags = STARTF_USESTDHANDLES;
07359   startup.hStdInput = (HANDLE)sin;
07360   startup.hStdOutput = (HANDLE)sout;
07361   startup.hStdError = (HANDLE)serr;
07362 
07363   /* If none of the stdio handles are consoles, specifically
07364      create the subprocess without a console: */
07365   if (!is_fd_terminal((int)startup.hStdInput)
07366       && !is_fd_terminal((int)startup.hStdOutput)
07367       && !is_fd_terminal((int)startup.hStdError))
07368     cr_flag = CREATE_NO_WINDOW;
07369   else
07370     cr_flag = 0;
07371 
07372   if (CreateProcessW(WIDE_PATH_COPY(command), WIDE_PATH_COPY(cmdline), 
07373                    NULL, NULL, 1 /*inherit*/,
07374                    cr_flag, NULL, NULL,
07375                    &startup, &info)) {
07376     CloseHandle(info.hThread);
07377     *pid = info.dwProcessId;
07378     return (long)info.hProcess;
07379   } else
07380     return -1;
07381 }
07382 
07383 static void close_subprocess_handle(void *sp, void *ignored)
07384 {
07385   Scheme_Subprocess *subproc = (Scheme_Subprocess *)sp;
07386   CloseHandle(subproc->handle);
07387 }
07388 
07389 #endif /* WINDOWS_PROCESSES */
07390 
07391 /*********** All: The main system/process/execute function *************/
07392 
07393 static Scheme_Object *subprocess(int c, Scheme_Object *args[])
07394      /* subprocess(out, in, err, exe, arg ...) */
07395 {
07396   const char *name = "subprocess";
07397 #if defined(PROCESS_FUNCTION) && !defined(MAC_CLASSIC_PROCESS_CONTROL)
07398   char *command;
07399   int to_subprocess[2], from_subprocess[2], err_subprocess[2];
07400   int i, pid;
07401   char **argv;
07402   Scheme_Object *in, *out, *err;
07403 #if defined(UNIX_PROCESSES)
07404   System_Child *sc;
07405   int fork_errno = 0;
07406 #else
07407   void *sc = 0;
07408 #endif
07409   Scheme_Object *inport;
07410   Scheme_Object *outport;
07411   Scheme_Object *errport;
07412   Scheme_Object *a[4];
07413   Scheme_Subprocess *subproc;
07414 #if defined(WINDOWS_PROCESSES)
07415   int exact_cmdline = 0;
07416 #endif
07417 #if defined(WINDOWS_PROCESSES)
07418   int spawn_status;
07419 #endif
07420 
07421   /*--------------------------------------------*/
07422   /* Sort out ports (create later if necessary) */
07423   /*--------------------------------------------*/
07424 
07425   if (SCHEME_TRUEP(args[0])) {
07426     outport = args[0];
07427     if (SCHEME_OUTPUT_PORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
07428 #ifdef PROCESS_FUNCTION
07429       Scheme_Output_Port *op;
07430 
07431       op = scheme_output_port_record(outport);
07432 
07433       if (SAME_OBJ(op->sub_type, file_output_port_type)) {
07434        int tmp;
07435        tmp = MSC_IZE(fileno)(((Scheme_Output_File *)op->port_data)->f);
07436        from_subprocess[1] = tmp;
07437       }
07438 # ifdef MZ_FDS
07439       else if (SAME_OBJ(op->sub_type, fd_output_port_type))
07440        from_subprocess[1] = ((Scheme_FD *)op->port_data)->fd;
07441 # endif
07442 #endif
07443     } else
07444       scheme_wrong_type(name, "file-stream-output-port", 0, c, args);
07445   } else
07446     outport = NULL;
07447 
07448   if (SCHEME_TRUEP(args[1])) {
07449     inport = args[1];
07450     if (SCHEME_INPUT_PORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
07451 #ifdef PROCESS_FUNCTION
07452       Scheme_Input_Port *ip;
07453 
07454       ip = scheme_input_port_record(inport);
07455 
07456       if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
07457        int tmp;
07458        tmp = MSC_IZE(fileno)(((Scheme_Input_File *)ip->port_data)->f);
07459        to_subprocess[0] = tmp;
07460       }
07461 # ifdef MZ_FDS
07462       else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
07463        to_subprocess[0] = ((Scheme_FD *)ip->port_data)->fd;
07464 # endif
07465 #endif
07466     } else
07467       scheme_wrong_type(name, "file-stream-input-port", 1, c, args);
07468   } else
07469     inport = NULL;
07470 
07471   if (SCHEME_TRUEP(args[2])) {
07472     errport = args[2];
07473     if (SCHEME_OUTPUT_PORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
07474 #ifdef PROCESS_FUNCTION
07475       Scheme_Output_Port *op;
07476 
07477       op = scheme_output_port_record(errport);
07478 
07479       if (SAME_OBJ(op->sub_type, file_output_port_type)) {
07480        int tmp;
07481        tmp = MSC_IZE(fileno)(((Scheme_Output_File *)op->port_data)->f);
07482        err_subprocess[1] = tmp;
07483       }
07484 # ifdef MZ_FDS
07485       else if (SAME_OBJ(op->sub_type, fd_output_port_type))
07486        err_subprocess[1] = ((Scheme_FD *)op->port_data)->fd;
07487 # endif
07488 #endif
07489     } else
07490       scheme_wrong_type(name, "file-stream-output-port", 2, c, args);
07491   } else
07492     errport = NULL;
07493 
07494   if (!SCHEME_PATH_STRINGP(args[3]))
07495     scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 3, c, args);
07496 
07497   /*--------------------------------------*/
07498   /*          Sort out arguments          */
07499   /*--------------------------------------*/
07500 
07501   argv = MALLOC_N(char *, c - 3 + 1);
07502   {
07503     char *ef;
07504     ef = scheme_expand_string_filename(args[3],
07505                                    (char *)name, 
07506                                    NULL,
07507                                    SCHEME_GUARD_FILE_EXECUTE);
07508     argv[0] = ef;
07509   }
07510   {
07511     /* This is for Windows: */
07512     char *np;
07513     int nplen;
07514     nplen = strlen(argv[0]);
07515     np = scheme_normal_path_seps(argv[0], &nplen, 0);
07516     argv[0] = np;
07517   }
07518 
07519   if ((c == 6) && SAME_OBJ(args[4], exact_symbol)) {
07520     argv[2] = NULL;
07521     if (!SCHEME_CHAR_STRINGP(args[5]) || scheme_any_string_has_null(args[5]))
07522       scheme_wrong_type(name, CHAR_STRING_W_NO_NULLS, 5, c, args);
07523     {
07524       Scheme_Object *bs;
07525       bs = scheme_char_string_to_byte_string(args[5]);
07526       argv[1] = SCHEME_BYTE_STR_VAL(bs);
07527     }
07528 #ifdef WINDOWS_PROCESSES
07529     exact_cmdline = 1;
07530 #else
07531     /* 'exact-full only works in windows */
07532     scheme_arg_mismatch(name,
07533                      "exact command line not supported on this platform: ",
07534                      args[5]);
07535 #endif
07536   } else {
07537     for (i = 4; i < c; i++) {
07538       if (!SCHEME_CHAR_STRINGP(args[i]) || scheme_any_string_has_null(args[i]))
07539        scheme_wrong_type(name, CHAR_STRING_W_NO_NULLS, i, c, args);
07540       {
07541        Scheme_Object *bs;
07542        bs = scheme_char_string_to_byte_string_locale(args[i]);
07543        argv[i - 3] = SCHEME_BYTE_STR_VAL(bs);
07544       }
07545     }
07546     argv[c - 3] = NULL;
07547   }
07548 
07549   command = argv[0];
07550 
07551   if (!inport || !outport || !errport)
07552     scheme_custodian_check_available(NULL, name, "file-stream");
07553 
07554   /*--------------------------------------*/
07555   /*          Create needed pipes         */
07556   /*--------------------------------------*/
07557 
07558   if (!inport && PIPE_FUNC(to_subprocess, 1 _EXTRA_PIPE_ARGS))
07559     scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
07560   if (!outport && PIPE_FUNC(from_subprocess, 0 _EXTRA_PIPE_ARGS)) {
07561     if (!inport) {
07562       MSC_IZE(close)(to_subprocess[0]);
07563       MSC_IZE(close)(to_subprocess[1]);
07564     }
07565     scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
07566   }
07567   if (!errport && PIPE_FUNC(err_subprocess, 0 _EXTRA_PIPE_ARGS)) {
07568     if (!inport) {
07569       MSC_IZE(close)(to_subprocess[0]);
07570       MSC_IZE(close)(to_subprocess[1]);
07571     }
07572     if (!outport) {
07573       MSC_IZE(close)(from_subprocess[0]);
07574       MSC_IZE(close)(from_subprocess[1]);
07575     }
07576     scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
07577   }
07578 
07579 #if defined(WINDOWS_PROCESSES)
07580 
07581   /*--------------------------------------*/
07582   /*        Execute: Windows              */
07583   /*--------------------------------------*/
07584 
07585   /* Windows: quasi-stdin is locked, and we'll say it doesn't matter */
07586   fflush(stdin);
07587   fflush(stdout);
07588   fflush(stderr);
07589 
07590   {
07591     Scheme_Object *tcd;
07592 
07593     if (!exact_cmdline) {
07594       /* protect spaces, etc. in the arguments: */
07595       for (i = 0; i < (c - 3); i++) {
07596        char *cla;
07597        cla = cmdline_protect(argv[i]);
07598        argv[i] = cla;
07599       }
07600     }
07601 
07602     /* Set real CWD before spawn: */
07603     tcd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
07604     scheme_os_setcwd(SCHEME_BYTE_STR_VAL(tcd), 0);
07605 
07606     spawn_status = mz_spawnv(command, (const char * const *)argv,
07607                           exact_cmdline,
07608                           to_subprocess[0],
07609                           from_subprocess[1],
07610                           err_subprocess[1],
07611                           &pid);
07612 
07613     if (spawn_status != -1)
07614       sc = (void *)spawn_status;
07615   }
07616 
07617 # define mzCLOSE_PIPE_END(x) CloseHandle((HANDLE)(x))
07618 #else
07619 
07620 
07621   /*--------------------------------------*/
07622   /*            Execute: Unix             */
07623   /*--------------------------------------*/
07624 
07625   {
07626     init_sigchld();
07627 
07628     sc = MALLOC_ONE_RT(System_Child);
07629 #ifdef MZTAG_REQUIRED
07630     sc->type = scheme_rt_system_child;
07631 #endif
07632     sc->id = 0;
07633     sc->done = 0;
07634 
07635     scheme_block_child_signals(1);
07636 
07637     pid = fork();
07638 
07639     if (pid > 0) {
07640       sc->next = scheme_system_children;
07641       scheme_system_children = sc;
07642       sc->id = pid;
07643     } else if (!pid) {
07644 #ifdef USE_ITIMER
07645       /* Turn off the timer. */
07646       /* SIGPROF is masked at this point due to
07647         block_child_signals() */
07648       struct itimerval t, old;
07649       sigset_t sigs;
07650 
07651       t.it_value.tv_sec = 0;
07652       t.it_value.tv_usec = 0;
07653       t.it_interval.tv_sec = 0;
07654       t.it_interval.tv_usec = 0;
07655 
07656       setitimer(ITIMER_PROF, &t, &old);
07657 
07658       /* Clear already-queued PROF signal, if any: */
07659       START_XFORM_SKIP;
07660       sigemptyset(&sigs);
07661       while (!sigpending(&sigs)) {
07662        if (sigismember(&sigs, SIGPROF)) {
07663          sigprocmask(SIG_SETMASK, NULL, &sigs);
07664          sigdelset(&sigs, SIGPROF);
07665          sigsuspend(&sigs);
07666          sigemptyset(&sigs);
07667        } else
07668          break;
07669       }
07670       END_XFORM_SKIP;
07671 #endif
07672     } else {
07673       fork_errno = errno;
07674     }
07675 
07676     scheme_block_child_signals(0);
07677   }
07678 
07679   switch (pid)
07680     {
07681     case -1:
07682       /* Close unused descriptors. */
07683       if (!inport) {
07684        MSC_IZE(close)(to_subprocess[0]);
07685        MSC_IZE(close)(to_subprocess[1]);
07686       }
07687       if (!outport) {
07688        MSC_IZE(close)(from_subprocess[0]);
07689        MSC_IZE(close)(from_subprocess[1]);
07690       }
07691       if (!errport) {
07692        MSC_IZE(close)(err_subprocess[0]);
07693        MSC_IZE(close)(err_subprocess[1]);
07694       }
07695       scheme_raise_exn(MZEXN_FAIL, "%s: fork failed (%e)", name, fork_errno);
07696       return scheme_false;
07697 
07698     case 0: /* child */
07699 
07700       {
07701        /* Copy pipe descriptors to stdin and stdout */
07702        MSC_IZE(dup2)(to_subprocess[0], 0);
07703        MSC_IZE(dup2)(from_subprocess[1], 1);
07704        MSC_IZE(dup2)(err_subprocess[1], 2);
07705 
07706        /* Close unwanted descriptors. */
07707        if (!inport) {
07708          MSC_IZE(close)(to_subprocess[0]);
07709          MSC_IZE(close)(to_subprocess[1]);
07710        }
07711        if (!outport) {
07712          MSC_IZE(close)(from_subprocess[0]);
07713          MSC_IZE(close)(from_subprocess[1]);
07714        }
07715        if (!errport) {
07716          MSC_IZE(close)(err_subprocess[0]);
07717          MSC_IZE(close)(err_subprocess[1]);
07718        }
07719 
07720 #ifdef CLOSE_ALL_FDS_AFTER_FORK
07721        /* Actually, unwanted includes everything
07722           except stdio. */
07723 #ifdef USE_ULIMIT
07724        i = ulimit(4, 0);
07725 #else
07726        i = getdtablesize();
07727 #endif
07728        while (i-- > 3) {
07729          int cr;
07730          do {
07731            cr = close(i);
07732          } while ((cr == -1) && (errno == EINTR));
07733        }
07734 #endif
07735       }
07736 
07737       /* Set real CWD */
07738       {
07739        Scheme_Object *dir;
07740        dir = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
07741        scheme_os_setcwd(SCHEME_PATH_VAL(dir), 0);
07742       }
07743 
07744       /* Exec new process */
07745 
07746       {
07747        int err;
07748 
07749        /* Reset ignored signals: */
07750        START_XFORM_SKIP;
07751 #ifndef DONT_IGNORE_FPE_SIGNAL
07752        MZ_SIGSET(SIGFPE, SIG_DFL);
07753 #endif
07754 #ifndef DONT_IGNORE_PIPE_SIGNAL
07755        MZ_SIGSET(SIGPIPE, SIG_DFL);
07756 #endif
07757        END_XFORM_SKIP;
07758 
07759        err = MSC_IZE(execv)(command, argv);
07760 
07761        /* If we get here it failed; give up */
07762 
07763         /* using scheme_signal_error will leave us in the forked process,
07764           so use scheme_console_printf instead */
07765         scheme_console_printf("mzscheme: exec failed (%d)\n", err);
07766 
07767        /* back to MzScheme signal dispositions: */
07768        START_XFORM_SKIP;
07769 #ifndef DONT_IGNORE_FPE_SIGNAL
07770        MZ_SIGSET(SIGFPE, SIG_IGN);
07771 #endif
07772 #ifndef DONT_IGNORE_PIPE_SIGNAL
07773        MZ_SIGSET(SIGPIPE, SIG_IGN);
07774 #endif
07775        END_XFORM_SKIP;
07776 
07777        _exit(1);
07778       }
07779 
07780     default: /* parent */
07781 
07782       break;
07783     }
07784 # define mzCLOSE_PIPE_END(x) MSC_IZE(close)(x)
07785 #endif
07786 
07787   /*--------------------------------------*/
07788   /*      Close unneeded descriptors      */
07789   /*--------------------------------------*/
07790 
07791   if (!inport) {
07792     mzCLOSE_PIPE_END(to_subprocess[0]);
07793     out = NULL;
07794     scheme_file_open_count += 1;
07795   } else
07796     out = scheme_false;
07797   if (!outport) {
07798     mzCLOSE_PIPE_END(from_subprocess[1]);
07799     in = NULL;
07800     scheme_file_open_count += 1;
07801   } else
07802     in = scheme_false;
07803   if (!errport) {
07804     mzCLOSE_PIPE_END(err_subprocess[1]);
07805     err = NULL;
07806     scheme_file_open_count += 1;
07807   } else
07808     err = scheme_false;
07809 
07810   /*--------------------------------------*/
07811   /*        Create new port objects       */
07812   /*--------------------------------------*/
07813 
07814   in = (in ? in : make_fd_input_port(from_subprocess[0], scheme_intern_symbol("subprocess-stdout"), 0, 0, NULL, 0));
07815   out = (out ? out : make_fd_output_port(to_subprocess[1], scheme_intern_symbol("subprocess-stdin"), 0, 0, 0, -1));
07816   err = (err ? err : make_fd_input_port(err_subprocess[0], scheme_intern_symbol("subprocess-stderr"), 0, 0, NULL, 0));
07817 
07818   /*--------------------------------------*/
07819   /*          Return result info          */
07820   /*--------------------------------------*/
07821 
07822   subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
07823   subproc->so.type = scheme_subprocess_type;
07824   subproc->handle = (void *)sc;
07825   subproc->pid = pid;
07826 # if defined(WINDOWS_PROCESSES)
07827   scheme_add_finalizer(subproc, close_subprocess_handle, NULL);
07828 # endif
07829 
07830 #define cons scheme_make_pair
07831 
07832   a[0] = (Scheme_Object *)subproc;
07833   a[1] = in;
07834   a[2] = out;
07835   a[3] = err;
07836 
07837   return scheme_values(4, a);
07838 
07839 #else
07840 # ifdef MAC_CLASSIC_PROCESS_CONTROL
07841 
07842   /*--------------------------------------*/
07843   /*            Macintosh hacks           */
07844   /*--------------------------------------*/
07845 
07846   {
07847     int i;
07848     Scheme_Object *a[4], *appname;
07849     Scheme_Subprocess *subproc;
07850 
07851     for (i = 0; i < 3; i++) {
07852       if (!SCHEME_FALSEP(args[i]))
07853        scheme_arg_mismatch(name,
07854                          "non-#f port argument not allowed on this platform: ",
07855                          args[i]);
07856     }
07857 
07858     if (c > 4) {
07859       if (c == 5) {
07860        Scheme_Object *bs;
07861        if (!SCHEME_PATH_STRINGP(args[3]))
07862          scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 3, c, args);
07863        if (SCHEME_PATHP(args[3]))
07864          bs = args[3];
07865        else
07866          bs = scheme_char_string_to_path(args[3]);
07867        if (strcmp(SCHEME_PATH_VAL(bs), "by-id"))
07868          scheme_arg_mismatch(name,
07869                            "in five-argument mode on this platform, the 4th argument must be \"by-id\": ",
07870                            args[3]);
07871 
07872        appname = args[4];
07873        i = scheme_mac_start_app((char *)name, 1, appname);
07874       } else
07875        scheme_arg_mismatch(name,
07876                          "extra arguments after the application id are "
07877                          "not allowed on this platform: ",
07878                          args[5]);
07879     } else {
07880       appname = args[3];
07881       i = scheme_mac_start_app((char *)name, 0, appname);
07882     }
07883 
07884     if (!i) {
07885       scheme_raise_exn(MZEXN_FAIL, "%s: launch failed for application: %Q", name, appname);
07886       return NULL;
07887     }
07888 
07889     subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
07890     subproc->type = scheme_subprocess_type;
07891 
07892     a[0] = (Scheme_Object *)subproc;
07893     a[1] = scheme_false;
07894     a[2] = scheme_false;
07895     a[3] = scheme_false;
07896 
07897     return scheme_values(4, a);
07898   }
07899 
07900 # else
07901   /*--------------------------------------*/
07902   /*  Subprocess functionality disabled   */
07903   /*--------------------------------------*/
07904 
07905   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
07906                  "%s: not supported on this platform",
07907                  name);
07908   return NULL;
07909 # endif
07910 #endif
07911 }
07912 
07913 static Scheme_Object *sch_shell_execute(int c, Scheme_Object *argv[])
07914 {
07915   int show;
07916   char *dir;
07917 #ifdef WINDOWS_PROCESSES
07918 # define mzseSHOW(x) x
07919 #else
07920 # define mzseSHOW(x) 1
07921 #endif
07922 
07923   if (!SCHEME_FALSEP(argv[0]) && !SCHEME_CHAR_STRINGP(argv[0]))
07924     scheme_wrong_type("shell-execute", "string or #f", 0, c, argv);
07925   if (!SCHEME_CHAR_STRINGP(argv[1]))
07926     scheme_wrong_type("shell-execute", "string", 1, c, argv);
07927   if (!SCHEME_CHAR_STRINGP(argv[2]))
07928     scheme_wrong_type("shell-execute", "string", 2, c, argv);
07929   if (!SCHEME_PATH_STRINGP(argv[3]))
07930     scheme_wrong_type("shell-execute", SCHEME_PATH_STRING_STR, 3, c, argv);
07931   {
07932     int show_set = 0;
07933     show = 0;
07934 # define mzseCMP(id, str)                        \
07935     if (SAME_OBJ(scheme_intern_symbol(str), argv[4])   \
07936         || SAME_OBJ(scheme_intern_symbol(# id), argv[4])) { \
07937       show = mzseSHOW(id); show_set = 1; }
07938     mzseCMP(SW_HIDE, "sw_hide");
07939     mzseCMP(SW_MAXIMIZE, "sw_maximize");
07940     mzseCMP(SW_MINIMIZE, "sw_minimize");
07941     mzseCMP(SW_RESTORE, "sw_restore");
07942     mzseCMP(SW_SHOW, "sw_show");
07943     mzseCMP(SW_SHOWDEFAULT, "sw_showdefault");
07944     mzseCMP(SW_SHOWMAXIMIZED, "sw_showmaximized");
07945     mzseCMP(SW_SHOWMINIMIZED, "sw_showminimized");
07946     mzseCMP(SW_SHOWMINNOACTIVE, "sw_showminnoactive");
07947     mzseCMP(SW_SHOWNA, "sw_showna");
07948     mzseCMP(SW_SHOWNOACTIVATE, "sw_shownoactivate");
07949     mzseCMP(SW_SHOWNORMAL, "sw_shownormal");
07950 
07951     if (!show_set)
07952       scheme_wrong_type("shell-execute", "show-mode symbol", 4, c, argv);
07953   }
07954 
07955   dir = scheme_expand_string_filename(argv[3],
07956                                   "shell-execute", NULL,
07957                                   SCHEME_GUARD_FILE_EXISTS);
07958 #ifdef WINDOWS_PROCESSES
07959   {
07960     SHELLEXECUTEINFOW se;
07961     int nplen;
07962     Scheme_Object *sv, *sf, *sp;
07963 
07964     nplen = strlen(dir);
07965     dir = scheme_normal_path_seps(dir, &nplen, 0);
07966 
07967     if (SCHEME_FALSEP(argv[0]))
07968       sv = scheme_false;
07969     else
07970       sv = scheme_char_string_to_byte_string(argv[0]);
07971     sf = scheme_char_string_to_byte_string(argv[1]);
07972     sp = scheme_char_string_to_byte_string(argv[2]);
07973 
07974     memset(&se, 0, sizeof(se));
07975     se.fMask = SEE_MASK_NOCLOSEPROCESS | SEE_MASK_FLAG_DDEWAIT;
07976     se.cbSize = sizeof(se);
07977     if (SCHEME_FALSEP(sv))
07978       se.lpVerb = NULL;
07979     else {
07980       se.lpVerb = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sv));
07981     }
07982     se.lpFile = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sf));
07983     se.lpParameters = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sp));
07984     se.lpDirectory = WIDE_PATH_COPY(dir);
07985     se.nShow = show;
07986     se.hwnd = NULL;
07987 
07988     /* Used to use ShellExecuteEx(&se) here. Not sure why it doesn't work,
07989        and the problem was intermittent (e.g., worked for opening a URL
07990        with IE as the default browser, but failed with Netscape). */
07991     if (ShellExecuteW(se.hwnd, se.lpVerb, se.lpFile, se.lpParameters, se.lpDirectory, se.nShow)) {
07992       if (se.hProcess) {
07993        Scheme_Subprocess *subproc;
07994 
07995        subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
07996 
07997        subproc->so.type = scheme_subprocess_type;
07998        subproc->handle = (void *)se.hProcess;
07999        subproc->pid = 0;
08000        scheme_add_finalizer(subproc, close_subprocess_handle, NULL);
08001 
08002        return (Scheme_Object *)subproc;
08003       } else
08004        return scheme_false;
08005     } else {
08006       scheme_signal_error("shell-execute: execute failed for: %V (%E)",
08007                        argv[1],
08008                        GetLastError());
08009       return NULL;
08010     }
08011   }
08012 #else
08013   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
08014                  "shell-execute: not supported on this platform");
08015   return NULL;
08016 #endif
08017 }
08018 
08019 /*========================================================================*/
08020 /*                          fd reservation                                */
08021 /*========================================================================*/
08022 
08023 /* We don't want on-demand loading of code to fail because we run out of
08024    file descriptors. So, keep one in reserve. */
08025 
08026 #ifdef USE_FD_PORTS
08027 static int fd_reserved, the_fd;
08028 #endif
08029 
08030 void scheme_reserve_file_descriptor(void)
08031 {
08032 #ifdef USE_FD_PORTS
08033   if (!fd_reserved) {
08034     the_fd = open("/dev/null", O_RDONLY); 
08035     if (the_fd != -1)
08036       fd_reserved = 1;
08037   }
08038 #endif
08039 }
08040 
08041 void scheme_release_file_descriptor(void)
08042 {
08043 #ifdef USE_FD_PORTS
08044   if (fd_reserved) {
08045     close(the_fd);
08046     fd_reserved = 0;
08047   }
08048 #endif
08049 }
08050 
08051 
08052 /*========================================================================*/
08053 /*                             sleeping                                   */
08054 /*========================================================================*/
08055 
08056 /* This code is used to implement sleeping when MzScheme is completely
08057    blocked on external objects, such as ports. For Unix, sleeping is
08058    essentially just a select(). */
08059 
08060 /****************** Windows cleanup  *****************/
08061 
08062 #if defined(WIN32_FD_HANDLES)
08063 
08064 static void clean_up_wait(long result, OS_SEMAPHORE_TYPE *array,
08065                        int *rps, int count)
08066 {
08067   if ((result >= (long)WAIT_OBJECT_0) && (result < (long)WAIT_OBJECT_0 + count)) {
08068     result -= WAIT_OBJECT_0;
08069     if (rps[result])
08070       ReleaseSemaphore(array[result], 1, NULL);
08071   }
08072 
08073   /* Clear out break semaphore */
08074   WaitForSingleObject(scheme_break_semaphore, 0);
08075 }
08076 
08077 static int made_progress;
08078 static DWORD max_sleep_time;
08079 
08080 void scheme_notify_sleep_progress()
08081 {
08082   made_progress = 1;
08083 }
08084 
08085 #else
08086 
08087 void scheme_notify_sleep_progress()
08088 {
08089 }
08090 
08091 #endif
08092 
08093 /******************** Main sleep function  *****************/
08094 /* The simple select() stuff is buried in Windows complexity. */
08095 
08096 /* This sleep function is not allowed to allocate in OS X, because it
08097    is called in a non-main thread. */
08098 
08099 #ifdef OS_X
08100 # ifdef MZ_XFORM
08101 START_XFORM_SKIP;
08102 # endif
08103 #endif
08104 
08105 static void default_sleep(float v, void *fds)
08106 {
08107   /* REMEMBER: don't allocate in this function (at least not GCable
08108      memory) for OS X. Not that FD setups are ok, because they use
08109      eternal mallocs. */
08110 
08111 #ifdef USE_OSKIT_CONSOLE
08112   /* Don't really sleep; keep polling the keyboard: */
08113   if (!v || (v > 0.01))
08114     v = 0.01;
08115 #endif
08116 
08117   if (!fds) {
08118     /* Nothing to block on - just sleep for some amount of time. */
08119 #if defined(FILES_HAVE_FDS)
08120     /* Sleep by selecting on the external event fd */
08121     struct timeval time;
08122     long secs = (long)v;
08123     long usecs = (long)(fmod(v, 1.0) * 1000000);
08124 
08125     if (v && (v > 100000))
08126       secs = 100000;
08127     if (usecs < 0)
08128       usecs = 0;
08129     if (usecs >= 1000000)
08130       usecs = 999999;
08131 
08132     time.tv_sec = secs;
08133     time.tv_usec = usecs;
08134 
08135     if (external_event_fd) {
08136       DECL_FDSET(readfds, 1);
08137 
08138       INIT_DECL_FDSET(readfds, 1);
08139 
08140       MZ_FD_ZERO(readfds);
08141       MZ_FD_SET(external_event_fd, readfds);
08142 
08143       select(external_event_fd + 1, readfds, NULL, NULL, &time);
08144     } else {
08145       select(0, NULL, NULL, NULL, &time);
08146     }
08147 
08148 #else
08149 # ifndef NO_SLEEP
08150 #  ifndef NO_USLEEP
08151    usleep((unsigned)(v * 1000));
08152 #   else
08153    sleep(v);
08154 #  endif
08155 # endif
08156 #endif
08157   } else {
08158     /* Something to block on - sort our the parts in Windows. */
08159 
08160 #if defined(FILES_HAVE_FDS) || defined(USE_WINSOCK_TCP)
08161     int limit, actual_limit;
08162     fd_set *rd, *wr, *ex;
08163     struct timeval time;
08164 
08165 #ifdef SIGCHILD_DOESNT_INTERRUPT_SELECT
08166     if (scheme_system_children) {
08167       /* Better poll every second or so... */
08168       if (!v || (v > 1))
08169        v = 1;
08170     }
08171 #endif
08172 
08173     {
08174       long secs = (long)v;
08175       long usecs = (long)(fmod(v, 1.0) * 1000000);
08176 
08177       if (v && (v > 100000))
08178        secs = 100000;
08179       if (usecs < 0)
08180        usecs = 0;
08181       if (usecs >= 1000000)
08182        usecs = 999999;
08183 
08184       time.tv_sec = secs;
08185       time.tv_usec = usecs;
08186     }
08187 
08188 # ifdef USE_WINSOCK_TCP
08189     limit = 0;
08190 # else
08191 #  ifdef USE_ULIMIT
08192     limit = ulimit(4, 0);
08193 #  else
08194 #   ifdef FIXED_FD_LIMIT
08195     limit = FIXED_FD_LIMIT;
08196 #   else
08197     limit = getdtablesize();
08198 #   endif
08199 #  endif
08200 #endif
08201 
08202     rd = (fd_set *)fds;
08203     wr = (fd_set *)MZ_GET_FDSET(fds, 1);
08204     ex = (fd_set *)MZ_GET_FDSET(fds, 2);
08205 # ifdef STORED_ACTUAL_FDSET_LIMIT
08206     actual_limit = FDSET_LIMIT(rd);
08207     if (FDSET_LIMIT(wr) > actual_limit)
08208       actual_limit = FDSET_LIMIT(wr);
08209     if (FDSET_LIMIT(ex) > actual_limit)
08210       actual_limit = FDSET_LIMIT(ex);
08211     actual_limit++;
08212 # else
08213     actual_limit = limit;
08214 # endif
08215 
08216     /******* Start Windows stuff *******/
08217 
08218 #if defined(WIN32_FD_HANDLES)
08219     {
08220       long result;
08221       OS_SEMAPHORE_TYPE *array, just_two_array[2], break_sema;
08222       int count, rcount, *rps;
08223 
08224       if (((win_extended_fd_set *)rd)->no_sleep)
08225        return;
08226 
08227       scheme_collapse_win_fd(fds); /* merges */
08228 
08229       rcount = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->num_handles);
08230       count = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->combined_len);
08231       array = ((win_extended_fd_set *)fds)->combined_wait_array;
08232       rps = ((win_extended_fd_set *)fds)->repost_sema;
08233 
08234       /* add break semaphore: */
08235       if (!count) {
08236        array = just_two_array;
08237       }
08238       break_sema = scheme_break_semaphore;
08239       array[count++] = break_sema;
08240 
08241       /* Extensions may handle events.
08242         If the event queue is empty (as reported by GetQueueStatus),
08243         everything's ok.
08244 
08245         Otherwise, we have trouble sleeping until an event is ready. We
08246         sometimes leave events on th queue because, say, an eventspace is
08247         not ready. The problem is that MsgWait... only unblocks when a new
08248         event appears. Since extensions may check the queue using a sequence of
08249         PeekMessages, it's possible that an event is added during the
08250         middle of the sequence, but doesn't get handled.
08251 
08252         To avoid this problem, we don't actually sleep indefinitely if an event
08253         is pending. Instead, we slep 10 ms, then 20 ms, etc. This exponential 
08254         backoff ensures that we eventually handle a pending event, but we don't 
08255         spin and eat CPU cycles. The back-off is reset whenever a thread makes
08256         progress. */
08257 
08258 
08259       if (SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask)
08260          && GetQueueStatus(SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask))) {
08261        if (!made_progress) {
08262          /* Ok, we've gone around at least once. */
08263          if (max_sleep_time < 0x20000000)
08264            max_sleep_time *= 2;
08265        } else {
08266          /* Starting back-off mode */
08267          made_progress = 0;
08268          max_sleep_time = 5;
08269        }
08270       } else {
08271        /* Disable back-off mode */
08272        made_progress = 1;
08273        max_sleep_time = 0;
08274       }
08275 
08276       /* Wait for HANDLE-based input: */
08277       {
08278        DWORD msec;
08279        if (v) {
08280          if (v > 100000)
08281            msec = 100000000;
08282          else
08283            msec = (DWORD)(v * 1000);
08284          if (max_sleep_time && (msec > max_sleep_time))
08285            msec = max_sleep_time;
08286        } else {
08287          if (max_sleep_time)
08288            msec = max_sleep_time;
08289          else
08290            msec = INFINITE;
08291        }
08292 
08293        result = MsgWaitForMultipleObjects(count, array, FALSE, msec,
08294                                       SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask));
08295       }
08296       clean_up_wait(result, array, rps, rcount);
08297       scheme_collapse_win_fd(fds); /* cleans up */
08298 
08299       return;
08300     }
08301 #endif
08302 
08303 #ifdef USE_WINSOCK_TCP
08304     /* Stupid Windows: give select() empty fd_sets and it ignores the timeout. */
08305     if (!rd->fd_count && !wr->fd_count && !ex->fd_count) {
08306       if (v)
08307        Sleep((DWORD)(v * 1000));
08308       return;
08309     }
08310 #endif
08311 
08312     /******* End Windows stuff *******/
08313 
08314 #if defined(FILES_HAVE_FDS)
08315     /* Watch for external events, too: */
08316     if (external_event_fd) {
08317       MZ_FD_SET(external_event_fd, rd);
08318       if (external_event_fd >= actual_limit)
08319         actual_limit = external_event_fd + 1;
08320     }
08321 #endif
08322 
08323     select(actual_limit, rd, wr, ex, v ? &time : NULL);
08324 
08325 #endif
08326   }
08327 
08328 #if defined(FILES_HAVE_FDS)
08329   /* Clear external event flag */
08330   if (external_event_fd) {
08331     char buf[10];
08332     read(external_event_fd, buf, 10);
08333   }
08334 #endif
08335 }
08336 
08337 #ifdef OS_X
08338 # ifdef MZ_XFORM
08339 END_XFORM_SKIP;
08340 # endif
08341 #endif
08342 
08343 #ifdef MZ_XFORM
08344 START_XFORM_SKIP;
08345 #endif
08346 
08347 void scheme_signal_received(void)
08348 /* Ensure that MzScheme wakes up if asleep. */
08349 {
08350 #if defined(FILES_HAVE_FDS)
08351   if (put_external_event_fd) {
08352     int v;
08353     do {
08354       v = write(put_external_event_fd, "!", 1);
08355     } while ((v == -1) && (errno == EINTR));
08356   }
08357 #endif
08358 #if defined(WINDOWS_PROCESSES) || defined(WINDOWS_FILE_HANDLES)
08359   ReleaseSemaphore(scheme_break_semaphore, 1, NULL);
08360 #endif
08361 }
08362 
08363 #ifdef MZ_XFORM
08364 END_XFORM_SKIP;
08365 #endif
08366 
08367 int scheme_get_external_event_fd(void)
08368 {
08369 #if defined(FILES_HAVE_FDS)
08370   return external_event_fd;
08371 #else
08372   return 0;
08373 #endif
08374 }
08375 
08376 #ifdef USE_WIN32_THREAD_TIMER
08377 
08378 static HANDLE itimer;
08379 static OS_SEMAPHORE_TYPE itimer_semaphore;
08380 static long itimer_delay;
08381 
08382 #ifdef MZ_XFORM
08383 START_XFORM_SKIP;
08384 #endif
08385 
08386 static long ITimer(void)
08387 {
08388   WaitForSingleObject(itimer_semaphore, INFINITE);
08389 
08390   while (1) {
08391     if (WaitForSingleObject(itimer_semaphore, itimer_delay / 1000) == WAIT_TIMEOUT) {
08392       scheme_fuel_counter = 0;
08393       scheme_jit_stack_boundary = (unsigned long)-1;
08394       WaitForSingleObject(itimer_semaphore, INFINITE);
08395     }
08396   }
08397 }
08398 
08399 #ifdef MZ_XFORM
08400 END_XFORM_SKIP;
08401 #endif
08402 
08403 void scheme_start_itimer_thread(long usec)
08404 {
08405   DWORD id;
08406 
08407   if (!itimer) {
08408     itimer = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)ITimer, NULL, 0, &id);
08409     itimer_semaphore = CreateSemaphore(NULL, 0, 1, NULL);
08410     scheme_remember_thread(itimer, 0);
08411   }
08412 
08413   itimer_delay = usec;
08414   ReleaseSemaphore(itimer_semaphore, 1, NULL);
08415 }
08416 
08417 #endif
08418 
08419 #ifdef USE_PTHREAD_THREAD_TIMER
08420 
08421 #include <pthread.h>
08422 
08423 static int itimer = 0, itimer_continue = 0;
08424 static pthread_mutex_t itimer_mutex;
08425 static pthread_cond_t itimer_cond;
08426 static volatile long itimer_delay;
08427 
08428 #ifdef MZ_XFORM
08429 START_XFORM_SKIP;
08430 #endif
08431 static void *run_itimer(void *p)
08432 {
08433   while (1) {
08434     usleep(itimer_delay);
08435     scheme_fuel_counter = 0;
08436     scheme_jit_stack_boundary = (unsigned long)-1;
08437 
08438     pthread_mutex_lock(&itimer_mutex);
08439     if (itimer_continue) {
08440       itimer_continue = 0;
08441     } else {
08442       itimer_continue = -1;
08443       pthread_cond_wait(&itimer_cond, &itimer_mutex);
08444     }
08445     pthread_mutex_unlock(&itimer_mutex);
08446   }
08447 }
08448 #ifdef MZ_XFORM
08449 END_XFORM_SKIP;
08450 #endif
08451 
08452 void scheme_start_itimer_thread(long usec)
08453 {
08454   itimer_delay = usec;
08455 
08456   if (!itimer) {
08457     pthread_t t;
08458     pthread_mutex_init(&itimer_mutex, NULL);
08459     pthread_cond_init(&itimer_cond, NULL);
08460     pthread_create(&t, NULL, run_itimer,  NULL);
08461     itimer = 1;
08462   } else {
08463     pthread_mutex_lock(&itimer_mutex);
08464     if (!itimer_continue) {
08465       /* itimer thread is currently running working */
08466       itimer_continue = 1;
08467     } else if (itimer_continue < 0) {
08468       /* itimer thread is waiting on cond */
08469       itimer_continue = 0;
08470       pthread_cond_signal(&itimer_cond);
08471     } else {
08472       /* itimer thread is working, and we've already
08473          asked it to continue */
08474     }
08475     pthread_mutex_unlock(&itimer_mutex);
08476   }
08477 }
08478 
08479 #endif
08480 
08481 
08482 #ifdef OS_X
08483 
08484 /* Sleep-in-thread support needed for GUIs Mac OS X.
08485    To merge waiting on a CoreFoundation event with a select(), an embedding
08486    application can attach a single socket to an event callback, and then
08487    create a Mac thread to call the usual sleep and write to the socket when
08488    data is available. */
08489 
08490 #ifdef MZ_PRECISE_GC
08491 START_XFORM_SKIP;
08492 #endif
08493 
08494 typedef struct {
08495   pthread_mutex_t lock;
08496   pthread_cond_t cond;
08497   int count;
08498 } pt_sema_t;
08499 
08500 void pt_sema_init(pt_sema_t *sem)
08501 {
08502   pthread_mutex_init(&sem->lock, NULL);
08503   pthread_cond_init(&sem->cond, NULL);
08504   sem->count = 0;
08505 }
08506 
08507 void pt_sema_wait(pt_sema_t *sem)
08508 {
08509   pthread_mutex_lock(&sem->lock);
08510   while (sem->count <= 0)
08511     pthread_cond_wait(&sem->cond, &sem->lock);
08512   sem->count--;
08513   pthread_mutex_unlock(&sem->lock);
08514 }
08515 
08516 void pt_sema_post(pt_sema_t *sem)
08517 {
08518   pthread_mutex_lock(&sem->lock);
08519   sem->count++;
08520   if (sem->count > 0)
08521     pthread_cond_signal(&sem->cond);
08522   pthread_mutex_unlock(&sem->lock);
08523 }
08524 
08525 static pthread_t watcher;
08526 static pt_sema_t sleeping_sema, done_sema;
08527 static float sleep_secs;
08528 static int slept_fd;
08529 static void *sleep_fds;
08530 static void (*sleep_sleep)(float seconds, void *fds);
08531 
08532 static void *do_watch()
08533 {
08534   while (1) {
08535     pt_sema_wait(&sleeping_sema);
08536 
08537     sleep_sleep(sleep_secs, sleep_fds);
08538     write(slept_fd, "y", 1);
08539 
08540     pt_sema_post(&done_sema);
08541   }
08542 }
08543 
08544 void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd)
08545 {
08546   if (!watcher) {
08547     pt_sema_init(&sleeping_sema);
08548     pt_sema_init(&done_sema);
08549 
08550     if (pthread_create(&watcher, NULL, do_watch, NULL)) {
08551       scheme_log_abort("pthread_create failed");
08552       abort();
08553     }
08554   }
08555 
08556   sleep_sleep = given_sleep;
08557   sleep_fds = fds;
08558   sleep_secs = secs;
08559   slept_fd = hit_fd;
08560   pt_sema_post(&sleeping_sema);
08561 }
08562 
08563 void scheme_end_sleeper_thread()
08564 {
08565   scheme_signal_received();
08566   pt_sema_wait(&done_sema);
08567 
08568   /* Clear external event flag */
08569   if (external_event_fd) {
08570     char buf[10];
08571     read(external_event_fd, buf, 10);
08572   }
08573 }
08574 
08575 #ifdef MZ_PRECISE_GC
08576 END_XFORM_SKIP;
08577 #endif
08578 
08579 #else
08580 
08581 void scheme_start_sleeper_thread(void (*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd)
08582 {
08583 }
08584 void scheme_end_sleeper_thread()
08585 {
08586 }
08587 
08588 #endif
08589 
08590 /*========================================================================*/
08591 /*                       memory debugging help                            */
08592 /*========================================================================*/
08593 
08594 
08595 #ifdef MEMORY_COUNTING_ON
08596 void scheme_count_input_port(Scheme_Object *port, long *s, long *e,
08597                           Scheme_Hash_Table *ht)
08598 {
08599   Scheme_Input_Port *ip;
08600 
08601   ip = scheme_input_port_record(port);
08602 
08603   *e = (ht ? scheme_count_memory(ip->read_handler, ht) : 0);
08604   *s = sizeof(Scheme_Input_Port);
08605 
08606   if (ip->sub_type == file_input_port_type)
08607     *s += sizeof(Scheme_Input_File);
08608   else if (ip->sub_type == scheme_string_input_port_type) {
08609     Scheme_Indexed_String *is;
08610     is = (Scheme_Indexed_String *)ip->port_data;
08611     *s += (sizeof(Scheme_Indexed_String)
08612           + is->size);
08613   } else if (ip->sub_type == scheme_tcp_input_port_type) {
08614     if (ht && !scheme_hash_get(ht, (Scheme_Object *)ip->port_data)) {
08615       scheme_hash_set(ht, (Scheme_Object *)ip->port_data, scheme_true);
08616     }
08617   } else if (ip->sub_type == scheme_user_input_port_type) {
08618     Scheme_Object **d;
08619     d = (Scheme_Object **)ip->port_data;
08620     *s += (3 * sizeof(Scheme_Object *));
08621     *e += (ht
08622           ? (scheme_count_memory(d[0], ht)
08623              + scheme_count_memory(d[1], ht)
08624              + scheme_count_memory(d[2], ht))
08625           : 0);
08626   } else if (ip->sub_type == scheme_pipe_read_port_type) {
08627     if (ht && !scheme_hash_get(ht, (Scheme_Object *)ip->port_data)) {
08628       Scheme_Pipe *p = (Scheme_Pipe *)ip->port_data;
08629       scheme_hash_set(ht, (Scheme_Object *)ip->port_data, scheme_true);
08630       *s += (sizeof(Scheme_Pipe) + p->buflen);
08631     }
08632   }
08633 }
08634 
08635 void scheme_count_output_port(Scheme_Object *port, long *s, long *e,
08636                            Scheme_Hash_Table *ht)
08637 {
08638   Scheme_Output_Port *op;
08639 
08640   op = scheme_output_port_record(port);
08641 
08642   *e = 0;
08643   *s = sizeof(Scheme_Output_Port);
08644 
08645   if (op->sub_type == file_output_port_type)
08646     *s += sizeof(Scheme_Output_File);
08647   else if (op->sub_type == scheme_string_output_port_type) {
08648     Scheme_Indexed_String *is;
08649     is = (Scheme_Indexed_String *)op->port_data;
08650     *s += (sizeof(Scheme_Indexed_String)
08651           + is->size);
08652   } else if (op->sub_type == scheme_tcp_output_port_type) {
08653     if (!scheme_hash_get(ht, (Scheme_Object *)op->port_data)) {
08654       scheme_hash_set(ht, (Scheme_Object *)op->port_data, scheme_true);
08655     }
08656   } else if (op->sub_type == scheme_user_output_port_type) {
08657     Scheme_Object **d;
08658     d = (Scheme_Object **)op->port_data;
08659     *s += (2 * sizeof(Scheme_Object *));
08660     *e += (ht
08661           ? (scheme_count_memory(d[0], ht)
08662              + scheme_count_memory(d[1], ht))
08663           : 0);
08664   } else if (op->sub_type == scheme_pipe_read_port_type) {
08665     if (!scheme_hash_get(ht, (Scheme_Object *)op->port_data)) {
08666       Scheme_Pipe *p = (Scheme_Pipe *)op->port_data;
08667       scheme_hash_set(ht, (Scheme_Object *)op->port_data, scheme_true);
08668       *s += (sizeof(Scheme_Pipe) + p->buflen);
08669     }
08670   }
08671 }
08672 #endif
08673 
08674 /*========================================================================*/
08675 /*                       precise GC traversers                            */
08676 /*========================================================================*/
08677 
08678 #ifdef MZ_PRECISE_GC
08679 
08680 START_XFORM_SKIP;
08681 
08682 #define MARKS_FOR_PORT_C
08683 #include "mzmark.c"
08684 
08685 static void register_traversers(void)
08686 {
08687 #ifdef WINDOWS_PROCESSES
08688   GC_REG_TRAV(scheme_rt_thread_memory, mark_thread_memory);
08689 #endif
08690   GC_REG_TRAV(scheme_rt_input_file, mark_input_file);
08691   GC_REG_TRAV(scheme_rt_output_file, mark_output_file);
08692 
08693 #ifdef MZ_FDS
08694   GC_REG_TRAV(scheme_rt_input_fd, mark_input_fd);
08695 #endif
08696 
08697 #if defined(UNIX_PROCESSES)
08698   GC_REG_TRAV(scheme_rt_system_child, mark_system_child);
08699 #endif
08700 
08701 #ifdef USE_OSKIT_CONSOLE
08702   GC_REG_TRAV(scheme_rt_oskit_console_input, mark_oskit_console_input);
08703 #endif
08704 
08705   GC_REG_TRAV(scheme_subprocess_type, mark_subprocess);
08706   GC_REG_TRAV(scheme_write_evt_type, mark_read_write_evt);
08707 }
08708 
08709 END_XFORM_SKIP;
08710 
08711 #endif