code:
/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008, 2009, 2010 Free Software
 * Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include <unistd.h>
#include <unicase.h>

#include "libguile/_scm.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/arrays.h"
#include "libguile/bitvectors.h"
#include "libguile/keywords.h"
#include "libguile/alist.h"
#include "libguile/srcprop.h"
#include "libguile/hashtab.h"
#include "libguile/hash.h"
#include "libguile/ports.h"
#include "libguile/fports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
#include "libguile/validate.h"
#include "libguile/srfi-4.h"
#include "libguile/srfi-13.h"

#include "libguile/read.h"
#include "libguile/private-options.h"

SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
SCM_SYMBOL (scm_keyword_prefix, "prefix");
SCM_SYMBOL (scm_keyword_postfix, "postfix");
SCM_SYMBOL (sym_nil, "nil");

scm_t_option scm_read_opts[] = {
  { SCM_OPTION_BOOLEAN, "copy", 0,
    "Copy source code expressions." },
  { SCM_OPTION_BOOLEAN, "positions", 0,
    "Record positions of source code expressions." },
  { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
    "Convert symbols to lower case."},
  { SCM_OPTION_SCM, "keywords", (unsigned long) SCM_BOOL_F,
    "Style of keyword recognition: #f, 'prefix or 'postfix."},
  { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
    "Support Elisp vector syntax, namely `[...]'."},
  { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
    "Support `\\(' and `\\)' in strings."},
  { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
    "Use R6RS variable-length character and string hex escapes."},
  { SCM_OPTION_BOOLEAN, "square-brackets", 1,
    "Treat `[' and `]' as parentheses, for R6RS compatibility."},
  { 0, },
};

/*
  Give meaningful error messages for errors

  We use the format

  FILE:LINE:COL: MESSAGE
  This happened in ....

  This is not standard GNU format, but the test-suite likes the real
  message to be in front.

 */

void
scm_i_input_error (char const *function,
		   SCM port, const char *message, SCM arg)
{
  SCM fn = (scm_is_string (SCM_FILENAME(port))
	    ? SCM_FILENAME(port)
	    : scm_from_locale_string ("#<unknown port>"));

  SCM string_port = scm_open_output_string ();
  SCM string = SCM_EOL;
  scm_simple_format (string_port,
		     scm_from_locale_string ("~A:~S:~S: ~A"),
		     scm_list_4 (fn,
				 scm_from_long (SCM_LINUM (port) + 1),
				 scm_from_int (SCM_COL (port) + 1),
				 scm_from_locale_string (message)));

  string = scm_get_output_string (string_port);
  scm_close_output_port (string_port);
  scm_error_scm (scm_from_locale_symbol ("read-error"),
		 function? scm_from_locale_string (function) : SCM_BOOL_F,
		 string,
		 arg,
		 SCM_BOOL_F);
}

SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
            (SCM setting),
	    "Option interface for the read options. Instead of using\n"
	    "this procedure directly, use the procedures @code{read-enable},\n"
	    "@code{read-disable}, @code{read-set!} and @code{read-options}.")
#define FUNC_NAME s_scm_read_options
{
  SCM ans = scm_options (setting,
			 scm_read_opts,
			 FUNC_NAME);
  if (SCM_COPY_SOURCE_P)
    SCM_RECORD_POSITIONS_P = 1;
  return ans;
}
#undef FUNC_NAME

/* An association list mapping extra hash characters to procedures.  */
static SCM *scm_read_hash_procedures;

/* Token readers.  */

/* Size of the C buffer used to read symbols and numbers.  */
#define READER_BUFFER_SIZE            128

/* Size of the C buffer used to read strings.  */
#define READER_STRING_BUFFER_SIZE     512

/* The maximum size of Scheme character names.  */
#define READER_CHAR_NAME_MAX_SIZE      50

/* `isblank' is only in C99.  */
#define CHAR_IS_BLANK_(_chr)					\
  (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n')	\
   || ((_chr) == '\f') || ((_chr) == '\r'))

#ifdef MSDOS
# define CHAR_IS_BLANK(_chr)			\
  ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
#else
# define CHAR_IS_BLANK CHAR_IS_BLANK_
#endif

/* R5RS one-character delimiters (see section 7.1.1, ``Lexical
   structure'').  */
#define CHAR_IS_R5RS_DELIMITER(c)				\
  (CHAR_IS_BLANK (c)						\
   || (c == ')') || (c == '(') || (c == ';') || (c == '"')      \
   || (SCM_SQUARE_BRACKETS_P && ((c == '[') || (c == ']'))))

#define CHAR_IS_DELIMITER  CHAR_IS_R5RS_DELIMITER

/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
   Structure''.  */
#define CHAR_IS_EXPONENT_MARKER(_chr)				\
  (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f')	\
   || ((_chr) == 'd') || ((_chr) == 'l'))

/* Read an SCSH block comment.  */
static inline SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
static SCM scm_read_commented_expression (scm_t_wchar, SCM);
static SCM scm_read_shebang (scm_t_wchar, SCM);
static SCM scm_get_hash_procedure (int);

/* Read from PORT until a delimiter (e.g., a whitespace) is read.  Put the
   result in the pre-allocated buffer BUF.  Return zero if the whole token has
   fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of
   bytes actually read.  */
static inline int
read_token (SCM port, char *buf, const size_t buf_size, size_t *read)
 {
   *read = 0;

   while (*read < buf_size)
     {
       int chr;

       chr = scm_get_byte_or_eof (port);

       if (chr == EOF)
        return 0;
      else if (CHAR_IS_DELIMITER (chr))
        {
          scm_unget_byte (chr, port);
          return 0;
        }
      else
        {
          *buf = (char) chr;
          buf++, (*read)++;
        }
     }

   return 1;
 }

/* Read from PORT until a delimiter (e.g., a whitespace) is read.  Put the
   result in the pre-allocated buffer BUFFER, if the whole token has fewer than
   BUFFER_SIZE bytes, or into OVERFLOW_BUFFER, allocated here to be freed by the
   caller.  Return zero if the token fits in BUFFER, non-zero otherwise. READ
   will be set the number of bytes actually read.  */
static int
read_complete_token (SCM port, char *buffer, const size_t buffer_size,
                           char **overflow_buffer, size_t *read)
{
  int overflow = 0;
  size_t bytes_read, overflow_size;

  *overflow_buffer = NULL;
  overflow_size = 0;

  do
    {
      overflow = read_token (port, buffer, buffer_size, &bytes_read);
      if (bytes_read == 0)
        break;
      if (overflow || overflow_size != 0)
        {
          if (overflow_size == 0)
            {
              *overflow_buffer = scm_malloc (bytes_read);
              memcpy (*overflow_buffer, buffer, bytes_read);
              overflow_size = bytes_read;
            }
          else
            {
              *overflow_buffer = scm_realloc (*overflow_buffer, overflow_size + bytes_read);
              memcpy (*overflow_buffer + overflow_size, buffer, bytes_read);
              overflow_size += bytes_read;
            }
        }
    }
  while (overflow);

  if (overflow_size)
    *read = overflow_size;
  else
    *read = bytes_read;

  return (overflow_size != 0);
}

/* Skip whitespace from PORT and return the first non-whitespace character
   read.  Raise an error on end-of-file.  */
static int
flush_ws (SCM port, const char *eoferr)
{
  register scm_t_wchar c;
  while (1)
    switch (c = scm_getc (port))
      {
      case EOF:
      goteof:
	if (eoferr)
	  {
	    scm_i_input_error (eoferr,
			       port,
			       "end of file",
			       SCM_EOL);
	  }
	return c;

      case ';':
      lp:
	switch (c = scm_getc (port))
	  {
	  case EOF:
	    goto goteof;
	  default:
	    goto lp;
	  case SCM_LINE_INCREMENTORS:
	    break;
	  }
	break;

      case '#':
	switch (c = scm_getc (port))
	  {
	  case EOF:
	    eoferr = "read_sharp";
	    goto goteof;
	  case '!':
	    scm_read_shebang (c, port);
	    break;
	  case ';':
	    scm_read_commented_expression (c, port);
	    break;
	  case '|':
	    if (scm_is_false (scm_get_hash_procedure (c)))
	      {
		scm_read_r6rs_block_comment (c, port);
		break;
	      }
	    /* fall through */
	  default:
	    scm_ungetc (c, port);
	    return '#';
	  }
	break;

      case SCM_LINE_INCREMENTORS:
      case SCM_SINGLE_SPACES:
      case '\t':
	break;

      default:
	return c;
      }

  return 0;
}

/* Token readers.  */

static SCM scm_read_expression (SCM port);
static SCM scm_read_sharp (int chr, SCM port);
static SCM recsexpr (SCM obj, long line, int column, SCM filename);

static SCM
scm_read_sexp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_i_lreadparen"
{
  register int c;
  register SCM tmp;
  register SCM tl, ans = SCM_EOL;
  SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
  const int terminating_char = ((chr == '[') ? ']' : ')');

  /* Need to capture line and column numbers here. */
  long line = SCM_LINUM (port);
  int column = SCM_COL (port) - 1;

  c = flush_ws (port, FUNC_NAME);
  if (terminating_char == c)
    return SCM_EOL;

  scm_ungetc (c, port);
  if (scm_is_eq (scm_sym_dot,
		 (tmp = scm_read_expression (port))))
    {
      ans = scm_read_expression (port);
      if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
	scm_i_input_error (FUNC_NAME, port, "missing close paren",
			   SCM_EOL);
      return ans;
    }

  /* Build the head of the list structure. */
  ans = tl = scm_cons (tmp, SCM_EOL);

  if (SCM_COPY_SOURCE_P)
    ans2 = tl2 = scm_cons (scm_is_pair (tmp)
			   ? copy
			   : tmp,
			   SCM_EOL);

  while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
    {
      SCM new_tail;

      if (c == ')' || (SCM_SQUARE_BRACKETS_P && c == ']'))
        scm_i_input_error (FUNC_NAME, port,
                           "in pair: mismatched close paren: ~A",
                           scm_list_1 (SCM_MAKE_CHAR (c)));

      scm_ungetc (c, port);
      tmp = scm_read_expression (port);

      if (scm_is_eq (scm_sym_dot, tmp))
	{
	  SCM_SETCDR (tl, tmp = scm_read_expression (port));

	  if (SCM_COPY_SOURCE_P)
	    SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
				       SCM_EOL));

	  c = flush_ws (port, FUNC_NAME);
	  if (terminating_char != c)
	    scm_i_input_error (FUNC_NAME, port,
			       "in pair: missing close paren", SCM_EOL);
	  goto exit;
	}

      new_tail = scm_cons (tmp, SCM_EOL);
      SCM_SETCDR (tl, new_tail);
      tl = new_tail;

      if (SCM_COPY_SOURCE_P)
	{
	  SCM new_tail2 = scm_cons (scm_is_pair (tmp)
				    ? copy
				    : tmp, SCM_EOL);
	  SCM_SETCDR (tl2, new_tail2);
	  tl2 = new_tail2;
	}
    }

 exit:
  if (SCM_RECORD_POSITIONS_P)
    scm_whash_insert (scm_source_whash,
		      ans,
		      scm_make_srcprops (line, column,
					 SCM_FILENAME (port),
					 SCM_COPY_SOURCE_P
					 ? ans2
					 : SCM_UNDEFINED,
					 SCM_EOL));
  return ans;
}
#undef FUNC_NAME

/* Read a hexadecimal number NDIGITS in length.  Put its value into the variable
   C.  If TERMINATOR is non-null, terminate early if the TERMINATOR character is
   found.  */
#define SCM_READ_HEX_ESCAPE(ndigits, terminator)                   \
  do                                                               \
    {                                                              \
      scm_t_wchar a;                                               \
      size_t i = 0;                                                \
      c = 0;                                                       \
      while (i < ndigits)                                          \
        {                                                          \
          a = scm_getc (port);                                     \
          if (a == EOF)                                            \
            goto str_eof;                                          \
          if (terminator                                           \
              && (a == (scm_t_wchar) terminator)                   \
              && (i > 0))                                          \
            break;                                                 \
          if ('0' <= a && a <= '9')                                \
            a -= '0';                                              \
          else if ('A' <= a && a <= 'F')                           \
            a = a - 'A' + 10;                                      \
          else if ('a' <= a && a <= 'f')                           \
            a = a - 'a' + 10;                                      \
          else                                                     \
            {                                                      \
              c = a;                                               \
              goto bad_escaped;                                    \
            }                                                      \
          c = c * 16 + a;                                          \
          i ++;                                                    \
        }                                                          \
    } while (0)

static SCM
scm_read_string (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  /* For strings smaller than C_STR, this function creates only one Scheme
     object (the string returned).  */

  SCM str = SCM_BOOL_F;
  unsigned c_str_len = 0;
  scm_t_wchar c;

  str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
  while ('"' != (c = scm_getc (port)))
    {
      if (c == EOF)
        {
        str_eof:
          scm_i_input_error (FUNC_NAME, port,
                             "end of file in string constant", SCM_EOL);
        }

      if (c_str_len + 1 >= scm_i_string_length (str))
        {
          SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);

          str = scm_string_append (scm_list_2 (str, addy));
        }

      if (c == '\\')
        {
          switch (c = scm_getc (port))
            {
            case EOF:
              goto str_eof;
            case '"':
            case '\\':
              break;
            case '(':
            case ')':
              if (SCM_ESCAPED_PARENS_P)
                break;
              goto bad_escaped;
            case '\n':
              continue;
            case '0':
              c = '\0';
              break;
            case 'f':
              c = '\f';
              break;
            case 'n':
              c = '\n';
              break;
            case 'r':
              c = '\r';
              break;
            case 't':
              c = '\t';
              break;
            case 'a':
              c = '\007';
              break;
            case 'v':
              c = '\v';
              break;
            case 'b':
              c = '\010';
              break;
            case 'x':
              if (SCM_R6RS_ESCAPES_P)
                SCM_READ_HEX_ESCAPE (10, ';');
              else
                SCM_READ_HEX_ESCAPE (2, '\0');
              break;
            case 'u':
              if (!SCM_R6RS_ESCAPES_P)
                {
                  SCM_READ_HEX_ESCAPE (4, '\0');
                  break;
                }
            case 'U':
              if (!SCM_R6RS_ESCAPES_P)
                {
                  SCM_READ_HEX_ESCAPE (6, '\0');
                  break;
                }
            default:
            bad_escaped:
              scm_i_input_error (FUNC_NAME, port,
                                 "illegal character in escape sequence: ~S",
                                 scm_list_1 (SCM_MAKE_CHAR (c)));
            }
        }
      str = scm_i_string_start_writing (str);
      scm_i_string_set_x (str, c_str_len++, c);
      scm_i_string_stop_writing ();
    }

  if (c_str_len > 0)
    {
      return scm_i_substring_copy (str, 0, c_str_len);
    }

  return scm_nullstr;
}
#undef FUNC_NAME

static SCM
scm_read_number (scm_t_wchar chr, SCM port)
{
  SCM result, str = SCM_EOL;
  char buffer[READER_BUFFER_SIZE];
  char *overflow_buffer = NULL;
  size_t bytes_read;
  int overflow;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  scm_ungetc (chr, port);
  overflow = read_complete_token (port, buffer, sizeof (buffer),
                                  &overflow_buffer, &bytes_read);

  if (!overflow)
    str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
  else
    str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
                            pt->ilseq_handler);

  result = scm_string_to_number (str, SCM_UNDEFINED);
  if (!scm_is_true (result))
    {
      /* Return a symbol instead of a number */
      if (SCM_CASE_INSENSITIVE_P)
        str = scm_string_downcase_x (str);
      result = scm_string_to_symbol (str);
    }

  if (overflow)
    free (overflow_buffer);
  SCM_COL (port) += scm_i_string_length (str);
  return result;
}

static SCM
scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
{
  SCM result;
  int ends_with_colon = 0;
  size_t bytes_read;
  int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
  int overflow;
  char buffer[READER_BUFFER_SIZE], *overflow_buffer;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  SCM str;

  scm_ungetc (chr, port);
  overflow = read_complete_token (port, buffer, READER_BUFFER_SIZE,
                                  &overflow_buffer, &bytes_read);
  if (bytes_read > 0)
    {
      if (!overflow)
        ends_with_colon = buffer[bytes_read - 1] == ':';
      else
        ends_with_colon = overflow_buffer[bytes_read - 1] == ':';
    }

  if (postfix && ends_with_colon && (bytes_read > 1))
    {
      if (!overflow)
        str = scm_from_stringn (buffer, bytes_read - 1, pt->encoding, pt->ilseq_handler);
      else
        str = scm_from_stringn (overflow_buffer, bytes_read - 1, pt->encoding,
                                pt->ilseq_handler);

      if (SCM_CASE_INSENSITIVE_P)
        str = scm_string_downcase_x (str);
      result = scm_symbol_to_keyword (scm_string_to_symbol (str));
    }
  else
    {
      if (!overflow)
        str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
      else
        str = scm_from_stringn (overflow_buffer, bytes_read, pt->encoding,
                                pt->ilseq_handler);

      if (SCM_CASE_INSENSITIVE_P)
        str = scm_string_downcase_x (str);
      result = scm_string_to_symbol (str);
    }

  if (overflow)
    free (overflow_buffer);
  SCM_COL (port) += scm_i_string_length (str);
  return result;
}

static SCM
scm_read_number_and_radix (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  SCM result;
  size_t read;
  char buffer[READER_BUFFER_SIZE], *overflow_buffer;
  int overflow;
  unsigned int radix;
  SCM str;
  scm_t_port *pt;

  switch (chr)
    {
    case 'B':
    case 'b':
      radix = 2;
      break;

    case 'o':
    case 'O':
      radix = 8;
      break;

    case 'd':
    case 'D':
      radix = 10;
      break;

    case 'x':
    case 'X':
      radix = 16;
      break;

    default:
      scm_ungetc (chr, port);
      scm_ungetc ('#', port);
      radix = 10;
    }

  overflow = read_complete_token (port, buffer, sizeof (buffer),
                                  &overflow_buffer, &read);

  pt = SCM_PTAB_ENTRY (port);
  if (!overflow)
    str = scm_from_stringn (buffer, read, pt->encoding, pt->ilseq_handler);
  else
    str = scm_from_stringn (overflow_buffer, read, pt->encoding,
                            pt->ilseq_handler);

  result = scm_string_to_number (str, scm_from_uint (radix));

  if (overflow)
    free (overflow_buffer);

  SCM_COL (port) += scm_i_string_length (str);

  if (scm_is_true (result))
    return result;

  scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);

  return SCM_BOOL_F;
}
#undef FUNC_NAME

static SCM
scm_read_quote (int chr, SCM port)
{
  SCM p;
  long line = SCM_LINUM (port);
  int column = SCM_COL (port) - 1;

  switch (chr)
    {
    case '`':
      p = scm_sym_quasiquote;
      break;

    case '\'':
      p = scm_sym_quote;
      break;

    case ',':
      {
	scm_t_wchar c;

	c = scm_getc (port);
	if ('@' == c)
	  p = scm_sym_uq_splicing;
	else
	  {
	    scm_ungetc (c, port);
	    p = scm_sym_unquote;
	  }
	break;
      }

    default:
      fprintf (stderr, "%s: unhandled quote character (%i)\n",
	       "scm_read_quote", chr);
      abort ();
    }

  p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
  if (SCM_RECORD_POSITIONS_P)
    scm_whash_insert (scm_source_whash, p,
		      scm_make_srcprops (line, column,
					 SCM_FILENAME (port),
					 SCM_COPY_SOURCE_P
					 ? (scm_cons2 (SCM_CAR (p),
						       SCM_CAR (SCM_CDR (p)),
						       SCM_EOL))
					 : SCM_UNDEFINED,
					 SCM_EOL));

  return p;
}

SCM_SYMBOL (sym_syntax, "syntax");
SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
SCM_SYMBOL (sym_unsyntax, "unsyntax");
SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");

static SCM
scm_read_syntax (int chr, SCM port)
{
  SCM p;
  long line = SCM_LINUM (port);
  int column = SCM_COL (port) - 1;

  switch (chr)
    {
    case '`':
      p = sym_quasisyntax;
      break;

    case '\'':
      p = sym_syntax;
      break;

    case ',':
      {
	int c;

	c = scm_getc (port);
	if ('@' == c)
	  p = sym_unsyntax_splicing;
	else
	  {
	    scm_ungetc (c, port);
	    p = sym_unsyntax;
	  }
	break;
      }

    default:
      fprintf (stderr, "%s: unhandled syntax character (%i)\n",
	       "scm_read_syntax", chr);
      abort ();
    }

  p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
  if (SCM_RECORD_POSITIONS_P)
    scm_whash_insert (scm_source_whash, p,
		      scm_make_srcprops (line, column,
					 SCM_FILENAME (port),
					 SCM_COPY_SOURCE_P
					 ? (scm_cons2 (SCM_CAR (p),
						       SCM_CAR (SCM_CDR (p)),
						       SCM_EOL))
					 : SCM_UNDEFINED,
					 SCM_EOL));

  return p;
}

static inline SCM
scm_read_nil (int chr, SCM port)
{
  SCM id = scm_read_mixed_case_symbol (chr, port);

  if (!scm_is_eq (id, sym_nil))
    scm_i_input_error ("scm_read_nil", port,
                       "unexpected input while reading #nil: ~a",
                       scm_list_1 (id));

  return SCM_ELISP_NIL;
}

static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
  int c;

  /* We use the get_byte here because there is no need to get the
     locale correct with comment input. This presumes that newline
     always represents itself no matter what the encoding is.  */
  for (c = scm_get_byte_or_eof (port);
       (c != EOF) && (c != '\n');
       c = scm_get_byte_or_eof (port));

  return SCM_UNSPECIFIED;
}

/* Sharp readers, i.e. readers called after a `#' sign has been read.  */

static SCM
scm_read_boolean (int chr, SCM port)
{
  switch (chr)
    {
    case 't':
    case 'T':
      return SCM_BOOL_T;

    case 'f':
    case 'F':
      return SCM_BOOL_F;
    }

  return SCM_UNSPECIFIED;
}

static SCM
scm_read_character (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  char buffer[READER_CHAR_NAME_MAX_SIZE];
  SCM charname;
  size_t charname_len, bytes_read;
  scm_t_wchar cp;
  int overflow;
  scm_t_port *pt;

  overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read);
  if (overflow)
    goto char_error;

  if (bytes_read == 0)
    {
      chr = scm_getc (port);
      if (chr == EOF)
	scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
			   "while reading character", SCM_EOL);

      /* CHR must be a token delimiter, like a whitespace.  */
      return (SCM_MAKE_CHAR (chr));
    }

  pt = SCM_PTAB_ENTRY (port);

  /* Simple ASCII characters can be processed immediately.  Also, simple
     ISO-8859-1 characters can be processed immediately if the encoding for this
     port is ISO-8859-1.  */
  if (bytes_read == 1 && ((unsigned char) buffer[0] <= 127 || pt->encoding == NULL))
    {
      SCM_COL (port) += 1;
      return SCM_MAKE_CHAR (buffer[0]);
    }

  /* Otherwise, convert the buffer into a proper scheme string for
     processing.  */
  charname = scm_from_stringn (buffer, bytes_read, pt->encoding,
			       pt->ilseq_handler);
  charname_len = scm_i_string_length (charname);
  SCM_COL (port) += charname_len;
  cp = scm_i_string_ref (charname, 0);
  if (charname_len == 1)
    return SCM_MAKE_CHAR (cp);

  /* Ignore dotted circles, which may be used to keep combining characters from
     combining with the backslash in #\charname.  */
  if (cp == SCM_CODEPOINT_DOTTED_CIRCLE && charname_len == 2)
    return SCM_MAKE_CHAR (scm_i_string_ref (charname, 1));

  if (cp >= '0' && cp < '8')
    {
      /* Dirk:FIXME::  This type of character syntax is not R5RS
       * compliant.  Further, it should be verified that the constant
       * does only consist of octal digits.  */
      SCM p = scm_string_to_number (charname, scm_from_uint (8));
      if (SCM_I_INUMP (p))
        {
          scm_t_wchar c = SCM_I_INUM (p);
          if (SCM_IS_UNICODE_CHAR (c))
            return SCM_MAKE_CHAR (c);
          else
            scm_i_input_error (FUNC_NAME, port,
                               "out-of-range octal character escape: ~a",
                               scm_list_1 (charname));
        }
    }

  if (cp == 'x' && (charname_len > 1))
    {
      SCM p;

      /* Convert from hex, skipping the initial 'x' character in CHARNAME */
      p = scm_string_to_number (scm_c_substring (charname, 1, charname_len),
                                scm_from_uint (16));
      if (SCM_I_INUMP (p))
        {
          scm_t_wchar c = SCM_I_INUM (p);
          if (SCM_IS_UNICODE_CHAR (c))
            return SCM_MAKE_CHAR (c);
          else
            scm_i_input_error (FUNC_NAME, port,
                               "out-of-range hex character escape: ~a",
                               scm_list_1 (charname));
        }
    }

  /* The names of characters should never have non-Latin1
     characters.  */
  if (scm_i_is_narrow_string (charname)
      || scm_i_try_narrow_string (charname))
    { SCM ch = scm_i_charname_to_char (scm_i_string_chars (charname),
                                       charname_len);
      if (scm_is_true (ch))
        return ch;
    }

 char_error:
  scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
		     scm_list_1 (charname));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static inline SCM
scm_read_keyword (int chr, SCM port)
{
  SCM symbol;

  /* Read the symbol that comprises the keyword.  Doing this instead of
     invoking a specific symbol reader function allows `scm_read_keyword ()'
     to adapt to the delimiters currently valid of symbols.

     XXX: This implementation allows sloppy syntaxes like `#:  key'.  */
  symbol = scm_read_expression (port);
  if (!scm_is_symbol (symbol))
    scm_i_input_error ("scm_read_keyword", port,
		       "keyword prefix `~a' not followed by a symbol: ~s",
		       scm_list_2 (SCM_MAKE_CHAR (chr), symbol));

  return (scm_symbol_to_keyword (symbol));
}

static inline SCM
scm_read_vector (int chr, SCM port)
{
  /* Note: We call `scm_read_sexp ()' rather than READER here in order to
     guarantee that it's going to do what we want.  After all, this is an
     implementation detail of `scm_read_vector ()', not a desirable
     property.  */
  return (scm_vector (scm_read_sexp (chr, port)));
}

static inline SCM
scm_read_srfi4_vector (int chr, SCM port)
{
  return scm_i_read_array (port, chr);
}

static SCM
scm_read_bytevector (scm_t_wchar chr, SCM port)
{
  chr = scm_getc (port);
  if (chr != 'u')
    goto syntax;

  chr = scm_getc (port);
  if (chr != '8')
    goto syntax;

  chr = scm_getc (port);
  if (chr != '(')
    goto syntax;

  return scm_u8_list_to_bytevector (scm_read_sexp (chr, port));

 syntax:
  scm_i_input_error ("read_bytevector", port,
		     "invalid bytevector prefix",
		     SCM_MAKE_CHAR (chr));
  return SCM_UNSPECIFIED;
}

static SCM
scm_read_guile_bit_vector (scm_t_wchar chr, SCM port)
{
  /* Read the `#*10101'-style read syntax for bit vectors in Guile.  This is
     terribly inefficient but who cares?  */
  SCM s_bits = SCM_EOL;

  for (chr = scm_getc (port);
       (chr != EOF) && ((chr == '0') || (chr == '1'));
       chr = scm_getc (port))
    {
      s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
    }

  if (chr != EOF)
    scm_ungetc (chr, port);

  return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
}

static inline SCM
scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
{
  int bang_seen = 0;

  /* We can use the get_byte here because there is no need to get the
     locale correct when reading comments. This presumes that
     hash and exclamation points always represent themselves no
     matter what the source encoding is.*/
  for (;;)
    {
      int c = scm_get_byte_or_eof (port);

      if (c == EOF)
	scm_i_input_error ("skip_block_comment", port,
			   "unterminated `#! ... !#' comment", SCM_EOL);

      if (c == '!')
	bang_seen = 1;
      else if (c == '#' && bang_seen)
	break;
      else
	bang_seen = 0;
    }

  return SCM_UNSPECIFIED;
}

static inline SCM
scm_read_shebang (scm_t_wchar chr, SCM port)
{
  int c = 0;
  if ((c = scm_get_byte_or_eof (port)) != 'r')
    {
      scm_ungetc (c, port);
      return scm_read_scsh_block_comment (chr, port);
    }
  if ((c = scm_get_byte_or_eof (port)) != '6')
    {
      scm_ungetc (c, port);
      scm_ungetc ('r', port);
      return scm_read_scsh_block_comment (chr, port);
    }
  if ((c = scm_get_byte_or_eof (port)) != 'r')
    {
      scm_ungetc (c, port);
      scm_ungetc ('6', port);
      scm_ungetc ('r', port);
      return scm_read_scsh_block_comment (chr, port);
    }
  if ((c = scm_get_byte_or_eof (port)) != 's')
    {
      scm_ungetc (c, port);
      scm_ungetc ('r', port);
      scm_ungetc ('6', port);
      scm_ungetc ('r', port);
      return scm_read_scsh_block_comment (chr, port);
    }

  return SCM_UNSPECIFIED;
}

static SCM
scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
{
  /* Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be
     nested.  So care must be taken.  */
  int nesting_level = 1;
  int opening_seen = 0, closing_seen = 0;

  while (nesting_level > 0)
    {
      int c = scm_getc (port);

      if (c == EOF)
	scm_i_input_error ("scm_read_r6rs_block_comment", port,
			   "unterminated `#| ... |#' comment", SCM_EOL);

      if (opening_seen)
	{
	  if (c == '|')
	    nesting_level++;
	  opening_seen = 0;
	}
      else if (closing_seen)
	{
	  if (c == '#')
	    nesting_level--;
	  closing_seen = 0;
	}
      else if (c == '|')
	closing_seen = 1;
      else if (c == '#')
	opening_seen = 1;
      else
	opening_seen = closing_seen = 0;
    }

  return SCM_UNSPECIFIED;
}

static SCM
scm_read_commented_expression (scm_t_wchar chr, SCM port)
{
  scm_t_wchar c;

  c = flush_ws (port, (char *) NULL);
  if (EOF == c)
    scm_i_input_error ("read_commented_expression", port,
                       "no expression after #; comment", SCM_EOL);
  scm_ungetc (c, port);
  scm_read_expression (port);
  return SCM_UNSPECIFIED;
}

static SCM
scm_read_extended_symbol (scm_t_wchar chr, SCM port)
{
  /* Guile's extended symbol read syntax looks like this:

       #{This is all a symbol name}#

     So here, CHR is expected to be `{'.  */
  int saw_brace = 0, finished = 0;
  size_t len = 0;
  SCM buf = scm_i_make_string (1024, NULL);

  buf = scm_i_string_start_writing (buf);

  while ((chr = scm_getc (port)) != EOF)
    {
      if (saw_brace)
	{
	  if (chr == '#')
	    {
	      finished = 1;
	      break;
	    }
	  else
	    {
	      saw_brace = 0;
	      scm_i_string_set_x (buf, len++, '}');
	      scm_i_string_set_x (buf, len++, chr);
	    }
	}
      else if (chr == '}')
	saw_brace = 1;
      else
	scm_i_string_set_x (buf, len++, chr);

      if (len >= scm_i_string_length (buf) - 2)
	{
	  SCM addy;

	  scm_i_string_stop_writing ();
	  addy = scm_i_make_string (1024, NULL);
	  buf = scm_string_append (scm_list_2 (buf, addy));
	  len = 0;
	  buf = scm_i_string_start_writing (buf);
	}

      if (finished)
	break;
    }
  scm_i_string_stop_writing ();

  return (scm_string_to_symbol (scm_c_substring (buf, 0, len)));
}

/* Top-level token readers, i.e., dispatchers.  */

static SCM
scm_read_sharp_extension (int chr, SCM port)
{
  SCM proc;

  proc = scm_get_hash_procedure (chr);
  if (scm_is_true (scm_procedure_p (proc)))
    {
      long line = SCM_LINUM (port);
      int column = SCM_COL (port) - 2;
      SCM got;

      got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
      if (!scm_is_eq (got, SCM_UNSPECIFIED))
	{
	  if (SCM_RECORD_POSITIONS_P)
	    return (recsexpr (got, line, column,
			      SCM_FILENAME (port)));
	  else
	    return got;
	}
    }

  return SCM_UNSPECIFIED;
}

/* The reader for the sharp `#' character.  It basically dispatches reads
   among the above token readers.   */
static SCM
scm_read_sharp (scm_t_wchar chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
  SCM result;

  chr = scm_getc (port);

  result = scm_read_sharp_extension (chr, port);
  if (!scm_is_eq (result, SCM_UNSPECIFIED))
    return result;

  switch (chr)
    {
    case '\\':
      return (scm_read_character (chr, port));
    case '(':
      return (scm_read_vector (chr, port));
    case 's':
    case 'u':
    case 'f':
      /* This one may return either a boolean or an SRFI-4 vector.  */
      return (scm_read_srfi4_vector (chr, port));
    case 'v':
      return (scm_read_bytevector (chr, port));
    case '*':
      return (scm_read_guile_bit_vector (chr, port));
    case 't':
    case 'T':
    case 'F':
      /* This one may return either a boolean or an SRFI-4 vector.  */
      return (scm_read_boolean (chr, port));
    case ':':
      return (scm_read_keyword (chr, port));
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
    case '@':
#if SCM_ENABLE_DEPRECATED
      /* See below for 'i' and 'e'. */
    case 'a':
    case 'c':
    case 'y':
    case 'h':
    case 'l':
#endif
      return (scm_i_read_array (port, chr));

    case 'i':
    case 'e':
#if SCM_ENABLE_DEPRECATED
      {
	/* When next char is '(', it really is an old-style
	   uniform array. */
	scm_t_wchar next_c = scm_getc (port);
	if (next_c != EOF)
	  scm_ungetc (next_c, port);
	if (next_c == '(')
	  return scm_i_read_array (port, chr);
	/* Fall through. */
      }
#endif
    case 'b':
    case 'B':
    case 'o':
    case 'O':
    case 'd':
    case 'D':
    case 'x':
    case 'X':
    case 'I':
    case 'E':
      return (scm_read_number_and_radix (chr, port));
    case '{':
      return (scm_read_extended_symbol (chr, port));
    case '!':
      return (scm_read_shebang (chr, port));
    case ';':
      return (scm_read_commented_expression (chr, port));
    case '`':
    case '\'':
    case ',':
      return (scm_read_syntax (chr, port));
    case 'n':
      return (scm_read_nil (chr, port));
    default:
      result = scm_read_sharp_extension (chr, port);
      if (scm_is_eq (result, SCM_UNSPECIFIED))
	{
	  /* To remain compatible with 1.8 and earlier, the following
	     characters have lower precedence than `read-hash-extend'
	     characters.  */
	  switch (chr)
	    {
	    case '|':
	      return scm_read_r6rs_block_comment (chr, port);
	    default:
	      scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
				 scm_list_1 (SCM_MAKE_CHAR (chr)));
	    }
	}
      else
	return result;
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

static SCM
scm_read_expression (SCM port)
#define FUNC_NAME "scm_read_expression"
{
  while (1)
    {
      register scm_t_wchar chr;

      chr = scm_getc (port);

      switch (chr)
	{
	case SCM_WHITE_SPACES:
	case SCM_LINE_INCREMENTORS:
	  break;
	case ';':
	  (void) scm_read_semicolon_comment (chr, port);
	  break;
	case '[':
          if (!SCM_SQUARE_BRACKETS_P)
            return (scm_read_mixed_case_symbol (chr, port));
          /* otherwise fall through */
	case '(':
	  return (scm_read_sexp (chr, port));
	case '"':
	  return (scm_read_string (chr, port));
	case '\'':
	case '`':
	case ',':
	  return (scm_read_quote (chr, port));
	case '#':
	  {
	    SCM result;
	    result = scm_read_sharp (chr, port);
	    if (scm_is_eq (result, SCM_UNSPECIFIED))
	      /* We read a comment or some such.  */
	      break;
	    else
	      return result;
	  }
	case ')':
	  scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
	  break;
	case EOF:
	  return SCM_EOF_VAL;
	case ':':
	  if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
	    return scm_symbol_to_keyword (scm_read_expression (port));
	  /* Fall through.  */

	default:
	  {
	    if (((chr >= '0') && (chr <= '9'))
		|| (strchr ("+-.", chr)))
	      return (scm_read_number (chr, port));
	    else
	      return (scm_read_mixed_case_symbol (chr, port));
	  }
	}
    }
}
#undef FUNC_NAME

/* Actual reader.  */

SCM_DEFINE (scm_read, "read", 0, 1, 0,
            (SCM port),
	    "Read an s-expression from the input port @var{port}, or from\n"
	    "the current input port if @var{port} is not specified.\n"
	    "Any whitespace before the next token is discarded.")
#define FUNC_NAME s_scm_read
{
  int c;

  if (SCM_UNBNDP (port))
    port = scm_current_input_port ();
  SCM_VALIDATE_OPINPORT (1, port);

  c = flush_ws (port, (char *) NULL);
  if (EOF == c)
    return SCM_EOF_VAL;
  scm_ungetc (c, port);

  return (scm_read_expression (port));
}
#undef FUNC_NAME

/* Used when recording expressions constructed by `scm_read_sharp ()'.  */
static SCM
recsexpr (SCM obj, long line, int column, SCM filename)
{
  if (!scm_is_pair(obj)) {
    return obj;
  } else {
    SCM tmp = obj, copy;
    /* If this sexpr is visible in the read:sharp source, we want to
       keep that information, so only record non-constant cons cells
       which haven't previously been read by the reader. */
    if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
      {
	if (SCM_COPY_SOURCE_P)
	  {
	    copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
			     SCM_UNDEFINED);
	    while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
	      {
		SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
						      line,
						      column,
						      filename),
					    SCM_UNDEFINED));
		copy = SCM_CDR (copy);
	      }
	    SCM_SETCDR (copy, tmp);
	  }
	else
	  {
	    recsexpr (SCM_CAR (obj), line, column, filename);
	    while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
	      recsexpr (SCM_CAR (tmp), line, column, filename);
	    copy = SCM_UNDEFINED;
	  }
	scm_whash_insert (scm_source_whash,
			  obj,
			  scm_make_srcprops (line,
					     column,
					     filename,
					     copy,
					     SCM_EOL));
      }
    return obj;
  }
}

/* Manipulate the read-hash-procedures alist.  This could be written in
   Scheme, but maybe it will also be used by C code during initialisation.  */
SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
            (SCM chr, SCM proc),
	    "Install the procedure @var{proc} for reading expressions\n"
	    "starting with the character sequence @code{#} and @var{chr}.\n"
	    "@var{proc} will be called with two arguments:  the character\n"
	    "@var{chr} and the port to read further data from. The object\n"
	    "returned will be the return value of @code{read}. \n"
	    "Passing @code{#f} for @var{proc} will remove a previous setting. \n"
	    )
#define FUNC_NAME s_scm_read_hash_extend
{
  SCM this;
  SCM prev;

  SCM_VALIDATE_CHAR (1, chr);
  SCM_ASSERT (scm_is_false (proc)
	      || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
	      proc, SCM_ARG2, FUNC_NAME);

  /* Check if chr is already in the alist.  */
  this = *scm_read_hash_procedures;
  prev = SCM_BOOL_F;
  while (1)
    {
      if (scm_is_null (this))
	{
	  /* not found, so add it to the beginning.  */
	  if (scm_is_true (proc))
	    {
	      *scm_read_hash_procedures =
		scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
	    }
	  break;
	}
      if (scm_is_eq (chr, SCM_CAAR (this)))
	{
	  /* already in the alist.  */
	  if (scm_is_false (proc))
	    {
	      /* remove it.  */
	      if (scm_is_false (prev))
		{
		  *scm_read_hash_procedures =
		    SCM_CDR (*scm_read_hash_procedures);
		}
	      else
		scm_set_cdr_x (prev, SCM_CDR (this));
	    }
	  else
	    {
	      /* replace it.  */
	      scm_set_cdr_x (SCM_CAR (this), proc);
	    }
	  break;
	}
      prev = this;
      this = SCM_CDR (this);
    }

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Recover the read-hash procedure corresponding to char c.  */
static SCM
scm_get_hash_procedure (int c)
{
  SCM rest = *scm_read_hash_procedures;

  while (1)
    {
      if (scm_is_null (rest))
	return SCM_BOOL_F;

      if (SCM_CHAR (SCM_CAAR (rest)) == c)
	return SCM_CDAR (rest);

      rest = SCM_CDR (rest);
    }
}

#define SCM_ENCODING_SEARCH_SIZE (500)

/* Search the first few hundred characters of a file for an Emacs-like coding
   declaration.  Returns either NULL or a string whose storage has been
   allocated with `scm_gc_malloc ()'.  */
char *
scm_i_scan_for_encoding (SCM port)
{
  char header[SCM_ENCODING_SEARCH_SIZE+1];
  size_t bytes_read, encoding_length, i;
  char *encoding = NULL;
  int utf8_bom = 0;
  char *pos, *encoding_start;
  int in_comment;

  if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port)))
    /* PORT is a non-seekable file port (e.g., as created by Bash when using
       "guile <(echo '(display "hello")')") so bail out.  */
    return NULL;

  bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);

  scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));

  if (bytes_read > 3
      && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf')
    utf8_bom = 1;

  /* search past "coding[:=]" */
  pos = header;
  while (1)
    {
      if ((pos = strstr(pos, "coding")) == NULL)
        return NULL;

      pos += strlen("coding");
      if (pos - header >= SCM_ENCODING_SEARCH_SIZE ||
          (*pos == ':' || *pos == '='))
        {
          pos ++;
          break;
        }
    }

  /* skip spaces */
  while (pos - header <= SCM_ENCODING_SEARCH_SIZE &&
	 (*pos == ' ' || *pos == '\t'))
    pos ++;

  /* grab the next token */
  encoding_start = pos;
  i = 0;
  while (encoding_start + i - header <= SCM_ENCODING_SEARCH_SIZE
         && encoding_start + i - header < bytes_read
	 && (isalnum ((int) encoding_start[i])
	     || strchr ("_-.:/,+=()", encoding_start[i]) != NULL))
    i++;

  encoding_length = i;
  if (encoding_length == 0)
    return NULL;

  encoding = scm_gc_strndup (encoding_start, encoding_length, "encoding");
  for (i = 0; i < encoding_length; i++)
    encoding[i] = toupper ((int) encoding[i]);

  /* push backwards to make sure we were in a comment */
  in_comment = 0;
  pos = encoding_start;
  while (pos >= header)
    {
      if (*pos == '\n')
	{
	  /* This wasn't in a semicolon comment. Check for a
	   hash-bang comment. */
	  char *beg = strstr (header, "#!");
	  char *end = strstr (header, "!#");
	  if (beg < encoding_start && encoding_start + encoding_length < end)
	    in_comment = 1;
	  break;
	}
      if (*pos == ';')
	{
	  in_comment = 1;
	  break;
	}
      pos --;
    }
  if (!in_comment)
    /* This wasn't in a comment */
    return NULL;

  if (utf8_bom && strcmp(encoding, "UTF-8"))
    scm_misc_error (NULL,
		    "the port input declares the encoding ~s but is encoded as UTF-8",
		    scm_list_1 (scm_from_locale_string (encoding)));

  return encoding;
}

SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
            (SCM port),
            "Scans the port for an Emacs-like character coding declaration\n"
            "near the top of the contents of a port with random-acessible contents.\n"
            "The coding declaration is of the form\n"
            "@code{coding: XXXXX} and must appear in a scheme comment.\n"
            "\n"
            "Returns a string containing the character encoding of the file\n"
            "if a declaration was found, or @code{#f} otherwise.\n")
#define FUNC_NAME s_scm_file_encoding
{
  char *enc;
  SCM s_enc;

  enc = scm_i_scan_for_encoding (port);
  if (enc == NULL)
    return SCM_BOOL_F;
  else
    {
      s_enc = scm_from_locale_string (enc);
      return s_enc;
    }

  return SCM_BOOL_F;
}
#undef FUNC_NAME

void
scm_init_read ()
{
  scm_read_hash_procedures =
    SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));

  scm_init_opts (scm_read_options, scm_read_opts);
#include "libguile/read.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_READ_H
#define SCM_READ_H

/* Copyright (C) 1995,1996,2000, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

#include "libguile/options.h"

/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
 * be incremented for the purposes of error reporting.  This feature
 * is only used for scheme code loaded from files.
 *
 * SCM_WHITE_SPACES are other characters which should be treated like spaces
 * in programs.
 */

#define SCM_LINE_INCREMENTORS  '\n'

#ifdef MSDOS
# define SCM_SINGLE_SPACES  ' ':case '\r':case '\f': case 26
#else
# define SCM_SINGLE_SPACES  ' ':case '\r':case '\f'
#endif

#define SCM_WHITE_SPACES  SCM_SINGLE_SPACES: case '\t'

SCM_API SCM scm_sym_dot;

SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port);
SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port);
SCM_API SCM scm_file_encoding (SCM port);

SCM_INTERNAL void scm_i_input_error (const char *func, SCM port,
				     const char *message, SCM arg)
  SCM_NORETURN;

SCM_INTERNAL void scm_init_read (void);

#endif  /* SCM_READ_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: mit


code:
/*	Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

/* regex-posix.c -- POSIX regular expression support.

   This code was written against Henry Spencer's famous regex package.
   The principal reference for POSIX behavior was the man page for this
   library, not the 1003.2 document itself.  Ergo, other `POSIX'
   libraries which do not agree with the Spencer implementation may
   produce varying behavior.  Sigh. */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <sys/types.h>

#include "libguile/_scm.h"

/* Supposedly, this file is never compiled unless we know we have
   POSIX regular expressions.  But we still put this in an #ifdef so
   the file is CPP'able (for dependency scanning) even on systems that
   don't have a <regex.h> header.  */
#ifdef HAVE_REGCOMP
#ifdef HAVE_REGEX_H
#include <regex.h>
#else
#ifdef HAVE_RXPOSIX_H
#include <rxposix.h>		/* GNU Rx library */
#else
#ifdef HAVE_RX_RXPOSIX_H
#include <rx/rxposix.h>		/* GNU Rx library on Linux */
#endif
#endif
#endif
#endif

#include "libguile/async.h"
#include "libguile/smob.h"
#include "libguile/symbols.h"
#include "libguile/vectors.h"
#include "libguile/strports.h"
#include "libguile/ports.h"
#include "libguile/feature.h"
#include "libguile/strings.h"

#include "libguile/validate.h"
#include "libguile/regex-posix.h"

/* This is defined by some regex libraries and omitted by others. */
#ifndef REG_BASIC
#define REG_BASIC 0
#endif

scm_t_bits scm_tc16_regex;

static size_t
regex_free (SCM obj)
{
  regfree (SCM_RGX (obj));
  scm_gc_free (SCM_RGX (obj), sizeof(regex_t), "regex");
  return 0;
}

SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax");

static SCM
scm_regexp_error_msg (int regerrno, regex_t *rx)
{
  char *errmsg;
  int l;

  errmsg = scm_malloc (80);
  l = regerror (regerrno, rx, errmsg, 80);
  if (l > 80)
    {
      free (errmsg);
      errmsg = scm_malloc (l);
      regerror (regerrno, rx, errmsg, l);
    }
  return scm_take_locale_string (errmsg);
}

SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a compiled regular expression,\n"
	    "or @code{#f} otherwise.")
#define FUNC_NAME s_scm_regexp_p
{
  return scm_from_bool(SCM_RGXP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1,
            (SCM pat, SCM flags),
	    "Compile the regular expression described by @var{pat}, and\n"
	    "return the compiled regexp structure.  If @var{pat} does not\n"
	    "describe a legal regular expression, @code{make-regexp} throws\n"
	    "a @code{regular-expression-syntax} error.\n"
	    "\n"
	    "The @var{flags} arguments change the behavior of the compiled\n"
	    "regular expression.  The following flags may be supplied:\n"
	    "\n"
	    "@table @code\n"
	    "@item regexp/icase\n"
	    "Consider uppercase and lowercase letters to be the same when\n"
	    "matching.\n"
	    "@item regexp/newline\n"
	    "If a newline appears in the target string, then permit the\n"
	    "@samp{^} and @samp{$} operators to match immediately after or\n"
	    "immediately before the newline, respectively.  Also, the\n"
	    "@samp{.} and @samp{[^...]} operators will never match a newline\n"
	    "character.  The intent of this flag is to treat the target\n"
	    "string as a buffer containing many lines of text, and the\n"
	    "regular expression as a pattern that may match a single one of\n"
	    "those lines.\n"
	    "@item regexp/basic\n"
	    "Compile a basic (``obsolete'') regexp instead of the extended\n"
	    "(``modern'') regexps that are the default.  Basic regexps do\n"
	    "not consider @samp{|}, @samp{+} or @samp{?} to be special\n"
	    "characters, and require the @samp{@{...@}} and @samp{(...)}\n"
	    "metacharacters to be backslash-escaped (@pxref{Backslash\n"
	    "Escapes}).  There are several other differences between basic\n"
	    "and extended regular expressions, but these are the most\n"
	    "significant.\n"
	    "@item regexp/extended\n"
	    "Compile an extended regular expression rather than a basic\n"
	    "regexp.  This is the default behavior; this flag will not\n"
	    "usually be needed.  If a call to @code{make-regexp} includes\n"
	    "both @code{regexp/basic} and @code{regexp/extended} flags, the\n"
	    "one which comes last will override the earlier one.\n"
	    "@end table")
#define FUNC_NAME s_scm_make_regexp
{
  SCM flag;
  regex_t *rx;
  int status, cflags;
  char *c_pat;

  SCM_VALIDATE_STRING (1, pat);
  SCM_VALIDATE_REST_ARGUMENT (flags);

  /* Examine list of regexp flags.  If REG_BASIC is supplied, then
     turn off REG_EXTENDED flag (on by default). */
  cflags = REG_EXTENDED;
  flag = flags;
  while (!scm_is_null (flag))
    {
      if (scm_to_int (SCM_CAR (flag)) == REG_BASIC)
	cflags &= ~REG_EXTENDED;
      else
	cflags |= scm_to_int (SCM_CAR (flag));
      flag = SCM_CDR (flag);
    }

  rx = scm_gc_malloc_pointerless (sizeof (regex_t), "regex");
  c_pat = scm_to_locale_string (pat);
  status = regcomp (rx, c_pat,
		    /* Make sure they're not passing REG_NOSUB;
                       regexp-exec assumes we're getting match data.  */
		    cflags & ~REG_NOSUB);
  free (c_pat);
  if (status != 0)
    {
      SCM errmsg = scm_regexp_error_msg (status, rx);
      scm_gc_free (rx, sizeof(regex_t), "regex");
      scm_error_scm (scm_regexp_error_key,
		     scm_from_locale_string (FUNC_NAME),
		     errmsg,
		     SCM_BOOL_F,
		     scm_list_1 (pat));

      /* never returns */
    }
  SCM_RETURN_NEWSMOB (scm_tc16_regex, rx);
}
#undef FUNC_NAME

SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
            (SCM rx, SCM str, SCM start, SCM flags),
	    "Match the compiled regular expression @var{rx} against\n"
	    "@code{str}.  If the optional integer @var{start} argument is\n"
	    "provided, begin matching from that position in the string.\n"
	    "Return a match structure describing the results of the match,\n"
	    "or @code{#f} if no match could be found.\n"
            "\n"
            "The @var{flags} arguments change the matching behavior.\n"
            "The following flags may be supplied:\n"
	    "\n"
	    "@table @code\n"
	    "@item regexp/notbol\n"
            "Operator @samp{^} always fails (unless @code{regexp/newline}\n"
            "is used).  Use this when the beginning of the string should\n"
            "not be considered the beginning of a line.\n"
	    "@item regexp/noteol\n"
            "Operator @samp{$} always fails (unless @code{regexp/newline}\n"
            "is used).  Use this when the end of the string should not be\n"
            "considered the end of a line.\n"
            "@end table")
#define FUNC_NAME s_scm_regexp_exec
{
  /* We used to have an SCM_DEFER_INTS, and then later an
     SCM_CRITICAL_SECTION_START, around the regexec() call.  Can't quite
     remember what defer ints was for, but a critical section would only be
     wanted now if we think regexec() is not thread-safe.  The posix spec

     http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html

     reads like regexec is meant to be both thread safe and reentrant
     (mentioning simultaneous use in threads, and in signal handlers).  So
     for now believe no protection needed.  */

  int status, nmatches, offset;
  regmatch_t *matches;
  char *c_str;
  SCM mvec = SCM_BOOL_F;
  SCM substr;

  SCM_VALIDATE_RGXP (1, rx);
  SCM_VALIDATE_STRING (2, str);

  if (SCM_UNBNDP (start))
    {
      substr = str;
      offset = 0;
    }
  else
    {
      substr = scm_substring (str, start, SCM_UNDEFINED);
      offset = scm_to_int (start);
    }

  if (SCM_UNBNDP (flags))
    flags = SCM_INUM0;

  /* re_nsub doesn't account for the `subexpression' representing the
     whole regexp, so add 1 to nmatches. */

  nmatches = SCM_RGX(rx)->re_nsub + 1;
  matches = scm_malloc (sizeof (regmatch_t) * nmatches);
  c_str = scm_to_locale_string (substr);
  status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
		    scm_to_int (flags));
  free (c_str);

  if (!status)
    {
      int i;
      /* The match vector must include a cell for the string that was matched,
	 so add 1. */
      mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED);
      SCM_SIMPLE_VECTOR_SET(mvec,0, str);
      for (i = 0; i < nmatches; ++i)
	if (matches[i].rm_so == -1)
	  SCM_SIMPLE_VECTOR_SET(mvec, i+1,
			 scm_cons (scm_from_int (-1), scm_from_int (-1)));
	else
	  SCM_SIMPLE_VECTOR_SET(mvec, i+1,
			 scm_cons (scm_from_long (matches[i].rm_so + offset),
				   scm_from_long (matches[i].rm_eo + offset)));
    }
  free (matches);

  if (status != 0 && status != REG_NOMATCH)
    scm_error_scm (scm_regexp_error_key,
		   scm_from_locale_string (FUNC_NAME),
		   scm_regexp_error_msg (status, SCM_RGX (rx)),
		   SCM_BOOL_F, SCM_BOOL_F);
  return mvec;
}
#undef FUNC_NAME

void
scm_init_regex_posix ()
{
  scm_tc16_regex = scm_make_smob_type ("regexp", sizeof (regex_t));
  scm_set_smob_free (scm_tc16_regex, regex_free);

  /* Compilation flags.  */
  scm_c_define ("regexp/basic",    scm_from_int (REG_BASIC));
  scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED));
  scm_c_define ("regexp/icase",    scm_from_int (REG_ICASE));
  scm_c_define ("regexp/newline",  scm_from_int (REG_NEWLINE));

  /* Execution flags.  */
  scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL));
  scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL));

#include "libguile/regex-posix.x"

  scm_add_feature ("regex");
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_REGEX_POSIX_H
#define SCM_REGEX_POSIX_H

/* Copyright (C) 1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API scm_t_bits scm_tc16_regex;
#define SCM_RGX(X)	((regex_t *) SCM_SMOB_DATA (X))
#define SCM_RGXP(X)	(SCM_SMOB_PREDICATE (scm_tc16_regex, (X)))

SCM_API SCM scm_make_regexp (SCM pat, SCM flags);
SCM_API SCM scm_regexp_p (SCM x);
SCM_API SCM scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags);
SCM_INTERNAL void scm_init_regex_posix (void);

#endif  /* SCM_REGEX_POSIX_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <string.h>
#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/stackchk.h"
#include "libguile/dynwind.h"
#include "libguile/eval.h"
#include "libguile/smob.h"
#include "libguile/pairs.h"
#include "libguile/throw.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"

#include "libguile/root.h"

/* {call-with-dynamic-root}
 *
 * Suspending the current thread to evaluate a thunk on the
 * same C stack but under a new root.
 *
 * Calls to call-with-dynamic-root return exactly once (unless
 * the process is somehow exitted).  */

/* cwdr fills out both of these structures, and then passes a pointer
   to them through scm_internal_catch to the cwdr_body and
   cwdr_handler functions, to tell them how to behave and to get
   information back from them.

   A cwdr is a lot like a catch, except there is no tag (all
   exceptions are caught), and the body procedure takes the arguments
   passed to cwdr as A1 and ARGS.  The handler is also special since
   it is not directly run from scm_internal_catch.  It is executed
   outside the new dynamic root. */

struct cwdr_body_data {
  /* Arguments to pass to the cwdr body function.  */
  SCM a1, args;

  /* Scheme procedure to use as body of cwdr.  */
  SCM body_proc;
};

struct cwdr_handler_data {
  /* Do we need to run the handler? */
  int run_handler;

  /* The tag and args to pass it. */
  SCM tag, args;
};

/* Invoke the body of a cwdr, assuming that the throw handler has
   already been set up.  DATA points to a struct set up by cwdr that
   says what proc to call, and what args to apply it to.

   With a little thought, we could replace this with scm_body_thunk,
   but I don't want to mess with that at the moment.  */
static SCM
cwdr_body (void *data)
{
  struct cwdr_body_data *c = (struct cwdr_body_data *) data;

  return scm_apply (c->body_proc, c->a1, c->args);
}

/* Record the fact that the body of the cwdr has thrown.  Record
   enough information to invoke the handler later when the dynamic
   root has been deestablished.  */

static SCM
cwdr_handler (void *data, SCM tag, SCM args)
{
  struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;

  c->run_handler = 1;
  c->tag = tag;
  c->args = args;
  return SCM_UNSPECIFIED;
}

SCM
scm_internal_cwdr (scm_t_catch_body body, void *body_data,
		   scm_t_catch_handler handler, void *handler_data,
		   SCM_STACKITEM *stack_start)
{
  struct cwdr_handler_data my_handler_data;
  SCM answer, old_winds;

  /* Exit caller's dynamic state.
   */
  old_winds = scm_i_dynwinds ();
  scm_dowinds (SCM_EOL, scm_ilength (old_winds));

  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));

  my_handler_data.run_handler = 0;
  answer = scm_i_with_continuation_barrier (body, body_data,
					    cwdr_handler, &my_handler_data,
					    NULL, NULL);

  scm_dynwind_end ();

  /* Enter caller's dynamic state.
   */
  scm_dowinds (old_winds, - scm_ilength (old_winds));

  /* Now run the real handler iff the body did a throw. */
  if (my_handler_data.run_handler)
    return handler (handler_data, my_handler_data.tag, my_handler_data.args);
  else
    return answer;
}

/* The original CWDR for invoking Scheme code with a Scheme handler. */

static SCM
cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
{
  struct cwdr_body_data c;

  c.a1 = a1;
  c.args = args;
  c.body_proc = proc;

  return scm_internal_cwdr (cwdr_body, &c,
			    scm_handle_by_proc, &handler,
			    stack_start);
}

SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
           (SCM thunk, SCM handler),
	    "Call @var{thunk} with a new dynamic state and within"
	    "a continuation barrier.  The @var{handler} catches all"
	    "otherwise uncaught throws and executes within the same"
	    "dynamic context as @var{thunk}.")
#define FUNC_NAME s_scm_call_with_dynamic_root
{
  SCM_STACKITEM stack_place;
  return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
}
#undef FUNC_NAME

SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
           (),
	    "Return an object representing the current dynamic root.\n\n"
	    "These objects are only useful for comparison using @code{eq?}.\n")
#define FUNC_NAME s_scm_dynamic_root
{
  return SCM_I_CURRENT_THREAD->continuation_root;
}
#undef FUNC_NAME

SCM
scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
{
  SCM_STACKITEM stack_place;
  return cwdr (proc, a1, args, handler, &stack_place);
}

void
scm_init_root ()
{
#include "libguile/root.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_ROOT_H
#define SCM_ROOT_H

/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"
#include "libguile/debug.h"
#include "libguile/throw.h"

SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
			       void *body_data,
			       scm_t_catch_handler handler,
			       void *handler_data,
			       SCM_STACKITEM *stack_start);
SCM_API SCM scm_call_with_dynamic_root (SCM thunk, SCM handler);
SCM_API SCM scm_dynamic_root (void);
SCM_API SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler);
SCM_INTERNAL void scm_init_root (void);

#endif  /* SCM_ROOT_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
#!/bin/sh -
# Run the guile-test script using the guile binary from this directory
cd ../test-suite
../libguile/guile -e main -s guile-test "$@"

path: libguile/run-test


code:
/* 	Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

/* This is the C part of the (ice-9 rw) module.  */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <errno.h>
#include <string.h>

#include "libguile/_scm.h"
#include "libguile/fports.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/rw.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/modules.h"
#include "libguile/strports.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_IO_H
#include <io.h>
#endif

#if defined (EAGAIN)
#define SCM_MAYBE_EAGAIN || errno == EAGAIN
#else
#define SCM_MAYBE_EAGAIN
#endif

#if defined (EWOULDBLOCK)
#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK
#else
#define SCM_MAYBE_EWOULDBLOCK
#endif

/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK.  */
#define SCM_EBLOCK(errno) \
   (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK)

SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
	    (SCM str, SCM port_or_fdes, SCM start, SCM end),
	    "Read characters from a port or file descriptor into a\n"
	    "string @var{str}.  A port must have an underlying file\n"
	    "descriptor --- a so-called fport.  This procedure is\n"
	    "scsh-compatible and can efficiently read large strings.\n"
	    "It will:\n\n"
	    "@itemize\n"
	    "@item\n"
	    "attempt to fill the entire string, unless the @var{start}\n"
	    "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
	    "defaults to 0 and @var{end} defaults to\n"
	    "@code{(string-length str)}\n"
	    "@item\n"
	    "use the current input port if @var{port_or_fdes} is not\n"
	    "supplied.\n"
	    "@item\n"
	    "return fewer than the requested number of characters in some\n"
	    "cases, e.g., on end of file, if interrupted by a signal, or if\n"
	    "not all the characters are immediately available.\n"
	    "@item\n"
	    "wait indefinitely for some input if no characters are\n"
	    "currently available,\n"
	    "unless the port is in non-blocking mode.\n"
	    "@item\n"
	    "read characters from the port's input buffers if available,\n"
	    "instead from the underlying file descriptor.\n"
	    "@item\n"
	    "return @code{#f} if end-of-file is encountered before reading\n"
            "any characters, otherwise return the number of characters\n"
	    "read.\n"
	    "@item\n"
	    "return 0 if the port is in non-blocking mode and no characters\n"
	    "are immediately available.\n"
	    "@item\n"
	    "return 0 if the request is for 0 bytes, with no\n"
	    "end-of-file check.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_read_string_x_partial
{
  char *dest;
  size_t offset;
  long read_len;
  long chars_read = 0;
  int fdes;

  {
    size_t last;

    SCM_VALIDATE_STRING (1, str);
    scm_i_get_substring_spec (scm_i_string_length (str),
			      start, &offset, end, &last);
    read_len = last - offset;
  }

  if (scm_is_integer (port_or_fdes))
    fdes = scm_to_int (port_or_fdes);
  else
    {
      SCM port = (SCM_UNBNDP (port_or_fdes)?
		  scm_current_input_port () : port_or_fdes);

      SCM_VALIDATE_OPFPORT (2, port);
      SCM_VALIDATE_INPUT_PORT (2, port);

      /* if there's anything in the port buffers, use it, but then
	 don't touch the file descriptor.  otherwise the
	 "return immediately if something is available" rule may
	 be violated.  */
      str = scm_i_string_start_writing (str);
      dest = scm_i_string_writable_chars (str) + offset;
      chars_read = scm_take_from_input_buffers (port, dest, read_len);
      scm_i_string_stop_writing ();
      fdes = SCM_FPORT_FDES (port);
    }

  if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
					  EOF.  */
    {
      str = scm_i_string_start_writing (str);
      dest = scm_i_string_writable_chars (str) + offset;
      SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
      scm_i_string_stop_writing ();
      if (chars_read == -1)
	{
	  if (SCM_EBLOCK (errno))
	    chars_read = 0;
	  else
	    SCM_SYSERROR;
        }
      else if (chars_read == 0)
	{
	  scm_remember_upto_here_1 (str);
	  return SCM_BOOL_F;
	}
    }

  scm_remember_upto_here_1 (str);
  return scm_from_long (chars_read);
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
	    (SCM str, SCM port_or_fdes, SCM start, SCM end),
	    "Write characters from a string @var{str} to a port or file\n"
	    "descriptor.  A port must have an underlying file descriptor\n"
	    "--- a so-called fport.  This procedure is\n"
	    "scsh-compatible and can efficiently write large strings.\n"
	    "It will:\n\n"
	    "@itemize\n"
	    "@item\n"
	    "attempt to write the entire string, unless the @var{start}\n"
	    "and/or @var{end} arguments are supplied.  i.e., @var{start}\n"
	    "defaults to 0 and @var{end} defaults to\n"
	    "@code{(string-length str)}\n"
	    "@item\n"
	    "use the current output port if @var{port_of_fdes} is not\n"
	    "supplied.\n"
	    "@item\n"
	    "in the case of a buffered port, store the characters in the\n"
	    "port's output buffer, if all will fit.  If they will not fit\n"
	    "then any existing buffered characters will be flushed\n"
	    "before attempting\n"
	    "to write the new characters directly to the underlying file\n"
	    "descriptor.  If the port is in non-blocking mode and\n"
	    "buffered characters can not be flushed immediately, then an\n"
	    "@code{EAGAIN} system-error exception will be raised (Note:\n"
	    "scsh does not support the use of non-blocking buffered ports.)\n"
	    "@item\n"
	    "write fewer than the requested number of\n"
	    "characters in some cases, e.g., if interrupted by a signal or\n"
	    "if not all of the output can be accepted immediately.\n"
	    "@item\n"
	    "wait indefinitely for at least one character\n"
	    "from @var{str} to be accepted by the port, unless the port is\n"
	    "in non-blocking mode.\n"
	    "@item\n"
	    "return the number of characters accepted by the port.\n"
	    "@item\n"
	    "return 0 if the port is in non-blocking mode and can not accept\n"
	    "at least one character from @var{str} immediately\n"
	    "@item\n"
	    "return 0 immediately if the request size is 0 bytes.\n"
	    "@end itemize")
#define FUNC_NAME s_scm_write_string_partial
{
  const char *src;
  scm_t_off write_len;
  int fdes;

  {
    size_t offset;
    size_t last;

    SCM_VALIDATE_STRING (1, str);
    src = scm_i_string_chars (str);
    scm_i_get_substring_spec (scm_i_string_length (str),
			      start, &offset, end, &last);
    src += offset;
    write_len = last - offset;
  }

  if (write_len == 0)
    return SCM_INUM0;

  if (scm_is_integer (port_or_fdes))
    fdes = scm_to_int (port_or_fdes);
  else
    {
      SCM port = (SCM_UNBNDP (port_or_fdes)?
		  scm_current_output_port () : port_or_fdes);
      scm_t_port *pt;
      scm_t_off space;

      SCM_VALIDATE_OPFPORT (2, port);
      SCM_VALIDATE_OUTPUT_PORT (2, port);
      pt = SCM_PTAB_ENTRY (port);
      /* filling the last character in the buffer would require a flush.  */
      space = pt->write_end - pt->write_pos - 1;
      if (space >= write_len)
	{
	  memcpy (pt->write_pos, src, write_len);
	  pt->write_pos += write_len;
	  return scm_from_long (write_len);
	}
      if (pt->write_pos > pt->write_buf)
	scm_flush (port);
      fdes = SCM_FPORT_FDES (port);
    }
  {
    long rv;

    SCM_SYSCALL (rv = write (fdes, src, write_len));
    if (rv == -1)
      {
	if (SCM_EBLOCK (errno))
	  rv = 0;
	else
	  SCM_SYSERROR;
      }

    scm_remember_upto_here_1 (str);
    return scm_from_long (rv);
  }
}
#undef FUNC_NAME

SCM
scm_init_rw_builtins ()
{
#include "libguile/rw.x"

  return SCM_UNSPECIFIED;
}

void
scm_init_rw ()
{
  scm_c_define_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins);
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_RW_H
#define SCM_RW_H

/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

SCM_API SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start,
				       SCM end);
SCM_API SCM scm_write_string_partial (SCM str, SCM port_or_fdes, SCM start,
				      SCM end);

SCM_INTERNAL SCM scm_init_rw_builtins (void);
SCM_INTERNAL void scm_init_rw (void);

#endif  /* SCM_RW_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 2003, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <fcntl.h>      /* for mingw */
#include <signal.h>
#include <stdio.h>
#include <errno.h>

#include "libguile/_scm.h"

#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/threads.h"

#include "libguile/validate.h"
#include "libguile/scmsigs.h"

#ifdef HAVE_IO_H
#include <io.h>  /* for mingw _pipe() */
#endif

#ifdef HAVE_PROCESS_H
#include <process.h>    /* for mingw */
#endif

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#ifdef HAVE_SYS_TIME_H
#include <sys/time.h>
#endif

#ifdef __MINGW32__
#include <windows.h>
#define alarm(sec) (0)
/* This weird comma expression is because Sleep is void under Windows. */
#define sleep(sec) (Sleep ((sec) * 1000), 0)
#define usleep(usec) (Sleep ((usec) / 1000), 0)
#define pipe(fd) _pipe (fd, 256, O_BINARY)
#endif

#include <full-write.h>

/* SIGRETTYPE is the type that signal handlers return.  See <signal.h> */

#ifdef RETSIGTYPE
# define SIGRETTYPE RETSIGTYPE
#else
# ifdef STDC_HEADERS
#  define SIGRETTYPE void
# else
#  define SIGRETTYPE int
# endif
#endif

/* take_signal is installed as the C signal handler whenever a Scheme
   handler is set.  When a signal arrives, take_signal will write a
   byte into the 'signal pipe'.  The 'signal delivery thread' will
   read this pipe and queue the appropriate asyncs.

   When Guile is built without threads, the signal handler will
   install the async directly.
*/

/* Scheme vectors with information about a signal.  signal_handlers
   contains the handler procedure or #f, signal_handler_asyncs
   contains the thunk to be marked as an async when the signal arrives
   (or the cell with the thunk in a singlethreaded Guile), and
   signal_handler_threads points to the thread that a signal should be
   delivered to.
*/
static SCM *signal_handlers;
static SCM signal_handler_asyncs;
static SCM signal_handler_threads;

/* The signal delivery thread.  */
scm_i_thread *scm_i_signal_delivery_thread = NULL;

/* The mutex held when launching the signal delivery thread.  */
static scm_i_pthread_mutex_t signal_delivery_thread_mutex =
  SCM_I_PTHREAD_MUTEX_INITIALIZER;

/* saves the original C handlers, when a new handler is installed.
   set to SIG_ERR if the original handler is installed.  */
#ifdef HAVE_SIGACTION
static struct sigaction orig_handlers[NSIG];
#else
static SIGRETTYPE (*orig_handlers[NSIG])(int);
#endif

static SCM
close_1 (SCM proc, SCM arg)
{
  return scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
					   scm_list_2 (proc, arg)));
}

#if SCM_USE_PTHREAD_THREADS
/* On mingw there's no notion of inter-process signals, only a raise()
   within the process itself which apparently invokes the registered handler
   immediately.  Not sure how well the following code will cope in this
   case.  It builds but it may not offer quite the same scheme-level
   semantics as on a proper system.  If you're relying on much in the way of
   signal handling on mingw you probably lose anyway.  */

static int signal_pipe[2];

static SIGRETTYPE
take_signal (int signum)
{
  char sigbyte = signum;
  full_write (signal_pipe[1], &sigbyte, 1);

#ifndef HAVE_SIGACTION
  signal (signum, take_signal);
#endif
}

static SCM
signal_delivery_thread (void *data)
{
  int n, sig;
  char sigbyte;
#if HAVE_PTHREAD_SIGMASK  /* not on mingw, see notes above */
  sigset_t all_sigs;
  sigfillset (&all_sigs);
  scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
#endif

  while (1)
    {
      n = read (signal_pipe[0], &sigbyte, 1);
      sig = sigbyte;
      if (n == 1 && sig >= 0 && sig < NSIG)
	{
	  SCM h, t;

	  h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
	  t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
	  if (scm_is_true (h))
	    scm_system_async_mark_for_thread (h, t);
	}
      else if (n == 0)
	break; /* the signal pipe was closed. */
      else if (n < 0 && errno != EINTR)
	perror ("error in signal delivery thread");
    }

  return SCM_UNSPECIFIED; /* not reached unless all other threads exited */
}

static void
start_signal_delivery_thread (void)
{
  SCM signal_thread;

  scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);

  if (pipe (signal_pipe) != 0)
    scm_syserror (NULL);
  signal_thread = scm_spawn_thread (signal_delivery_thread, NULL,
				    scm_handle_by_message,
				    "signal delivery thread");
  scm_i_signal_delivery_thread = SCM_I_THREAD_DATA (signal_thread);

  scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
}

void
scm_i_ensure_signal_delivery_thread ()
{
  static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
  scm_i_pthread_once (&once, start_signal_delivery_thread);
}

#else /* !SCM_USE_PTHREAD_THREADS */

static SIGRETTYPE
take_signal (int signum)
{
  SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  if (scm_is_false (SCM_CDR (cell)))
    {
      SCM_SETCDR (cell, t->active_asyncs);
      t->active_asyncs = cell;
      t->pending_asyncs = 1;
    }

#ifndef HAVE_SIGACTION
  signal (signum, take_signal);
#endif
}

void
scm_i_ensure_signal_delivery_thread ()
{
  return;
}

#endif /* !SCM_USE_PTHREAD_THREADS */

static void
install_handler (int signum, SCM thread, SCM handler)
{
  if (scm_is_false (handler))
    {
      SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, SCM_BOOL_F);
      SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, SCM_BOOL_F);
    }
  else
    {
      SCM async = close_1 (handler, scm_from_int (signum));
#if !SCM_USE_PTHREAD_THREADS
      async = scm_cons (async, SCM_BOOL_F);
#endif
      SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
      SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
    }

  SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
}

SCM
scm_sigaction (SCM signum, SCM handler, SCM flags)
{
  return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
}

/* user interface for installation of signal handlers.  */
SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
           (SCM signum, SCM handler, SCM flags, SCM thread),
	    "Install or report the signal handler for a specified signal.\n\n"
	    "@var{signum} is the signal number, which can be specified using the value\n"
	    "of variables such as @code{SIGINT}.\n\n"
	    "If @var{handler} is omitted, @code{sigaction} returns a pair: the\n"
	    "CAR is the current\n"
	    "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
	    "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
	    "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
	    "signal.  The CDR contains the current @code{sigaction} flags for the handler.\n\n"
	    "If @var{handler} is provided, it is installed as the new handler for\n"
	    "@var{signum}.  @var{handler} can be a Scheme procedure taking one\n"
	    "argument, or the value of @code{SIG_DFL} (default action) or\n"
	    "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
	    "was installed before @code{sigaction} was first used.  When\n"
	    "a scheme procedure has been specified, that procedure will run\n"
	    "in the given @var{thread}.   When no thread has been given, the\n"
	    "thread that made this call to @code{sigaction} is used.\n"
	    "Flags can optionally be specified for the new handler.\n"
	    "The return value is a pair with information about the\n"
	    "old handler as described above.\n\n"
	    "This interface does not provide access to the \"signal blocking\"\n"
	    "facility.  Maybe this is not needed, since the thread support may\n"
	    "provide solutions to the problem of consistent access to data\n"
	    "structures.")
#define FUNC_NAME s_scm_sigaction_for_thread
{
  int csig;
#ifdef HAVE_SIGACTION
  struct sigaction action;
  struct sigaction old_action;
#else
  SIGRETTYPE (* chandler) (int) = SIG_DFL;
  SIGRETTYPE (* old_chandler) (int);
#endif
  int query_only = 0;
  int save_handler = 0;

  SCM old_handler;

  csig = scm_to_signed_integer (signum, 0, NSIG-1);

#if defined(HAVE_SIGACTION)
  action.sa_flags = 0;
  if (!SCM_UNBNDP (flags))
    action.sa_flags |= scm_to_int (flags);
  sigemptyset (&action.sa_mask);
#endif

  if (SCM_UNBNDP (thread))
    thread = scm_current_thread ();
  else
    {
      SCM_VALIDATE_THREAD (4, thread);
      if (scm_c_thread_exited_p (thread))
	SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
    }

  scm_i_ensure_signal_delivery_thread ();

  SCM_CRITICAL_SECTION_START;
  old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
  if (SCM_UNBNDP (handler))
    query_only = 1;
  else if (scm_is_integer (handler))
    {
      long handler_int = scm_to_long (handler);

      if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
	{
#ifdef HAVE_SIGACTION
	  action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
#else
	  chandler = (SIGRETTYPE (*) (int)) handler_int;
#endif
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
	}
      else
	{
	  SCM_CRITICAL_SECTION_END;
	  SCM_OUT_OF_RANGE (2, handler);
	}
    }
  else if (scm_is_false (handler))
    {
      /* restore the default handler.  */
#ifdef HAVE_SIGACTION
      if (orig_handlers[csig].sa_handler == SIG_ERR)
	query_only = 1;
      else
	{
	  action = orig_handlers[csig];
	  orig_handlers[csig].sa_handler = SIG_ERR;
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
	}
#else
      if (orig_handlers[csig] == SIG_ERR)
	query_only = 1;
      else
	{
	  chandler = orig_handlers[csig];
	  orig_handlers[csig] = SIG_ERR;
	  install_handler (csig, SCM_BOOL_F, SCM_BOOL_F);
	}
#endif
    }
  else
    {
      SCM_VALIDATE_PROC (2, handler);
#ifdef HAVE_SIGACTION
      action.sa_handler = take_signal;
      if (orig_handlers[csig].sa_handler == SIG_ERR)
	save_handler = 1;
#else
      chandler = take_signal;
      if (orig_handlers[csig] == SIG_ERR)
	save_handler = 1;
#endif
      install_handler (csig, thread, handler);
    }

  /* XXX - Silently ignore setting handlers for `program error signals'
     because they can't currently be handled by Scheme code.
  */

  switch (csig)
    {
      /* This list of program error signals is from the GNU Libc
         Reference Manual */
    case SIGFPE:
    case SIGILL:
    case SIGSEGV:
#ifdef SIGBUS
    case SIGBUS:
#endif
    case SIGABRT:
#if defined(SIGIOT) && (SIGIOT != SIGABRT)
    case SIGIOT:
#endif
#ifdef SIGTRAP
    case SIGTRAP:
#endif
#ifdef SIGEMT
    case SIGEMT:
#endif
#ifdef SIGSYS
    case SIGSYS:
#endif
      query_only = 1;
    }

#ifdef HAVE_SIGACTION
  if (query_only)
    {
      if (sigaction (csig, 0, &old_action) == -1)
	SCM_SYSERROR;
    }
  else
    {
      if (sigaction (csig, &action , &old_action) == -1)
	SCM_SYSERROR;
      if (save_handler)
	orig_handlers[csig] = old_action;
    }
  if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
    old_handler = scm_from_long ((long) old_action.sa_handler);
  SCM_CRITICAL_SECTION_END;
  return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
#else
  if (query_only)
    {
      if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
	SCM_SYSERROR;
      if (signal (csig, old_chandler) == SIG_ERR)
	SCM_SYSERROR;
    }
  else
    {
      if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
	SCM_SYSERROR;
      if (save_handler)
	orig_handlers[csig] = old_chandler;
    }
  if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
    old_handler = scm_from_long ((long) old_chandler);
  SCM_CRITICAL_SECTION_END;
  return scm_cons (old_handler, scm_from_int (0));
#endif
}
#undef FUNC_NAME

SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
            (void),
	    "Return all signal handlers to the values they had before any call to\n"
	    "@code{sigaction} was made.  The return value is unspecified.")
#define FUNC_NAME s_scm_restore_signals
{
  int i;
  for (i = 0; i < NSIG; i++)
    {
#ifdef HAVE_SIGACTION
      if (orig_handlers[i].sa_handler != SIG_ERR)
	{
	  if (sigaction (i, &orig_handlers[i], NULL) == -1)
	    SCM_SYSERROR;
	  orig_handlers[i].sa_handler = SIG_ERR;
	  SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
	}
#else
      if (orig_handlers[i] != SIG_ERR)
	{
	  if (signal (i, orig_handlers[i]) == SIG_ERR)
	    SCM_SYSERROR;
	  orig_handlers[i] = SIG_ERR;
	  SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
	}
#endif
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
           (SCM i),
	    "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
	    "number of seconds (an integer).  It's advisable to install a signal\n"
	    "handler for\n"
	    "@code{SIGALRM} beforehand, since the default action is to terminate\n"
	    "the process.\n\n"
	    "The return value indicates the time remaining for the previous alarm,\n"
	    "if any.  The new value replaces the previous alarm.  If there was\n"
	    "no previous alarm, the return value is zero.")
#define FUNC_NAME s_scm_alarm
{
  return scm_from_uint (alarm (scm_to_uint (i)));
}
#undef FUNC_NAME

#ifdef HAVE_SETITIMER
SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
           (SCM which_timer,
            SCM interval_seconds, SCM interval_microseconds,
            SCM value_seconds, SCM value_microseconds),
            "Set the timer specified by @var{which_timer} according to the given\n"
            "@var{interval_seconds}, @var{interval_microseconds},\n"
            "@var{value_seconds}, and @var{value_microseconds} values.\n"
            "\n"
            "Return information about the timer's previous setting."
            "\n"
            "Errors are handled as described in the guile info pages under ``POSIX\n"
            "Interface Conventions''.\n"
            "\n"
            "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
            "and @code{ITIMER_PROF}.\n"
            "\n"
            "The return value will be a list of two cons pairs representing the\n"
            "current state of the given timer.  The first pair is the seconds and\n"
            "microseconds of the timer @code{it_interval}, and the second pair is\n"
            "the seconds and microseconds of the timer @code{it_value}.")
#define FUNC_NAME s_scm_setitimer
{
  int rv;
  int c_which_timer;
  struct itimerval new_timer;
  struct itimerval old_timer;

  c_which_timer = SCM_NUM2INT(1, which_timer);
  new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
  new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
  new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
  new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);

  SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));

  if(rv != 0)
    SCM_SYSERROR;

  return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
			       scm_from_long (old_timer.it_interval.tv_usec)),
		     scm_cons (scm_from_long (old_timer.it_value.tv_sec),
			       scm_from_long (old_timer.it_value.tv_usec)));
}
#undef FUNC_NAME
#endif /* HAVE_SETITIMER */

#ifdef HAVE_GETITIMER
SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
  (SCM which_timer),
            "Return information about the timer specified by @var{which_timer}"
            "\n"
            "Errors are handled as described in the guile info pages under ``POSIX\n"
            "Interface Conventions''.\n"
            "\n"
            "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
            "and @code{ITIMER_PROF}.\n"
            "\n"
            "The return value will be a list of two cons pairs representing the\n"
            "current state of the given timer.  The first pair is the seconds and\n"
            "microseconds of the timer @code{it_interval}, and the second pair is\n"
            "the seconds and microseconds of the timer @code{it_value}.")
#define FUNC_NAME s_scm_getitimer
{
  int rv;
  int c_which_timer;
  struct itimerval old_timer;

  c_which_timer = SCM_NUM2INT(1, which_timer);

  SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));

  if(rv != 0)
    SCM_SYSERROR;

  return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
			       scm_from_long (old_timer.it_interval.tv_usec)),
		     scm_cons (scm_from_long (old_timer.it_value.tv_sec),
			       scm_from_long (old_timer.it_value.tv_usec)));
}
#undef FUNC_NAME
#endif /* HAVE_GETITIMER */

#ifdef HAVE_PAUSE
SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
           (),
	    "Pause the current process (thread?) until a signal arrives whose\n"
	    "action is to either terminate the current process or invoke a\n"
	    "handler procedure.  The return value is unspecified.")
#define FUNC_NAME s_scm_pause
{
  pause ();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
           (SCM i),
	    "Wait for the given number of seconds (an integer) or until a signal\n"
	    "arrives.  The return value is zero if the time elapses or the number\n"
	    "of seconds remaining otherwise.\n"
	    "\n"
	    "See also @code{usleep}.")
#define FUNC_NAME s_scm_sleep
{
  return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
           (SCM i),
	    "Wait the given period @var{usecs} microseconds (an integer).\n"
	    "If a signal arrives the wait stops and the return value is the\n"
	    "time remaining, in microseconds.  If the period elapses with no\n"
	    "signal the return is zero.\n"
	    "\n"
	    "On most systems the process scheduler is not microsecond accurate and\n"
	    "the actual period slept by @code{usleep} may be rounded to a system\n"
	    "clock tick boundary.  Traditionally such ticks were 10 milliseconds\n"
	    "apart, and that interval is often still used.\n"
	    "\n"
	    "See also @code{sleep}.")
#define FUNC_NAME s_scm_usleep
{
  return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
           (SCM sig),
	    "Sends a specified signal @var{sig} to the current process, where\n"
	    "@var{sig} is as described for the kill procedure.")
#define FUNC_NAME s_scm_raise
{
  if (raise (scm_to_int (sig)) != 0)
    SCM_SYSERROR;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_i_close_signal_pipe()
{
  /* SIGNAL_DELIVERY_THREAD_MUTEX is only locked while the signal delivery
     thread is being launched.  The thread that calls this function is
     already holding the thread admin mutex, so if the delivery thread hasn't
     been launched at this point, it never will be before shutdown.  */
  scm_i_pthread_mutex_lock (&signal_delivery_thread_mutex);

#if SCM_USE_PTHREAD_THREADS
  if (scm_i_signal_delivery_thread != NULL)
    close (signal_pipe[1]);
#endif

  scm_i_pthread_mutex_unlock (&signal_delivery_thread_mutex);
}

void
scm_init_scmsigs ()
{
  int i;

  signal_handlers =
    SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
				  scm_c_make_vector (NSIG, SCM_BOOL_F)));
  signal_handler_asyncs = scm_c_make_vector (NSIG, SCM_BOOL_F);
  signal_handler_threads = scm_c_make_vector (NSIG, SCM_BOOL_F);

  for (i = 0; i < NSIG; i++)
    {
#ifdef HAVE_SIGACTION
      orig_handlers[i].sa_handler = SIG_ERR;

#else
      orig_handlers[i] = SIG_ERR;
#endif
    }

  scm_c_define ("NSIG", scm_from_long (NSIG));
  scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
  scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
#ifdef SA_NOCLDSTOP
  scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
#endif
#ifdef SA_RESTART
  scm_c_define ("SA_RESTART", scm_from_long (SA_RESTART));
#endif

#if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER)
  /* Stuff needed by setitimer and getitimer. */
  scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
  scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
  scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
#endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */

#include "libguile/scmsigs.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SCMSIGS_H
#define SCM_SCMSIGS_H

/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006, 2007, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"
#include "libguile/threads.h"

SCM_API SCM scm_sigaction (SCM signum, SCM handler, SCM flags);
SCM_API SCM scm_sigaction_for_thread (SCM signum, SCM handler, SCM flags,
				      SCM thread);
SCM_API SCM scm_restore_signals (void);
SCM_API SCM scm_alarm (SCM i);
SCM_API SCM scm_setitimer (SCM which_timer,
			   SCM interval_seconds, SCM interval_microseconds,
			   SCM value_seconds, SCM value_microseconds);
SCM_API SCM scm_getitimer (SCM which_timer);
SCM_API SCM scm_pause (void);
SCM_API SCM scm_sleep (SCM i);
SCM_API SCM scm_usleep (SCM i);
SCM_API SCM scm_raise (SCM sig);
SCM_INTERNAL void scm_init_scmsigs (void);

SCM_INTERNAL void scm_i_close_signal_pipe (void);
SCM_INTERNAL void scm_i_ensure_signal_delivery_thread (void);

SCM_INTERNAL scm_i_thread *scm_i_signal_delivery_thread;

#endif  /* SCM_SCMSIGS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/