Back to index

plt-scheme  4.2.1
Classes | Defines | Typedefs | Functions | Variables
port.c File Reference
#include "schpriv.h"
#include "schmach.h"
#include <errno.h>
#include <signal.h>
#include <math.h>
#include "schfd.h"
#include "schwinfd.h"

Go to the source code of this file.

Classes

struct  Scheme_Input_File
struct  Scheme_Output_File
struct  Scheme_Subprocess
struct  Scheme_Read_Write_Evt

Defines

#define MZ_BINARY   0
#define mzAssert(x)   /* if (!(x)) abort() */
#define FILENAME_EXN_E   "%e"
#define READ_STRING_BYTE_BUFFER_SIZE   1024
#define fail_err_symbol   scheme_false
#define fdset_type   fd_set
#define state_len(state)   ((state >> 3) & 0x7)
#define MAX_SKIP_TRY_AMOUNT   65536
#define CHECK_IOPORT_CLOSED(who, port)
#define MZ_FAILURE_STATUS   -1
#define mzseSHOW(x)   1
#define mzseCMP(id, str)

Typedefs

typedef struct Scheme_Subprocess Scheme_Subprocess
typedef struct
Scheme_Read_Write_Evt 
Scheme_Read_Write_Evt

Functions

static intmalloc_refcount ()
static int dec_refcount (int *refcount)
void scheme_set_binary_mode_stdio (int v)
static void register_port_wait ()
static Scheme_Objectsubprocess (int c, Scheme_Object *args[])
static Scheme_Objectsubprocess_status (int c, Scheme_Object *args[])
static Scheme_Objectsubprocess_kill (int c, Scheme_Object *args[])
static Scheme_Objectsubprocess_pid (int c, Scheme_Object *args[])
static Scheme_Objectsubprocess_p (int c, Scheme_Object *args[])
static Scheme_Objectsubprocess_wait (int c, Scheme_Object *args[])
static Scheme_Objectsch_shell_execute (int c, Scheme_Object *args[])
static void register_subprocess_wait ()
static int rw_evt_ready (Scheme_Object *rww, Scheme_Schedule_Info *sinfo)
static void rw_evt_wakeup (Scheme_Object *rww, void *fds)
static int progress_evt_ready (Scheme_Object *rww, Scheme_Schedule_Info *sinfo)
static Scheme_Object_scheme_make_named_file_input_port (FILE *fp, Scheme_Object *name, int regfile)
static void default_sleep (float v, void *fds)
static void force_close_output_port (Scheme_Object *port)
static void force_close_input_port (Scheme_Object *port)
void scheme_init_port (Scheme_Env *env)
void scheme_init_port_places (void)
void scheme_init_port_config (void)
Scheme_Objectscheme_make_eof (void)
voidscheme_alloc_fdset_array (int count, int permanent)
voidscheme_init_fdset_array (void *fdarray, int count)
voidscheme_get_fdset (void *fdarray, int pos)
void scheme_fdzero (void *fd)
void scheme_fdclr (void *fd, int n)
void scheme_fdset (void *fd, int n)
int scheme_fdisset (void *fd, int n)
void scheme_add_fd_handle (void *h, void *fds, int repost)
void scheme_add_fd_nosleep (void *fds)
void scheme_add_fd_eventmask (void *fds, int mask)
void scheme_collapse_win_fd (void *fds)
Scheme_Objectscheme_make_port_type (const char *name)
static void init_port_locations (Scheme_Port *ip)
void scheme_set_next_port_custodian (Scheme_Custodian *c)
Scheme_Input_Portscheme_make_input_port (Scheme_Object *subtype, void *data, Scheme_Object *name, Scheme_Get_String_Fun get_string_fun, Scheme_Peek_String_Fun peek_string_fun, Scheme_Progress_Evt_Fun progress_evt_fun, Scheme_Peeked_Read_Fun peeked_read_fun, Scheme_In_Ready_Fun byte_ready_fun, Scheme_Close_Input_Fun close_fun, Scheme_Need_Wakeup_Input_Fun need_wakeup_fun, int must_close)
void scheme_set_port_location_fun (Scheme_Port *port, Scheme_Location_Fun location_fun)
void scheme_set_port_count_lines_fun (Scheme_Port *port, Scheme_Count_Lines_Fun count_lines_fun)
static int evt_input_port_p (Scheme_Object *p)
Scheme_Output_Portscheme_make_output_port (Scheme_Object *subtype, void *data, Scheme_Object *name, Scheme_Write_String_Evt_Fun write_string_evt_fun, Scheme_Write_String_Fun write_string_fun, Scheme_Out_Ready_Fun ready_fun, Scheme_Close_Output_Fun close_fun, Scheme_Need_Wakeup_Output_Fun need_wakeup_fun, Scheme_Write_Special_Evt_Fun write_special_evt_fun, Scheme_Write_Special_Fun write_special_fun, int must_close)
static int evt_output_port_p (Scheme_Object *p)
static int output_ready (Scheme_Object *port, Scheme_Schedule_Info *sinfo)
static void output_need_wakeup (Scheme_Object *port, void *fds)
int scheme_byte_ready_or_user_port_ready (Scheme_Object *p, Scheme_Schedule_Info *sinfo)
static XFORM_NONGCING int pipe_char_count (Scheme_Object *p)
int scheme_pipe_char_count (Scheme_Object *p)
static void post_progress (Scheme_Input_Port *ip)
static XFORM_NONGCING void inc_pos (Scheme_Port *ip, int a)
static Scheme_Objectquick_plus (Scheme_Object *s, long v)
static XFORM_NONGCING void do_count_lines (Scheme_Port *ip, const char *buffer, long offset, long got)
long scheme_get_byte_string_unless (const char *who, Scheme_Object *port, char *buffer, long offset, long size, int only_avail, int peek, Scheme_Object *peek_skip, Scheme_Object *unless_evt)
long scheme_get_byte_string_special_ok_unless (const char *who, Scheme_Object *port, char *buffer, long offset, long size, int only_avail, int peek, Scheme_Object *peek_skip, Scheme_Object *unless_evt)
long scheme_get_byte_string (const char *who, Scheme_Object *port, char *buffer, long offset, long size, int only_avail, int peek, Scheme_Object *peek_skip)
int scheme_unless_ready (Scheme_Object *unless)
void scheme_wait_input_allowed (Scheme_Input_Port *ip, int nonblock)
static void release_input_lock (Scheme_Input_Port *ip)
static void elect_new_main (Scheme_Input_Port *ip)
static void release_input_lock_and_elect_new_main (void *_ip)
static void check_suspended ()
static void remove_extra (void *ip_v)
static int complete_peeked_read_via_get (Scheme_Input_Port *ip, long size)
static Scheme_Objectreturn_data (void *data, int argc, Scheme_Object **argv)
int scheme_peeked_read_via_get (Scheme_Input_Port *ip, long _size, Scheme_Object *unless_evt, Scheme_Object *_target_evt)
int scheme_peeked_read (Scheme_Object *port, long size, Scheme_Object *unless_evt, Scheme_Object *target_evt)
Scheme_Objectscheme_progress_evt_via_get (Scheme_Input_Port *port)
Scheme_Objectscheme_progress_evt (Scheme_Object *port)
long scheme_get_char_string (const char *who, Scheme_Object *port, mzchar *buffer, long offset, long size, int peek, Scheme_Object *peek_skip)
static MZ_INLINE long get_one_byte (const char *who, Scheme_Object *port, char *buffer, long offset, int only_avail)
int scheme_getc (Scheme_Object *port)
int scheme_get_byte (Scheme_Object *port)
int scheme_getc_special_ok (Scheme_Object *port)
int scheme_get_byte_special_ok (Scheme_Object *port)
long scheme_get_bytes (Scheme_Object *port, long size, char *buffer, int offset)
int scheme_peek_byte_skip (Scheme_Object *port, Scheme_Object *skip, Scheme_Object *unless_evt)
int scheme_peek_byte (Scheme_Object *port)
int scheme_peek_byte_special_ok_skip (Scheme_Object *port, Scheme_Object *skip, Scheme_Object *unless_evt)
static int do_peekc_skip (Scheme_Object *port, Scheme_Object *skip, int only_avail, int *unavail)
int scheme_peekc_skip (Scheme_Object *port, Scheme_Object *skip)
int scheme_peekc (Scheme_Object *port)
int scheme_peekc_special_ok_skip (Scheme_Object *port, Scheme_Object *skip)
int scheme_peekc_special_ok (Scheme_Object *port)
int scheme_peekc_is_ungetc (Scheme_Object *port)
Scheme_Objectmake_read_write_evt (Scheme_Type type, Scheme_Object *port, Scheme_Object *skip, char *str, long start, long size)
Scheme_Objectscheme_write_evt_via_write (Scheme_Output_Port *port, const char *str, long offset, long size)
Scheme_Objectscheme_write_special_evt_via_write_special (Scheme_Output_Port *port, Scheme_Object *special)
Scheme_Objectscheme_make_write_evt (const char *who, Scheme_Object *port, Scheme_Object *special, char *str, long start, long size)
void scheme_ungetc (int ch, Scheme_Object *port)
int scheme_byte_ready (Scheme_Object *port)
int scheme_char_ready (Scheme_Object *port)
Scheme_Objectscheme_get_special (Scheme_Object *port, Scheme_Object *src, long line, long col, long pos, int peek, Scheme_Hash_Table **for_read)
static Scheme_Objectdo_get_ready_special (Scheme_Object *port, Scheme_Object *stxsrc, int peek, Scheme_Hash_Table **ht)
Scheme_Objectscheme_get_ready_read_special (Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table **ht)
Scheme_Objectscheme_get_ready_special (Scheme_Object *port, Scheme_Object *stxsrc, int peek)
void scheme_bad_time_for_special (const char *who, Scheme_Object *port)
static Scheme_Objectcheck_special_args (void *sbox, int argc, Scheme_Object **argv)
Scheme_Objectscheme_get_special_proc (Scheme_Object *inport)
void scheme_need_wakeup (Scheme_Object *port, void *fds)
long scheme_tell (Scheme_Object *port)
long scheme_tell_line (Scheme_Object *port)
long scheme_tell_column (Scheme_Object *port)
void scheme_tell_all (Scheme_Object *port, long *_line, long *_col, long *_pos)
void scheme_count_lines (Scheme_Object *port)
void scheme_close_input_port (Scheme_Object *port)
int scheme_close_should_force_port_closed ()
long scheme_put_byte_string (const char *who, Scheme_Object *port, const char *str, long d, long len, int rarely_block)
void scheme_write_byte_string (const char *str, long len, Scheme_Object *port)
void scheme_write_char_string (const mzchar *str, long len, Scheme_Object *port)
long scheme_put_char_string (const char *who, Scheme_Object *port, const mzchar *str, long d, long len)
long scheme_output_tell (Scheme_Object *port)
void scheme_close_output_port (Scheme_Object *port)
void scheme_flush_orig_outputs (void)
void scheme_flush_output (Scheme_Object *o)
Scheme_Objectscheme_file_stream_port_p (int argc, Scheme_Object *argv[])
int scheme_get_port_file_descriptor (Scheme_Object *p, long *_fd)
long scheme_get_port_fd (Scheme_Object *p)
Scheme_Objectscheme_file_identity (int argc, Scheme_Object *argv[])
static int is_fd_terminal (int fd)
Scheme_Objectscheme_terminal_port_p (int argc, Scheme_Object *argv[])
static void filename_exn (char *name, char *msg, char *filename, int err)
Scheme_Objectscheme_do_open_input_file (char *name, int offset, int argc, Scheme_Object *argv[], int internal)
Scheme_Objectscheme_do_open_output_file (char *name, int offset, int argc, Scheme_Object *argv[], int and_read)
Scheme_Objectscheme_open_input_file (const char *name, const char *who)
Scheme_Objectscheme_open_output_file (const char *name, const char *who)
Scheme_Objectscheme_open_input_output_file (const char *name, const char *who, Scheme_Object **oport)
Scheme_Objectscheme_open_output_file_with_mode (const char *name, const char *who, int text)
Scheme_Objectscheme_file_position (int argc, Scheme_Object *argv[])
long scheme_set_file_position (Scheme_Object *port, long pos)
Scheme_Objectscheme_file_buffer (int argc, Scheme_Object *argv[])
static int file_byte_ready (Scheme_Input_Port *port)
static long file_get_string (Scheme_Input_Port *port, char *buffer, long offset, long size, int nonblock, Scheme_Object *unless_evt)
static void file_close_input (Scheme_Input_Port *port)
static void file_need_wakeup (Scheme_Input_Port *port, void *fds)
static int file_buffer_mode (Scheme_Port *p, int mode)
Scheme_Objectscheme_make_named_file_input_port (FILE *fp, Scheme_Object *name)
Scheme_Objectscheme_make_file_input_port (FILE *fp)
Scheme_Objectscheme_make_fd_input_port (int fd, Scheme_Object *name, int regfile, int textmode)
static void file_flush (Scheme_Output_Port *port)
static long file_write_string (Scheme_Output_Port *port, const char *str, long d, long llen, int rarely_block, int enable_break)
static void file_close_output (Scheme_Output_Port *port)
Scheme_Objectscheme_make_file_output_port (FILE *fp)
Scheme_Objectscheme_make_fd_output_port (int fd, Scheme_Object *name, int regfile, int textmode, int read_too)
static long null_write_bytes (Scheme_Output_Port *port, const char *str, long d, long len, int rarely_block, int enable_break)
static void null_close_out (Scheme_Output_Port *port)
static Scheme_Objectnull_write_evt (Scheme_Output_Port *op, const char *str, long offset, long size)
static Scheme_Objectnull_write_special_evt (Scheme_Output_Port *op, Scheme_Object *v)
static int null_write_special (Scheme_Output_Port *op, Scheme_Object *v, int nonblock)
Scheme_Objectscheme_make_null_output_port (int can_write_special)
static Scheme_Objectredirect_write_bytes_k (void)
static long redirect_write_bytes (Scheme_Output_Port *op, const char *str, long d, long len, int rarely_block, int enable_break)
static void redirect_close_out (Scheme_Output_Port *port)
static Scheme_Objectredirect_write_evt (Scheme_Output_Port *op, const char *str, long offset, long size)
static Scheme_Objectredirect_write_special_evt (Scheme_Output_Port *op, Scheme_Object *special)
static int redirect_write_special (Scheme_Output_Port *op, Scheme_Object *special, int nonblock)
Scheme_Objectscheme_make_redirect_output_port (Scheme_Object *port)
static Scheme_Objectsubprocess_status (int argc, Scheme_Object **argv)
static Scheme_Objectsubprocess_wait (int argc, Scheme_Object **argv)
static Scheme_Objectsubprocess_kill (int argc, Scheme_Object **argv)
static Scheme_Objectsubprocess_pid (int argc, Scheme_Object **argv)
static Scheme_Objectsubprocess_p (int argc, Scheme_Object **argv)
void scheme_reserve_file_descriptor (void)
void scheme_release_file_descriptor (void)
void scheme_notify_sleep_progress ()
void scheme_signal_received (void)
int scheme_get_external_event_fd (void)
void scheme_start_sleeper_thread (void(*given_sleep)(float seconds, void *fds), float secs, void *fds, int hit_fd)
void scheme_end_sleeper_thread ()

Variables

Scheme_Object scheme_eof [1]
THREAD_LOCAL Scheme_Objectscheme_orig_stdout_port
THREAD_LOCAL Scheme_Objectscheme_orig_stderr_port
THREAD_LOCAL Scheme_Objectscheme_orig_stdin_port
Scheme_Object *(* scheme_make_stdin )(void) = NULL
Scheme_Object *(* scheme_make_stdout )(void) = NULL
Scheme_Object *(* scheme_make_stderr )(void) = NULL
int scheme_file_open_count
MZ_DLLSPEC int scheme_binary_mode_stdio
static int special_is_ok
static Scheme_Objectfile_input_port_type
Scheme_Objectscheme_string_input_port_type
static Scheme_Objectfile_output_port_type
Scheme_Objectscheme_string_output_port_type
Scheme_Objectscheme_user_input_port_type
Scheme_Objectscheme_user_output_port_type
Scheme_Objectscheme_pipe_read_port_type
Scheme_Objectscheme_pipe_write_port_type
Scheme_Objectscheme_null_output_port_type
Scheme_Objectscheme_redirect_output_port_type
int scheme_force_port_closed
static int flush_out
static int flush_err
static THREAD_LOCAL
Scheme_Custodian
new_port_cust
static Scheme_Objecttext_symbol
static Scheme_Objectbinary_symbol
static Scheme_Objectappend_symbol
static Scheme_Objecterror_symbol
static Scheme_Objectupdate_symbol
static Scheme_Objectcan_update_symbol
static Scheme_Objectreplace_symbol
static Scheme_Objecttruncate_symbol
static Scheme_Objecttruncate_replace_symbol
static Scheme_Objectmust_truncate_symbol
Scheme_Objectscheme_none_symbol
Scheme_Objectscheme_line_symbol
Scheme_Objectscheme_block_symbol
static Scheme_Objectexact_symbol
static char * read_string_byte_buffer

Class Documentation

struct Scheme_Input_File

Definition at line 90 of file port.c.

Class Members
MZTAG_IF_REQUIRED FILE * f
struct Scheme_Output_File

Definition at line 95 of file port.c.

Class Members
MZTAG_IF_REQUIRED FILE * f
struct Scheme_Subprocess

Definition at line 184 of file port.c.

Collaboration diagram for Scheme_Subprocess:
Class Members
void * handle
int pid
Scheme_Object so
struct Scheme_Read_Write_Evt

Definition at line 374 of file port.c.

Collaboration diagram for Scheme_Read_Write_Evt:
Class Members
Scheme_Object * port
long size
Scheme_Object so
long start
char * str
Scheme_Object * v

Define Documentation

#define CHECK_IOPORT_CLOSED (   who,
  port 
)
Value:
if (SCHEME_INPORTP((Scheme_Object *)port)) {                          \
          CHECK_PORT_CLOSED(who, "input", port, ((Scheme_Input_Port *)port)->closed); \
        } else { \
          CHECK_PORT_CLOSED(who, "output", port, ((Scheme_Output_Port *)port)->closed); \
        }

Definition at line 3227 of file port.c.

Definition at line 421 of file port.c.

#define fdset_type   fd_set

Definition at line 738 of file port.c.

#define FILENAME_EXN_E   "%e"

Definition at line 292 of file port.c.

#define MAX_SKIP_TRY_AMOUNT   65536
#define MZ_BINARY   0

Definition at line 83 of file port.c.

#define MZ_FAILURE_STATUS   -1

Definition at line 6748 of file port.c.

#define mzAssert (   x)    /* if (!(x)) abort() */

Definition at line 86 of file port.c.

#define mzseCMP (   id,
  str 
)
Value:
if (SAME_OBJ(scheme_intern_symbol(str), argv[4])   \
        || SAME_OBJ(scheme_intern_symbol(# id), argv[4])) { \
      show = mzseSHOW(id); show_set = 1; }
#define mzseSHOW (   x)    1
#define READ_STRING_BYTE_BUFFER_SIZE   1024

Definition at line 418 of file port.c.

#define state_len (   state)    ((state >> 3) & 0x7)

Definition at line 1540 of file port.c.


Typedef Documentation


Function Documentation

static Scheme_Object * _scheme_make_named_file_input_port ( FILE *  fp,
Scheme_Object name,
int  regfile 
) [static]

Definition at line 4775 of file port.c.

{
  Scheme_Input_Port *ip;
  Scheme_Input_File *fip;

  if (!fp)
    scheme_signal_error("make-file-input-port(internal): "
                     "null file pointer");

  fip = MALLOC_ONE_RT(Scheme_Input_File);
#ifdef MZTAG_REQUIRED
  fip->type = scheme_rt_input_file;
#endif

  fip->f = fp;

  ip = scheme_make_input_port(file_input_port_type,
                           fip,
                           name,
                           file_get_string,
                           NULL,
                           scheme_progress_evt_via_get,
                           scheme_peeked_read_via_get,
                           file_byte_ready,
                           file_close_input,
                           file_need_wakeup,
                           1);
  ip->p.buffer_mode_fun = file_buffer_mode;

  return (Scheme_Object *)ip;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* check_special_args ( void sbox,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 3167 of file port.c.

{
  Scheme_Object *special;
  Scheme_Cont_Frame_Data cframe;

  if (SCHEME_TRUEP(argv[1]))
    if (!scheme_nonneg_exact_p(argv[1]) || (SAME_OBJ(argv[1], scheme_make_integer(0))))
      scheme_wrong_type("read-special", "positive exact integer or #f", 1, argc, argv);
  if (SCHEME_TRUEP(argv[2]))
    if (!scheme_nonneg_exact_p(argv[2]))
      scheme_wrong_type("read-special", "non-negative exact integer or #f", 2, argc, argv);
  if (SCHEME_TRUEP(argv[3]))
    if (!scheme_nonneg_exact_p(argv[3]) || (SAME_OBJ(argv[3], scheme_make_integer(0))))
      scheme_wrong_type("read-special", "positive exact integer or #f", 3, argc, argv);

  special = *(Scheme_Object **)sbox;
  if (!special)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                   "read-special: cannot be called a second time");
  *(Scheme_Object **)sbox = NULL;

  scheme_push_continuation_frame(&cframe);
  scheme_set_in_read_mark(NULL, NULL);

  special = _scheme_apply(special, 4, argv);

  scheme_pop_continuation_frame(&cframe);

  return special;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void check_suspended ( ) [static]

Definition at line 2086 of file port.c.

Here is the caller graph for this function:

static int complete_peeked_read_via_get ( Scheme_Input_Port ip,
long  size 
) [static]

Definition at line 2116 of file port.c.

{
  Scheme_Get_String_Fun gs;
  int did;
  
  did = 0;
  
  /* Target event is ready, so commit must succeed */
  
  /* First remove ungotten_count chars */
  if (ip->ungotten_count) {
    if (ip->ungotten_count > size)
      ip->ungotten_count -= size;
    else {
      size -= ip->ungotten_count;
      ip->ungotten_count = 0;
    }
    if (ip->progress_evt)
      post_progress(ip);
    did = 1;
  }
  
  if (size) {
    Scheme_Input_Port *pip;

    if (ip->peek_string_fun) {
      /* If the port supplies its own peek, then we don't
        have peeked_r, so pass NULL as a buffer to the port's
        read proc. The read proc must not block. */
      gs = ip->get_string_fun;
      pip = ip;
    } else {
      /* Otherwise, peek was implemented through peeked_{w,r}: */
      if (ip->peeked_read) {
       int cnt;
       cnt = pipe_char_count(ip->peeked_read);
       if ((cnt < size) && (ip->pending_eof == 2))
         ip->pending_eof = 1;
       pip = (Scheme_Input_Port *)ip->peeked_read;
       gs = pip->get_string_fun;
      } else {
       gs = NULL;
       pip = NULL;
      }
    }
      
    if (gs) {
      size = gs(pip, NULL, 0, size, 1, NULL);
      if (size > 0) {
       if (ip->progress_evt)
         post_progress(ip);
       did = 1;
      }
    }
  }
   
  return did;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int dec_refcount ( int refcount) [static]

Definition at line 240 of file port.c.

{
  if (!refcount)
    return 0;
  *refcount -= 1;
  return *refcount;
}
static void default_sleep ( float  v,
void fds 
) [static]

Definition at line 8105 of file port.c.

{
  /* REMEMBER: don't allocate in this function (at least not GCable
     memory) for OS X. Not that FD setups are ok, because they use
     eternal mallocs. */

#ifdef USE_OSKIT_CONSOLE
  /* Don't really sleep; keep polling the keyboard: */
  if (!v || (v > 0.01))
    v = 0.01;
#endif

  if (!fds) {
    /* Nothing to block on - just sleep for some amount of time. */
#if defined(FILES_HAVE_FDS)
    /* Sleep by selecting on the external event fd */
    struct timeval time;
    long secs = (long)v;
    long usecs = (long)(fmod(v, 1.0) * 1000000);

    if (v && (v > 100000))
      secs = 100000;
    if (usecs < 0)
      usecs = 0;
    if (usecs >= 1000000)
      usecs = 999999;

    time.tv_sec = secs;
    time.tv_usec = usecs;

    if (external_event_fd) {
      DECL_FDSET(readfds, 1);

      INIT_DECL_FDSET(readfds, 1);

      MZ_FD_ZERO(readfds);
      MZ_FD_SET(external_event_fd, readfds);

      select(external_event_fd + 1, readfds, NULL, NULL, &time);
    } else {
      select(0, NULL, NULL, NULL, &time);
    }

#else
# ifndef NO_SLEEP
#  ifndef NO_USLEEP
   usleep((unsigned)(v * 1000));
#   else
   sleep(v);
#  endif
# endif
#endif
  } else {
    /* Something to block on - sort our the parts in Windows. */

#if defined(FILES_HAVE_FDS) || defined(USE_WINSOCK_TCP)
    int limit, actual_limit;
    fd_set *rd, *wr, *ex;
    struct timeval time;

#ifdef SIGCHILD_DOESNT_INTERRUPT_SELECT
    if (scheme_system_children) {
      /* Better poll every second or so... */
      if (!v || (v > 1))
       v = 1;
    }
#endif

    {
      long secs = (long)v;
      long usecs = (long)(fmod(v, 1.0) * 1000000);

      if (v && (v > 100000))
       secs = 100000;
      if (usecs < 0)
       usecs = 0;
      if (usecs >= 1000000)
       usecs = 999999;

      time.tv_sec = secs;
      time.tv_usec = usecs;
    }

# ifdef USE_WINSOCK_TCP
    limit = 0;
# else
#  ifdef USE_ULIMIT
    limit = ulimit(4, 0);
#  else
#   ifdef FIXED_FD_LIMIT
    limit = FIXED_FD_LIMIT;
#   else
    limit = getdtablesize();
#   endif
#  endif
#endif

    rd = (fd_set *)fds;
    wr = (fd_set *)MZ_GET_FDSET(fds, 1);
    ex = (fd_set *)MZ_GET_FDSET(fds, 2);
# ifdef STORED_ACTUAL_FDSET_LIMIT
    actual_limit = FDSET_LIMIT(rd);
    if (FDSET_LIMIT(wr) > actual_limit)
      actual_limit = FDSET_LIMIT(wr);
    if (FDSET_LIMIT(ex) > actual_limit)
      actual_limit = FDSET_LIMIT(ex);
    actual_limit++;
# else
    actual_limit = limit;
# endif

    /******* Start Windows stuff *******/

#if defined(WIN32_FD_HANDLES)
    {
      long result;
      OS_SEMAPHORE_TYPE *array, just_two_array[2], break_sema;
      int count, rcount, *rps;

      if (((win_extended_fd_set *)rd)->no_sleep)
       return;

      scheme_collapse_win_fd(fds); /* merges */

      rcount = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->num_handles);
      count = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->combined_len);
      array = ((win_extended_fd_set *)fds)->combined_wait_array;
      rps = ((win_extended_fd_set *)fds)->repost_sema;

      /* add break semaphore: */
      if (!count) {
       array = just_two_array;
      }
      break_sema = scheme_break_semaphore;
      array[count++] = break_sema;

      /* Extensions may handle events.
        If the event queue is empty (as reported by GetQueueStatus),
        everything's ok.

        Otherwise, we have trouble sleeping until an event is ready. We
        sometimes leave events on th queue because, say, an eventspace is
        not ready. The problem is that MsgWait... only unblocks when a new
        event appears. Since extensions may check the queue using a sequence of
        PeekMessages, it's possible that an event is added during the
        middle of the sequence, but doesn't get handled.

        To avoid this problem, we don't actually sleep indefinitely if an event
        is pending. Instead, we slep 10 ms, then 20 ms, etc. This exponential 
        backoff ensures that we eventually handle a pending event, but we don't 
        spin and eat CPU cycles. The back-off is reset whenever a thread makes
        progress. */


      if (SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask)
         && GetQueueStatus(SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask))) {
       if (!made_progress) {
         /* Ok, we've gone around at least once. */
         if (max_sleep_time < 0x20000000)
           max_sleep_time *= 2;
       } else {
         /* Starting back-off mode */
         made_progress = 0;
         max_sleep_time = 5;
       }
      } else {
       /* Disable back-off mode */
       made_progress = 1;
       max_sleep_time = 0;
      }

      /* Wait for HANDLE-based input: */
      {
       DWORD msec;
       if (v) {
         if (v > 100000)
           msec = 100000000;
         else
           msec = (DWORD)(v * 1000);
         if (max_sleep_time && (msec > max_sleep_time))
           msec = max_sleep_time;
       } else {
         if (max_sleep_time)
           msec = max_sleep_time;
         else
           msec = INFINITE;
       }

       result = MsgWaitForMultipleObjects(count, array, FALSE, msec,
                                      SCHEME_INT_VAL(((win_extended_fd_set *)fds)->wait_event_mask));
      }
      clean_up_wait(result, array, rps, rcount);
      scheme_collapse_win_fd(fds); /* cleans up */

      return;
    }
#endif

#ifdef USE_WINSOCK_TCP
    /* Stupid Windows: give select() empty fd_sets and it ignores the timeout. */
    if (!rd->fd_count && !wr->fd_count && !ex->fd_count) {
      if (v)
       Sleep((DWORD)(v * 1000));
      return;
    }
#endif

    /******* End Windows stuff *******/

#if defined(FILES_HAVE_FDS)
    /* Watch for external events, too: */
    if (external_event_fd) {
      MZ_FD_SET(external_event_fd, rd);
      if (external_event_fd >= actual_limit)
        actual_limit = external_event_fd + 1;
    }
#endif

    select(actual_limit, rd, wr, ex, v ? &time : NULL);

#endif
  }

#if defined(FILES_HAVE_FDS)
  /* Clear external event flag */
  if (external_event_fd) {
    char buf[10];
    read(external_event_fd, buf, 10);
  }
#endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING void do_count_lines ( Scheme_Port ip,
const char *  buffer,
long  offset,
long  got 
) [static]

Definition at line 1542 of file port.c.

{
  long i;
  int c, degot = 0;

  mzAssert(ip->lineNumber >= 0);
  mzAssert(ip->column >= 0);
  mzAssert(ip->position >= 0);

  ip->oldColumn = ip->column; /* works for a single-char read, like `read' */

  ip->readpos += got; /* add for CR LF below */

  /* Find start of last line: */
  for (i = got, c = 0; i--; c++) {
    if (buffer[offset + i] == '\n' || buffer[offset + i] == '\r') {
      break;
    }
  }

  /* Count UTF-8-decoded chars, up to last line: */
  if (i >= 0) {
    int state = ip->utf8state;
    int n;
    degot += state_len(state);
    n = scheme_utf8_decode_count((const unsigned char *)buffer, offset, offset + i + 1, &state, 0, 0xFFFD);
    degot += (i + 1 - n);
    ip->utf8state = 0; /* assert: state == 0, because we ended with a newline */
  }
       
  if (i >= 0) {
    int n = 0;
    ip->charsSinceNewline = c + 1;
    i++;
    /* Continue walking, back over the previous lines, to find
       out how many there were: */
    while (i--) {
      if (buffer[offset + i] == '\n') {
       if (!(i && (buffer[offset + i - 1] == '\r'))
           && !(!i && ip->was_cr)) {
         n++;
       } else
         degot++; /* adjust positions for CRLF -> LF conversion */
      } else if (buffer[offset + i] == '\r') {
       n++;
      }
    }
                
    mzAssert(n > 0);
    ip->lineNumber += n;
    ip->was_cr = (buffer[offset + got - 1] == '\r');
    /* Now reset column to 0: */
    ip->column = 0;
  } else {
    ip->charsSinceNewline += c;
  }

  /* Do the last line to get the column count right and to
     further adjust positions for UTF-8 decoding: */
  {
    int col = ip->column, n;
    int prev_i = got - c;
    int state = ip->utf8state;
    n = state_len(state);
    degot += n;
    col -= n;
    for (i = prev_i; i < got; i++) {
      if (buffer[offset + i] == '\t') {
       n = scheme_utf8_decode_count((const unsigned char *)buffer, offset + prev_i, offset + i, &state, 0, 0xFFFD);
       degot += ((i - prev_i) - n);
       col += n;
       col = col - (col & 0x7) + 8;
       prev_i = i + 1;
      }
    }
    if (prev_i < i) {
      n = scheme_utf8_decode_count((const unsigned char *)buffer, offset + prev_i, offset + i, &state, 1, 0xFFFD);
      n += state_len(state);
      col += n;
      degot += ((i - prev_i) - n);
    }
    ip->column = col;
    ip->utf8state = state;
  }

  ip->readpos -= degot;

  mzAssert(ip->lineNumber >= 0);
  mzAssert(ip->column >= 0);
  mzAssert(ip->position >= 0);
}

Here is the caller graph for this function:

static Scheme_Object* do_get_ready_special ( Scheme_Object port,
Scheme_Object stxsrc,
int  peek,
Scheme_Hash_Table **  ht 
) [static]

Definition at line 3128 of file port.c.

{
  long line, col, pos;

  if (!stxsrc) {
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(port);
    stxsrc = ip->name;
  }

  /* Don't use scheme_tell_all(), because we always want the
     MzScheme-computed values here. */
  line = scheme_tell_line(port);
  col = scheme_tell_column(port);
  pos = scheme_tell(port);

  return scheme_get_special(port, stxsrc, line, col, pos, peek, ht);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int do_peekc_skip ( Scheme_Object port,
Scheme_Object skip,
int  only_avail,
int unavail 
) [static]

Definition at line 2788 of file port.c.

{
  char s[MAX_UTF8_CHAR_BYTES];
  unsigned int r[1];
  int v, delta = 0;
  Scheme_Object *skip2;

  if (unavail)
    *unavail = 0;

  while(1) {
    if (delta) {
      if (!skip)
       skip = scheme_make_integer(0);
      skip2 = quick_plus(skip, delta);
    } else
      skip2 = skip;

    v = scheme_get_byte_string_unless("peek-char", port,
                                  s, delta, 1,
                                  only_avail,
                                  1, skip2,
                                  NULL);

    if (!v) {
      if (unavail)
        *unavail = 1;
      return 0;
    }

    if ((v == EOF) || (v == SCHEME_SPECIAL)) {
      if (!delta)
       return v;
      else {
       /* This counts as a decoding error, so return 0xFFFD */
       return 0xFFFD;
      }
    } else {
      v = scheme_utf8_decode_prefix((const unsigned char *)s, delta + 1, r, 0);
      if (v > 0)
       return r[0];
      else if (v == -2) {
       /* -2 => decoding error */
       return 0xFFFD;
      } else if (v == -1) {
       /* In middle of sequence - keep getting bytes. */
       delta++;
      }
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void elect_new_main ( Scheme_Input_Port ip) [static]

Definition at line 2067 of file port.c.

Here is the caller graph for this function:

static int evt_input_port_p ( Scheme_Object p) [static]

Definition at line 1349 of file port.c.

{
  return 1;
}

Here is the caller graph for this function:

static int evt_output_port_p ( Scheme_Object p) [static]

Definition at line 1403 of file port.c.

{
  return 1;
}

Here is the caller graph for this function:

static int file_buffer_mode ( Scheme_Port p,
int  mode 
) [static]

Definition at line 4741 of file port.c.

{
  FILE *f;
  int bad;

  if (mode < 0)
    return -1; /* unknown mode */

  if (SCHEME_INPORTP((Scheme_Object *)p)) {
    Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
    f = ((Scheme_Output_File *)ip->port_data)->f;
  } else {
    Scheme_Output_Port *op = (Scheme_Output_Port *)p;
    f = ((Scheme_Output_File *)op->port_data)->f;
  }
  
  if (mode == MZ_FLUSH_NEVER)
    bad = setvbuf(f, NULL, _IOFBF, 0);
  else if (mode == MZ_FLUSH_BY_LINE)
    bad = setvbuf(f, NULL, _IOLBF, 0);
  else
    bad = setvbuf(f, NULL, _IONBF, 0);
  
  if (bad) {
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                   "file-stream-buffer-mode: error changing buffering (%e)",
                   errno);
  }

  return mode;
}

Here is the caller graph for this function:

static int file_byte_ready ( Scheme_Input_Port port) [static]

Definition at line 4689 of file port.c.

{
  return 1;
}

Here is the caller graph for this function:

static void file_close_input ( Scheme_Input_Port port) [static]

Definition at line 4725 of file port.c.

{
  Scheme_Input_File *fip;

  fip = (Scheme_Input_File *)port->port_data;

  fclose(fip->f);
  --scheme_file_open_count;
}

Here is the caller graph for this function:

static void file_close_output ( Scheme_Output_Port port) [static]

Definition at line 5782 of file port.c.

{
  Scheme_Output_File *fop = (Scheme_Output_File *)port->port_data;
  FILE *fp = fop->f;

  fclose(fp);
  --scheme_file_open_count;
}

Here is the caller graph for this function:

static void file_flush ( Scheme_Output_Port port) [static]

Definition at line 5735 of file port.c.

{
  if (fflush(((Scheme_Output_File *)port->port_data)->f)) {
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                   "error flushing file port (%e)",
                   errno);
  }
}

Here is the caller graph for this function:

static long file_get_string ( Scheme_Input_Port port,
char *  buffer,
long  offset,
long  size,
int  nonblock,
Scheme_Object unless_evt 
) [static]

Definition at line 4694 of file port.c.

{
  FILE *fp;
  Scheme_Input_File *fip;
  int c;

  fip = (Scheme_Input_File *)port->port_data;
  fp = fip->f;

  c = fread(buffer XFORM_OK_PLUS offset, 1, size, fp);

  if (c <= 0) {
    if (!feof(fp)) {
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                     "error reading from file port %V (%e)",
                     port->name, errno);
      return 0;
    } else
      c = EOF;
#ifndef DONT_CLEAR_FILE_EOF
    clearerr(fp);
#endif
  }

  return c;
}

Here is the caller graph for this function:

static void file_need_wakeup ( Scheme_Input_Port port,
void fds 
) [static]

Definition at line 4736 of file port.c.

{
}

Here is the caller graph for this function:

static long file_write_string ( Scheme_Output_Port port,
const char *  str,
long  d,
long  llen,
int  rarely_block,
int  enable_break 
) [static]

Definition at line 5745 of file port.c.

{
  FILE *fp;
  long len = llen;

  fp = ((Scheme_Output_File *)port->port_data)->f;

  if (!len) {
    file_flush(port);
    return 0;
  }

  if (fwrite(str XFORM_OK_PLUS d, len, 1, fp) != 1) {
    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                   "error writing to file port (%e)",
                   errno);
    return 0;
  }

  if (rarely_block) {
    file_flush(port);
  } else {
    while (len--) {
      if (str[d] == '\n' || str[d] == '\r') {
       file_flush(port);
       break;
      }
      d++;
    }
  }

  return llen;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void filename_exn ( char *  name,
char *  msg,
char *  filename,
int  err 
) [static]

Definition at line 3775 of file port.c.

{
  char *dir, *drive;
  int len;
  char *pre, *rel, *post;

  len = strlen(filename);

  if (scheme_is_relative_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
    dir = scheme_os_getcwd(NULL, 0, NULL, 1);
    drive = NULL;
  } else if (scheme_is_complete_path(filename, len, SCHEME_PLATFORM_PATH_KIND)) {
    dir = NULL;
    drive = NULL;
  } else {
    dir = NULL;
    drive = scheme_getdrive();
  }

  pre = dir ? " in directory \"" : (drive ? " on drive " : "");
  rel = dir ? dir : (drive ? drive : "");
  post = dir ? "\"" : "";

  scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                 "%s: %s: \"%q\"%s%q%s (" FILENAME_EXN_E ")",
                 name, msg, filename,
                 pre, rel, post,
                 err);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void force_close_input_port ( Scheme_Object port) [static]

Definition at line 3407 of file port.c.

Here is the caller graph for this function:

static void force_close_output_port ( Scheme_Object port) [static]

Definition at line 3554 of file port.c.

Here is the caller graph for this function:

static MZ_INLINE long get_one_byte ( const char *  who,
Scheme_Object port,
char *  buffer,
long  offset,
int  only_avail 
) [static]

Definition at line 2561 of file port.c.

{
  Scheme_Input_Port *ip;
  long gc;
  int special_ok = special_is_ok;
  Scheme_Get_String_Fun gs;

  special_is_ok = 0;

  ip = scheme_input_port_record(port);

  CHECK_PORT_CLOSED(who, "input", port, ip->closed);

  if (ip->input_lock)
    scheme_wait_input_allowed(ip, only_avail);

  if (ip->ungotten_count) {
    buffer[offset] = ip->ungotten[--ip->ungotten_count];
    gc = 1;
  } else if (ip->peeked_read && pipe_char_count(ip->peeked_read)) {
    int ch;
    ch = scheme_get_byte(ip->peeked_read);
    buffer[offset] = ch;
    gc = 1;
  } else if (ip->ungotten_special) {
    if (ip->progress_evt)
      post_progress(ip);
    if (!special_ok) {
      ip->ungotten_special = NULL;
      scheme_bad_time_for_special(who, port);
      return 0;
    }
    ip->special = ip->ungotten_special;
    ip->ungotten_special = NULL;
    if (ip->p.position >= 0)
      ip->p.position++;
    if (ip->p.count_lines)
      inc_pos((Scheme_Port *)ip, 1);
    return SCHEME_SPECIAL;
  } else {
    if (ip->pending_eof > 1) {
      ip->pending_eof = 1;
      return EOF;
    } else {
      /* Call port's get function. */
      gs = ip->get_string_fun;

      gc = gs(ip, buffer, offset, 1, 0, NULL);
       
      if (ip->progress_evt && (gc > 0))
       post_progress(ip);

      if (gc < 1) {
       if (gc == SCHEME_SPECIAL) {
         if (special_ok) {
           if (ip->p.position >= 0)
             ip->p.position++;
           if (ip->p.count_lines)
             inc_pos((Scheme_Port *)ip, 1);
           return SCHEME_SPECIAL;
         } else {
           scheme_bad_time_for_special(who, port);
           return 0;
         }
       } else if (gc == EOF) {
         ip->p.utf8state = 0;
         return EOF;
       } else {
         /* didn't get anything the first try, so use slow path: */
         special_is_ok = special_ok;
         return scheme_get_byte_string_unless(who, port,
                                          buffer, offset, 1,
                                          0, 0, NULL, NULL);
       }
      }
    }
  }

  /****************************************************/
  /* Adjust position information for chars got so far */
  /****************************************************/
  
  if (ip->p.position >= 0)
    ip->p.position++;
  if (ip->p.count_lines)
    do_count_lines((Scheme_Port *)ip, buffer, offset, 1);
  
  return gc;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING void inc_pos ( Scheme_Port ip,
int  a 
) [static]

Definition at line 1512 of file port.c.

{
  ip->column += a;
  ip->readpos += a;
  ip->charsSinceNewline += a;
  ip->utf8state = 0;
}

Here is the caller graph for this function:

static void init_port_locations ( Scheme_Port ip) [static]

Definition at line 1267 of file port.c.

{
  int cl;

  ip->position = 0;
  ip->readpos = 0; /* like position, but post UTF-8 decoding, collapses CRLF, etc. */
  ip->lineNumber = 1;
  ip->oldColumn = 0;
  ip->column = 0;
  ip->charsSinceNewline = 1;
  cl = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_PORT_COUNT_LINES));
  ip->count_lines = cl;
}

Here is the caller graph for this function:

static int is_fd_terminal ( int  fd) [static]

Definition at line 3707 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  if (GetFileType((HANDLE)fd) == FILE_TYPE_CHAR) {
    DWORD mode;
    if (GetConsoleMode((HANDLE)fd, &mode))
      return 1;
    else
      return 0;
  } else
    return 0;
#else
  return isatty(fd);
#endif
}

Here is the caller graph for this function:

Scheme_Object* make_read_write_evt ( Scheme_Type  type,
Scheme_Object port,
Scheme_Object skip,
char *  str,
long  start,
long  size 
)

Definition at line 2873 of file port.c.

{
  Scheme_Read_Write_Evt *rww;

  rww = MALLOC_ONE_TAGGED(Scheme_Read_Write_Evt);
  rww->so.type = type;
  rww->port = port;
  rww->v = skip;
  rww->str = str;
  rww->start = start;
  rww->size = size;

  return (Scheme_Object *)rww;
}

Here is the caller graph for this function:

static int* malloc_refcount ( ) [static]

Definition at line 235 of file port.c.

{
  return (int *)scheme_malloc_atomic(sizeof(int));
}
static void null_close_out ( Scheme_Output_Port port) [static]

Definition at line 6914 of file port.c.

{
}

Here is the caller graph for this function:

static long null_write_bytes ( Scheme_Output_Port port,
const char *  str,
long  d,
long  len,
int  rarely_block,
int  enable_break 
) [static]

Definition at line 6906 of file port.c.

{
  return len;
}

Here is the caller graph for this function:

static Scheme_Object* null_write_evt ( Scheme_Output_Port op,
const char *  str,
long  offset,
long  size 
) [static]

Definition at line 6919 of file port.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static int null_write_special ( Scheme_Output_Port op,
Scheme_Object v,
int  nonblock 
) [static]

Definition at line 6937 of file port.c.

{
  return 1;
}

Here is the caller graph for this function:

Definition at line 6928 of file port.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static void output_need_wakeup ( Scheme_Object port,
void fds 
) [static]

Definition at line 1436 of file port.c.

{
  Scheme_Output_Port *op;

  /* If this is a user output port and its evt needs a wakeup, we
     shouldn't get here. The target use above will take care of it. */

  op = scheme_output_port_record(port);
  if (op->need_wakeup_fun) {
    Scheme_Need_Wakeup_Output_Fun f;
    f = op->need_wakeup_fun;
    f(op, fds);
  }
}

Here is the caller graph for this function:

static int output_ready ( Scheme_Object port,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 1408 of file port.c.

{
  Scheme_Output_Port *op;

  op = scheme_output_port_record(port);

  if (op->closed)
    return 1;

  if (SAME_OBJ(scheme_user_output_port_type, op->sub_type)) {
    /* We can't call the normal ready because that might run Scheme
       code, and this function is called by the scheduler when
       false_pos_ok is true. So, in that case, we asume that if the
       port's evt is ready, then the port is ready. (After
       all, false positives are ok in that mode.) Even when the
       scheduler isn't requesting the status, we need sinfo. */
    return scheme_user_port_write_probably_ready(op, sinfo);
  }

  if (op->ready_fun) {
    Scheme_Out_Ready_Fun rf;
    rf = op->ready_fun;
    return rf(op);
  }

  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static XFORM_NONGCING int pipe_char_count ( Scheme_Object p) [static]

Definition at line 1482 of file port.c.

{
  if (p) {
    Scheme_Pipe *pipe;
    Scheme_Input_Port *ip;

    ip = (Scheme_Input_Port *)p;
    pipe = (Scheme_Pipe *)ip->port_data;

    if (pipe->bufstart <= pipe->bufend)
      return pipe->bufend - pipe->bufstart;
    else
      return (pipe->buflen - pipe->bufstart) + pipe->bufend;
  } else
    return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void post_progress ( Scheme_Input_Port ip) [static]

Definition at line 1506 of file port.c.

Here is the caller graph for this function:

static int progress_evt_ready ( Scheme_Object rww,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 2401 of file port.c.

{
  scheme_set_sync_target(sinfo, SCHEME_PTR2_VAL(evt), evt, NULL, 0, 1, NULL);
  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* quick_plus ( Scheme_Object s,
long  v 
) [static]

Definition at line 1520 of file port.c.

{
  if (SCHEME_INTP(s)) {
    int k;
    k = SCHEME_INT_VAL(s);
    if ((k < 0x1000000) && (v < 0x1000000)) {
      k += v;
      return scheme_make_integer(k);
    }
  }

  /* Generic addition, but we might not be in a position to allow
     thread swaps */
  scheme_start_atomic();
  s = scheme_bin_plus(s, scheme_make_integer(v));
  scheme_end_atomic_no_swap();

  return s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void redirect_close_out ( Scheme_Output_Port port) [static]

Definition at line 7022 of file port.c.

{
}

Here is the caller graph for this function:

static long redirect_write_bytes ( Scheme_Output_Port op,
const char *  str,
long  d,
long  len,
int  rarely_block,
int  enable_break 
) [static]

Definition at line 6973 of file port.c.

{
  /* arbitrary nesting means we can overflow the stack */
#ifdef DO_STACK_CHECK
# include "mzstkchk.h"
  {
    Scheme_Thread *p = scheme_current_thread;
    Scheme_Object *n;

    p->ku.k.p1 = (void *)op;
    p->ku.k.p2 = (void *)str;
    p->ku.k.i1 = d;
    p->ku.k.i2 = len;
    p->ku.k.i3 = rarely_block;
    p->ku.k.i4 = enable_break;

    n = scheme_handle_stack_overflow(redirect_write_bytes_k);
    return SCHEME_INT_VAL(n);
  }
#endif

  return scheme_put_byte_string("redirect-output",
                            (Scheme_Object *)op->port_data,
                            str, d, len,
                            rarely_block);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * redirect_write_bytes_k ( void  ) [static]

Definition at line 7002 of file port.c.

{
  Scheme_Thread *p = scheme_current_thread;
  Scheme_Output_Port *op = (Scheme_Output_Port *)p->ku.k.p1;
  const char *str = (const char *)p->ku.k.p2;
  long d = p->ku.k.i1;
  long len = p->ku.k.i2;
  int rarely_block = p->ku.k.i3;
  int enable_break = p->ku.k.i4;
  long n;

  p->ku.k.p1 = NULL;
  p->ku.k.p2 = NULL;

  n = redirect_write_bytes(op, str, d, len, rarely_block, enable_break);

  return scheme_make_integer(n);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* redirect_write_evt ( Scheme_Output_Port op,
const char *  str,
long  offset,
long  size 
) [static]

Definition at line 7027 of file port.c.

{
  return scheme_make_write_evt("redirect-write-evt", 
                            (Scheme_Object *)op->port_data,
                            NULL, (char *)str, offset, size);
}

Here is the caller graph for this function:

static int redirect_write_special ( Scheme_Output_Port op,
Scheme_Object special,
int  nonblock 
) [static]

Definition at line 7043 of file port.c.

{
  Scheme_Object *v, *a[2];

  a[0] = (Scheme_Object *)op->port_data;
  a[1] = special;

  if (nonblock)
    v = scheme_write_special(2, a);
  else
    v = scheme_write_special(2, a);
  
  return SCHEME_TRUEP(v);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* redirect_write_special_evt ( Scheme_Output_Port op,
Scheme_Object special 
) [static]

Definition at line 7035 of file port.c.

{
  return scheme_make_write_evt("redirect-write-evt", 
                            (Scheme_Object *)op->port_data,
                            special, NULL, 0, 0);
}

Here is the caller graph for this function:

static void register_port_wait ( ) [static]
static void register_subprocess_wait ( ) [static]

Definition at line 7168 of file port.c.

{
#if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
  scheme_add_evt(scheme_subprocess_type, subp_done,
                subp_needs_wakeup, NULL, 0);
#endif
}

Here is the caller graph for this function:

static void release_input_lock ( Scheme_Input_Port ip) [static]

Definition at line 2057 of file port.c.

Here is the caller graph for this function:

static void release_input_lock_and_elect_new_main ( void _ip) [static]

Definition at line 2076 of file port.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static void remove_extra ( void ip_v) [static]

Definition at line 2092 of file port.c.

{
  Scheme_Input_Port *ip;
  Scheme_Object *v = SCHEME_CDR(ip_v), *ll, *prev;

  ip = scheme_input_port_record(SCHEME_CAR(ip_v));

  prev = NULL;
  for (ll = ip->input_extras; ll; prev = ll, ll = SCHEME_CDR(ll)) {
    if (SAME_OBJ(ll, SCHEME_CDR(v))) {
      if (prev)
       SCHEME_CDR(prev) = SCHEME_CDR(ll);
      else
       ip->input_extras = SCHEME_CDR(ll);
      SCHEME_CDR(ll) = NULL;
      break;
    }
  }

  /* Tell the main commit thread (if any) to reset */
  if (ip->input_giveup)
    scheme_post_sema_all(ip->input_giveup);
}

Here is the caller graph for this function:

static Scheme_Object* return_data ( void data,
int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 2176 of file port.c.

{
  return (Scheme_Object *)data;
}

Here is the caller graph for this function:

static int rw_evt_ready ( Scheme_Object rww,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 2890 of file port.c.

{
  Scheme_Read_Write_Evt *rww = (Scheme_Read_Write_Evt *)_rww;
  long v;

  if (sinfo->false_positive_ok) {
    /* Causes the thread to swap in, which we need in case there's an
       exception: */
    sinfo->potentially_false_positive = 1;
    return 1;
  }
  
  if (rww->v) {
    Scheme_Output_Port *op;
    Scheme_Write_Special_Fun ws;

    op = scheme_output_port_record(rww->port);
    ws = op->write_special_fun;

    v = ws(op, rww->v, 1);
    if (v) {
      scheme_set_sync_target(sinfo, scheme_true, NULL, NULL, 0, 0, NULL);
      return 1;
    } else    
      return 0;
  } else {
    v = scheme_put_byte_string("write-evt", rww->port,
                            rww->str, rww->start, rww->size,
                            2);
    if (v < 1)
      return 0;
    else if (!v && rww->size)
      return 0;
    else {
      scheme_set_sync_target(sinfo, scheme_make_integer(v), NULL, NULL, 0, 0, NULL);
      return 1;
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void rw_evt_wakeup ( Scheme_Object rww,
void fds 
) [static]

Definition at line 2930 of file port.c.

{
  Scheme_Read_Write_Evt *rww = (Scheme_Read_Write_Evt *)_rww;

  if (rww->port) {
    if (rww->so.type == scheme_write_evt_type)
      output_need_wakeup(rww->port, fds);
    else
      scheme_need_wakeup(rww->port, fds);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * sch_shell_execute ( int  c,
Scheme_Object args[] 
) [static]

Definition at line 7913 of file port.c.

{
  int show;
  char *dir;
#ifdef WINDOWS_PROCESSES
# define mzseSHOW(x) x
#else
# define mzseSHOW(x) 1
#endif

  if (!SCHEME_FALSEP(argv[0]) && !SCHEME_CHAR_STRINGP(argv[0]))
    scheme_wrong_type("shell-execute", "string or #f", 0, c, argv);
  if (!SCHEME_CHAR_STRINGP(argv[1]))
    scheme_wrong_type("shell-execute", "string", 1, c, argv);
  if (!SCHEME_CHAR_STRINGP(argv[2]))
    scheme_wrong_type("shell-execute", "string", 2, c, argv);
  if (!SCHEME_PATH_STRINGP(argv[3]))
    scheme_wrong_type("shell-execute", SCHEME_PATH_STRING_STR, 3, c, argv);
  {
    int show_set = 0;
    show = 0;
# define mzseCMP(id, str)                        \
    if (SAME_OBJ(scheme_intern_symbol(str), argv[4])   \
        || SAME_OBJ(scheme_intern_symbol(# id), argv[4])) { \
      show = mzseSHOW(id); show_set = 1; }
    mzseCMP(SW_HIDE, "sw_hide");
    mzseCMP(SW_MAXIMIZE, "sw_maximize");
    mzseCMP(SW_MINIMIZE, "sw_minimize");
    mzseCMP(SW_RESTORE, "sw_restore");
    mzseCMP(SW_SHOW, "sw_show");
    mzseCMP(SW_SHOWDEFAULT, "sw_showdefault");
    mzseCMP(SW_SHOWMAXIMIZED, "sw_showmaximized");
    mzseCMP(SW_SHOWMINIMIZED, "sw_showminimized");
    mzseCMP(SW_SHOWMINNOACTIVE, "sw_showminnoactive");
    mzseCMP(SW_SHOWNA, "sw_showna");
    mzseCMP(SW_SHOWNOACTIVATE, "sw_shownoactivate");
    mzseCMP(SW_SHOWNORMAL, "sw_shownormal");

    if (!show_set)
      scheme_wrong_type("shell-execute", "show-mode symbol", 4, c, argv);
  }

  dir = scheme_expand_string_filename(argv[3],
                                  "shell-execute", NULL,
                                  SCHEME_GUARD_FILE_EXISTS);
#ifdef WINDOWS_PROCESSES
  {
    SHELLEXECUTEINFOW se;
    int nplen;
    Scheme_Object *sv, *sf, *sp;

    nplen = strlen(dir);
    dir = scheme_normal_path_seps(dir, &nplen, 0);

    if (SCHEME_FALSEP(argv[0]))
      sv = scheme_false;
    else
      sv = scheme_char_string_to_byte_string(argv[0]);
    sf = scheme_char_string_to_byte_string(argv[1]);
    sp = scheme_char_string_to_byte_string(argv[2]);

    memset(&se, 0, sizeof(se));
    se.fMask = SEE_MASK_NOCLOSEPROCESS | SEE_MASK_FLAG_DDEWAIT;
    se.cbSize = sizeof(se);
    if (SCHEME_FALSEP(sv))
      se.lpVerb = NULL;
    else {
      se.lpVerb = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sv));
    }
    se.lpFile = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sf));
    se.lpParameters = WIDE_PATH_COPY(SCHEME_BYTE_STR_VAL(sp));
    se.lpDirectory = WIDE_PATH_COPY(dir);
    se.nShow = show;
    se.hwnd = NULL;

    /* Used to use ShellExecuteEx(&se) here. Not sure why it doesn't work,
       and the problem was intermittent (e.g., worked for opening a URL
       with IE as the default browser, but failed with Netscape). */
    if (ShellExecuteW(se.hwnd, se.lpVerb, se.lpFile, se.lpParameters, se.lpDirectory, se.nShow)) {
      if (se.hProcess) {
       Scheme_Subprocess *subproc;

       subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);

       subproc->so.type = scheme_subprocess_type;
       subproc->handle = (void *)se.hProcess;
       subproc->pid = 0;
       scheme_add_finalizer(subproc, close_subprocess_handle, NULL);

       return (Scheme_Object *)subproc;
      } else
       return scheme_false;
    } else {
      scheme_signal_error("shell-execute: execute failed for: %V (%E)",
                       argv[1],
                       GetLastError());
      return NULL;
    }
  }
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                 "shell-execute: not supported on this platform");
  return NULL;
#endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

void scheme_add_fd_eventmask ( void fds,
int  mask 
)

Definition at line 922 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fds;
  efd->wait_event_mask = scheme_make_integer(mask | SCHEME_INT_VAL(efd->wait_event_mask));
#endif
}
void scheme_add_fd_handle ( void h,
void fds,
int  repost 
)

Definition at line 888 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fds;
  OS_SEMAPHORE_TYPE *hs;
  int i, *rps;

  i = SCHEME_INT_VAL(efd->num_handles);
  hs = MALLOC_N_ATOMIC(OS_SEMAPHORE_TYPE, i + 1);
  rps = MALLOC_N_ATOMIC(int, i + 1);
  hs[i] = (OS_SEMAPHORE_TYPE)h;
  rps[i] = repost;
  while (i--) {
    hs[i] = efd->handles[i];
    rps[i] = efd->repost_sema[i];
  }
  efd->num_handles = scheme_make_integer(1 + SCHEME_INT_VAL(efd->num_handles));
  efd->handles = hs;
  efd->repost_sema = rps;
  reset_wait_array(efd);
#else
  /* Do nothing. */
#endif
}

Definition at line 913 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fds;
  efd->no_sleep = scheme_true;
#else
#endif
}
void* scheme_alloc_fdset_array ( int  count,
int  permanent 
)

Definition at line 741 of file port.c.

{
#if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP) || defined(WIN32_FD_HANDLES)
  void *fdarray;
# if defined(WIN32_FD_HANDLES)
  if (count) {
    fdarray = scheme_malloc_allow_interior(count * sizeof(fdset_type));
    if (permanent)
      scheme_dont_gc_ptr(fdarray);
    
    scheme_init_fdset_array(fdarray, count);
  } else
    fdarray = NULL;
# else
  if (permanent)
    fdarray = scheme_malloc_eternal(count * sizeof(fdset_type));
  else
    fdarray = scheme_malloc_atomic(count * sizeof(fdset_type));
# endif
  return fdarray;
#else
  return NULL;
#endif
}
void scheme_bad_time_for_special ( const char *  who,
Scheme_Object port 
)

Definition at line 3162 of file port.c.

{
  scheme_arg_mismatch(who, "non-character in an unsupported context, from port: ", port);
}

Here is the caller graph for this function:

Definition at line 3032 of file port.c.

{
  Scheme_Input_Port *ip;
  int retval;

  ip = scheme_input_port_record(port);

  CHECK_PORT_CLOSED("char-ready?", "input", port, ip->closed);

  if (ip->ungotten_count || ip->ungotten_special
      || (ip->pending_eof > 1)
      || pipe_char_count(ip->peeked_read))
    retval = 1;
  else {
    Scheme_In_Ready_Fun f = ip->byte_ready_fun;
    retval = f(ip);
  }

  return retval;
}

Here is the call graph for this function:

Definition at line 1451 of file port.c.

{
  Scheme_Input_Port *ip;

  ip = scheme_input_port_record(p);

  if (ip->closed)
    return 1;

  if (SAME_OBJ(scheme_user_input_port_type, ip->sub_type)) {
    /* We can't call the normal byte_ready because that runs Scheme
       code, and this function is called by the scheduler when
       false_pos_ok is true. So, in that case, we asume that if the
       port's evt is ready, then the port is ready. (After
       all, false positives are ok in that mode.) Even when the
       scheduler isn't requesting the status, we need sinfo. */
    return scheme_user_port_byte_probably_ready(ip, sinfo);
  } else
    return scheme_byte_ready(p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 3054 of file port.c.

{
  int unavail;

  if (!scheme_byte_ready(port))
    return 0;

  do_peekc_skip(port, scheme_make_integer(0), 2, &unavail);
  
  return !unavail;
}

Here is the call graph for this function:

Definition at line 3378 of file port.c.

{
  Scheme_Input_Port *ip;

  ip = scheme_input_port_record(port);

  if (!ip->closed) {
    if (ip->close_fun) {
      Scheme_Close_Input_Fun f = ip->close_fun;
      f(ip);
    }

    if (ip->progress_evt) {
      scheme_post_sema_all(ip->progress_evt);
      ip->progress_evt = NULL;
    }

    if (ip->mref) {
      scheme_remove_managed(ip->mref, (Scheme_Object *)ip);
      ip->mref = NULL;
    }

    ip->closed = 1;
    ip->ungotten_count = 0;
    ip->ungotten_special = NULL;
  }
}

Definition at line 3528 of file port.c.

{
  Scheme_Output_Port *op;

  op = scheme_output_port_record(port);

  if (!op->closed) {
    /* call close function first; it might raise an exception */
    if (op->close_fun) {
      Scheme_Close_Output_Fun f = op->close_fun;
      f(op);
    }

    /* NOTE: Allow the possibility that some other thread finishes the
       close while f blocks. */

    if (op->mref) {
      scheme_remove_managed(op->mref, (Scheme_Object *)op);
      op->mref = NULL;
    }
    
    op->closed = 1;
  }
}

Definition at line 3414 of file port.c.

Definition at line 959 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *rfd, *wfd, *efd;
  HANDLE *wa, e;
  int i, p = 0, mask, j;
  SOCKET s;

  rfd = (win_extended_fd_set *)fds;
  wfd = (win_extended_fd_set *)scheme_get_fdset(fds, 1);
  efd = (win_extended_fd_set *)scheme_get_fdset(fds, 2);

  if (rfd->combined_wait_array) {
    /* clean up */
    for (i = SCHEME_INT_VAL(rfd->added); i--; ) {
      if (rfd->sockets[i] != INVALID_SOCKET)
       WSAEventSelect(rfd->sockets[i], NULL, 0);
    }
    for (i = SCHEME_INT_VAL(wfd->added); i--; ) {
      if (wfd->sockets[i] != INVALID_SOCKET)
       WSAEventSelect(wfd->sockets[i], NULL, 0);
    }
    for (i = SCHEME_INT_VAL(efd->added); i--; ) {
      if (efd->sockets[i] != INVALID_SOCKET)
       WSAEventSelect(efd->sockets[i], NULL, 0);
    }
    p = SCHEME_INT_VAL(rfd->num_handles);
    for (i = SCHEME_INT_VAL(rfd->combined_len); i-- > p; ) {
      WSACloseEvent(rfd->combined_wait_array[i]);
    }
    rfd->combined_wait_array = NULL;
  } else {
    /* merge */
    if (SCHEME_INT_VAL(rfd->alloc) < SCHEME_INT_VAL(wfd->alloc)) {
      if (SCHEME_INT_VAL(wfd->alloc) < SCHEME_INT_VAL(efd->alloc))
       wa = efd->wait_array;
      else
       wa = wfd->wait_array;
    } else {
      if (SCHEME_INT_VAL(rfd->alloc) < SCHEME_INT_VAL(efd->alloc))
       wa = efd->wait_array;
      else
       wa = rfd->wait_array;
    }

    rfd->combined_wait_array = wa;

    p = SCHEME_INT_VAL(rfd->num_handles);
    for (i = 0; i < p; i++) {
      wa[i] = rfd->handles[i];
    }
  
    for (i = SCHEME_INT_VAL(rfd->added); i--; ) {
      s = rfd->sockets[i];
      if (s != INVALID_SOCKET) {
       mask = FD_READ | FD_ACCEPT | FD_CLOSE;
       
       for (j = SCHEME_INT_VAL(wfd->added); j--; ) {
         if (wfd->sockets[j] == s) {
           mask |= FD_WRITE;
           break;
         }
       }

       for (j = SCHEME_INT_VAL(efd->added); j--; ) {
         if (efd->sockets[j] == s) {
           mask |= FD_OOB;
           break;
         }
       }

       e = WSACreateEvent();
       wa[p++] = e;
       WSAEventSelect_plus_check(s, e, mask);
      }
    }

    for (i = SCHEME_INT_VAL(wfd->added); i--; ) {
      s = wfd->sockets[i];
      if (s != INVALID_SOCKET) {
       mask = FD_WRITE | FD_CONNECT | FD_CLOSE;
       
       for (j = SCHEME_INT_VAL(rfd->added); j--; ) {
         if (rfd->sockets[j] == s) {
           mask = 0;
           break;
         }
       }

       if (mask) {
         for (j = SCHEME_INT_VAL(efd->added); j--; ) {
           if (efd->sockets[j] == s) {
             mask |= FD_OOB;
             break;
           }
         }
         
         e = WSACreateEvent();
         wa[p++] = e;
         WSAEventSelect_plus_check(s, e, mask);
       }
      }
    }

    for (i = SCHEME_INT_VAL(efd->added); i--; ) {
      s = efd->sockets[i];
      if (s != INVALID_SOCKET) {
       mask = FD_OOB | FD_CLOSE;
       
       for (j = SCHEME_INT_VAL(rfd->added); j--; ) {
         if (rfd->sockets[j] == s) {
           mask = 0;
           break;
         }
       }

       if (mask) {
         for (j = SCHEME_INT_VAL(wfd->added); j--; ) {
           if (wfd->sockets[j] == s) {
             mask = 0;
             break;
           }
         }
         
         if (mask) {
           e = WSACreateEvent();
           wa[p++] = e;
           WSAEventSelect_plus_check(s, e, mask);
         }
       }
      }
    }

    rfd->combined_len = scheme_make_integer(p);
  }
#endif
}

Definition at line 3362 of file port.c.

{
  Scheme_Port *ip;

  ip = scheme_port_record(port);

  if (!ip->count_lines) {
    ip->count_lines = 1;
    if (ip->count_lines_fun) {
      Scheme_Count_Lines_Fun cl = ip->count_lines_fun;
      cl(ip);
    }
  }
}
Scheme_Object* scheme_do_open_input_file ( char *  name,
int  offset,
int  argc,
Scheme_Object argv[],
int  internal 
)

Definition at line 3806 of file port.c.

{
#ifdef USE_FD_PORTS
  int fd;
  struct stat buf;
#else
# ifdef WINDOWS_FILE_HANDLES
  HANDLE fd;
# else
  FILE *fp;
# endif
#endif
  char *mode = "rb";
  char *filename;
  int regfile, i;
  int m_set = 0;
  Scheme_Object *result;

  if (!SCHEME_PATH_STRINGP(argv[0]))
    scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 0, argc, argv);

  for (i = 1 + offset; argc > i; i++) {
    if (!SCHEME_SYMBOLP(argv[i]))
      scheme_wrong_type(name, "symbol", i, argc, argv);

    if (SAME_OBJ(argv[i], text_symbol)) {
      mode = "rt";
      m_set++;
    } else if (SAME_OBJ(argv[i], binary_symbol)) {
      /* This is the default */
      m_set++;
    } else {
      char *astr;
      long alen;

      astr = scheme_make_args_string("other ", i, argc, argv, &alen);
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: bad mode: %s%t", name,
                     scheme_make_provided_string(argv[i], 1, NULL),
                     astr, alen);
    }

    if (m_set > 1) {
      char *astr;
      long alen;

      astr = scheme_make_args_string("", -1, argc, argv, &alen);
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: conflicting or redundant "
                     "file modes given%t", name,
                     astr, alen);
    }
  }

  filename = scheme_expand_string_filename(argv[0],
                                      name,
                                      NULL,
                                      (internal ? 0 : SCHEME_GUARD_FILE_READ));

  if (!internal)
    scheme_custodian_check_available(NULL, name, "file-stream");

#ifdef USE_FD_PORTS
  /* Note: assuming there's no difference between text and binary mode */
  do {
    fd = open(filename, O_RDONLY | MZ_NONBLOCKING | MZ_BINARY);
  } while ((fd == -1) && (errno == EINTR));

  if (fd == -1) {
    filename_exn(name, "cannot open input file", filename, errno);
    return NULL;
  } else {
    int ok;

    do {
      ok = fstat(fd, &buf);
    } while ((ok == -1) && (errno == EINTR));

    if (S_ISDIR(buf.st_mode)) {
      int cr;
      do {
       cr = close(fd);
      } while ((cr == -1) && (errno == EINTR));
      filename_exn(name, "cannot open directory as a file", filename, 0);
      return NULL;
    } else {
      regfile = S_ISREG(buf.st_mode);
      scheme_file_open_count++;
      result = make_fd_input_port(fd, scheme_make_path(filename), regfile, 0, NULL, internal);
    }
  }
#else
# ifdef WINDOWS_FILE_HANDLES
  fd = CreateFileW(WIDE_PATH(filename),
                 GENERIC_READ,
                 FILE_SHARE_READ | FILE_SHARE_WRITE,
                 NULL,
                 OPEN_EXISTING,
                 0,
                 NULL);

  if (fd == INVALID_HANDLE_VALUE) {
    filename_exn(name, "cannot open input file", filename, GetLastError());
    return NULL;
  } else
    regfile = (GetFileType(fd) == FILE_TYPE_DISK);

  if ((mode[1] == 't') && !regfile) {
    CloseHandle(fd);
    filename_exn(name, "cannot use text-mode on a non-file device", filename, 0);
    return NULL;
  }

  result = make_fd_input_port((int)fd, scheme_make_path(filename), regfile, mode[1] == 't', NULL, internal);
# else
  if (scheme_directory_exists(filename)) {
    filename_exn(name, "cannot open directory as a file", filename, 0);
    return NULL;
  }

  regfile = scheme_is_regular_file(filename);

  fp = fopen(filename, mode);
  if (!fp) {
    filename_exn(name, "cannot open input file", filename, errno);
    return NULL;
  }
  scheme_file_open_count++;

  result = scheme_make_named_file_input_port(fp, scheme_make_path(filename));
# endif
#endif

  return result;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Scheme_Object* scheme_do_open_output_file ( char *  name,
int  offset,
int  argc,
Scheme_Object argv[],
int  and_read 
)

Definition at line 3943 of file port.c.

{
#ifdef USE_FD_PORTS
  int fd;
  int flags, regfile;
  struct stat buf;
  int ok;
#else
# ifdef WINDOWS_FILE_HANDLES
  HANDLE fd;
  int hmode, regfile;
  BY_HANDLE_FILE_INFORMATION info;
# else
  FILE *fp;
# endif
#endif
  int e_set = 0, m_set = 0, i;
  int existsok = 0, must_exist = 0;
  char *filename;
  char mode[4];
  int typepos;

  mode[0] = 'w';
  mode[1] = 'b';
  mode[2] = 0;
  mode[3] = 0;
  typepos = 1;

  if (!SCHEME_PATH_STRINGP(argv[0]))
    scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 0, argc, argv);

  for (i = 1 + offset; argc > i; i++) {
    if (!SCHEME_SYMBOLP(argv[i]))
      scheme_wrong_type(name, "symbol", i, argc, argv);

    if (SAME_OBJ(argv[i], append_symbol)) {
      mode[0] = 'a';
      existsok = -1;
      e_set++;
    } else if (SAME_OBJ(argv[i], replace_symbol)) {
      existsok = 1;
      e_set++;
    } else if (SAME_OBJ(argv[i], truncate_symbol)) {
      existsok = -1;
      e_set++;
    } else if (SAME_OBJ(argv[i], must_truncate_symbol)) {
      existsok = -1;
      must_exist = 1;
      e_set++;
    } else if (SAME_OBJ(argv[i], truncate_replace_symbol)) {
      existsok = -2;
      e_set++;
    } else if (SAME_OBJ(argv[i], update_symbol)) {
      existsok = 2;
      must_exist = 1;
      if (typepos == 1) {
       mode[2] = mode[1];
       typepos = 2;
      }
      mode[0] = 'r';
      mode[1] = '+';
      e_set++;
    } else if (SAME_OBJ(argv[i], can_update_symbol)) {
      existsok = 3;
      if (typepos == 1) {
       mode[2] = mode[1];
       typepos = 2;
      }
      mode[0] = 'r';
      mode[1] = '+';
      e_set++;
    } else if (SAME_OBJ(argv[i], error_symbol)) {
      /* This is the default */
      e_set++;
    } else if (SAME_OBJ(argv[i], text_symbol)) {
      mode[typepos] = 't';
      m_set++;
    } else if (SAME_OBJ(argv[i], binary_symbol)) {
      /* This is the default */
      m_set++;
    } else {
      char *astr;
      long alen;

      astr = scheme_make_args_string("other ", i, argc, argv, &alen);
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: bad mode: %s%s", name,
                     scheme_make_provided_string(argv[i], 1, NULL),
                     astr, alen);
    }

    if (m_set > 1 || e_set > 1) {
      char *astr;
      long alen;

      astr = scheme_make_args_string("", -1, argc, argv, &alen);
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: conflicting or redundant "
                     "file modes given%t", name,
                     astr, alen);
    }
  }

  filename = scheme_expand_string_filename(argv[0],
                                      name, NULL,
                                      (SCHEME_GUARD_FILE_WRITE
                                       | ((existsok && ((existsok == 1) || (existsok == -2)))
                                          ? SCHEME_GUARD_FILE_DELETE
                                          : 0)
                                       /* append mode: */
                                       | ((mode[0] == 'a')
                                          ? SCHEME_GUARD_FILE_READ
                                          : 0)
                                       /* update mode: */
                                       | ((existsok > 1)
                                          ? SCHEME_GUARD_FILE_READ
                                          : 0)));

  scheme_custodian_check_available(NULL, name, "file-stream");

#ifdef USE_FD_PORTS
  /* Note: assuming there's no difference between text and binary mode */

  flags = (and_read ? O_RDWR : O_WRONLY) | (must_exist ? 0 : O_CREAT);

  if (mode[0] == 'a')
    flags |= O_APPEND;
  else if (existsok < 0)
    flags |= O_TRUNC;

  if ((existsok <= 1) && (existsok > -1))
    flags |= O_EXCL;

  do {
    fd = open(filename, flags | MZ_NONBLOCKING | MZ_BINARY, 0666);
  } while ((fd == -1) && (errno == EINTR));

  if (errno == ENXIO) {
    /* FIFO with no reader? Try opening in RW mode: */
    flags -= O_WRONLY;
    flags |= O_RDWR;
    do {
      fd = open(filename, flags | MZ_NONBLOCKING | MZ_BINARY, 0666);
    } while ((fd == -1) && (errno == EINTR));
  }

  if (fd == -1) {
    if (errno == EISDIR) {
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: \"%q\" exists as a directory",
                     name, filename);
    } else if (errno == EEXIST) {
      if (!existsok)
       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                      "%s: file \"%q\" exists", name, filename);
      else {
       do {
         ok = unlink(filename);
       } while ((ok == -1) && (errno == EINTR));

       if (ok)
         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                        "%s: error deleting \"%q\"",
                        name, filename);
       do {
         fd = open(filename, flags | MZ_BINARY, 0666);
       } while ((fd == -1) && (errno == EINTR));
      }
    }

    if (fd == -1) {
      filename_exn(name, "cannot open output file", filename, errno);
      return NULL; /* shouldn't get here */
    }
  }

  do {
    ok = fstat(fd, &buf);
  } while ((ok == -1) && (errno == EINTR));

  regfile = S_ISREG(buf.st_mode);
  scheme_file_open_count++;
  return make_fd_output_port(fd, scheme_make_path(filename), regfile, 0, and_read, -1);
#else
# ifdef WINDOWS_FILE_HANDLES
  if (!existsok)
    hmode = CREATE_NEW;
  else if (existsok < 0) {
    if (must_exist)
      hmode = TRUNCATE_EXISTING;
    else
      hmode = OPEN_ALWAYS;
  } else if (existsok  == 1) {
    /* assert: !must_exist */
    hmode = CREATE_ALWAYS;
  } else if (existsok == 2) {
    hmode = OPEN_EXISTING;
  } else if (existsok == 3) {
    hmode = OPEN_ALWAYS;
  }

  fd = CreateFileW(WIDE_PATH(filename),
                 GENERIC_WRITE | (and_read ? GENERIC_READ : 0),
                 FILE_SHARE_READ | FILE_SHARE_WRITE,
                 NULL,
                 hmode,
                 FILE_FLAG_BACKUP_SEMANTICS, /* lets us detect directories in NT */
                 NULL);

  if (fd == INVALID_HANDLE_VALUE) {
    int err;
    err = GetLastError();
    if ((err == ERROR_ACCESS_DENIED) && (existsok < -1)) {
      /* Delete and try again... */
      if (DeleteFile(filename)) {
       fd = CreateFile(filename,
                     GENERIC_WRITE,
                     FILE_SHARE_READ | FILE_SHARE_WRITE,
                     NULL,
                     hmode,
                     0,
                     NULL);
       if (fd == INVALID_HANDLE_VALUE)
         err = GetLastError();
      } else {
       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                      "%s: error deleting \"%q\" (%E)",
                      name, filename, GetLastError());
       return NULL;
      }
    } else if (err == ERROR_FILE_EXISTS) {
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: file \"%q\" exists", name, filename);
      return NULL;
    }

    if (fd == INVALID_HANDLE_VALUE) {
      filename_exn(name, "cannot open output file", filename, err);
      return NULL;
    }
  }

  if (GetFileInformationByHandle(fd, &info)) {
    if (info.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) {
      CloseHandle(fd);
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: \"%q\" exists as a directory",
                     name, filename);
      return NULL;
    }
  }

  regfile = (GetFileType(fd) == FILE_TYPE_DISK);

  if ((mode[1] == 't') && !regfile) {
    CloseHandle(fd);
    filename_exn(name, "cannot use text-mode on a non-file device", filename, 0);
    return NULL;
  }

  if (regfile && (existsok < 0)) {
    if (mode[0] == 'a')
      SetFilePointer(fd, 0, NULL, FILE_END);
    else
      SetEndOfFile(fd);
  }

  scheme_file_open_count++;
  return make_fd_output_port((int)fd, scheme_make_path(filename), regfile, mode[1] == 't', and_read, -1);
# else
  if (scheme_directory_exists(filename)) {
    if (!existsok)
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: \"%q\" exists as a directory",
                     name, filename);
    else
      filename_exn(name, "cannot open directory as a file", filename, errno);
    return scheme_void;
  }


  if (and_read) {
    scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                   "%s: not supported on this platform",
                   name);
    return NULL;
  }

  if (scheme_file_exists(filename)) {
    int uok;

    if (!existsok)
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: file \"%q\" exists", name, filename);
    do {
      uok = MSC_IZE(unlink)(filename);
    } while ((uok == -1) && (errno == EINTR));

    if (uok)
      scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                     "%s: error deleting \"%q\" (%e)",
                     name, filename, errno);
  }

  fp = fopen(filename, mode);
  if (!fp) {
    if (existsok < -1) {
      /* Can't truncate; try to replace */
      if (scheme_file_exists(filename)) {
       int uok;

       do {
         uok = MSC_IZE(unlink)(filename);
       } while ((uok == -1) && (errno == EINTR));

       if (uok)
         scheme_raise_exn(MZEXN_FAIL_FILESYSTEM_EXISTS,
                        "%s: error deleting \"%q\"",
                        name, filename);
       else {
         fp = fopen(filename, mode);
       }
      }
    }
    if (!fp)
      filename_exn(name, "cannot open output file", filename, errno);
  }
  scheme_file_open_count++;

  return scheme_make_file_output_port(fp);
# endif
#endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 8584 of file port.c.

{
}
void scheme_fdclr ( void fd,
int  n 
)

Definition at line 824 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fd;
  int i;
  for (i = SCHEME_INT_VAL(efd->added); i--; ) {
    if (efd->sockets[i] == n)
      efd->sockets[i] = INVALID_SOCKET;
  }
#else
# if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
  FD_CLR((unsigned)n, ((fd_set *)fd));
# endif
#endif
}
int scheme_fdisset ( void fd,
int  n 
)

Definition at line 869 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fd;
  int i;
  for (i = SCHEME_INT_VAL(efd->added); i--; ) {
    if (efd->sockets[i] == n)
      return 1;
  }
  return 0;
#else
# if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
  return FD_ISSET(n, ((fd_set *)fd));
# else
  return 0;
# endif
#endif
}
void scheme_fdset ( void fd,
int  n 
)

Definition at line 840 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  win_extended_fd_set *efd = (win_extended_fd_set *)fd;
  if (SCHEME_INT_VAL(efd->added) >= SCHEME_INT_VAL(efd->alloc)) {
    SOCKET *naya;
    int na;
    na = (SCHEME_INT_VAL(efd->alloc) * 2) + 10;
    naya = (SOCKET *)scheme_malloc_atomic(na * sizeof(SOCKET));
    memcpy(naya, efd->sockets, SCHEME_INT_VAL(efd->alloc) * sizeof(SOCKET));
    efd->sockets = naya;
    efd->alloc = scheme_make_integer(na);
    reset_wait_array(efd);
  }
  efd->sockets[SCHEME_INT_VAL(efd->added)] = n;
  efd->added = scheme_make_integer(1 + SCHEME_INT_VAL(efd->added));
#else
# if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
#  ifdef STORED_ACTUAL_FDSET_LIMIT
  int mx;
  mx = FDSET_LIMIT(fd);
  if (n > mx)
    FDSET_LIMIT(fd) = n;
#  endif
  FD_SET(n, ((fd_set *)fd));
# endif
#endif
}
void scheme_fdzero ( void fd)

Definition at line 811 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  scheme_init_fdset_array(fd, 1);
#else
# if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP)
  FD_ZERO((fd_set *)fd);
# endif
#endif
}

Definition at line 4624 of file port.c.

{
  Scheme_Port *p = NULL;

  if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
    scheme_wrong_type("file-stream-buffer-mode", "port", 0, argc, argv);

  p = scheme_port_record(argv[0]);

  if (argc == 1) {
    Scheme_Buffer_Mode_Fun bm;

    bm = p->buffer_mode_fun;
    if (bm) {
      switch (bm(p, -1)) {
      case MZ_FLUSH_NEVER:
       return scheme_block_symbol;
      case MZ_FLUSH_BY_LINE:
       return scheme_line_symbol;
      case MZ_FLUSH_ALWAYS:
       return scheme_none_symbol;
      }
    }

    return scheme_false;
  } else {
    Scheme_Object *s = argv[1];
    Scheme_Buffer_Mode_Fun bm;

    if (!SAME_OBJ(s, scheme_block_symbol)
       && !SAME_OBJ(s, scheme_line_symbol)
       && !SAME_OBJ(s, scheme_none_symbol))
      scheme_wrong_type("file-stream-buffer-mode", "'none, 'line, or 'block", 1, argc, argv);

    if (SCHEME_INPUT_PORTP(argv[0]) && SAME_OBJ(s, scheme_line_symbol))
      scheme_arg_mismatch("file-stream-buffer-mode", 
                       "'line buffering not supported for an input port: ",
                       argv[0]);

    bm = p->buffer_mode_fun;
    if (bm) {
      int mode;
      if (SAME_OBJ(s, scheme_block_symbol))
       mode = MZ_FLUSH_NEVER;
      else if (SAME_OBJ(s, scheme_line_symbol))
       mode = MZ_FLUSH_BY_LINE;
      else
       mode = MZ_FLUSH_ALWAYS;

      bm(p, mode);
    } else {
      scheme_arg_mismatch("file-stream-buffer-mode", 
                       "cannot set buffer mode on port: ",
                       argv[0]);
    }

    return scheme_void;
  }
}

Here is the caller graph for this function:

Definition at line 3673 of file port.c.

{
  long fd = 0;
  int fd_ok = 0;
  Scheme_Object *p;

  p = argv[0];

  fd_ok = scheme_get_port_file_descriptor(p, &fd);

  if (!fd_ok) {
    /* Maybe failed because it was closed... */
    if (SCHEME_INPUT_PORTP(p)) {
      Scheme_Input_Port *ip;

      ip = scheme_input_port_record(p);
      
      CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
    } else if (SCHEME_OUTPUT_PORTP(p)) {
      Scheme_Output_Port *op;
      
      op = scheme_output_port_record(p);
      
      CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
    }

    /* Otherwise, it's just the wrong type: */
    scheme_wrong_type("port-file-identity", "file-stream-port", 0, argc, argv);
    return NULL;
  }

  return scheme_get_fd_identity(p, fd);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 4316 of file port.c.

{
  FILE *f;
  Scheme_Indexed_String *is;
  int fd;
#ifdef MZ_FDS
  int had_fd;
#endif
  int wis;

  if (!SCHEME_OUTPUT_PORTP(argv[0]) && !SCHEME_INPUT_PORTP(argv[0]))
    scheme_wrong_type("file-position", "port", 0, argc, argv);
  if (argc == 2) {
    if (!SCHEME_EOFP(argv[1])) {
      int ok = 0;

      if (SCHEME_INTP(argv[1])) {
       ok = (SCHEME_INT_VAL(argv[1]) >= 0);
      }
      
      if (SCHEME_BIGNUMP(argv[1])) {
       ok = SCHEME_BIGPOS(argv[1]);
      }
      
      if (!ok)
       scheme_wrong_type("file-position", "non-negative exact integer or eof", 1, argc, argv);
    }
  }

  f = NULL;
  is = NULL;
  wis = 0;
  fd = 0;
#ifdef MZ_FDS
  had_fd = 0;
#endif

  if (!SCHEME_INPUT_PORTP(argv[0])) {
    Scheme_Output_Port *op;

    op = scheme_output_port_record(argv[0]);

    if (SAME_OBJ(op->sub_type, file_output_port_type)) {
      f = ((Scheme_Output_File *)op->port_data)->f;
#ifdef MZ_FDS
    } else if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
      fd = ((Scheme_FD *)op->port_data)->fd;
      had_fd = 1;
#endif
    } else if (SAME_OBJ(op->sub_type, scheme_string_output_port_type)) {
      is = (Scheme_Indexed_String *)op->port_data;
      wis = 1;
    } else if (argc < 2)
      return scheme_make_integer(scheme_output_tell(argv[0]));
  } else {
    Scheme_Input_Port *ip;

    ip = scheme_input_port_record(argv[0]);

    if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
      f = ((Scheme_Input_File *)ip->port_data)->f;
#ifdef MZ_FDS
    } else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
      fd = ((Scheme_FD *)ip->port_data)->fd;
      had_fd = 1;
#endif
    } else if (SAME_OBJ(ip->sub_type, scheme_string_input_port_type))
      is = (Scheme_Indexed_String *)ip->port_data;
    else if (argc < 2) {
      long pos;
      pos = ip->p.position;
      if (pos < 0) {
       scheme_raise_exn(MZEXN_FAIL,
                      "the port's current position is not known: %v",
                      ip);
      }
      return scheme_make_integer_value(pos);
    }
  }

  if (!f
#ifdef MZ_FDS
      && !had_fd
#endif
      && !is)
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                   "file-position: setting position allowed for file-stream and string ports only;"
                   " given %s and position %s",
                   scheme_make_provided_string(argv[0], 2, NULL),
                   scheme_make_provided_string(argv[1], 2, NULL));

  if (argc > 1) {
    mzlonglong nll;
    int whence;

    if (SCHEME_EOFP(argv[1])) {
      nll = 0;
      whence = SEEK_END;
    } else if (scheme_get_long_long_val(argv[1], &nll)) {
      whence = SEEK_SET;
      if ((mzlonglong)(mz_off_t)nll != nll) {
       nll = -1;
      }
    } else {
      whence = SEEK_SET; /* not used */
      nll = -1;
    }

    if (nll < 0) {
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                       "file-position: new position is too large: %s for port: %s",
                       scheme_make_provided_string(argv[1], 2, NULL),
                       scheme_make_provided_string(argv[0], 2, NULL));
      return NULL;
    }
      
    if (f) {
      if (BIG_OFF_T_IZE(fseeko)(f, nll, whence)) {
       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                      "file-position: position change failed on file (%e)",
                      errno);
      }
#ifdef MZ_FDS
    } else if (had_fd) {
      long lv;
      
      if (!SCHEME_INPUT_PORTP(argv[0])) {
       flush_fd(scheme_output_port_record(argv[0]), NULL, 0, 0, 0, 0);
      }
      
# ifdef WINDOWS_FILE_HANDLES
      {
       DWORD r;
       LONG lo_w, hi_w;
       lo_w = (LONG)(nll & 0xFFFFFFFF);
       hi_w = (LONG)(nll >> 32);
        r = SetFilePointer((HANDLE)fd, lo_w, &hi_w,
                        ((whence == SEEK_SET) ? FILE_BEGIN : FILE_END));
       if ((r == INVALID_SET_FILE_POINTER)
           && GetLastError() != NO_ERROR)
          lv = -1;
       else
         lv = 0;
      }
# else
      lv = BIG_OFF_T_IZE(lseek)(fd, nll, whence);
# endif

      if (lv < 0) {
# ifdef WINDOWS_FILE_HANDLES
       int errid;
       errid = GetLastError();
       errno = errid;
# endif
       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
                      "file-position: position change failed on stream (" FILENAME_EXN_E ")",
                      errno);
      }

      if (SCHEME_INPUT_PORTP(argv[0])) {
       /* Get rid of buffered data: */
       Scheme_FD *sfd;
        Scheme_Input_Port *ip;
        ip = scheme_input_port_record(argv[0]);
       sfd = (Scheme_FD *)ip->port_data;
       sfd->bufcount = 0;
       sfd->buffpos = 0;
       /* 1 means no pending eof, but can set: */
       ip->pending_eof = 1;
      }
#endif
    } else {
      long n;

      if (whence == SEEK_SET) {
        if (!scheme_get_int_val(argv[1], &n)) {
          scheme_raise_out_of_memory(NULL, NULL);
        }
      } else {
        n = 0;
      }

      if (whence == SEEK_END) {
        if (wis)
          n = is->u.hot;
        else
          n = is->size;
      }
      if (wis) {
       if (is->index > is->u.hot)
         is->u.hot = is->index;
       if (is->size < n) {
         /* Expand string up to n: */
         char *old;

         old = is->string;
         {
           char *ca;
           ca = (char *)scheme_malloc_fail_ok(scheme_malloc_atomic, n + 1);
           is->string = ca;
          }
         is->size = n;
         memcpy(is->string, old, is->u.hot);
       }
       if (n > is->u.hot) {
         memset(is->string + is->u.hot, 0, n - is->u.hot);
          is->u.hot = n;
        }
      } else {
       /* Can't really move past end of read string, but pretend we do: */
       if (n > is->size) {
         is->u.pos = n;
         n = is->size;
       } else
         is->u.pos = 0;
      }
      is->index = n;
    }

    /* Remove any chars saved from peeks: */
    if (SCHEME_INPUT_PORTP(argv[0])) {
      Scheme_Input_Port *ip;
      ip = scheme_input_port_record(argv[0]);
      ip->ungotten_count = 0;
      if (pipe_char_count(ip->peeked_read)) {
       ip->peeked_read = NULL;
       ip->peeked_write = NULL;
      }
    }

    return scheme_void;
  } else {
    mzlonglong pll;
    if (f) {
      pll = BIG_OFF_T_IZE(ftello)(f);
#ifdef MZ_FDS
    } else if (had_fd) {
# ifdef WINDOWS_FILE_HANDLES
      {
       DWORD lo_w, hi_w;
       hi_w = 0;
        lo_w = SetFilePointer((HANDLE)fd, 0, &hi_w, FILE_CURRENT);
       if ((lo_w == INVALID_SET_FILE_POINTER)
           && GetLastError() != NO_ERROR)
          pll = -1;
        else
          pll = ((mzlonglong)hi_w << 32) | lo_w;
      }
# else
      pll = BIG_OFF_T_IZE(lseek)(fd, 0, 1);
# endif
      if (pll < 0) {
       if (SCHEME_INPUT_PORTP(argv[0])) {
         pll = scheme_tell(argv[0]);
       } else {
         pll = scheme_output_tell(argv[0]);
       }
      } else {
       if (SCHEME_INPUT_PORTP(argv[0])) {          
          Scheme_Input_Port *ip;
          ip = scheme_input_port_record(argv[0]);
         pll -= ((Scheme_FD *)ip->port_data)->bufcount;
       } else {
          Scheme_Output_Port *op;
          op = scheme_output_port_record(argv[0]);
         pll += ((Scheme_FD *)op->port_data)->bufcount;
       }
      }
#endif
    } else if (wis)
      pll = is->index;
    else {
      /* u.pos > index implies we previously moved past the end with file-position */
      if (is->u.pos > is->index)
       pll = is->u.pos;
      else
       pll = is->index;
    }

    /* Back up for un-gotten & peeked chars: */
    if (SCHEME_INPUT_PORTP(argv[0])) {
      Scheme_Input_Port *ip;
      ip = scheme_input_port_record(argv[0]);
      pll -= ip->ungotten_count;
      pll -= pipe_char_count(ip->peeked_read);
    }

    return scheme_make_integer_value_from_long_long(pll);
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 3582 of file port.c.

{
  Scheme_Object *p = argv[0];

  if (SCHEME_INPUT_PORTP(p)) {
    Scheme_Input_Port *ip;

    ip = scheme_input_port_record(p);

    if (SAME_OBJ(ip->sub_type, file_input_port_type))
      return scheme_true;
#ifdef MZ_FDS
    else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
      return scheme_true;
#endif
  } else if (SCHEME_OUTPUT_PORTP(p)) {
    Scheme_Output_Port *op;

    op = scheme_output_port_record(p);

    if (SAME_OBJ(op->sub_type, file_output_port_type))
      return scheme_true;
#ifdef MZ_FDS
    else if (SAME_OBJ(op->sub_type, fd_output_port_type))
      return scheme_true;
#endif
  } else {
    scheme_wrong_type("file-stream-port?", "port", 0, argc, argv);
  }

  return scheme_false;
}

Here is the caller graph for this function:

Definition at line 3565 of file port.c.

Here is the caller graph for this function:

Definition at line 3574 of file port.c.

{
  scheme_put_byte_string("flush-output", o,
                      NULL, 0, 0,
                      0);
}

Definition at line 2706 of file port.c.

{
  char s[1];
  int v;

  v = get_one_byte("read-byte", port,
                 s, 0,
                 0);

  if ((v == EOF) || (v == SCHEME_SPECIAL))
    return v;
  else
    return ((unsigned char *)s)[0];
}

Here is the call graph for this function:

Definition at line 2729 of file port.c.

{
  special_is_ok = 1;
  return scheme_get_byte(port);
}
long scheme_get_byte_string ( const char *  who,
Scheme_Object port,
char *  buffer,
long  offset,
long  size,
int  only_avail,
int  peek,
Scheme_Object peek_skip 
)

Definition at line 2021 of file port.c.

{
  return scheme_get_byte_string_unless(who, port,
                                   buffer, offset, size,
                                   only_avail,
                                   peek, peek_skip,
                                   NULL);
}
long scheme_get_byte_string_special_ok_unless ( const char *  who,
Scheme_Object port,
char *  buffer,
long  offset,
long  size,
int  only_avail,
int  peek,
Scheme_Object peek_skip,
Scheme_Object unless_evt 
)

Definition at line 2009 of file port.c.

{
  special_is_ok = 1;
  return scheme_get_byte_string_unless(who, port, buffer, offset, size, 
                                   only_avail, peek, peek_skip, unless_evt);
}
long scheme_get_byte_string_unless ( const char *  who,
Scheme_Object port,
char *  buffer,
long  offset,
long  size,
int  only_avail,
int  peek,
Scheme_Object peek_skip,
Scheme_Object unless_evt 
)

Definition at line 1634 of file port.c.

{
  Scheme_Input_Port *ip;
  long got = 0, total_got = 0, gc;
  int special_ok = special_is_ok, check_special;
  Scheme_Get_String_Fun gs;
  Scheme_Peek_String_Fun ps;

  /* See also get_one_byte, below. Any change to this function
     may require a change to 1-byte specialization of get_one_byte. */

  /* back-door argument: */
  special_is_ok = 0;

  if (!size) {
    if (only_avail == -1) {
      /* We might need to break. */
      if (scheme_current_thread->external_break) {
       scheme_thread_block_enable_break(0.0, 1);
       scheme_current_thread->ran_some = 1;
      }
    }
    return 0;
  }
  if (!peek_skip)
    peek_skip = scheme_make_integer(0);

  ip = scheme_input_port_record(port);

  gs = ip->get_string_fun;
  ps = ip->peek_string_fun;

  while (1) {
    SCHEME_USE_FUEL(1);

    CHECK_PORT_CLOSED(who, "input", port, ip->closed);

    if (ip->input_lock)
      scheme_wait_input_allowed(ip, only_avail);

    if (only_avail == -1) {
      /* We might need to break. */
      if (scheme_current_thread->external_break) {
       scheme_thread_block_enable_break(0.0, 1);
       scheme_current_thread->ran_some = 1;
      }
    }

    if ((ip->ungotten_count || pipe_char_count(ip->peeked_read))
       && (!total_got || !peek)) {
      long l, i;
      unsigned char *s;

      i = ip->ungotten_count;
      /* s will be in reverse order */

      if (peek) {
       if (!SCHEME_INTP(peek_skip) || (i < SCHEME_INT_VAL(peek_skip))) {
         peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(i));
         i = 0;
       } else {
         i -= SCHEME_INT_VAL(peek_skip);
         peek_skip = scheme_make_integer(0);
       }
      }

      if (i < size)
       l = i;
      else
       l = size;

      size -= l;
      s = (unsigned char *)ip->ungotten; /* Not GC-safe! */
      while (l--) {
       buffer[offset + got++] = s[--i];
      }
      s = NULL;

      if (!peek)
       ip->ungotten_count = i;

      l = pipe_char_count(ip->peeked_read);
      if (size && l) {
       if (SCHEME_INTP(peek_skip) && (l > SCHEME_INT_VAL(peek_skip))) {
         l -= SCHEME_INT_VAL(peek_skip);

         if (l > size)
           l = size;

         if (l) {
           scheme_get_byte_string("depipe", ip->peeked_read,
                               buffer, offset + got, l,
                               1, peek, peek_skip);
           size -= l;
           got += l;
           peek_skip = scheme_make_integer(0);
           if (!peek && ip->progress_evt)
             post_progress(ip);
         }
       } else
         peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(l));
      }
      check_special = (!got || peek);
    } else
      check_special = 1;

    if (check_special && ip->ungotten_special) {
      if (!special_ok) {
       if (!peek) {
         if (ip->progress_evt)
           post_progress(ip);
         ip->ungotten_special = NULL;
       }
       scheme_bad_time_for_special(who, port);
      }
      if (!peek) {
       ip->special = ip->ungotten_special;
       ip->ungotten_special = NULL;
      } else {
       if (peek_skip != scheme_make_integer(0))
         scheme_bad_time_for_special(who, port);
      }

      if (!peek) {
       if (ip->p.position >= 0)
         ip->p.position++;
       if (ip->p.count_lines)
         inc_pos((Scheme_Port *)ip, 1);
      }

      if (!peek && ip->progress_evt)
       post_progress(ip);

      return SCHEME_SPECIAL;
    }

    if (got && ((only_avail == 1) || (only_avail == -1)))
      only_avail = 2;

    /* If we get this far in peek mode, ps is NULL, peek_skip is non-zero, and
       we haven't gotten anything so far, it means that we need to read before we
       can actually peek. Handle this case with a recursive peek that starts
       from the current position, then set peek_skip to 0 and go on. */
    while (peek && !ps && (peek_skip != scheme_make_integer(0)) && !total_got && !got
          && (ip->pending_eof < 2)) {
      char *tmp;
      int v, pcc;
      long skip;
      Scheme_Cont_Frame_Data cframe;


#     define MAX_SKIP_TRY_AMOUNT 65536

      if (SCHEME_INTP(peek_skip)) {
       skip = SCHEME_INT_VAL(peek_skip);
       if (skip > MAX_SKIP_TRY_AMOUNT)
         skip = MAX_SKIP_TRY_AMOUNT;
      } else
       skip = MAX_SKIP_TRY_AMOUNT;

      tmp = (char *)scheme_malloc_atomic(skip);
      pcc = pipe_char_count(ip->peeked_read);

      if (only_avail == -1) {
       /* To implement .../enable-break, we enable
          breaks during the skip-ahead peek. */
       scheme_push_break_enable(&cframe, 1, 1);
      }

      v = scheme_get_byte_string_unless(who, port, tmp, 0, skip,
                                   (only_avail == 2) ? 2 : 0,
                                   1, scheme_make_integer(ip->ungotten_count + pcc),
                                   unless_evt);

      if (only_avail == -1) {
       scheme_pop_break_enable(&cframe, 0);
      }

      if (v == EOF) {
       ip->p.utf8state = 0;
       return EOF;
      } else if (v == SCHEME_SPECIAL) {
       ip->special = NULL;
       scheme_bad_time_for_special(who, port);
      } else if (v == skip) {
       peek_skip = scheme_bin_minus(peek_skip, scheme_make_integer(skip));
       /* Ok... ready to continue (if skip == peek_skip) */
      } else
       return 0;
    }

    if (size) {
      int nonblock;

      if (only_avail == 2) {
       if (got)
         nonblock = 2;
       else
         nonblock = 1;
      } else if (only_avail == -1)
       nonblock = -1;
      else
       nonblock = 0;

      if (unless_evt && SAME_TYPE(SCHEME_TYPE(unless_evt), scheme_progress_evt_type))
       unless_evt = SCHEME_PTR2_VAL(unless_evt);

      if (ip->pending_eof > 1) {
       ip->pending_eof = 1;
       gc = EOF;
      } else {
       /* Call port's get or peek function. But first, set up
          an "unless" to detect other accesses of the port
          if we block. */
       Scheme_Object *unless;
         
       if (nonblock > 0) {
         if (ip->unless)
           unless = ip->unless;
         else
           unless = NULL;
       } else if (ip->unless_cache) {
         if (ip->unless) {
           unless = ip->unless;
           /* Setting car to #f means that it can't be recycled */
           SCHEME_CAR(unless) = scheme_false;
         } else if (SCHEME_TRUEP(ip->unless_cache)) {
           unless = ip->unless_cache;
           ip->unless_cache = scheme_false;
           ip->unless = unless;
         } else {
           unless = scheme_make_raw_pair(NULL, NULL);
           ip->unless = unless;
         }
         if (unless_evt)
           SCHEME_CDR(unless) = unless_evt;
       } else
         unless = unless_evt;

       /* Finally, call port's get or peek: */
       if (peek && ps)
         gc = ps(ip, buffer, offset + got, size, peek_skip, nonblock, unless);
       else {
         gc = gs(ip, buffer, offset + got, size, nonblock, unless);

         if (!peek && gc && ip->progress_evt
             && (gc != EOF) 
             && (gc != SCHEME_UNLESS_READY))
           post_progress(ip);
       }

       /* Let other threads know that something happened,
          and/or deregister this thread's request for information. */
       if (unless && ip->unless_cache) {
         if (!SCHEME_CAR(unless)) {
           /* Recycle "unless", since we were the only user */
           ip->unless_cache = unless;
           SCHEME_CDR(unless) = NULL;
         } else {
           if (SCHEME_TRUEP(SCHEME_CAR(unless))) {
             /* gc should be SCHEME_UNLESS_READY; only a user
               port without a peek can incorrectly produce something 
               else */
             if (gc == SCHEME_UNLESS_READY) {
              gc = 0;
             }
           } else if (gc) {
             /* Notify other threads that something happened */
             SCHEME_CAR(unless) = scheme_true;
           }
         }
         ip->unless = NULL;
       }
      }

      if (gc == SCHEME_SPECIAL) {
       if (!got && !total_got && special_ok) {
         if (!peek) {
           if (ip->p.position >= 0)
             ip->p.position++;
           if (ip->p.count_lines)
             inc_pos((Scheme_Port *)ip, 1);
         }
         
         return SCHEME_SPECIAL;
       }

       if ((got || total_got) && only_avail) {
         ip->ungotten_special = ip->special;
         ip->special = NULL;
         gc = 0;
       } else {
         ip->special = NULL;
         scheme_bad_time_for_special(who, port);
         return 0;
       }
      } else if (gc == EOF) {
       ip->p.utf8state = 0;
       if (!got && !total_got) {
         if (peek && ip->pending_eof)
           ip->pending_eof = 2;
         return EOF;
       }
       /* remember the EOF for next time */
       if (ip->pending_eof)
         ip->pending_eof = 2;
       gc = 0;
       size = 0; /* so that we stop */
      } else if (gc == SCHEME_UNLESS_READY) {
       gc = 0;
       size = 0; /* so that we stop */
      }
      mzAssert(gc >= 0);
    } else
      gc = 0;

    got += gc;
    if (peek)
      peek_skip = quick_plus(peek_skip, gc);
    size -= gc;

    if (!peek) {
      /****************************************************/
      /* Adjust position information for chars got so far */
      /****************************************************/

      /* We don't get here if SCHEME_SPECIAL is returned, so
        the positions are updated separately in the two
        returning places above. */

      if (ip->p.position >= 0)
       ip->p.position += got;
      if (ip->p.count_lines)
       do_count_lines((Scheme_Port *)ip, buffer, offset, got);
    } else if (!ps) {
      /***************************************************/
      /* save newly peeked string for future peeks/reads */
      /***************************************************/
      if (gc) {
       if ((gc == 1) && !ip->ungotten_count && !ip->peeked_write) {
         ip->ungotten[ip->ungotten_count++] = buffer[offset];
       } else {
         if (!ip->peeked_write) {
           Scheme_Object *rd, *wt;
           scheme_pipe(&rd, &wt);
           ip->peeked_read = rd;
           ip->peeked_write = wt;
         }

         scheme_put_byte_string("peek", ip->peeked_write,
                             buffer, offset + got - gc, gc, 0);
       }
      }
    }

    offset += got;
    total_got += got;
    got = 0; /* for next round, if any */

    if (!size
       || (total_got && ((only_avail == 1) || (only_avail == -1)))
       || (only_avail == 2))
      break;

    /* Need to try to get more. */
  }
  
  return total_got;
}

Here is the call graph for this function:

long scheme_get_bytes ( Scheme_Object port,
long  size,
char *  buffer,
int  offset 
)

Definition at line 2735 of file port.c.

{
  int n;
  int only_avail = 0;

  if (size < 0) {
    size = -size;
    only_avail = 1;
  }

  n = scheme_get_byte_string_unless("read-bytes", port,
                                buffer, offset, size,
                                only_avail,
                                0, 0,
                                NULL);

  if (n == EOF)
    n = 0;

  mzAssert(n >= 0);

  return n;
}
long scheme_get_char_string ( const char *  who,
Scheme_Object port,
mzchar buffer,
long  offset,
long  size,
int  peek,
Scheme_Object peek_skip 
)

Definition at line 2407 of file port.c.

{
  int ahead_skip = 0;
  char *s;
  int total_got = 0, bsize, leftover = 0, got;

  /* read_string_byte_buffer helps avoid allocation */
  if (read_string_byte_buffer) {
    s = read_string_byte_buffer;
    read_string_byte_buffer = NULL;
  } else
    s = (char *)scheme_malloc_atomic(READ_STRING_BYTE_BUFFER_SIZE);

  while (1) {
    /* Since we want "size" more chars and we don't have leftovers, we
       need at least "size" more bytes.

       "leftover" is the number of bytes (<< READ_STRING_BYTE_BUFFER_SIZE) that
       we already have toward the first character. If the next
       character doesn't continue a leftover sequence, the next
       character actually belongs to a (leftover+1)th character. Thus,
       if leftover is positive and we're not merely peeking, ask for
       at leat one byte, but otherwise no more than size - leftover
       bytes. If size is 1, then we are forced to peek in all cases.

       Overall, if the size is big enough, we only read as many
       characters as our buffer holds. */

    bsize = size;
    if (leftover) {
      bsize -= leftover;
      if (bsize < 1) {
       /* This is the complex case. Need to peek a byte to see
          whether it continues the leftover sequence or ends it an in
          an error. */
       if (!peek_skip)
         peek_skip = scheme_make_integer(0);
       special_is_ok = 1;
       got = scheme_get_byte_string_unless(who, port,
                                       s, leftover, 1,
                                       0, 1 /* => peek */, 
                                       quick_plus(peek_skip, ahead_skip),
                                       NULL);
       if (got > 0) {
         long ulen, glen;
         glen = scheme_utf8_decode_as_prefix((const unsigned char *)s, 0, got + leftover,
                                         buffer, offset, offset + size,
                                         &ulen, 0, 0xFFFD);
         if (glen && (ulen < got + leftover)) {
           /* Got one, with a decoding error. If we weren't peeking,
              don't read the lookahead bytes after all, yet. */
           total_got++;
           bsize = 0;
           ahead_skip++;
           size--;
           offset++;
           /* leftover stays the same */
           memmove(s, s + 1, leftover);
         } else {
           /* Either we got one character, or we're still continuing. */
           ahead_skip++;
           if (!glen) {
             /* Continuing */
             leftover++;
           } else {
             /* Got one (no encoding error) */
             leftover = 0;
             offset++;
             --size;
             total_got++;
             if (!peek) {
              /* Read the lookahead bytes and discard them */
              scheme_get_byte_string_unless(who, port,
                                         s, 0, ahead_skip,
                                         0, 0, scheme_make_integer(0),
                                         NULL);
             } else {
              peek_skip = quick_plus(peek_skip, ahead_skip);
             }
             ahead_skip = 0;
           }
           /* Continue with the normal decoing process (but get 0
              more characters this time around) */
           bsize = 0;
         }
       } else {
         /* Either EOF or SPECIAL -- either one ends the leftover
            sequence in an error. We may have more leftover chars
            than we need, but they haven't been read, yet. */
         while (leftover && size) {
           buffer[offset++] = 0xFFFD;
           total_got++;
           --leftover;
           --size;
         }
         return total_got;
       }
      }
    }

    if (bsize) {
      /* Read bsize bytes */
      if (bsize + leftover > READ_STRING_BYTE_BUFFER_SIZE)
       bsize = READ_STRING_BYTE_BUFFER_SIZE - leftover;
      
      got = scheme_get_byte_string_unless(who, port,
                                     s, leftover, bsize,
                                     0, peek, peek_skip,
                                     NULL);
    } else
      got = 0;

    if (got >= 0) {
      long ulen, glen;

      glen = scheme_utf8_decode_as_prefix((const unsigned char *)s, 0, got + leftover,
                                     buffer, offset, offset + size,
                                     &ulen, 0, 0xFFFD);
      
      total_got += glen;
      if (glen == size) {
       /* Got enough */
       read_string_byte_buffer = s;
       return total_got;
      }
      offset += glen;
      size -= glen;
      leftover = (got + leftover) - ulen;
      memmove(s, s + ulen, leftover);
      if (peek) {
       peek_skip = quick_plus(peek_skip, got);
      }
    } else {
      read_string_byte_buffer = s;

      /* Leftover bytes must be decoding-error bytes: */
      while (leftover) {
       buffer[offset++] = 0xFFFD;
       total_got++;
       --leftover;
      }

      if (!total_got)
       return got; /* must be EOF */
      else
       return total_got;
    }
  }
}

Here is the call graph for this function:

Definition at line 8367 of file port.c.

{
#if defined(FILES_HAVE_FDS)
  return external_event_fd;
#else
  return 0;
#endif
}
void* scheme_get_fdset ( void fdarray,
int  pos 
)

Definition at line 802 of file port.c.

{
#if defined(FILES_HAVE_FDS) || defined(USE_SOCKETS_TCP) || defined(WIN32_FD_HANDLES)
  return ((fdset_type *)fdarray) + pos;
#else
  return NULL;
#endif
}

Definition at line 3663 of file port.c.

{
  long fd;

  if (scheme_get_port_file_descriptor(p, &fd))
    return fd;
  else
    return -1;
}

Definition at line 3615 of file port.c.

{
  long fd = 0;
  int fd_ok = 0;

  if (SCHEME_INPUT_PORTP(p)) {
    Scheme_Input_Port *ip;

    ip = scheme_input_port_record(p);

    if (!ip->closed) {
      if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
       fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
       fd_ok = 1;
      }
#ifdef MZ_FDS
      else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
       fd = ((Scheme_FD *)ip->port_data)->fd;
       fd_ok = 1;
      }
#endif
    }
  } else if (SCHEME_OUTPUT_PORTP(p)) {
    Scheme_Output_Port *op;

    op = scheme_output_port_record(p);

    if (!op->closed) {
      if (SAME_OBJ(op->sub_type, file_output_port_type))  {
       fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
       fd_ok = 1;
      }
#ifdef MZ_FDS
      else if (SAME_OBJ(op->sub_type, fd_output_port_type))  {
       fd = ((Scheme_FD *)op->port_data)->fd;
       fd_ok = 1;
      }
#endif
    }
  }

  if (!fd_ok)
    return 0;

  *_fd = fd;
  return 1;
}

Definition at line 3150 of file port.c.

{
  return do_get_ready_special(port, stxsrc, 0, ht);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 3155 of file port.c.

{
  return do_get_ready_special(port, stxsrc, peek, NULL);
}

Here is the call graph for this function:

Scheme_Object* scheme_get_special ( Scheme_Object port,
Scheme_Object src,
long  line,
long  col,
long  pos,
int  peek,
Scheme_Hash_Table **  for_read 
)

Definition at line 3066 of file port.c.

{
  int cnt;
  Scheme_Object *a[4], *special;
  Scheme_Input_Port *ip;
  Scheme_Cont_Frame_Data cframe;

  SCHEME_USE_FUEL(1);

  ip = scheme_input_port_record(port);

  /* Only `read' and similar internals should call this function. A
     caller must should ensure that there are no ungotten
     characters. */

  if (ip->ungotten_count) {
    scheme_signal_error("ungotten characters at get-special");
    return NULL;
  }
  if (!ip->special) {
    scheme_signal_error("no ready special");
    return NULL;
  }

  CHECK_PORT_CLOSED("#<primitive:get-special>", "input", port, ip->closed);

  special = ip->special;
  ip->special = NULL;

  if (peek) {
    /* do location increment, since read didn't */
    if (line > 0)
      line++;
    if (col >= 0)
      col++;
    if (pos > 0)
      pos++;
  }

  a[0] = special;
  if (!src && scheme_check_proc_arity(NULL, 2, 0, 1, a))
    cnt = 0;
  else {
    cnt = 4;
    a[0] = (src ? src : scheme_false);
    a[1] = (line > 0) ? scheme_make_integer(line) : scheme_false;
    a[2] = (col > 0) ? scheme_make_integer(col-1) : scheme_false;
    a[3] = (pos > 0) ? scheme_make_integer(pos) : scheme_false;
  }

  scheme_push_continuation_frame(&cframe);
  scheme_set_in_read_mark(src, for_read);

  special = scheme_apply(special, cnt, a);

  scheme_pop_continuation_frame(&cframe);

  return special;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 3198 of file port.c.

{
  Scheme_Object *special, **sbox;
  Scheme_Input_Port *ip;

  ip = scheme_input_port_record(inport);
  special = ip->special;
  ip->special = NULL;
  
  sbox = MALLOC_ONE(Scheme_Object *);
  *sbox = special;
  return scheme_make_closed_prim_w_arity(check_special_args, 
                                    sbox, "read-special",
                                    4, 4);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2655 of file port.c.

{
  char s[MAX_UTF8_CHAR_BYTES];
  unsigned int r[1];
  int v, delta = 0;

  while(1) {
    if (delta) {
      v = scheme_get_byte_string_unless("read-char", port,
                                   s, delta, 1,
                                   0,
                                   delta > 0, scheme_make_integer(delta-1),
                                   NULL);
    } else {
      v = get_one_byte("read-char", port,
                     s, 0, 
                     0);
    }

    if ((v == EOF) || (v == SCHEME_SPECIAL)) {
      if (!delta)
       return v;
      else {
       /* This counts as a decoding error. The high bit
          on the first character must be set. */
       return 0xFFFD;
      }
    } else {
      v = scheme_utf8_decode_prefix((const unsigned char *)s, delta + 1, r, 0);
      if (v > 0) {
       if (delta) {
         /* Need to read the peeked bytes (will ignore) */
         v = scheme_get_byte_string_unless("read-char", port,
                                       s, 0, delta,
                                       0,
                                       0, 0,
                                       NULL);
       }
       return r[0];
      } else if (v == -2) {
       /* -2 => decoding error */
       return 0xFFFD;
      } else if (v == -1) {
       /* In middle of sequence; start/continue peeking bytes */
       delta++;
      }
    }
  }
}

Here is the call graph for this function:

Definition at line 2722 of file port.c.

{
  special_is_ok = 1;
  return scheme_getc(port);
}
void* scheme_init_fdset_array ( void fdarray,
int  count 
)

Definition at line 779 of file port.c.

{
#if defined(WIN32_FD_HANDLES)
  if (count) {
    int i;
    win_extended_fd_set *fd;
    for (i = 0; i < count; i++) {
      fd = (win_extended_fd_set *)scheme_get_fdset(fdarray, i);
      fd->sockets = NULL;
      fd->added = scheme_make_integer(0);
      fd->alloc = scheme_make_integer(0);
      fd->handles = NULL;
      fd->num_handles = scheme_make_integer(0);
      fd->no_sleep = NULL;
      fd->wait_event_mask = scheme_make_integer(0);
      fd->wait_array = NULL;
      reset_wait_array(fdarray);
    }
  }
#endif
  return fdarray;
}

Definition at line 430 of file port.c.

{
#ifdef MZ_PRECISE_GC
  register_traversers();
#endif

  REGISTER_SO(text_symbol);
  REGISTER_SO(binary_symbol);
  REGISTER_SO(append_symbol);
  REGISTER_SO(error_symbol);
  REGISTER_SO(replace_symbol);
  REGISTER_SO(truncate_symbol);
  REGISTER_SO(truncate_replace_symbol);
  REGISTER_SO(update_symbol);
  REGISTER_SO(can_update_symbol);
  REGISTER_SO(must_truncate_symbol);

  text_symbol = scheme_intern_symbol("text");
  binary_symbol = scheme_intern_symbol("binary");
  append_symbol = scheme_intern_symbol("append");
  error_symbol = scheme_intern_symbol("error");
  replace_symbol = scheme_intern_symbol("replace");
  truncate_symbol = scheme_intern_symbol("truncate");
  truncate_replace_symbol = scheme_intern_symbol("truncate/replace");
  update_symbol = scheme_intern_symbol("update");
  can_update_symbol = scheme_intern_symbol("can-update");
  must_truncate_symbol = scheme_intern_symbol("must-truncate");

  REGISTER_SO(scheme_none_symbol);
  REGISTER_SO(scheme_line_symbol);
  REGISTER_SO(scheme_block_symbol);

  scheme_none_symbol = scheme_intern_symbol("none");
  scheme_line_symbol = scheme_intern_symbol("line");
  scheme_block_symbol = scheme_intern_symbol("block");

  REGISTER_SO(exact_symbol);

  exact_symbol = scheme_intern_symbol("exact");

#ifdef MZ_FDS
  REGISTER_SO(fd_input_port_type);
  REGISTER_SO(fd_output_port_type);
#endif
#ifdef USE_OSKIT_CONSOLE
  REGISTER_SO(oskit_console_input_port_type);
#endif
  REGISTER_SO(file_input_port_type);
  REGISTER_SO(scheme_string_input_port_type);
#ifdef USE_TCP
  REGISTER_SO(scheme_tcp_input_port_type);
  REGISTER_SO(scheme_tcp_output_port_type);
#endif
  REGISTER_SO(file_output_port_type);
  REGISTER_SO(scheme_string_output_port_type);
  REGISTER_SO(scheme_user_input_port_type);
  REGISTER_SO(scheme_user_output_port_type);
  REGISTER_SO(scheme_pipe_read_port_type);
  REGISTER_SO(scheme_pipe_write_port_type);
  REGISTER_SO(scheme_null_output_port_type);
  REGISTER_SO(scheme_redirect_output_port_type);

#if defined(UNIX_PROCESSES)
  REGISTER_SO(scheme_system_children);
#endif

#ifndef DONT_IGNORE_PIPE_SIGNAL
  START_XFORM_SKIP;
  MZ_SIGSET(SIGPIPE, SIG_IGN);
  END_XFORM_SKIP;
#endif

  if (!scheme_sleep)
    scheme_sleep = default_sleep;

  scheme_eof->type = scheme_eof_type;

  scheme_string_input_port_type = scheme_make_port_type("<string-input-port>");
  scheme_string_output_port_type = scheme_make_port_type("<string-output-port>");

#ifdef MZ_FDS
  fd_input_port_type = scheme_make_port_type("<stream-input-port>");
  fd_output_port_type = scheme_make_port_type("<stream-output-port>");
#endif
#ifdef USE_OSKIT_CONSOLE
  oskit_console_input_port_type = scheme_make_port_type("<console-input-port>");
#endif

  file_input_port_type = scheme_make_port_type("<file-input-port>");
  file_output_port_type = scheme_make_port_type("<file-output-port>");

  scheme_user_input_port_type = scheme_make_port_type("<user-input-port>");
  scheme_user_output_port_type = scheme_make_port_type("<user-output-port>");

  scheme_pipe_read_port_type = scheme_make_port_type("<pipe-input-port>");
  scheme_pipe_write_port_type = scheme_make_port_type("<pipe-output-port>");

#ifdef USE_TCP
  scheme_tcp_input_port_type = scheme_make_port_type("<tcp-input-port>");
  scheme_tcp_output_port_type = scheme_make_port_type("<tcp-output-port>");
#endif

  scheme_null_output_port_type = scheme_make_port_type("<null-output-port>");
  scheme_redirect_output_port_type = scheme_make_port_type("<redirect-output-port>");

#ifdef WIN32_FD_HANDLES
  scheme_break_semaphore = CreateSemaphore(NULL, 0, 1, NULL);

  /* We'll need to know whether this is Win95 or WinNT: */
  {
    OSVERSIONINFO info;
    info.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
    GetVersionEx(&info);
    if (info.dwPlatformId == VER_PLATFORM_WIN32_NT)
      scheme_stupid_windows_machine = -1; /* not as stupid */
    else
      scheme_stupid_windows_machine = 1;
  }
#endif

  scheme_init_port_places();

  flush_out = SCHEME_TRUEP(scheme_terminal_port_p(1, &scheme_orig_stdout_port));
  flush_err = SCHEME_TRUEP(scheme_terminal_port_p(1, &scheme_orig_stderr_port));

#ifdef MZ_FDS
  scheme_add_atexit_closer(flush_if_output_fds);
  /* Note: other threads might continue to write even after
     the flush completes, but that's the threads' problem.
     All writing by the main thread will get flushed on exit
     (but not, of course, if the thread is shutdown via a
     custodian). */
#endif

#if defined(FILES_HAVE_FDS)
# ifndef USE_OSKIT_CONSOLE
  /* Set up a pipe for signalling external events: */
  {
    int fds[2];
    if (!pipe(fds)) {
      external_event_fd = fds[0];
      put_external_event_fd = fds[1];
      fcntl(external_event_fd, F_SETFL, MZ_NONBLOCKING);
      fcntl(put_external_event_fd, F_SETFL, MZ_NONBLOCKING);
    }
  }
# endif
#endif

  register_port_wait();

  scheme_add_global_constant("subprocess", scheme_make_prim_w_arity2(subprocess, "subprocess", 4, -1, 4, 4), env);
  scheme_add_global_constant("subprocess-status", scheme_make_prim_w_arity(subprocess_status, "subprocess-status", 1, 1), env);
  scheme_add_global_constant("subprocess-kill", scheme_make_prim_w_arity(subprocess_kill, "subprocess-kill", 2, 2), env);
  scheme_add_global_constant("subprocess-pid", scheme_make_prim_w_arity(subprocess_pid, "subprocess-pid", 1, 1), env);
  scheme_add_global_constant("subprocess?", scheme_make_prim_w_arity(subprocess_p, "subprocess?", 1, 1), env);
  scheme_add_global_constant("subprocess-wait", scheme_make_prim_w_arity(subprocess_wait, "subprocess-wait", 1, 1), env);


  register_subprocess_wait();

  scheme_add_global_constant("shell-execute", scheme_make_prim_w_arity(sch_shell_execute, "shell-execute", 5, 5), env);

  REGISTER_SO(read_string_byte_buffer);

  scheme_add_evt(scheme_progress_evt_type, (Scheme_Ready_Fun)progress_evt_ready, NULL, NULL, 1);
  scheme_add_evt(scheme_write_evt_type, (Scheme_Ready_Fun)rw_evt_ready, rw_evt_wakeup, NULL, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 599 of file port.c.

{
  REGISTER_SO(scheme_orig_stdout_port);
  REGISTER_SO(scheme_orig_stderr_port);
  REGISTER_SO(scheme_orig_stdin_port);
  scheme_orig_stdin_port = (scheme_make_stdin
                         ? scheme_make_stdin()
#ifdef USE_OSKIT_CONSOLE
                         : (osk_not_console
                            ? scheme_make_named_file_input_port(stdin, scheme_intern_symbol("stdin"))
                            : make_oskit_console_input_port())
#else
# ifdef MZ_FDS
#  ifdef WINDOWS_FILE_HANDLES
                         : make_fd_input_port((int)GetStdHandle(STD_INPUT_HANDLE), scheme_intern_symbol("stdin"), 0, 0, NULL, 0)
#  else
                         : make_fd_input_port(0, scheme_intern_symbol("stdin"), 0, 0, NULL, 0)
#  endif
# else
                         : scheme_make_named_file_input_port(stdin, scheme_intern_symbol("stdin"))
# endif
#endif
                         );

  scheme_orig_stdout_port = (scheme_make_stdout
                          ? scheme_make_stdout()
#ifdef MZ_FDS
# ifdef WINDOWS_FILE_HANDLES
                          : make_fd_output_port((int)GetStdHandle(STD_OUTPUT_HANDLE), 
                                             scheme_intern_symbol("stdout"), 0, 0, 0,
                                                   -1)
# else
                          : make_fd_output_port(1, scheme_intern_symbol("stdout"), 0, 0, 0, -1)
# endif
#else
                          : scheme_make_file_output_port(stdout)
#endif
                          );

  scheme_orig_stderr_port = (scheme_make_stderr
                          ? scheme_make_stderr()
#ifdef MZ_FDS
# ifdef WINDOWS_FILE_HANDLES
                          : make_fd_output_port((int)GetStdHandle(STD_ERROR_HANDLE), 
                                             scheme_intern_symbol("stderr"), 0, 0, 0,
                                                   MZ_FLUSH_ALWAYS)
# else
                          : make_fd_output_port(2, scheme_intern_symbol("stderr"), 0, 0, 0,
                                                   MZ_FLUSH_ALWAYS)
# endif
#else
                          : scheme_make_file_output_port(stderr)
#endif
                          );
}

Here is the caller graph for this function:

Definition at line 666 of file port.c.

{
  return scheme_eof;
}
Scheme_Object* scheme_make_fd_input_port ( int  fd,
Scheme_Object name,
int  regfile,
int  textmode 
)

Definition at line 5517 of file port.c.

{
#ifdef MZ_FDS
  return make_fd_input_port(fd, name, regfile, textmode, NULL, 0);
#else
  return NULL;
#endif
}
Scheme_Object* scheme_make_fd_output_port ( int  fd,
Scheme_Object name,
int  regfile,
int  textmode,
int  read_too 
)

Definition at line 6733 of file port.c.

{
#ifdef MZ_FDS
  return make_fd_output_port(fd, name, regfile, textmode, read_too, -1);
#else
  return NULL;
#endif
}

Definition at line 4814 of file port.c.

Definition at line 5792 of file port.c.

{
  Scheme_Output_File *fop;
  Scheme_Output_Port *op;

  if (!fp)
    scheme_signal_error("make-file-out-port(internal): "
                     "null file pointer");

  fop = MALLOC_ONE_RT(Scheme_Output_File);
#ifdef MZTAG_REQUIRED
  fop->type = scheme_rt_output_file;
#endif

  fop->f = fp;

  op = scheme_make_output_port(file_output_port_type,
                            fop,
                            scheme_intern_symbol("file"),
                            scheme_write_evt_via_write,
                            file_write_string,
                            NULL,
                            file_close_output,
                            NULL,
                            NULL,
                            NULL,
                            1);
  op->p.buffer_mode_fun = file_buffer_mode;

  return (Scheme_Object *)op;
}

Here is the call graph for this function:

Scheme_Input_Port* scheme_make_input_port ( Scheme_Object subtype,
void data,
Scheme_Object name,
Scheme_Get_String_Fun  get_string_fun,
Scheme_Peek_String_Fun  peek_string_fun,
Scheme_Progress_Evt_Fun  progress_evt_fun,
Scheme_Peeked_Read_Fun  peeked_read_fun,
Scheme_In_Ready_Fun  byte_ready_fun,
Scheme_Close_Input_Fun  close_fun,
Scheme_Need_Wakeup_Input_Fun  need_wakeup_fun,
int  must_close 
)

Definition at line 1287 of file port.c.

{
  Scheme_Input_Port *ip;
  Scheme_Custodian *cust = new_port_cust;

  new_port_cust = NULL;

  ip = MALLOC_ONE_TAGGED(Scheme_Input_Port);
  ip->p.so.type = scheme_input_port_type;
  ip->sub_type = subtype;
  ip->port_data = data;
  ip->get_string_fun = get_string_fun;
  ip->peek_string_fun = peek_string_fun;
  ip->progress_evt_fun = progress_evt_fun;
  ip->peeked_read_fun = peeked_read_fun;
  ip->byte_ready_fun = byte_ready_fun;
  ip->need_wakeup_fun = need_wakeup_fun;
  ip->close_fun = close_fun;
  ip->name = name;
  ip->ungotten_count = 0;
  ip->closed = 0;
  ip->read_handler = NULL;
  init_port_locations((Scheme_Port *)ip);

  if (progress_evt_fun == scheme_progress_evt_via_get)
    ip->unless_cache = scheme_false;

  if (must_close) {
    Scheme_Custodian_Reference *mref;
    mref = scheme_add_managed(cust,
                           (Scheme_Object *)ip,
                           (Scheme_Close_Custodian_Client *)force_close_input_port,
                           NULL, must_close);
    ip->mref = mref;
  } else
    ip->mref = NULL;

  return (ip);
}

Here is the call graph for this function:

Definition at line 4808 of file port.c.

{
  return _scheme_make_named_file_input_port(fp, name, 0);
}

Here is the call graph for this function:

Scheme_Output_Port* scheme_make_output_port ( Scheme_Object subtype,
void data,
Scheme_Object name,
Scheme_Write_String_Evt_Fun  write_string_evt_fun,
Scheme_Write_String_Fun  write_string_fun,
Scheme_Out_Ready_Fun  ready_fun,
Scheme_Close_Output_Fun  close_fun,
Scheme_Need_Wakeup_Output_Fun  need_wakeup_fun,
Scheme_Write_Special_Evt_Fun  write_special_evt_fun,
Scheme_Write_Special_Fun  write_special_fun,
int  must_close 
)

Definition at line 1355 of file port.c.

{
  Scheme_Output_Port *op;
  Scheme_Custodian *cust = new_port_cust;

  new_port_cust = NULL;

  op = MALLOC_ONE_TAGGED(Scheme_Output_Port);
  op->p.so.type = scheme_output_port_type;
  op->sub_type = subtype;
  op->port_data = data;
  op->name = name;
  op->write_string_evt_fun = write_string_evt_fun;
  op->write_string_fun = write_string_fun;
  op->close_fun = close_fun;
  op->ready_fun = ready_fun;
  op->need_wakeup_fun = need_wakeup_fun;
  op->write_special_evt_fun = write_special_evt_fun;
  op->write_special_fun = write_special_fun;
  op->closed = 0;
  op->display_handler = NULL;
  op->write_handler = NULL;
  op->print_handler = NULL;
  init_port_locations((Scheme_Port *)op);

  if (must_close) {
    Scheme_Custodian_Reference *mref;
    mref = scheme_add_managed(cust,
                           (Scheme_Object *)op,
                           (Scheme_Close_Custodian_Client *)force_close_output_port,
                           NULL, must_close);
    op->mref = mref;
  } else
    op->mref = NULL;

  return op;
}

Here is the call graph for this function:

Definition at line 1262 of file port.c.

{
  return scheme_make_symbol(name);
}

Definition at line 7059 of file port.c.

Here is the call graph for this function:

Scheme_Object* scheme_make_write_evt ( const char *  who,
Scheme_Object port,
Scheme_Object special,
char *  str,
long  start,
long  size 
)

Definition at line 2956 of file port.c.

{
  Scheme_Output_Port *op;

  op = scheme_output_port_record(port);

  if (!special) {
    if (op->write_string_evt_fun) {
      Scheme_Write_String_Evt_Fun wse;
      wse = op->write_string_evt_fun;
      return wse(op, str, start, size);
    }
  } else {
    if (op->write_special_evt_fun) {
      Scheme_Write_Special_Evt_Fun wse = op->write_special_evt_fun;
      return wse(op, special);
    }
  }

  scheme_arg_mismatch("write-bytes-avail-evt",
                    "port does not support atomic writes: ",
                    port);
  return NULL;
}
void scheme_need_wakeup ( Scheme_Object port,
void fds 
)

Definition at line 3215 of file port.c.

Definition at line 8087 of file port.c.

{
}
Scheme_Object* scheme_open_input_file ( const char *  name,
const char *  who 
)

Definition at line 4277 of file port.c.

{
  Scheme_Object *a[1];

  a[0]= scheme_make_path(name);
  return scheme_do_open_input_file((char *)who, 0, 1, a, 0);
}

Here is the call graph for this function:

Scheme_Object* scheme_open_input_output_file ( const char *  name,
const char *  who,
Scheme_Object **  oport 
)

Definition at line 4294 of file port.c.

Here is the call graph for this function:

Scheme_Object* scheme_open_output_file ( const char *  name,
const char *  who 
)

Definition at line 4285 of file port.c.

{
  Scheme_Object *a[2];

  a[0]= scheme_make_path(name);
  a[1] = truncate_replace_symbol;
  return scheme_do_open_output_file((char *)who, 0, 2, a, 0);
}

Here is the call graph for this function:

Scheme_Object* scheme_open_output_file_with_mode ( const char *  name,
const char *  who,
int  text 
)

Definition at line 4305 of file port.c.

{
  Scheme_Object *a[3];

  a[0]= scheme_make_path(name);
  a[1] = truncate_replace_symbol;
  a[2] = (text ? text_symbol : binary_symbol);
  return scheme_do_open_output_file((char *)who, 0, 3, a, 0);
}

Here is the call graph for this function:

Definition at line 3522 of file port.c.

{
  return scheme_tell(port);
}

Definition at line 2776 of file port.c.

{
  return scheme_peek_byte_skip(port, NULL, NULL);
}
int scheme_peek_byte_skip ( Scheme_Object port,
Scheme_Object skip,
Scheme_Object unless_evt 
)

Definition at line 2759 of file port.c.

{
  char s[1];
  int v;

  v = scheme_get_byte_string_unless("peek-byte", port,
                                s, 0, 1,
                                0,
                                1, skip,
                                unless_evt);

  if ((v == EOF) || (v == SCHEME_SPECIAL))
    return v;
  else
    return ((unsigned char *)s)[0];
}

Definition at line 2782 of file port.c.

{
  special_is_ok = 1;
  return scheme_peek_byte_skip(port, skip, unless_evt);
}

Definition at line 2846 of file port.c.

{
  return scheme_peekc_skip(port, scheme_make_integer(0));
}

Definition at line 2864 of file port.c.

Definition at line 2841 of file port.c.

{
  return do_peekc_skip(port, skip, 0, NULL);
}

Here is the call graph for this function:

Definition at line 2859 of file port.c.

Definition at line 2852 of file port.c.

{
  special_is_ok = 1;
  return scheme_peekc_skip(port, skip);
}
int scheme_peeked_read ( Scheme_Object port,
long  size,
Scheme_Object unless_evt,
Scheme_Object target_evt 
)

Definition at line 2345 of file port.c.

{
  Scheme_Input_Port *ip;
  Scheme_Peeked_Read_Fun pr;
  
  ip = scheme_input_port_record(port);

  unless_evt = SCHEME_PTR2_VAL(unless_evt);

  pr = ip->peeked_read_fun;

  return pr(ip, size, unless_evt, target_evt);
}
int scheme_peeked_read_via_get ( Scheme_Input_Port ip,
long  _size,
Scheme_Object unless_evt,
Scheme_Object _target_evt 
)

Definition at line 2181 of file port.c.

{
  Scheme_Object * volatile v, *sema, *a[3], ** volatile aa, * volatile l;
  volatile long size = _size;
  volatile int n, current_leader = 0;
  volatile Scheme_Type t;
  Scheme_Object * volatile target_evt = _target_evt;

  /* Check whether t's event value is known to be always itself: */
  t = SCHEME_TYPE(target_evt);
  if (!SAME_TYPE(t, scheme_sema_type)
      && !SAME_TYPE(t, scheme_channel_put_type)
      && !SAME_TYPE(t, scheme_always_evt_type)
      && !SAME_TYPE(t, scheme_never_evt_type)
      && !SAME_TYPE(t, scheme_semaphore_repost_type)) {
    /* Make an event whose value is itself */
    a[0] = target_evt;
    v = scheme_make_closed_prim(return_data, target_evt);
    a[1] = v;
    target_evt = scheme_wrap_evt(2, a);
    ((Scheme_Closed_Primitive_Proc *)v)->data = target_evt;
  }

  /* This commit implementation is essentially CML style, but we avoid
     actually allocating a manager thread. Instead the various
     committing threads elect a leader, and we rely on being in the
     kernel to detect when the leader is killed or suspended, in which
     case we elect a new leader. */

  while (1) {
    if (scheme_wait_sema(unless_evt, 1)) {
      if (current_leader)
       elect_new_main(ip);
      return 0;
    }

    if (!current_leader && ip->input_giveup) {
      /* Some other thread is already trying to commit.
        Ask it to sync on our target, too */
      v = scheme_make_pair(scheme_make_integer(_size), target_evt);
      l = scheme_make_raw_pair(v, ip->input_extras);
      ip->input_extras = l;

      scheme_post_sema_all(ip->input_giveup);

      if (!ip->input_extras_ready) {
       sema = scheme_make_sema(0);
       ip->input_extras_ready = sema;
      }

      a[0] = ip->input_extras_ready;
      l = scheme_make_pair((Scheme_Object *)ip, v);
      BEGIN_ESCAPEABLE(remove_extra, l);
      scheme_sync(1, a);
      END_ESCAPEABLE();

      if (!SCHEME_CDR(v)) {
       /* We were selected, so the commit succeeded. */
       return SCHEME_TRUEP(SCHEME_CAR(v)) ? 1 : 0;
      }
    } else {
      /* No other thread is trying to commit. This one is hereby
        elected "main" if multiple threads try to commit. */

      if (SAME_TYPE(t, scheme_always_evt_type)) {
       /* Fast path: always-evt is ready */
       return complete_peeked_read_via_get(ip, size);
      }

      /* This sema makes other threads wait before reading: */
      sema = scheme_make_sema(0);
      ip->input_lock = sema;
      
      /* This sema lets other threads try to make progress,
        if the current target doesn't work out */
      sema = scheme_make_sema(0);
      ip->input_giveup = sema;
      
      if (ip->input_extras) {
       /* There are other threads trying to commit, and
          as main thread, we'll help them out. */
       n = 3;
       for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
         n++;
       }
       aa = MALLOC_N(Scheme_Object *, n);
       n = 3;
       for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
         aa[n++] = SCHEME_CDR(SCHEME_CAR(l));
       }
      } else {
       /* This is the only thread trying to commit */
       n = 3;
       aa = a;
      }

      /* Suspend here is a problem if another thread
        tries to commit, because this thread will be
        responsible for multiplexing the commits. That's
        why the thread waits on its own suspend event. */
      
      aa[0] = target_evt;
      aa[1] = ip->input_giveup;
      v = scheme_get_thread_suspend(scheme_current_thread);
      aa[2] = v;

      scheme_current_thread->running |= MZTHREAD_NEED_SUSPEND_CLEANUP;
      BEGIN_ESCAPEABLE(release_input_lock_and_elect_new_main, ip);
      v = scheme_sync(n, aa);
      END_ESCAPEABLE();

      release_input_lock(ip);
      
      if (SAME_OBJ(v, target_evt)) {
       int r;
       elect_new_main(ip);
       r = complete_peeked_read_via_get(ip, size);
       check_suspended();
       return r;
      }

      if (n > 3) {
       /* Check whether one of the others was selected: */
       for (l = ip->input_extras; l; l = SCHEME_CDR(l)) {
         if (SAME_OBJ(v, SCHEME_CDR(SCHEME_CAR(l)))) {
           /* Yep. Clear the cdr to tell the relevant thread
              that it was selected, and reset the extras. */
           v = SCHEME_CAR(l);
           SCHEME_CDR(v) = NULL;
           size = SCHEME_INT_VAL(SCHEME_CAR(v));
           elect_new_main(ip);
           if (complete_peeked_read_via_get(ip, size))
             SCHEME_CAR(v) = scheme_true;
           else
             SCHEME_CAR(v) = scheme_false;
           check_suspended();
           return 0;
         }
       }
      }

      if (scheme_current_thread->running & MZTHREAD_USER_SUSPENDED) {
       elect_new_main(ip);
       current_leader = 0;
       check_suspended();
      } else {
       current_leader = 1;
       
       /* Technically redundant, but avoid a thread swap
          if we know the commit isn't going to work: */
       if (scheme_wait_sema(unless_evt, 1)) {
         elect_new_main(ip);
         return 0;
       }
      
       scheme_thread_block(0.0);
      }
    }
  }
}

Here is the call graph for this function:

Definition at line 1499 of file port.c.

{
  return pipe_char_count(p);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2376 of file port.c.

{  
  Scheme_Input_Port *ip;
  
  ip = scheme_input_port_record(port);
  
  if (ip->progress_evt_fun) {
    Scheme_Progress_Evt_Fun ce;
    Scheme_Object *evt, *o;

    ce = ip->progress_evt_fun;

    evt = ce(ip);

    o = scheme_alloc_object();
    o->type = scheme_progress_evt_type;
    SCHEME_PTR1_VAL(o) = (Scheme_Object *)port;
    SCHEME_PTR2_VAL(o) = evt;

    return o;
  }

  return NULL;
}

Definition at line 2362 of file port.c.

{
  Scheme_Object *sema;

  if (port->progress_evt)
    return port->progress_evt;

  sema = scheme_make_sema(0);

  port->progress_evt = sema;

  return sema;
}
long scheme_put_byte_string ( const char *  who,
Scheme_Object port,
const char *  str,
long  d,
long  len,
int  rarely_block 
)

Definition at line 3422 of file port.c.

{
  /* Unlike the main reader, the main writer is simple. It doesn't
     have to deal with peeks and specials, so it's a thin wrapper on
     the port's function. */

  Scheme_Output_Port *op;
  Scheme_Write_String_Fun ws;
  long out, llen, oout;
  int enable_break;

  op = scheme_output_port_record(port);

  CHECK_PORT_CLOSED(who, "output", port, op->closed);

  ws = op->write_string_fun;

  if (rarely_block == -1) {
    enable_break = 1;
    rarely_block = 1;
  } else
    enable_break = 0;

  if (enable_break) {
    if (scheme_current_thread->external_break) {
      scheme_thread_block_enable_break(0.0, 1);
      scheme_current_thread->ran_some = 1;
    }
  }

  if ((rarely_block == 1) && !len)
    /* By definition, a partial-progress write on a 0-length string is
       the same as a blocking flush */
    rarely_block = 0;

  llen = len;
  oout = 0;
  while (llen || !len) {
    out = ws(op, str, d, llen, rarely_block, enable_break);
    
    /* If out is 0, it might be because the port got closed: */
    if (!out) {
      CHECK_PORT_CLOSED(who, "output", port, op->closed);
    }
    
    if (out > 0) {
      op->p.position += out;
      oout += out;
      if (op->p.count_lines)
       do_count_lines((Scheme_Port *)op, str, d, out);
    }

    if (rarely_block || !len)
      break;

    llen -= out;
    d += out;
  }

  mzAssert(!rarely_block ? (oout == len) : 1);
  mzAssert((oout < 0) ? (rarely_block == 2) : 1);

  return oout;
}

Here is the call graph for this function:

long scheme_put_char_string ( const char *  who,
Scheme_Object port,
const mzchar str,
long  d,
long  len 
)

Definition at line 3505 of file port.c.

{
  long blen;
  char *bstr, buf[64];

  blen = scheme_utf8_encode(str, d, d + len, NULL, 0, 0);
  if (blen < 64)
    bstr = buf;
  else
    bstr = (char *)scheme_malloc_atomic(blen);
  scheme_utf8_encode(str, d, d + len, (unsigned char *)bstr, 0, 0);

  return scheme_put_byte_string(who, port, bstr, 0, blen, 0);
}

Definition at line 8041 of file port.c.

{
#ifdef USE_FD_PORTS
  if (fd_reserved) {
    close(the_fd);
    fd_reserved = 0;
  }
#endif
}

Here is the caller graph for this function:

Definition at line 8030 of file port.c.

{
#ifdef USE_FD_PORTS
  if (!fd_reserved) {
    the_fd = open("/dev/null", O_RDONLY); 
    if (the_fd != -1)
      fd_reserved = 1;
  }
#endif
}

Here is the caller graph for this function:

Definition at line 316 of file port.c.

long scheme_set_file_position ( Scheme_Object port,
long  pos 
)

Definition at line 4607 of file port.c.

{
  if (pos >= 0) {
    Scheme_Object *a[2];

    a[0] = port;
    a[1] = scheme_make_integer(pos);
    (void)scheme_file_position(2, a);
    return 0;
  } else {
    Scheme_Object *n;
    n = scheme_file_position(1, &port);
    return SCHEME_INT_VAL(n);
  }
}

Here is the call graph for this function:

Definition at line 1281 of file port.c.

{
  new_port_cust = c;
}

Definition at line 1343 of file port.c.

{
  port->count_lines_fun = count_lines_fun;
}

Definition at line 1337 of file port.c.

{
  port->location_fun = location_fun;
}

Definition at line 8347 of file port.c.

{
#if defined(FILES_HAVE_FDS)
  if (put_external_event_fd) {
    int v;
    do {
      v = write(put_external_event_fd, "!", 1);
    } while ((v == -1) && (errno == EINTR));
  }
#endif
#if defined(WINDOWS_PROCESSES) || defined(WINDOWS_FILE_HANDLES)
  ReleaseSemaphore(scheme_break_semaphore, 1, NULL);
#endif
}
void scheme_start_sleeper_thread ( void(*)(float seconds, void *fds)  given_sleep,
float  secs,
void fds,
int  hit_fd 
)

Definition at line 8581 of file port.c.

{
}
long scheme_tell ( Scheme_Object port)

Definition at line 3235 of file port.c.

{
  Scheme_Port *ip;
  long pos;

  ip = scheme_port_record(port);
  
  CHECK_IOPORT_CLOSED("get-file-position", ip);

  if (!ip->count_lines || (ip->position < 0))
    pos = ip->position;
  else
    pos = ip->readpos;

  return pos;
}
void scheme_tell_all ( Scheme_Object port,
long *  _line,
long *  _col,
long *  _pos 
)

Definition at line 3289 of file port.c.

{
  Scheme_Port *ip;
  long line = -1, col = -1, pos = -1;
  
  ip = scheme_port_record(port);

  if (ip->count_lines && ip->location_fun) {
    Scheme_Location_Fun location_fun;
    Scheme_Object *r, *a[3];
    long v;
    int got, i;
    
    location_fun = ip->location_fun;
    r = location_fun(ip);

    got = (SAME_OBJ(r, SCHEME_MULTIPLE_VALUES) ? scheme_multiple_count : 1);
    if (got != 3) {
      scheme_wrong_return_arity("user port next-location",
                            3, got, 
                            (got == 1) ? (Scheme_Object **)r : scheme_multiple_array,
                            "calling port-next-location procedure");
      return;
    }

    a[0] = scheme_multiple_array[0];
    a[1] = scheme_multiple_array[1];
    a[2] = scheme_multiple_array[2];

    for (i = 0; i < 3; i++) {
      v = -1;
      if (SCHEME_TRUEP(a[i])) {
       if (scheme_nonneg_exact_p(a[i])) {
         if (SCHEME_INTP(a[i])) {
           v = SCHEME_INT_VAL(a[i]);
           if ((i != 1) && !v) {
             a[0] = a[i];
             scheme_wrong_type("user port next-location", 
                            ((i == 1) ? "non-negative exact integer or #f" : "positive exact integer or #f"),
                            -1, -1, a);
             return;
           }
         }
       }
      }
      switch(i) {
      case 0:
       line = v;
       break;
      case 1:
       col = v;
       break;
      case 2:
       pos = v;
       break;
      }
    }

    /* Internally, positions count from 0 instead of 1 */
    if (pos > -1)
      pos--;
  } else {
    line = scheme_tell_line(port);
    col = scheme_tell_column(port);
    pos = scheme_tell(port);
  }

  if (_line) *_line = line;
  if (_col) *_col = col;
  if (_pos) *_pos = pos;  
}

Here is the call graph for this function:

Definition at line 3271 of file port.c.

{
  Scheme_Port *ip;
  long col;

  ip = scheme_port_record(port);

  if (!ip->count_lines || (ip->position < 0))
    return -1;
  
  CHECK_IOPORT_CLOSED("get-file-column", ip);

  col = ip->column;

  return col;
}
long scheme_tell_line ( Scheme_Object port)

Definition at line 3253 of file port.c.

{
  Scheme_Port *ip;
  long line;

  ip = scheme_port_record(port);

  if (!ip->count_lines || (ip->position < 0))
    return -1;

  CHECK_IOPORT_CLOSED("get-file-line", ip);

  line = ip->lineNumber;

  return line;
}

Definition at line 3723 of file port.c.

{
  long fd = 0;
  int fd_ok = 0;
  Scheme_Object *p;

  p = argv[0];

  if (SCHEME_INPUT_PORTP(p)) {
    Scheme_Input_Port *ip;

    ip = scheme_input_port_record(p);

    if (ip->closed)
      return scheme_false;

    if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
      fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
      fd_ok = 1;
    }
#ifdef MZ_FDS
    else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
      fd = ((Scheme_FD *)ip->port_data)->fd;
      fd_ok = 1;
    }
#endif
  } else if (SCHEME_OUTPUT_PORTP(p)) {
    Scheme_Output_Port *op;

    op = scheme_output_port_record(p);

    if (op->closed)
      return scheme_false;

    if (SAME_OBJ(op->sub_type, file_output_port_type))  {
      fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
      fd_ok = 1;
    }
#ifdef MZ_FDS
    else if (SAME_OBJ(op->sub_type, fd_output_port_type))  {
      fd = ((Scheme_FD *)op->port_data)->fd;
      fd_ok = 1;
    }
#endif
  }

  if (!fd_ok)
    return scheme_false;

  return is_fd_terminal(fd) ? scheme_true : scheme_false;
}

Here is the call graph for this function:

Here is the caller graph for this function:

void scheme_ungetc ( int  ch,
Scheme_Object port 
)

Definition at line 2983 of file port.c.

{
  Scheme_Input_Port *ip;

  ip = scheme_input_port_record(port);

  CHECK_PORT_CLOSED("#<primitive:peek-port-char>", "input", port, ip->closed);

  if (ch == EOF) {
    if (ip->pending_eof) /* non-zero means that EOFs are tracked */
      ip->pending_eof = 2;
    return;
  } else if (ch == SCHEME_SPECIAL) {
    ip->ungotten_special = ip->special;
    ip->special = NULL;
  } else if (ch > 127) {
    unsigned char e[MAX_UTF8_CHAR_BYTES];
    unsigned int us[1];
    int len;

    us[0] = ch;
    len = scheme_utf8_encode_all(us, 1, e);

    if (ip->ungotten_count + len >= 24)
      scheme_signal_error("ungetc overflow");
    while (len) {
      ip->ungotten[ip->ungotten_count++] = e[--len];
    }
  } else {
    if (ip->ungotten_count == 24)
      scheme_signal_error("ungetc overflow");
    ip->ungotten[ip->ungotten_count++] = ch;
  }

  if (ip->p.position > 0)
    --ip->p.position;
  if (ip->p.count_lines) {
    --ip->p.column;
    --ip->p.readpos;
    if (!(--ip->p.charsSinceNewline)) {
      mzAssert(ip->p.lineNumber > 0);
      --ip->p.lineNumber;
      ip->p.column = ip->p.oldColumn;
    } else if (ch == '\t')
      ip->p.column = ip->p.oldColumn;
  }
}

Definition at line 2034 of file port.c.

{
  if (!unless)
    return 0;

  if (SCHEME_CAR(unless) && SCHEME_TRUEP(SCHEME_CAR(unless)))
    return 1;

  if (SCHEME_CDR(unless))
    return scheme_try_plain_sema(SCHEME_CDR(unless));

  return 0;
}

Definition at line 2049 of file port.c.

{
  while (ip->input_lock) {
    scheme_post_sema_all(ip->input_giveup);
    scheme_wait_sema(ip->input_lock, nonblock ? -1 : 0);
  }
}
void scheme_write_byte_string ( const char *  str,
long  len,
Scheme_Object port 
)

Definition at line 3489 of file port.c.

{
  (void)scheme_put_byte_string("write-string", port, str, 0, len, 0);
}

Here is the call graph for this function:

void scheme_write_char_string ( const mzchar str,
long  len,
Scheme_Object port 
)

Definition at line 3494 of file port.c.

{
  long blen;
  char *bstr, buf[64];

  bstr = scheme_utf8_encode_to_buffer_len(str, len, buf, 64, &blen);
  
  scheme_write_byte_string(bstr, blen, port);
}
Scheme_Object* scheme_write_evt_via_write ( Scheme_Output_Port port,
const char *  str,
long  offset,
long  size 
)

Definition at line 2942 of file port.c.

Here is the call graph for this function:

Definition at line 2949 of file port.c.

{
  return make_read_write_evt(scheme_write_evt_type, (Scheme_Object *)port, special, 
                          NULL, 0, 1);
}

Here is the call graph for this function:

static Scheme_Object * subprocess ( int  c,
Scheme_Object args[] 
) [static]

Definition at line 7393 of file port.c.

{
  const char *name = "subprocess";
#if defined(PROCESS_FUNCTION) && !defined(MAC_CLASSIC_PROCESS_CONTROL)
  char *command;
  int to_subprocess[2], from_subprocess[2], err_subprocess[2];
  int i, pid;
  char **argv;
  Scheme_Object *in, *out, *err;
#if defined(UNIX_PROCESSES)
  System_Child *sc;
  int fork_errno = 0;
#else
  void *sc = 0;
#endif
  Scheme_Object *inport;
  Scheme_Object *outport;
  Scheme_Object *errport;
  Scheme_Object *a[4];
  Scheme_Subprocess *subproc;
#if defined(WINDOWS_PROCESSES)
  int exact_cmdline = 0;
#endif
#if defined(WINDOWS_PROCESSES)
  int spawn_status;
#endif

  /*--------------------------------------------*/
  /* Sort out ports (create later if necessary) */
  /*--------------------------------------------*/

  if (SCHEME_TRUEP(args[0])) {
    outport = args[0];
    if (SCHEME_OUTPUT_PORTP(outport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &outport))) {
#ifdef PROCESS_FUNCTION
      Scheme_Output_Port *op;

      op = scheme_output_port_record(outport);

      if (SAME_OBJ(op->sub_type, file_output_port_type)) {
       int tmp;
       tmp = MSC_IZE(fileno)(((Scheme_Output_File *)op->port_data)->f);
       from_subprocess[1] = tmp;
      }
# ifdef MZ_FDS
      else if (SAME_OBJ(op->sub_type, fd_output_port_type))
       from_subprocess[1] = ((Scheme_FD *)op->port_data)->fd;
# endif
#endif
    } else
      scheme_wrong_type(name, "file-stream-output-port", 0, c, args);
  } else
    outport = NULL;

  if (SCHEME_TRUEP(args[1])) {
    inport = args[1];
    if (SCHEME_INPUT_PORTP(inport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &inport))) {
#ifdef PROCESS_FUNCTION
      Scheme_Input_Port *ip;

      ip = scheme_input_port_record(inport);

      if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
       int tmp;
       tmp = MSC_IZE(fileno)(((Scheme_Input_File *)ip->port_data)->f);
       to_subprocess[0] = tmp;
      }
# ifdef MZ_FDS
      else if (SAME_OBJ(ip->sub_type, fd_input_port_type))
       to_subprocess[0] = ((Scheme_FD *)ip->port_data)->fd;
# endif
#endif
    } else
      scheme_wrong_type(name, "file-stream-input-port", 1, c, args);
  } else
    inport = NULL;

  if (SCHEME_TRUEP(args[2])) {
    errport = args[2];
    if (SCHEME_OUTPUT_PORTP(errport) && SCHEME_TRUEP(scheme_file_stream_port_p(1, &errport))) {
#ifdef PROCESS_FUNCTION
      Scheme_Output_Port *op;

      op = scheme_output_port_record(errport);

      if (SAME_OBJ(op->sub_type, file_output_port_type)) {
       int tmp;
       tmp = MSC_IZE(fileno)(((Scheme_Output_File *)op->port_data)->f);
       err_subprocess[1] = tmp;
      }
# ifdef MZ_FDS
      else if (SAME_OBJ(op->sub_type, fd_output_port_type))
       err_subprocess[1] = ((Scheme_FD *)op->port_data)->fd;
# endif
#endif
    } else
      scheme_wrong_type(name, "file-stream-output-port", 2, c, args);
  } else
    errport = NULL;

  if (!SCHEME_PATH_STRINGP(args[3]))
    scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 3, c, args);

  /*--------------------------------------*/
  /*          Sort out arguments          */
  /*--------------------------------------*/

  argv = MALLOC_N(char *, c - 3 + 1);
  {
    char *ef;
    ef = scheme_expand_string_filename(args[3],
                                   (char *)name, 
                                   NULL,
                                   SCHEME_GUARD_FILE_EXECUTE);
    argv[0] = ef;
  }
  {
    /* This is for Windows: */
    char *np;
    int nplen;
    nplen = strlen(argv[0]);
    np = scheme_normal_path_seps(argv[0], &nplen, 0);
    argv[0] = np;
  }

  if ((c == 6) && SAME_OBJ(args[4], exact_symbol)) {
    argv[2] = NULL;
    if (!SCHEME_CHAR_STRINGP(args[5]) || scheme_any_string_has_null(args[5]))
      scheme_wrong_type(name, CHAR_STRING_W_NO_NULLS, 5, c, args);
    {
      Scheme_Object *bs;
      bs = scheme_char_string_to_byte_string(args[5]);
      argv[1] = SCHEME_BYTE_STR_VAL(bs);
    }
#ifdef WINDOWS_PROCESSES
    exact_cmdline = 1;
#else
    /* 'exact-full only works in windows */
    scheme_arg_mismatch(name,
                     "exact command line not supported on this platform: ",
                     args[5]);
#endif
  } else {
    for (i = 4; i < c; i++) {
      if (!SCHEME_CHAR_STRINGP(args[i]) || scheme_any_string_has_null(args[i]))
       scheme_wrong_type(name, CHAR_STRING_W_NO_NULLS, i, c, args);
      {
       Scheme_Object *bs;
       bs = scheme_char_string_to_byte_string_locale(args[i]);
       argv[i - 3] = SCHEME_BYTE_STR_VAL(bs);
      }
    }
    argv[c - 3] = NULL;
  }

  command = argv[0];

  if (!inport || !outport || !errport)
    scheme_custodian_check_available(NULL, name, "file-stream");

  /*--------------------------------------*/
  /*          Create needed pipes         */
  /*--------------------------------------*/

  if (!inport && PIPE_FUNC(to_subprocess, 1 _EXTRA_PIPE_ARGS))
    scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
  if (!outport && PIPE_FUNC(from_subprocess, 0 _EXTRA_PIPE_ARGS)) {
    if (!inport) {
      MSC_IZE(close)(to_subprocess[0]);
      MSC_IZE(close)(to_subprocess[1]);
    }
    scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
  }
  if (!errport && PIPE_FUNC(err_subprocess, 0 _EXTRA_PIPE_ARGS)) {
    if (!inport) {
      MSC_IZE(close)(to_subprocess[0]);
      MSC_IZE(close)(to_subprocess[1]);
    }
    if (!outport) {
      MSC_IZE(close)(from_subprocess[0]);
      MSC_IZE(close)(from_subprocess[1]);
    }
    scheme_raise_exn(MZEXN_FAIL, "%s: pipe failed (%e)", name, errno);
  }

#if defined(WINDOWS_PROCESSES)

  /*--------------------------------------*/
  /*        Execute: Windows              */
  /*--------------------------------------*/

  /* Windows: quasi-stdin is locked, and we'll say it doesn't matter */
  fflush(stdin);
  fflush(stdout);
  fflush(stderr);

  {
    Scheme_Object *tcd;

    if (!exact_cmdline) {
      /* protect spaces, etc. in the arguments: */
      for (i = 0; i < (c - 3); i++) {
       char *cla;
       cla = cmdline_protect(argv[i]);
       argv[i] = cla;
      }
    }

    /* Set real CWD before spawn: */
    tcd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
    scheme_os_setcwd(SCHEME_BYTE_STR_VAL(tcd), 0);

    spawn_status = mz_spawnv(command, (const char * const *)argv,
                          exact_cmdline,
                          to_subprocess[0],
                          from_subprocess[1],
                          err_subprocess[1],
                          &pid);

    if (spawn_status != -1)
      sc = (void *)spawn_status;
  }

# define mzCLOSE_PIPE_END(x) CloseHandle((HANDLE)(x))
#else


  /*--------------------------------------*/
  /*            Execute: Unix             */
  /*--------------------------------------*/

  {
    init_sigchld();

    sc = MALLOC_ONE_RT(System_Child);
#ifdef MZTAG_REQUIRED
    sc->type = scheme_rt_system_child;
#endif
    sc->id = 0;
    sc->done = 0;

    scheme_block_child_signals(1);

    pid = fork();

    if (pid > 0) {
      sc->next = scheme_system_children;
      scheme_system_children = sc;
      sc->id = pid;
    } else if (!pid) {
#ifdef USE_ITIMER
      /* Turn off the timer. */
      /* SIGPROF is masked at this point due to
        block_child_signals() */
      struct itimerval t, old;
      sigset_t sigs;

      t.it_value.tv_sec = 0;
      t.it_value.tv_usec = 0;
      t.it_interval.tv_sec = 0;
      t.it_interval.tv_usec = 0;

      setitimer(ITIMER_PROF, &t, &old);

      /* Clear already-queued PROF signal, if any: */
      START_XFORM_SKIP;
      sigemptyset(&sigs);
      while (!sigpending(&sigs)) {
       if (sigismember(&sigs, SIGPROF)) {
         sigprocmask(SIG_SETMASK, NULL, &sigs);
         sigdelset(&sigs, SIGPROF);
         sigsuspend(&sigs);
         sigemptyset(&sigs);
       } else
         break;
      }
      END_XFORM_SKIP;
#endif
    } else {
      fork_errno = errno;
    }

    scheme_block_child_signals(0);
  }

  switch (pid)
    {
    case -1:
      /* Close unused descriptors. */
      if (!inport) {
       MSC_IZE(close)(to_subprocess[0]);
       MSC_IZE(close)(to_subprocess[1]);
      }
      if (!outport) {
       MSC_IZE(close)(from_subprocess[0]);
       MSC_IZE(close)(from_subprocess[1]);
      }
      if (!errport) {
       MSC_IZE(close)(err_subprocess[0]);
       MSC_IZE(close)(err_subprocess[1]);
      }
      scheme_raise_exn(MZEXN_FAIL, "%s: fork failed (%e)", name, fork_errno);
      return scheme_false;

    case 0: /* child */

      {
       /* Copy pipe descriptors to stdin and stdout */
       MSC_IZE(dup2)(to_subprocess[0], 0);
       MSC_IZE(dup2)(from_subprocess[1], 1);
       MSC_IZE(dup2)(err_subprocess[1], 2);

       /* Close unwanted descriptors. */
       if (!inport) {
         MSC_IZE(close)(to_subprocess[0]);
         MSC_IZE(close)(to_subprocess[1]);
       }
       if (!outport) {
         MSC_IZE(close)(from_subprocess[0]);
         MSC_IZE(close)(from_subprocess[1]);
       }
       if (!errport) {
         MSC_IZE(close)(err_subprocess[0]);
         MSC_IZE(close)(err_subprocess[1]);
       }

#ifdef CLOSE_ALL_FDS_AFTER_FORK
       /* Actually, unwanted includes everything
          except stdio. */
#ifdef USE_ULIMIT
       i = ulimit(4, 0);
#else
       i = getdtablesize();
#endif
       while (i-- > 3) {
         int cr;
         do {
           cr = close(i);
         } while ((cr == -1) && (errno == EINTR));
       }
#endif
      }

      /* Set real CWD */
      {
       Scheme_Object *dir;
       dir = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
       scheme_os_setcwd(SCHEME_PATH_VAL(dir), 0);
      }

      /* Exec new process */

      {
       int err;

       /* Reset ignored signals: */
       START_XFORM_SKIP;
#ifndef DONT_IGNORE_FPE_SIGNAL
       MZ_SIGSET(SIGFPE, SIG_DFL);
#endif
#ifndef DONT_IGNORE_PIPE_SIGNAL
       MZ_SIGSET(SIGPIPE, SIG_DFL);
#endif
       END_XFORM_SKIP;

       err = MSC_IZE(execv)(command, argv);

       /* If we get here it failed; give up */

        /* using scheme_signal_error will leave us in the forked process,
          so use scheme_console_printf instead */
        scheme_console_printf("mzscheme: exec failed (%d)\n", err);

       /* back to MzScheme signal dispositions: */
       START_XFORM_SKIP;
#ifndef DONT_IGNORE_FPE_SIGNAL
       MZ_SIGSET(SIGFPE, SIG_IGN);
#endif
#ifndef DONT_IGNORE_PIPE_SIGNAL
       MZ_SIGSET(SIGPIPE, SIG_IGN);
#endif
       END_XFORM_SKIP;

       _exit(1);
      }

    default: /* parent */

      break;
    }
# define mzCLOSE_PIPE_END(x) MSC_IZE(close)(x)
#endif

  /*--------------------------------------*/
  /*      Close unneeded descriptors      */
  /*--------------------------------------*/

  if (!inport) {
    mzCLOSE_PIPE_END(to_subprocess[0]);
    out = NULL;
    scheme_file_open_count += 1;
  } else
    out = scheme_false;
  if (!outport) {
    mzCLOSE_PIPE_END(from_subprocess[1]);
    in = NULL;
    scheme_file_open_count += 1;
  } else
    in = scheme_false;
  if (!errport) {
    mzCLOSE_PIPE_END(err_subprocess[1]);
    err = NULL;
    scheme_file_open_count += 1;
  } else
    err = scheme_false;

  /*--------------------------------------*/
  /*        Create new port objects       */
  /*--------------------------------------*/

  in = (in ? in : make_fd_input_port(from_subprocess[0], scheme_intern_symbol("subprocess-stdout"), 0, 0, NULL, 0));
  out = (out ? out : make_fd_output_port(to_subprocess[1], scheme_intern_symbol("subprocess-stdin"), 0, 0, 0, -1));
  err = (err ? err : make_fd_input_port(err_subprocess[0], scheme_intern_symbol("subprocess-stderr"), 0, 0, NULL, 0));

  /*--------------------------------------*/
  /*          Return result info          */
  /*--------------------------------------*/

  subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
  subproc->so.type = scheme_subprocess_type;
  subproc->handle = (void *)sc;
  subproc->pid = pid;
# if defined(WINDOWS_PROCESSES)
  scheme_add_finalizer(subproc, close_subprocess_handle, NULL);
# endif

#define cons scheme_make_pair

  a[0] = (Scheme_Object *)subproc;
  a[1] = in;
  a[2] = out;
  a[3] = err;

  return scheme_values(4, a);

#else
# ifdef MAC_CLASSIC_PROCESS_CONTROL

  /*--------------------------------------*/
  /*            Macintosh hacks           */
  /*--------------------------------------*/

  {
    int i;
    Scheme_Object *a[4], *appname;
    Scheme_Subprocess *subproc;

    for (i = 0; i < 3; i++) {
      if (!SCHEME_FALSEP(args[i]))
       scheme_arg_mismatch(name,
                         "non-#f port argument not allowed on this platform: ",
                         args[i]);
    }

    if (c > 4) {
      if (c == 5) {
       Scheme_Object *bs;
       if (!SCHEME_PATH_STRINGP(args[3]))
         scheme_wrong_type(name, SCHEME_PATH_STRING_STR, 3, c, args);
       if (SCHEME_PATHP(args[3]))
         bs = args[3];
       else
         bs = scheme_char_string_to_path(args[3]);
       if (strcmp(SCHEME_PATH_VAL(bs), "by-id"))
         scheme_arg_mismatch(name,
                           "in five-argument mode on this platform, the 4th argument must be \"by-id\": ",
                           args[3]);

       appname = args[4];
       i = scheme_mac_start_app((char *)name, 1, appname);
      } else
       scheme_arg_mismatch(name,
                         "extra arguments after the application id are "
                         "not allowed on this platform: ",
                         args[5]);
    } else {
      appname = args[3];
      i = scheme_mac_start_app((char *)name, 0, appname);
    }

    if (!i) {
      scheme_raise_exn(MZEXN_FAIL, "%s: launch failed for application: %Q", name, appname);
      return NULL;
    }

    subproc = MALLOC_ONE_TAGGED(Scheme_Subprocess);
    subproc->type = scheme_subprocess_type;

    a[0] = (Scheme_Object *)subproc;
    a[1] = scheme_false;
    a[2] = scheme_false;
    a[3] = scheme_false;

    return scheme_values(4, a);
  }

# else
  /*--------------------------------------*/
  /*  Subprocess functionality disabled   */
  /*--------------------------------------*/

  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                 "%s: not supported on this platform",
                 name);
  return NULL;
# endif
#endif
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* subprocess_kill ( int  c,
Scheme_Object args[] 
) [static]

Here is the caller graph for this function:

static Scheme_Object* subprocess_kill ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 7196 of file port.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
    scheme_wrong_type("subprocess-kill", "subprocess", 0, argc, argv);

#if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
  {
    Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];

#if defined(UNIX_PROCESSES)
    {
      System_Child *sc = (System_Child *)sp->handle;

      check_child_done();

      while (1) {
       if (sc->done)
         return scheme_void;

       if (!kill(sp->pid, SCHEME_TRUEP(argv[1]) ? SIGKILL : SIGINT))
         return scheme_void;

       if (errno != EINTR)
         break;
       /* Otherwise we were interrupted. Try `kill' again. */
      }
    }
#else
    if (SCHEME_TRUEP(argv[1])) {
      DWORD w;
      int errid;

      if (!sp->handle)
       return scheme_void;

      if (GetExitCodeProcess((HANDLE)sp->handle, &w)) {
       if (w != STILL_ACTIVE)
         return scheme_void;
       if (TerminateProcess((HANDLE)sp->handle, 1))
         return scheme_void;
      }
      errid = GetLastError();
      errno = errid;
    } else
      return scheme_void;
#endif

    scheme_raise_exn(MZEXN_FAIL, "subprocess-kill: failed (%E)", errno);

    return NULL;
  }
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                 "%s: not supported on this platform",
                 "subprocess-wait");
#endif
}
static Scheme_Object* subprocess_p ( int  c,
Scheme_Object args[] 
) [static]

Here is the caller graph for this function:

static Scheme_Object* subprocess_p ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 7262 of file port.c.

static Scheme_Object* subprocess_pid ( int  c,
Scheme_Object args[] 
) [static]

Here is the caller graph for this function:

static Scheme_Object* subprocess_pid ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 7254 of file port.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
    scheme_wrong_type("subprocess-pid", "subprocess", 0, argc, argv);

  return scheme_make_integer_value(((Scheme_Subprocess *)argv[0])->pid);
}
static Scheme_Object* subprocess_status ( int  c,
Scheme_Object args[] 
) [static]

Here is the caller graph for this function:

static Scheme_Object* subprocess_status ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 7121 of file port.c.

{
  Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
    scheme_wrong_type("subprocess-status", "subprocess", 0, argc, argv);

#if defined(PROCESS_FUNCTION) && !defined(MAC_CLASSIC_PROCESS_CONTROL)
  {
    int going = 0, status = MZ_FAILURE_STATUS;

#if defined(UNIX_PROCESSES)
    System_Child *sc = (System_Child *)sp->handle;

    check_child_done();

    if (sc->done)
      status = sc->status;
    else
      going = 1;
#else
# ifdef WINDOWS_PROCESSES
    DWORD w;
    if (sp->handle) {
      if (GetExitCodeProcess((HANDLE)sp->handle, &w)) {
       if (w == STILL_ACTIVE)
         going = 1;
       else
         status = w;
      }
    }
# endif
#endif

    if (going)
      return scheme_intern_symbol("running");
    else
      return scheme_make_integer_value(status);
  }
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                 "%s: not supported on this platform",
                 "subprocess-status");
#endif
}
static Scheme_Object* subprocess_wait ( int  c,
Scheme_Object args[] 
) [static]

Here is the caller graph for this function:

static Scheme_Object* subprocess_wait ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 7176 of file port.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_subprocess_type))
    scheme_wrong_type("subprocess-wait", "subprocess", 0, argc, argv);

#if defined(UNIX_PROCESSES) || defined(WINDOWS_PROCESSES)
  {
    Scheme_Subprocess *sp = (Scheme_Subprocess *)argv[0];

    scheme_block_until(subp_done, subp_needs_wakeup, (Scheme_Object *)sp, (float)0.0);

    return scheme_void;
  }
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
                 "%s: not supported on this platform",
                 "subprocess-wait");
#endif
}

Variable Documentation

Definition at line 410 of file port.c.

Definition at line 409 of file port.c.

Definition at line 410 of file port.c.

Definition at line 410 of file port.c.

Definition at line 416 of file port.c.

Definition at line 327 of file port.c.

Definition at line 336 of file port.c.

int flush_err [static]

Definition at line 348 of file port.c.

int flush_out [static]

Definition at line 347 of file port.c.

Definition at line 412 of file port.c.

Definition at line 350 of file port.c.

char* read_string_byte_buffer [static]

Definition at line 419 of file port.c.

Definition at line 411 of file port.c.

Definition at line 315 of file port.c.

Definition at line 414 of file port.c.

Definition at line 304 of file port.c.

Definition at line 313 of file port.c.

Definition at line 345 of file port.c.

Definition at line 414 of file port.c.

Definition at line 311 of file port.c.

Definition at line 309 of file port.c.

Definition at line 310 of file port.c.

Definition at line 414 of file port.c.

Definition at line 342 of file port.c.

Definition at line 306 of file port.c.

Definition at line 307 of file port.c.

Definition at line 305 of file port.c.

Definition at line 340 of file port.c.

Definition at line 341 of file port.c.

Definition at line 343 of file port.c.

Definition at line 328 of file port.c.

Definition at line 337 of file port.c.

Definition at line 338 of file port.c.

Definition at line 339 of file port.c.

int special_is_ok [static]

Definition at line 318 of file port.c.

Definition at line 409 of file port.c.

Definition at line 411 of file port.c.

Definition at line 411 of file port.c.

Definition at line 410 of file port.c.