code:
#ifndef SCM_BYTEVECTORS_H
#define SCM_BYTEVECTORS_H

/* Copyright (C) 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"

/* R6RS bytevectors.  */

/* The size in words of the bytevector header (type tag and flags, length,
   and pointer to the underlying buffer).  */
#define SCM_BYTEVECTOR_HEADER_SIZE   3U

#define SCM_BYTEVECTOR_LENGTH(_bv)		\
  ((size_t) SCM_CELL_WORD_1 (_bv))
#define SCM_BYTEVECTOR_CONTENTS(_bv)		\
  ((signed char *) SCM_CELL_WORD_2 (_bv))

SCM_API SCM scm_endianness_big;
SCM_API SCM scm_endianness_little;

SCM_API SCM scm_c_make_bytevector (size_t);
SCM_API int scm_is_bytevector (SCM);
SCM_API size_t scm_c_bytevector_length (SCM);
SCM_API scm_t_uint8 scm_c_bytevector_ref (SCM, size_t);
SCM_API void scm_c_bytevector_set_x (SCM, size_t, scm_t_uint8);

SCM_API SCM scm_make_bytevector (SCM, SCM);
SCM_API SCM scm_native_endianness (void);
SCM_API SCM scm_bytevector_p (SCM);
SCM_API SCM scm_bytevector_length (SCM);
SCM_API SCM scm_bytevector_eq_p (SCM, SCM);
SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_copy (SCM);

SCM_API SCM scm_uniform_array_to_bytevector (SCM);

SCM_API SCM scm_bytevector_to_u8_list (SCM);
SCM_API SCM scm_u8_list_to_bytevector (SCM);
SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM);
SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM);

SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_u8_ref (SCM, SCM);
SCM_API SCM scm_bytevector_s8_ref (SCM, SCM);
SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM);
SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM);
SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM);
SCM_API SCM scm_string_to_utf8 (SCM);
SCM_API SCM scm_string_to_utf16 (SCM, SCM);
SCM_API SCM scm_string_to_utf32 (SCM, SCM);
SCM_API SCM scm_utf8_to_string (SCM);
SCM_API SCM scm_utf16_to_string (SCM, SCM);
SCM_API SCM scm_utf32_to_string (SCM, SCM);

/* Internal API.  */

#define SCM_BYTEVECTOR_P(x)				\
  (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_bytevector)
#define SCM_BYTEVECTOR_FLAGS(_bv)		\
  (SCM_CELL_TYPE (_bv) >> 7UL)
#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f)				\
  SCM_SET_CELL_TYPE ((_bv),						\
		     scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL))

#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv)	\
  (SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL)
#define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv)	\
  (SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL)

/* Hint that is passed to `scm_gc_malloc ()' and friends.  */
#define SCM_GC_BYTEVECTOR "bytevector"

SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type);
SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t,
                                              scm_t_array_element_type);

SCM_INTERNAL void scm_bootstrap_bytevectors (void);
SCM_INTERNAL void scm_init_bytevectors (void);

SCM_INTERNAL SCM scm_i_native_endianness;
SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t);

SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *);

SCM_INTERNAL SCM scm_c_shrink_bytevector (SCM, size_t);
SCM_INTERNAL void scm_i_bytevector_generalized_set_x (SCM, size_t, SCM);
SCM_INTERNAL SCM scm_null_bytevector;

#endif /* SCM_BYTEVECTORS_H */


code:
%option noyywrap
%option nounput
%pointer

EOL             \n
SPACE           [ \t\v\f]
WS              [ \t\v\n\f]
DIGIT		[0-9]
LETTER		[a-zA-Z_]
OCTDIGIT	[0-7]
HEXDIGIT	[a-fA-F0-9]
EXPONENT	[Ee][+-]?{DIGIT}+
FLOQUAL		(f|F|l|L)
INTQUAL		(l|L|ll|LL|lL|Ll|u|U)

%{

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

/* Prevent compilation of static input() function in generated scanner
   code.  This function is never actually used, and GCC 4.3 will emit
   an error for that. */
#define YY_NO_INPUT

int filter_snarfage = 0;
int print = 1;

enum t_state {
    SKIP,
    MULTILINE,
    MULTILINE_COOKIE,
    COOKIE
};

enum t_state state = SKIP;
int cookie_was_last = 0;

#define OUT_RAW(type,text) if (print) printf ("(%s . \"%s\")\n", #type, text)

#define OUT_T(type)        OUT_RAW (type, yytext)
#define OUT_S              if (print) printf ("%s\n", yytext)
#define OUT(type)          if (print) printf ("%s\n", #type)

#define IS_COOKIE cookie_was_last = 1
#define IS_NOT_COOKIE cookie_was_last = 0

%}

%%

\/\*(\n|[^*]|\*[^/])*\*\/                  { OUT_T (comment); }

({SPACE}*(\\\n)*{SPACE}*)+                 ;

({SPACE}*\n*{SPACE}*)+                     { OUT(eol); }

#.*\n                                      { OUT(hash); IS_NOT_COOKIE; }

{LETTER}({LETTER}|{DIGIT})*                { OUT_T (id); IS_NOT_COOKIE; }

0[xX]{HEXDIGIT}+{INTQUAL}?                 { OUT_RAW (int_hex, yytext + 2); IS_NOT_COOKIE; }
0{OCTDIGIT}+{INTQUAL}?                     { OUT_RAW (int_oct, yytext + 1); IS_NOT_COOKIE; }
{DIGIT}+{INTQUAL}?                         { OUT_T (int_dec); IS_NOT_COOKIE; }

L?\'(\\.|[^\\\'])+\'                       { OUT_T (char); IS_NOT_COOKIE; }

{DIGIT}+{EXPONENT}{FLOQUAL}?               { OUT_T (flo_dec); IS_NOT_COOKIE; }
{DIGIT}*"."{DIGIT}+({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; }
{DIGIT}+"."{DIGIT}*({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; }

L?\"(\\.|[^\\\"])*\"                       { OUT_S; IS_NOT_COOKIE; }

"..."                                      { OUT (ellipsis); IS_NOT_COOKIE; }

">>="                                      { OUT (shift_right_assign); IS_NOT_COOKIE; }
"<<="                                      { OUT (shift_left_assign); IS_NOT_COOKIE; }
"+="                                       { OUT (add_assign); IS_NOT_COOKIE; }
"-="                                       { OUT (sub_assign); IS_NOT_COOKIE; }
"*="                                       { OUT (mul-assign); IS_NOT_COOKIE; }
"/="                                       { OUT (div_assign); IS_NOT_COOKIE; }
"%="                                       { OUT (mod_assign); IS_NOT_COOKIE; }
"&="                                       { OUT (logand_assign); IS_NOT_COOKIE; }
"^="                                       { OUT (logxor_assign); IS_NOT_COOKIE; }
"|="                                       { OUT (logior_assign); IS_NOT_COOKIE; }
">>"                                       { OUT (right_shift); IS_NOT_COOKIE; }
"<<"                                       { OUT (left_shift); IS_NOT_COOKIE; }
"++"                                       { OUT (inc); IS_NOT_COOKIE; }
"--"                                       { OUT (dec); IS_NOT_COOKIE; }
"->"                                       { OUT (ptr); IS_NOT_COOKIE; }
"&&"                                       { OUT (and); IS_NOT_COOKIE; }
"||"                                       { OUT (or); IS_NOT_COOKIE; }
"<="                                       { OUT (le); IS_NOT_COOKIE; }
">="                                       { OUT (ge); IS_NOT_COOKIE; }
"=="                                       { OUT (eq); IS_NOT_COOKIE; }
"!="                                       { OUT (ne); IS_NOT_COOKIE; }
";"                                        { OUT (semicolon); IS_NOT_COOKIE; }

("{"|"<%")                                 {
  OUT (brace_open);
  if (filter_snarfage && cookie_was_last && state == COOKIE)
    state = MULTILINE;
  IS_NOT_COOKIE; }

("}"|"%>")                                 {
  OUT (brace_close);
  if (filter_snarfage && cookie_was_last && state == MULTILINE_COOKIE) {
    state = SKIP;
    print = 0;
  }
  IS_NOT_COOKIE; }

","                                        { OUT (comma); IS_NOT_COOKIE; }
":"                                        { OUT (colon); IS_NOT_COOKIE; }
"="                                        { OUT (assign); IS_NOT_COOKIE; }
"("                                        { OUT (paren_open); IS_NOT_COOKIE; }
")"                                        { OUT (paren_close); IS_NOT_COOKIE; }
("["|"<:")                                 { OUT (bracket_open); IS_NOT_COOKIE; }
("]"|":>")                                 { OUT (bracket_close); IS_NOT_COOKIE; }
"."                                        { OUT (dot); IS_NOT_COOKIE; }
"&"                                        { OUT (amp); IS_NOT_COOKIE; }
"!"                                        { OUT (bang); IS_NOT_COOKIE; }
"~"                                        { OUT (tilde); IS_NOT_COOKIE; }
"-"                                        { OUT (minus); IS_NOT_COOKIE; }
"+"                                        { OUT (plus); IS_NOT_COOKIE; }
"*"                                        { OUT (star); IS_NOT_COOKIE; }
"/"                                        { OUT (slash); IS_NOT_COOKIE; }
"%"                                        { OUT (percent); IS_NOT_COOKIE; }
"<"                                        { OUT (lt); IS_NOT_COOKIE; }
">"                                        { OUT (gt); IS_NOT_COOKIE; }

\^{WS}*\^                                  {
  if (filter_snarfage)
    switch (state) {
    case SKIP:
      state = COOKIE;
      print = 1;
      OUT (snarf_cookie);
      break;
    case MULTILINE:
    case MULTILINE_COOKIE:
      state = MULTILINE_COOKIE;
      OUT (snarf_cookie);
      break;
    case COOKIE:
      state = SKIP;
      OUT (snarf_cookie);
      print = 0;
      break;
    default:
      /* whoops */
      abort ();
      break;
    }
  else
    OUT (snarf_cookie);

  IS_COOKIE; }

"^"                                        { OUT (caret); IS_NOT_COOKIE; }
"|"                                        { OUT (pipe); IS_NOT_COOKIE; }
"?"                                        { OUT (question); IS_NOT_COOKIE; }

.                                          { fprintf (stderr, "*%s", yytext);  fflush (stderr); IS_NOT_COOKIE; }

%%

int
main (int argc, char *argv[])
{
    if (argc > 1 && !strcmp (argv[1], "--filter-snarfage")) {
        filter_snarfage = 1;
        print = 0;
    }

    yylex ();

    return EXIT_SUCCESS;
}

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

license: mit


code:
/*	Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 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 <ctype.h>
#include <limits.h>
#include <unicase.h>
#include <unictype.h>

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

#include "libguile/chars.h"
#include "libguile/srfi-14.h"

SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
            (SCM x),
	    "Return @code{#t} iff @var{x} is a character, else @code{#f}.")
#define FUNC_NAME s_scm_char_p
{
  return scm_from_bool (SCM_CHARP(x));
}
#undef FUNC_NAME

static SCM scm_i_char_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n"
            "code point of @var{y}, else @code{#f}.\n")
#define FUNC_NAME s_scm_i_char_eq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_eq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_eq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_eq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_eq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (scm_is_eq (x, y));
}
#undef FUNC_NAME

static SCM scm_i_char_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} iff the code point of @var{x} is less than the code\n"
            "point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_less_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_less_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_less_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_less_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_less_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (SCM_CHAR(x) < SCM_CHAR(y));
}
#undef FUNC_NAME

static SCM scm_i_char_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the Unicode code point of @var{x} is less than or\n"
            "equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_leq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_leq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_leq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_leq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_leq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (SCM_CHAR(x) <= SCM_CHAR(y));
}
#undef FUNC_NAME

static SCM scm_i_char_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
            "the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_gr_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_gr_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_gr_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_gr_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_gr_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (SCM_CHAR(x) > SCM_CHAR(y));
}
#undef FUNC_NAME

static SCM scm_i_char_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
            "or equal to the code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_geq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_geq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_geq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_geq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_geq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (SCM_CHAR(x) >= SCM_CHAR(y));
}
#undef FUNC_NAME

/* FIXME?: R6RS specifies that these comparisons are case-folded.
   This is the same thing as comparing the uppercase characters in
   practice, but, not in theory.  Unicode has table containing their
   definition of case-folded character mappings.  A more correct
   implementation would be to use that table and make a char-foldcase
   function.  */

static SCM scm_i_char_ci_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
            "the same as the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_ci_eq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_ci_eq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_ci_eq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_ci_eq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_ci_eq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (scm_c_upcase(SCM_CHAR(x))==scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME

static SCM scm_i_char_ci_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
            "less than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_ci_less_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_ci_less_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_ci_less_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_ci_less_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_ci_less_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool ((scm_c_upcase(SCM_CHAR(x))) < scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME

static SCM scm_i_char_ci_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} iff the case-folded Unicodd code point of @var{x} is\n"
            "less than or equal to the case-folded code point of @var{y}, else\n"
            "@code{#f}")
#define FUNC_NAME s_scm_i_char_ci_leq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_ci_leq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_ci_leq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_ci_leq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_ci_leq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) <= scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME

static SCM scm_i_char_ci_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
            "than the case-folded code point of @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_i_char_ci_gr_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_ci_gr_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_ci_gr_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_ci_gr_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_ci_gr_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) > scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME

static SCM scm_i_char_ci_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
            (SCM x, SCM y, SCM rest),
            "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
            "greater than or equal to the case-folded code point of @var{y}, else\n"
            "@code{#f}.")
#define FUNC_NAME s_scm_i_char_ci_geq_p
{
  if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (scm_char_ci_geq_p (x, y)))
        return SCM_BOOL_F;
      x = y;
      y = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return scm_char_ci_geq_p (x, y);
}
#undef FUNC_NAME

SCM scm_char_ci_geq_p (SCM x, SCM y)
#define FUNC_NAME s_scm_i_char_ci_geq_p
{
  SCM_VALIDATE_CHAR (1, x);
  SCM_VALIDATE_CHAR (2, y);
  return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) >= scm_c_upcase(SCM_CHAR(y)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0,
           (SCM chr),
	    "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_alphabetic_p
{
  return scm_char_set_contains_p (scm_char_set_letter, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0,
           (SCM chr),
	    "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_numeric_p
{
  return scm_char_set_contains_p (scm_char_set_digit, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
           (SCM chr),
	    "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_whitespace_p
{
  return scm_char_set_contains_p (scm_char_set_whitespace, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
           (SCM chr),
	    "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_upper_case_p
{
  return scm_char_set_contains_p (scm_char_set_upper_case, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
           (SCM chr),
	    "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n")
#define FUNC_NAME s_scm_char_lower_case_p
{
  return scm_char_set_contains_p (scm_char_set_lower_case, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
            (SCM chr),
	    "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n"
            "@code{#f}.\n")
#define FUNC_NAME s_scm_char_is_both_p
{
  if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
    return SCM_BOOL_T;
  return scm_char_set_contains_p (scm_char_set_upper_case, chr);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
            (SCM chr),
            "Return the Unicode code point of @var{chr}.")
#define FUNC_NAME s_scm_char_to_integer
{
  SCM_VALIDATE_CHAR (1, chr);
  return scm_from_uint32 (SCM_CHAR(chr));
}
#undef FUNC_NAME

SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
           (SCM n),
            "Return the character that has Unicode code point @var{n}.  The integer\n"
            "@var{n} must be a valid code point.  Valid code points are in the\n"
            "ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n"
            "@code{#x10FFFF} inclusive.")
#define FUNC_NAME s_scm_integer_to_char
{
  scm_t_wchar cn;

  cn = scm_to_wchar (n);

  /* Avoid the surrogates.  */
  if (!SCM_IS_UNICODE_CHAR (cn))
    scm_out_of_range (FUNC_NAME, n);

  return SCM_MAKE_CHAR (cn);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
           (SCM chr),
	    "Return the uppercase character version of @var{chr}.")
#define FUNC_NAME s_scm_char_upcase
{
  SCM_VALIDATE_CHAR (1, chr);
  return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
           (SCM chr),
	    "Return the lowercase character version of @var{chr}.")
#define FUNC_NAME s_scm_char_downcase
{
  SCM_VALIDATE_CHAR (1, chr);
  return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_titlecase, "char-titlecase", 1, 0, 0,
	   (SCM chr),
	    "Return the titlecase character version of @var{chr}.")
#define FUNC_NAME s_scm_char_titlecase
{
  SCM_VALIDATE_CHAR (1, chr);
  return SCM_MAKE_CHAR (scm_c_titlecase (SCM_CHAR(chr)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_general_category, "char-general-category", 1, 0, 0,
           (SCM chr),
            "Return a symbol representing the Unicode general category of "
            "@var{chr} or @code{#f} if a named category cannot be found.")
#define FUNC_NAME s_scm_char_general_category
{
  const char *sym;
  uc_general_category_t cat;

  SCM_VALIDATE_CHAR (1, chr);
  cat = uc_general_category (SCM_CHAR (chr));
  sym = uc_general_category_name (cat);

  if (sym != NULL)
    return scm_from_locale_symbol (sym);
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/*
TODO: change name  to scm_i_.. ? --hwn
*/

scm_t_wchar
scm_c_upcase (scm_t_wchar c)
{
  return uc_toupper ((int) c);
}

scm_t_wchar
scm_c_downcase (scm_t_wchar c)
{
  return uc_tolower ((int) c);
}

scm_t_wchar
scm_c_titlecase (scm_t_wchar c)
{
  return uc_totitle ((int) c);
}

/* There are a few sets of character names: R5RS, Guile
   extensions for control characters, and leftover Guile extensions.
   They are listed in order of precedence.  */

static const char *const scm_r5rs_charnames[] = {
  "space", "newline"
};

static const scm_t_uint32 const scm_r5rs_charnums[] = {
  0x20, 0x0a
};

#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))

static const char *const scm_r6rs_charnames[] = {
  "nul", "alarm", "backspace", "tab", "linefeed", "vtab", "page",
  "return", "esc", "delete"
  /* 'space' and 'newline' are already included from the R5RS list.  */
};

static const scm_t_uint32 const scm_r6rs_charnums[] = {
  0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c,
  0x0d, 0x1b, 0x7f
};

#define SCM_N_R6RS_CHARNAMES (sizeof (scm_r6rs_charnames) / sizeof (char *))

/* The abbreviated names for control characters.  */
static const char *const scm_C0_control_charnames[] = {
  /* C0 controls */
  "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
  "bs",  "ht",  "lf",  "vt",  "ff",  "cr",  "so",  "si",
  "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
  "can", "em",  "sub", "esc", "fs",  "gs",  "rs",  "us",
  "sp", "del"
};

static const scm_t_uint32 const scm_C0_control_charnums[] = {
  0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
  0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
  0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
  0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
  0x20, 0x7f
};

#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *))

static const char *const scm_alt_charnames[] = {
  "null", "nl", "np"
};

static const scm_t_uint32 const scm_alt_charnums[] = {
  0x00, 0x0a, 0x0c
};

#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))

/* Returns the string charname for a character if it exists, or NULL
   otherwise.  */
const char *
scm_i_charname (SCM chr)
{
  size_t c;
  scm_t_uint32 i = SCM_CHAR (chr);

  for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
    if (scm_r5rs_charnums[c] == i)
      return scm_r5rs_charnames[c];

  for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
    if (scm_r6rs_charnums[c] == i)
      return scm_r6rs_charnames[c];

  for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
    if (scm_C0_control_charnums[c] == i)
      return scm_C0_control_charnames[c];

  /* Since the characters in scm_alt_charnums is a subset of
     scm_C0_control_charnums, this code is never reached.  */
  for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
    if (scm_alt_charnums[c] == i)
      return scm_alt_charnames[c];

  return NULL;
}

/* Return a character from a string charname.  */
SCM
scm_i_charname_to_char (const char *charname, size_t charname_len)
{
  size_t c;

  /* The R5RS charnames.  These are supposed to be case insensitive. */
  for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
    if ((strlen (scm_r5rs_charnames[c]) == charname_len)
	&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
      return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);

  /* The R6RS charnames.  R6RS says that these should be case-sensitive.  They
     are left as case-insensitive to avoid confusion.  */
  for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
    if ((strlen (scm_r6rs_charnames[c]) == charname_len)
	&& (!strncasecmp (scm_r6rs_charnames[c], charname, charname_len)))
      return SCM_MAKE_CHAR (scm_r6rs_charnums[c]);

  /* Then come the controls.  By Guile convention, these are not case
     sensitive.  */
  for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
    if ((strlen (scm_C0_control_charnames[c]) == charname_len)
	&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
      return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);

  /* Lastly are some old names carried over for compatibility.  */
  for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
    if ((strlen (scm_alt_charnames[c]) == charname_len)
	&& (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
      return SCM_MAKE_CHAR (scm_alt_charnums[c]);

  return SCM_BOOL_F;
}

void
scm_init_chars ()
{
#include "libguile/chars.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_CHARS_H
#define SCM_CHARS_H

/* Copyright (C) 1995,1996,2000,2001,2004, 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"

#ifndef SCM_T_WCHAR_DEFINED
typedef scm_t_int32 scm_t_wchar;
#define SCM_T_WCHAR_DEFINED
#endif /* SCM_T_WCHAR_DEFINED */

/* Immediate Characters
 */
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))

/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0
   to 255) to Latin-1 codepoints (0 to 255) while allowing higher
   codepoints (256 to 1114111) to pass through unchanged.

   This macro evaluates x twice, which may lead to side effects if not
   used properly. */
#define SCM_MAKE_CHAR(x)                                                \
  ((x) <= 1                                                             \
   ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char)    \
   : SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))

#define SCM_CODEPOINT_DOTTED_CIRCLE (0x25cc)
#define SCM_CODEPOINT_SURROGATE_START (0xd800)
#define SCM_CODEPOINT_SURROGATE_END (0xdfff)
#define SCM_CODEPOINT_MAX (0x10ffff)
#define SCM_IS_UNICODE_CHAR(c)                                          \
  (((scm_t_wchar) (c) >= 0                                              \
    && (scm_t_wchar) (c) < SCM_CODEPOINT_SURROGATE_START)               \
   || ((scm_t_wchar) (c) > SCM_CODEPOINT_SURROGATE_END                  \
       && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))

SCM_API SCM scm_char_p (SCM x);
SCM_API SCM scm_char_eq_p (SCM x, SCM y);
SCM_API SCM scm_char_less_p (SCM x, SCM y);
SCM_API SCM scm_char_leq_p (SCM x, SCM y);
SCM_API SCM scm_char_gr_p (SCM x, SCM y);
SCM_API SCM scm_char_geq_p (SCM x, SCM y);
SCM_API SCM scm_char_ci_eq_p (SCM x, SCM y);
SCM_API SCM scm_char_ci_less_p (SCM x, SCM y);
SCM_API SCM scm_char_ci_leq_p (SCM x, SCM y);
SCM_API SCM scm_char_ci_gr_p (SCM x, SCM y);
SCM_API SCM scm_char_ci_geq_p (SCM x, SCM y);
SCM_API SCM scm_char_alphabetic_p (SCM chr);
SCM_API SCM scm_char_numeric_p (SCM chr);
SCM_API SCM scm_char_whitespace_p (SCM chr);
SCM_API SCM scm_char_upper_case_p (SCM chr);
SCM_API SCM scm_char_lower_case_p (SCM chr);
SCM_API SCM scm_char_is_both_p (SCM chr);
SCM_API SCM scm_char_to_integer (SCM chr);
SCM_API SCM scm_integer_to_char (SCM n);
SCM_API SCM scm_char_upcase (SCM chr);
SCM_API SCM scm_char_downcase (SCM chr);
SCM_API SCM scm_char_titlecase (SCM chr);
SCM_API SCM scm_char_general_category (SCM chr);
SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
SCM_API scm_t_wchar scm_c_titlecase (scm_t_wchar c);
SCM_INTERNAL const char *scm_i_charname (SCM chr);
SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname,
                                         size_t charname_len);
SCM_INTERNAL void scm_init_chars (void);

#endif  /* SCM_CHARS_H */

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


code:
/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 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 "libguile/_scm.h"

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

#include "libguile/async.h"
#include "libguile/debug.h"
#include "libguile/root.h"
#include "libguile/stackchk.h"
#include "libguile/smob.h"
#include "libguile/ports.h"
#include "libguile/dynwind.h"
#include "libguile/eval.h"
#include "libguile/vm.h"
#include "libguile/instructions.h"

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

static scm_t_bits tc16_continuation;
#define SCM_CONTREGSP(x)	SCM_TYP16_PREDICATE (tc16_continuation, x)

#define SCM_CONTREGS(x)		((scm_t_contregs *) SCM_SMOB_DATA_1 (x))

#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
#define SCM_SET_CONTINUATION_LENGTH(x, n)\
   (SCM_CONTREGS (x)->num_stack_items = (n))
#define SCM_JMPBUF(x)		 ((SCM_CONTREGS (x))->jmpbuf)
#define SCM_DYNENV(x)		 ((SCM_CONTREGS (x))->dynenv)
#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
#define SCM_DFRAME(x)		 ((SCM_CONTREGS (x))->dframe)

/* scm_i_make_continuation will return a procedure whose objcode contains an
   instruction to reinstate the continuation. Here, as in gsubr.c and smob.c, we
   define the form of that trampoline function.
 */

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
#define META_HEADER(meta)         0, 0, 0, meta, 0, 0, 0, 0
#else
#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
#define META_HEADER(meta)         meta, 0, 0, 0, 0,      0, 0, 0
#endif

#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))

#ifdef SCM_ALIGNED
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)     \
static const type sym[]
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)  \
static SCM_ALIGNED (alignment) const type sym[]
#else
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)     \
static type *sym
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)                  \
SCM_SNARF_INIT(sym = scm_malloc_pointerless (sizeof(sym##__unaligned)); \
               memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
static type *sym = NULL;                                                \
static const type sym##__unaligned[]
#endif

#define STATIC_OBJCODE_TAG                                      \
  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))

#define SCM_STATIC_OBJCODE(sym)                                         \
  SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode);      \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = {            \
    { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) },                 \
    { SCM_BOOL_F, SCM_PACK (0) }                                        \
  };                                                                    \
  static const SCM sym = SCM_PACK (sym##__cells);                       \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)

SCM_STATIC_OBJCODE (cont_objcode) = {
  /* This code is the same as in gsubr.c, except we use continuation_call
     instead of subr_call. */
  OBJCODE_HEADER (8, 19),
  /* leave args on the stack */
  /* 0 */ scm_op_object_ref, 0, /* push scm_t_contregs smob */
  /* 2 */ scm_op_continuation_call, /* and longjmp (whee) */
  /* 3 */ scm_op_nop, /* pad to 8 bytes */
  /* 4 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,
  /* 8 */

  /* We could put some meta-info to say that this proc is a continuation. Not sure
     how to do that, though. */
  META_HEADER (19),
  /* 0 */ scm_op_make_eol, /* bindings */
  /* 1 */ scm_op_make_eol, /* sources */
  /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 3, /* arity: from ip 0 to ip 3 */
  /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
  /* 7 */ scm_op_make_int8_0, /* 0 optionals */
  /* 8 */ scm_op_make_true, /* and a rest arg */
  /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
  /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
  /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
  /* 18 */ scm_op_return /* and return */
  /* 19 */
};

SCM_STATIC_OBJCODE (call_cc_objcode) = {
  /* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
     call/cc. */
  OBJCODE_HEADER (8, 17),
  /* 0 */ scm_op_assert_nargs_ee, 0, 1, /* assert that nargs==1 */
  /* 3 */ scm_op_local_ref, 0, /* push the proc */
  /* 5 */ scm_op_tail_call_cc, /* and call/cc */
  /* 6 */ scm_op_nop, scm_op_nop, /* pad to 8 bytes */
  /* 8 */

  META_HEADER (17),
  /* 0 */ scm_op_make_eol, /* bindings */
  /* 1 */ scm_op_make_eol, /* sources */
  /* 2 */ scm_op_make_int8, 3, scm_op_make_int8, 6, /* arity: from ip 0 to ip 6 */
  /* 6 */ scm_op_make_int8_1, /* the arity is 0 required args */
  /* 7 */ scm_op_list, 0, 3, /* make a list of those 5 vals */
  /* 10 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
  /* 13 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
  /* 16 */ scm_op_return /* and return */
  /* 17 */
};

static SCM
make_continuation_trampoline (SCM contregs)
{
  SCM ret = scm_make_program (cont_objcode,
                              scm_c_make_vector (1, contregs),
                              SCM_BOOL_F);
  SCM_SET_CELL_WORD_0 (ret,
                       SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_CONTINUATION);

  return ret;
}

/* {Continuations}
 */

static int
continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
{
  scm_t_contregs *continuation = SCM_CONTREGS (obj);

  scm_puts ("#<continuation ", port);
  scm_intprint (continuation->num_stack_items, 10, port);
  scm_puts (" @ ", port);
  scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port);
  scm_putc ('>', port);
  return 1;
}

/* this may return more than once: the first time with the escape
   procedure, then subsequently with SCM_UNDEFINED (the vals already having been
   placed on the VM stack). */
#define FUNC_NAME "scm_i_make_continuation"
SCM
scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
{
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  SCM cont;
  scm_t_contregs *continuation;
  long stack_size;
  SCM_STACKITEM * src;

  SCM_FLUSH_REGISTER_WINDOWS;
  stack_size = scm_stack_size (thread->continuation_base);
  continuation = scm_gc_malloc (sizeof (scm_t_contregs)
				+ (stack_size - 1) * sizeof (SCM_STACKITEM),
				"continuation");
  continuation->num_stack_items = stack_size;
  continuation->dynenv = scm_i_dynwinds ();
  continuation->root = thread->continuation_root;
  src = thread->continuation_base;
#if ! SCM_STACK_GROWS_UP
  src -= stack_size;
#endif
  continuation->offset = continuation->stack - src;
  memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
  continuation->vm = vm;
  continuation->vm_cont = vm_cont;

  SCM_NEWSMOB (cont, tc16_continuation, continuation);

  *first = !SCM_I_SETJMP (continuation->jmpbuf);
  if (*first)
    {
#ifdef __ia64__
      continuation->backing_store_size =
	(char *) scm_ia64_ar_bsp(&continuation->jmpbuf.ctx)
	-
	(char *) thread->register_backing_store_base;
      continuation->backing_store = NULL;
      continuation->backing_store =
        scm_gc_malloc (continuation->backing_store_size,
		       "continuation backing store");
      memcpy (continuation->backing_store,
              (void *) thread->register_backing_store_base,
              continuation->backing_store_size);
#endif /* __ia64__ */
      return make_continuation_trampoline (cont);
    }
  else
    return SCM_UNDEFINED;
}
#undef FUNC_NAME

SCM
scm_i_call_with_current_continuation (SCM proc)
{
  static SCM call_cc = SCM_BOOL_F;

  if (scm_is_false (call_cc))
    call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);

  return scm_call_1 (call_cc, proc);
}

SCM
scm_i_continuation_to_frame (SCM continuation)
{
  SCM contregs;
  scm_t_contregs *cont;

  contregs = scm_c_vector_ref (scm_program_objects (continuation), 0);
  cont = SCM_CONTREGS (contregs);

  if (scm_is_true (cont->vm_cont))
    {
      struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont);
      return scm_c_make_frame (cont->vm_cont,
                               data->fp + data->reloc,
                               data->sp + data->reloc,
                               data->ra,
                               data->reloc);
    }
  else
    return SCM_BOOL_F;
}

SCM
scm_i_contregs_vm (SCM contregs)
{
  return SCM_CONTREGS (contregs)->vm;
}

SCM
scm_i_contregs_vm_cont (SCM contregs)
{
  return SCM_CONTREGS (contregs)->vm_cont;
}

/* {Apply}
 */

/* Invoking a continuation proceeds as follows:
 *
 * - the stack is made large enough for the called continuation
 * - the old windchain is unwound down to the branching point
 * - the continuation stack is copied into place
 * - the windchain is rewound up to the continuation's context
 * - the continuation is invoked via longjmp (or setcontext)
 *
 * This order is important so that unwind and rewind handlers are run
 * with their correct stack.
 */

static void scm_dynthrow (SCM);

/* Grow the stack by a fixed amount to provide space to copy in the
 * continuation.  Possibly this function has to be called several times
 * recursively before enough space is available.  Make sure the compiler does
 * not optimize the growth array away by storing it's address into a global
 * variable.
 */

static scm_t_bits scm_i_dummy;

static void
grow_stack (SCM cont)
{
  scm_t_bits growth[100];

  scm_i_dummy = (scm_t_bits) growth;
  scm_dynthrow (cont);
}

/* Copy the continuation stack into the current stack.  Calling functions from
 * within this function is safe, since only stack frames below this function's
 * own frame are overwritten.  Thus, memcpy can be used for best performance.
 */

typedef struct {
  scm_t_contregs *continuation;
  SCM_STACKITEM *dst;
} copy_stack_data;

static void
copy_stack (void *data)
{
  copy_stack_data *d = (copy_stack_data *)data;
  memcpy (d->dst, d->continuation->stack,
	  sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
#ifdef __ia64__
  SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
#endif
}

static void
copy_stack_and_call (scm_t_contregs *continuation,
		     SCM_STACKITEM * dst)
{
  long delta;
  copy_stack_data data;

  delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
  data.continuation = continuation;
  data.dst = dst;
  scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);

  SCM_I_LONGJMP (continuation->jmpbuf, 1);
}

#ifdef __ia64__
void
scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
{
  scm_i_thread *t = SCM_I_CURRENT_THREAD;

  if (t->pending_rbs_continuation)
    {
      memcpy (t->register_backing_store_base,
	      t->pending_rbs_continuation->backing_store,
	      t->pending_rbs_continuation->backing_store_size);
      t->pending_rbs_continuation = NULL;
    }
  setcontext (&JB->ctx);
}
#endif

/* Call grow_stack until the stack space is large enough, then, as the current
 * stack frame might get overwritten, let copy_stack_and_call perform the
 * actual copying and continuation calling.
 */
static void
scm_dynthrow (SCM cont)
{
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  scm_t_contregs *continuation = SCM_CONTREGS (cont);
  SCM_STACKITEM *dst = thread->continuation_base;
  SCM_STACKITEM stack_top_element;

  if (thread->critical_section_level)
    {
      fprintf (stderr, "continuation invoked from within critical section.\n");
      abort ();
    }

#if SCM_STACK_GROWS_UP
  if (dst + continuation->num_stack_items >= &stack_top_element)
    grow_stack (cont);
#else
  dst -= continuation->num_stack_items;
  if (dst <= &stack_top_element)
    grow_stack (cont);
#endif /* def SCM_STACK_GROWS_UP */

  SCM_FLUSH_REGISTER_WINDOWS;
  copy_stack_and_call (continuation, dst);
}

void
scm_i_check_continuation (SCM cont)
{
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  scm_t_contregs *continuation = SCM_CONTREGS (cont);

  if (continuation->root != thread->continuation_root)
    scm_misc_error
      ("%continuation-call",
       "invoking continuation would cross continuation barrier: ~A",
       scm_list_1 (cont));
}

void
scm_i_reinstate_continuation (SCM cont)
{
  scm_dynthrow (cont);
}

SCM
scm_i_with_continuation_barrier (scm_t_catch_body body,
				 void *body_data,
				 scm_t_catch_handler handler,
				 void *handler_data,
				 scm_t_catch_handler pre_unwind_handler,
				 void *pre_unwind_handler_data)
{
  SCM_STACKITEM stack_item;
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  SCM old_controot;
  SCM_STACKITEM *old_contbase;
  SCM result;

  /* Establish a fresh continuation root.
   */
  old_controot = thread->continuation_root;
  old_contbase = thread->continuation_base;
  thread->continuation_root = scm_cons (thread->handle, old_controot);
  thread->continuation_base = &stack_item;

  /* Call FUNC inside a catch all.  This is now guaranteed to return
     directly and exactly once.
  */
  result = scm_c_catch (SCM_BOOL_T,
			body, body_data,
			handler, handler_data,
			pre_unwind_handler, pre_unwind_handler_data);

  /* Return to old continuation root.
   */
  thread->continuation_base = old_contbase;
  thread->continuation_root = old_controot;

  return result;
}

struct c_data {
  void *(*func) (void *);
  void *data;
  void *result;
};

static SCM
c_body (void *d)
{
  struct c_data *data = (struct c_data *)d;
  data->result = data->func (data->data);
  return SCM_UNSPECIFIED;
}

static SCM
c_handler (void *d, SCM tag, SCM args)
{
  struct c_data *data = (struct c_data *)d;
  data->result = NULL;
  return SCM_UNSPECIFIED;
}

void *
scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
{
  struct c_data c_data;
  c_data.func = func;
  c_data.data = data;
  scm_i_with_continuation_barrier (c_body, &c_data,
				   c_handler, &c_data,
				   scm_handle_by_message_noexit, NULL);
  return c_data.result;
}

struct scm_data {
  SCM proc;
};

static SCM
scm_body (void *d)
{
  struct scm_data *data = (struct scm_data *)d;
  return scm_call_0 (data->proc);
}

static SCM
scm_handler (void *d, SCM tag, SCM args)
{
  return SCM_BOOL_F;
}

SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
	    (SCM proc),
"Call @var{proc} and return its result.  Do not allow the invocation of\n"
"continuations that would leave or enter the dynamic extent of the call\n"
"to @code{with-continuation-barrier}.  Such an attempt causes an error\n"
"to be signaled.\n"
"\n"
"Throws (such as errors) that are not caught from within @var{proc} are\n"
"caught by @code{with-continuation-barrier}.  In that case, a short\n"
"message is printed to the current error port and @code{#f} is returned.\n"
"\n"
"Thus, @code{with-continuation-barrier} returns exactly once.\n")
#define FUNC_NAME s_scm_with_continuation_barrier
{
  struct scm_data scm_data;
  scm_data.proc = proc;
  return scm_i_with_continuation_barrier (scm_body, &scm_data,
					  scm_handler, &scm_data,
					  scm_handle_by_message_noexit, NULL);
}
#undef FUNC_NAME

void
scm_init_continuations ()
{
  tc16_continuation = scm_make_smob_type ("continuation", 0);
  scm_set_smob_print (tc16_continuation, continuation_print);
#include "libguile/continuations.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_CONTINUATIONS_H
#define SCM_CONTINUATIONS_H

/* Copyright (C) 1995,1996,2000,2001, 2006, 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
 */

#include "libguile/__scm.h"

#ifdef __ia64__
#include <signal.h>
#include <ucontext.h>
#endif /* __ia64__ */

#define SCM_CONTINUATIONP(x) \
  (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))

/* a continuation SCM is a non-immediate pointing to a heap cell with:
   word 0: bits 0-15: smob type tag: scm_tc16_continuation.
           bits 16-31: unused.
   word 1: malloc block containing an scm_t_contregs structure with a
           tail array of SCM_STACKITEM.  the size of the array is stored
	   in the num_stack_items field of the structure.
*/

typedef struct
{
  scm_i_jmp_buf jmpbuf;
  SCM dynenv;
#ifdef __ia64__
  void *backing_store;
  unsigned long backing_store_size;
#endif /* __ia64__ */
  size_t num_stack_items;   /* size of the saved stack.  */
  SCM root;                 /* continuation root identifier.  */
  SCM vm;                   /* vm */
  SCM vm_cont;              /* vm's stack and regs */

  /* The offset from the live stack location to this copy.  This is
     used to adjust pointers from within the copied stack to the stack
     itself.

     Thus, when you read a pointer from the copied stack that points
     into the live stack, you need to add OFFSET so that it points
     into the copy.
  */
  scm_t_ptrdiff offset;

  SCM_STACKITEM stack[1];    /* copied stack of size num_stack_items.  */
} scm_t_contregs;

SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
SCM_INTERNAL void scm_i_check_continuation (SCM cont);
SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);

SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);

SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);

SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
SCM_API SCM scm_with_continuation_barrier (SCM proc);

SCM_INTERNAL SCM
scm_i_with_continuation_barrier (scm_t_catch_body body,
				 void *body_data,
				 scm_t_catch_handler handler,
				 void *handler_data,
				 scm_t_catch_handler pre_unwind_handler,
				 void *pre_unwind_handler_data);

SCM_INTERNAL void scm_init_continuations (void);

#endif  /* SCM_CONTINUATIONS_H */

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


code:
/* Copyright (C) 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
 */

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

#include "libguile/_scm.h"
#include "libguile/control.h"
#include "libguile/objcodes.h"
#include "libguile/instructions.h"
#include "libguile/vm.h"

SCM
scm_c_make_prompt (SCM k, SCM *fp, SCM *sp, scm_t_uint8 *abort_ip,
                   scm_t_uint8 escape_only_p, scm_t_int64 vm_cookie,
                   SCM winds)
{
  scm_t_bits tag;
  struct scm_prompt_registers *regs;

  tag = scm_tc7_prompt;
  if (escape_only_p)
    tag |= (SCM_F_PROMPT_ESCAPE<<8);

  regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
  regs->fp = fp;
  regs->sp = sp;
  regs->ip = abort_ip;
  regs->cookie = vm_cookie;

  return scm_double_cell (tag, SCM_UNPACK (k), (scm_t_bits)regs,
                          SCM_UNPACK (winds));
}

/* Only to be called if the SCM_PROMPT_SETJMP returns 1 */
SCM
scm_i_prompt_pop_abort_args_x (SCM prompt)
{
  size_t i, n;
  SCM vals = SCM_EOL;

  n = scm_to_size_t (SCM_PROMPT_REGISTERS (prompt)->sp[0]);
  for (i = 0; i < n; i++)
    vals = scm_cons (SCM_PROMPT_REGISTERS (prompt)->sp[-(i + 1)], vals);

  /* The abort did reset the VM's registers, but then these values
     were pushed on; so we need to pop them ourselves. */
  SCM_VM_DATA (scm_the_vm ())->sp -= n + 1;
  /* FIXME NULLSTACK */

  return vals;
}

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER(main,meta) 0, 0, 0, main, 0, 0, 0, meta+8
#define META_HEADER(meta)         0, 0, 0, meta, 0, 0, 0, 0
#else
#define OBJCODE_HEADER(main,meta) main, 0, 0, 0, meta+8, 0, 0, 0
#define META_HEADER(meta)         meta, 0, 0, 0, 0,      0, 0, 0
#endif

#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))

#ifdef SCM_ALIGNED
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)     \
static const type sym[]
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)  \
static SCM_ALIGNED (alignment) const type sym[]
#else
#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)     \
static type *sym
#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)                  \
SCM_SNARF_INIT(sym = scm_malloc_pointerless (sizeof(sym##__unaligned); \
               memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
static type *sym = NULL;                                                \
static const type sym##__unaligned[]
#endif

#define STATIC_OBJCODE_TAG                                      \
  SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))

#define SCM_STATIC_OBJCODE(sym)                                         \
  SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode);      \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = {            \
    { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) },                 \
    { SCM_BOOL_F, SCM_PACK (0) }                                        \
  };                                                                    \
  static const SCM sym = SCM_PACK (sym##__cells);                       \
  SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)

SCM_STATIC_OBJCODE (cont_objcode) = {
  /* Like in continuations.c, but with partial-cont-call. */
  OBJCODE_HEADER (8, 19),
  /* leave args on the stack */
  /* 0 */ scm_op_object_ref, 0, /* push scm_vm_cont object */
  /* 2 */ scm_op_object_ref, 1, /* push internal winds */
  /* 4 */ scm_op_partial_cont_call, /* and go! */
  /* 5 */ scm_op_nop, scm_op_nop, scm_op_nop, /* pad to 8 bytes */
  /* 8 */

  /* We could put some meta-info to say that this proc is a continuation. Not sure
     how to do that, though. */
  META_HEADER (19),
  /* 0 */ scm_op_make_eol, /* bindings */
  /* 1 */ scm_op_make_eol, /* sources */
  /* 2 */ scm_op_make_int8, 0, scm_op_make_int8, 5, /* arity: from ip 0 to ip 7 */
  /* 6 */ scm_op_make_int8_0, /* the arity is 0 required args */
  /* 7 */ scm_op_make_int8_0, /* 0 optionals */
  /* 8 */ scm_op_make_true, /* and a rest arg */
  /* 9 */ scm_op_list, 0, 5, /* make a list of those 5 vals */
  /* 12 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */
  /* 15 */ scm_op_list, 0, 3, /* pack bindings, sources, and arities into list */
  /* 18 */ scm_op_return /* and return */
  /* 19 */
};

static SCM
reify_partial_continuation (SCM vm, SCM prompt, SCM extwinds,
                            scm_t_int64 cookie)
{
  SCM vm_cont, dynwinds, intwinds = SCM_EOL, ret;
  scm_t_uint32 flags;

  /* No need to reify if the continuation is never referenced in the handler. */
  if (SCM_PROMPT_ESCAPE_P (prompt))
    return SCM_BOOL_F;

  dynwinds = scm_i_dynwinds ();
  while (!scm_is_eq (dynwinds, extwinds))
    {
      intwinds = scm_cons (scm_car (dynwinds), intwinds);
      dynwinds = scm_cdr (dynwinds);
    }

  flags = SCM_F_VM_CONT_PARTIAL;
  if (cookie >= 0 && SCM_PROMPT_REGISTERS (prompt)->cookie == cookie)
    flags |= SCM_F_VM_CONT_REWINDABLE;

  /* Since non-escape continuations should begin with a thunk application, the
     first bit of the stack should be a frame, with the saved fp equal to the fp
     that was current when the prompt was made. */
  if ((SCM*)(SCM_PROMPT_REGISTERS (prompt)->sp[1])
      != SCM_PROMPT_REGISTERS (prompt)->fp)
    abort ();

  /* Capture from the top of the thunk application frame up to the end. Set an
     MVRA only, as the post-abort code is in an MV context. */
  vm_cont = scm_i_vm_capture_stack (SCM_PROMPT_REGISTERS (prompt)->sp + 4,
                                    SCM_VM_DATA (vm)->fp,
                                    SCM_VM_DATA (vm)->sp,
                                    NULL,
                                    SCM_VM_DATA (vm)->ip,
                                    flags);

  ret = scm_make_program (cont_objcode,
                          scm_vector (scm_list_2 (vm_cont, intwinds)),
                          SCM_BOOL_F);
  SCM_SET_CELL_WORD_0 (ret,
                       SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION);
  return ret;
}

void
scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv, scm_t_int64 cookie)
{
  SCM cont, winds, prompt = SCM_BOOL_F;
  long delta;
  size_t i;

  /* Search the wind list for an appropriate prompt.
     "Waiter, please bring us the wind list." */
  for (winds = scm_i_dynwinds (), delta = 0;
       scm_is_pair (winds);
       winds = SCM_CDR (winds), delta++)
    {
      SCM elt = SCM_CAR (winds);
      if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag))
        {
          prompt = elt;
          break;
        }
    }

  /* If we didn't find anything, raise an error. */
  if (scm_is_false (prompt))
    scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));

  cont = reify_partial_continuation (vm, prompt, winds, cookie);

  /* Unwind once more, beyond the prompt. */
  winds = SCM_CDR (winds), delta++;

  /* Unwind */
  scm_dowinds (winds, delta);

  /* Restore VM regs */
  SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp;
  SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp;
  SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip;

  /* Since we're jumping down, we should always have enough space */
  if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit)
    abort ();

  /* Push vals */
  *(++(SCM_VM_DATA (vm)->sp)) = cont;
  for (i = 0; i < n; i++)
    *(++(SCM_VM_DATA (vm)->sp)) = argv[i];
  *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */

  /* Jump! */
  SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1);

  /* Shouldn't get here */
  abort ();
}

SCM_DEFINE (scm_at_abort, "@abort", 2, 0, 0, (SCM tag, SCM args),
            "Abort to the nearest prompt with tag @var{tag}.")
#define FUNC_NAME s_scm_at_abort
{
  SCM *argv;
  size_t i, n;

  SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n);
  argv = alloca (sizeof (SCM)*n);
  for (i = 0; i < n; i++, args = scm_cdr (args))
    argv[i] = scm_car (args);

  scm_c_abort (scm_the_vm (), tag, n, argv, -1);

  /* Oh, what, you're still here? The abort must have been reinstated. Actually,
     that's quite impossible, given that we're already in C-land here, so...
     abort! */

  abort ();
}
#undef FUNC_NAME

void
scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<prompt ", port);
  scm_intprint (SCM_UNPACK (exp), 16, port);
  scm_putc ('>', port);
}

void
scm_init_control (void)
{
#include "libguile/control.x"
}

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


code:
/* Copyright (C) 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
 */

#ifndef SCM_CONTROL_H
#define SCM_CONTROL_H

#define SCM_F_PROMPT_ESCAPE 0x1

#define SCM_PROMPT_P(x)		(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_prompt)
#define SCM_PROMPT_FLAGS(x)	(SCM_CELL_WORD ((x), 0) >> 8)
#define SCM_PROMPT_ESCAPE_P(x)	(SCM_PROMPT_FLAGS (x) & SCM_F_PROMPT_ESCAPE)
#define SCM_PROMPT_TAG(x)	(SCM_CELL_OBJECT ((x), 1))
#define SCM_PROMPT_REGISTERS(x)	((struct scm_prompt_registers*)SCM_CELL_WORD ((x), 2))
#define SCM_PROMPT_DYNWINDS(x)	(SCM_CELL_OBJECT ((x), 3))

#define SCM_PROMPT_SETJMP(p)	(SCM_I_SETJMP (SCM_PROMPT_REGISTERS (p)->regs))

struct scm_prompt_registers
{
  scm_t_uint8 *ip;
  SCM *sp;
  SCM *fp;
  scm_t_int64 cookie;
  scm_i_jmp_buf regs;
};

SCM_INTERNAL SCM scm_c_make_prompt (SCM k, SCM *fp, SCM *sp,
                                    scm_t_uint8 *abort_ip,
                                    scm_t_uint8 escape_only_p,
                                    scm_t_int64 vm_cookie,
                                    SCM winds);
SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (SCM prompt);

SCM_INTERNAL void scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv,
                               scm_t_int64 cookie) SCM_NORETURN;
SCM_INTERNAL SCM scm_at_abort (SCM tag, SCM args) SCM_NORETURN;

SCM_INTERNAL void scm_i_prompt_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_control (void);

#endif /* SCM_CONTROL_H */


code:
/* This code in included by numbers.c to generate integer conversion
   functions like scm_to_int and scm_from_int.  It is only for signed
   types, see conv-uinteger.i.c for the unsigned variant.
*/

/* You need to define the following macros before including this
   template.  They are undefined at the end of this file to give a
   clean slate for the next inclusion.

   TYPE         - the integral type to be converted
   TYPE_MIN     - the smallest representable number of TYPE
   TYPE_MAX     - the largest representable number of TYPE
   SIZEOF_TYPE  - the size of TYPE, equal to "sizeof (TYPE)" but
                  in a form that can be computed by the preprocessor.
		  When this number is 0, the preprocessor is not used
		  to select which code to compile; the most general
		  code is always used.

   SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg)
                - These two macros should expand into the prototype
                  for the two defined functions, without the return
                  type.

*/

TYPE
SCM_TO_TYPE_PROTO (SCM val)
{
  if (SCM_I_INUMP (val))
    {
      scm_t_signed_bits n = SCM_I_INUM (val);
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SIZEOF_SCM_T_BITS
      return n;
#else
      if (n >= TYPE_MIN && n <= TYPE_MAX)
	return n;
      else
	{
	  goto out_of_range;
	}
#endif
    }
  else if (SCM_BIGP (val))
    {
      if (TYPE_MIN >= SCM_MOST_NEGATIVE_FIXNUM
	  && TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM)
	goto out_of_range;
      else if (TYPE_MIN >= LONG_MIN && TYPE_MAX <= LONG_MAX)
	{
	  if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
	    {
	      long n = mpz_get_si (SCM_I_BIG_MPZ (val));
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
	      return n;
#else
	      if (n >= TYPE_MIN && n <= TYPE_MAX)
		return n;
	      else
		goto out_of_range;
#endif
	    }
	  else
	    goto out_of_range;
	}
      else
	{
	  scm_t_intmax n;
	  size_t count;

	  if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
	      > CHAR_BIT*sizeof (scm_t_uintmax))
	    goto out_of_range;

	  mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
		      SCM_I_BIG_MPZ (val));

	  if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
	    {
	      if (n < 0)
		goto out_of_range;
	    }
	  else
	    {
	      n = -n;
	      if (n >= 0)
		goto out_of_range;
	    }

	  if (n >= TYPE_MIN && n <= TYPE_MAX)
	    return n;
	  else
	    {
	    out_of_range:
	      scm_i_range_error (val,
				 scm_from_signed_integer (TYPE_MIN),
				 scm_from_signed_integer (TYPE_MAX));
	      return 0;
	    }
	}
    }
  else
    {
      scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
      return 0;
    }
}

SCM
SCM_FROM_TYPE_PROTO (TYPE val)
{
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS
  return SCM_I_MAKINUM (val);
#else
  if (SCM_FIXABLE (val))
    return SCM_I_MAKINUM (val);
  else if (val >= LONG_MIN && val <= LONG_MAX)
    return scm_i_long2big (val);
  else
    {
      SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
      mpz_init (SCM_I_BIG_MPZ (z));
      if (val < 0)
	{
	  val = -val;
	  mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0,
		      &val);
	  mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
	}
      else
	mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0,
		    &val);
      return z;
    }
#endif
}

/* clean up */
#undef TYPE
#undef TYPE_MIN
#undef TYPE_MAX
#undef SIZEOF_TYPE
#undef SCM_TO_TYPE_PROTO
#undef SCM_FROM_TYPE_PROTO

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


code:
/* This code in included by number.s.c to generate integer conversion
   functions like scm_to_int and scm_from_int.  It is only for
   unsigned types, see conv-integer.i.c for the signed variant.
*/

/* You need to define the following macros before including this
   template.  They are undefined at the end of this file to giove a
   clean slate for the next inclusion.

   TYPE         - the integral type to be converted
   TYPE_MIN     - the smallest representable number of TYPE, typically 0.
   TYPE_MAX     - the largest representable number of TYPE
   SIZEOF_TYPE  - the size of TYPE, equal to "sizeof (TYPE)" but
                  in a form that can be computed by the preprocessor.
		  When this number is 0, the preprocessor is not used
		  to select which code to compile; the most general
		  code is always used.

   SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg)
                - These two macros should expand into the prototype
                  for the two defined functions, without the return
                  type.

*/

TYPE
SCM_TO_TYPE_PROTO (SCM val)
{
  if (SCM_I_INUMP (val))
    {
      scm_t_signed_bits n = SCM_I_INUM (val);
      if (n >= 0
	  && ((scm_t_uintmax)n) >= TYPE_MIN && ((scm_t_uintmax)n) <= TYPE_MAX)
	return n;
      else
	{
	out_of_range:
	  scm_i_range_error (val,
			     scm_from_unsigned_integer (TYPE_MIN),
			     scm_from_unsigned_integer (TYPE_MAX));
	  return 0;
	}
    }
  else if (SCM_BIGP (val))
    {
      if (TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM)
	goto out_of_range;
      else if (TYPE_MAX <= ULONG_MAX)
	{
	  if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
	    {
	      unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
	      return n;
#else

              if (n >= TYPE_MIN && n <= TYPE_MAX)
                return n;
              else
                goto out_of_range;

#endif
	    }
	  else
	    goto out_of_range;
	}
      else
	{
	  scm_t_uintmax n;
	  size_t count;

	  if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
	    goto out_of_range;

	  if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
	      > CHAR_BIT*sizeof (TYPE))
	    goto out_of_range;

	  mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val));

	  if (n >= TYPE_MIN && n <= TYPE_MAX)
	    return n;
          else
            goto out_of_range;

	}
    }
  else
    {
      scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
      return 0;
    }
}

SCM
SCM_FROM_TYPE_PROTO (TYPE val)
{
#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS
  return SCM_I_MAKINUM (val);
#else
  if (SCM_POSFIXABLE (val))
    return SCM_I_MAKINUM (val);
  else if (val <= ULONG_MAX)
    return scm_i_ulong2big (val);
  else
    {
      SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
      mpz_init (SCM_I_BIG_MPZ (z));
      mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, &val);
      return z;
    }
#endif
}

#undef TYPE
#undef TYPE_MIN
#undef TYPE_MAX
#undef SIZEOF_TYPE
#undef SCM_TO_TYPE_PROTO
#undef SCM_FROM_TYPE_PROTO


code:
E2BIG
EACCES
EADDRINUSE
EADDRNOTAVAIL
EADV
EAFNOSUPPORT
EAGAIN
EALREADY
EBADE
EBADF
EBADFD
EBADMSG
EBADR
EBADRQC
EBADSLT
EBFONT
EBUSY
ECHILD
ECHRNG
ECOMM
ECONNABORTED
ECONNREFUSED
ECONNRESET
EDEADLK
EDEADLOCK
EDESTADDRREQ
EDOM
EDOTDOT
EDQUOT
EEXIST
EFAULT
EFBIG
EHOSTDOWN
EHOSTUNREACH
EIDRM
EILSEQ
EINPROGRESS
EINTR
EINVAL
EIO
EISCONN
EISDIR
EISNAM
EL2HLT
EL2NSYNC
EL3HLT
EL3RST
ELIBACC
ELIBBAD
ELIBEXEC
ELIBMAX
ELIBSCN
ELNRNG
ELOOP
EMFILE
EMLINK
EMSGSIZE
EMULTIHOP
ENAMETOOLONG
ENAVAIL
ENETDOWN
ENETRESET
ENETUNREACH
ENFILE
ENOANO
ENOBUFS
ENOCSI
ENODATA
ENODEV
ENOENT
ENOEXEC
ENOLCK
ENOLINK
ENOMEM
ENOMSG
ENONET
ENOPKG
ENOPROTOOPT
ENOSPC
ENOSR
ENOSTR
ENOSYS
ENOTBLK
ENOTCONN
ENOTDIR
ENOTEMPTY
ENOTNAM
ENOTSOCK
ENOTTY
ENOTUNIQ
ENXIO
EOPNOTSUPP
EOVERFLOW
EPERM
EPFNOSUPPORT
EPIPE
EPROTO
EPROTONOSUPPORT
EPROTOTYPE
ERANGE
EREMCHG
EREMOTE
EREMOTEIO
ERESTART
EROFS
ESHUTDOWN
ESOCKTNOSUPPORT
ESPIPE
ESRCH
ESRMNT
ESTALE
ESTRPIPE
ETIME
ETIMEDOUT
ETOOMANYREFS
ETXTBSY
EUCLEAN
EUNATCH
EUSERS
EWOULDBLOCK
EXDEV
EXFULL


code:
SIGABRT
SIGALRM
SIGBREAK
SIGBUS
SIGCHLD
SIGCLD
SIGCONT
SIGFPE
SIGHUP
SIGILL
SIGINT
SIGIO
SIGIOT
SIGKILL
SIGPIPE
SIGPOLL
SIGPROF
SIGPWR
SIGQUIT
SIGSEGV
SIGSTKFLT
SIGSTOP
SIGSYS
SIGTERM
SIGTRAP
SIGTSTP
SIGTTIN
SIGTTOU
SIGUNUSED
SIGURG
SIGUSR1
SIGUSR2
SIGVTALRM
SIGWINCH
SIGXCPU
SIGXFSZ


code:
/* Copyright (C) 2000, 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
 */

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

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

#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/strings.h"

#include "libguile/debug-malloc.h"

/*
 * The following code is a hack which I wrote quickly in order to
 * solve a memory leak problem.  Since I wanted to have the
 * application running at close to normal speed, I prioritized speed
 * over maintainability.  /mdj
 */

typedef struct hash_entry {
  const void *key;
  const void *data;
} hash_entry_t;

#define N_SEEK 8

static int malloc_type_size = 31;
static hash_entry_t *malloc_type = 0;
static int malloc_object_size = 8191;
static hash_entry_t *malloc_object = 0;

#define TABLE(table) malloc_ ## table
#define SIZE(table) malloc_ ## table ## _size
#define HASH(table, key) \
  &TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]

#define CREATE_HASH_ENTRY_AT(entry, table, h, k, done)	\
{							\
  int i;						\
  do							\
    {							\
      for (i = 0; i < N_SEEK; ++i)			\
	if (h[i].key == 0)				\
	  goto done;					\
      grow (&TABLE (table), &SIZE (table));		\
      h = HASH (table, k);				\
    }							\
  while (1);						\
 done:							\
  (entry) = &h[i];					\
}

#define CREATE_HASH_ENTRY(table, k, d, done)		\
  do							\
    {							\
      hash_entry_t *h = HASH (table, k);		\
      hash_entry_t *entry;				\
      CREATE_HASH_ENTRY_AT (entry, table, h, k, done);	\
      entry->key = (k);					\
      entry->data = (d);				\
    }							\
  while (0)

#define GET_CREATE_HASH_ENTRY(entry, table, k, done)		\
  do								\
    {								\
      hash_entry_t *h = HASH (table, k);			\
      int i;							\
      for (i = 0; i < N_SEEK; ++i)				\
	if (h[i].key == (void *) (k))				\
	  goto done;						\
       CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done);	\
       entry->key = (k);					\
       entry->data = 0;						\
       break;							\
     done:							\
      (entry) = &h[i];						\
    }								\
  while (0)

static void
grow (hash_entry_t **table, int *size)
{
  hash_entry_t *oldtable = *table;
  int oldsize = *size + N_SEEK;
  hash_entry_t *TABLE (new) = 0;
  int SIZE (new);
  int i, j;
  SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
 again:
  TABLE (new) = realloc (TABLE (new),
			 sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
  memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
  for (i = 0; i < oldsize; ++i)
    if (oldtable[i].key)
      {
	hash_entry_t *h = HASH (new, oldtable[i].key);
	for (j = 0; j < N_SEEK; ++j)
	  if (h[j].key == 0)
	    {
	      h[j] = oldtable[i];
	      goto next;
	    }
	SIZE (new) *= 2;
	goto again;
      next:
	;
      }
  if (table == &malloc_type)
    {
      /* relocate malloc_object entries */
      for (i = 0; i < oldsize; ++i)
	if (oldtable[i].key)
	  {
	    hash_entry_t *h = HASH (new, oldtable[i].key);
	    while (h->key != oldtable[i].key)
	      ++h;
	    oldtable[i].data = h;
	  }
      for (i = 0; i < malloc_object_size + N_SEEK; ++i)
	if (malloc_object[i].key)
	  malloc_object[i].data
	    = ((hash_entry_t *) malloc_object[i].data)->data;
    }
  free (*table);
  *table = TABLE (new);
  *size = SIZE (new);
}

void
scm_malloc_register (void *obj, const char *what)
{
  hash_entry_t *type;
  GET_CREATE_HASH_ENTRY (type, type, what, l1);
  type->data = (void *) ((int) type->data + 1);
  CREATE_HASH_ENTRY (object, obj, type, l2);
}

void
scm_malloc_unregister (void *obj)
{
  hash_entry_t *object, *type;
  GET_CREATE_HASH_ENTRY (object, object, obj, l1);
  type = (hash_entry_t *) object->data;
  if (type == 0)
    {
      fprintf (stderr,
	       "scm_gc_free called on object not allocated with scm_gc_malloc\n");
      abort ();
    }
  type->data = (void *) ((int) type->data - 1);
  object->key = 0;
}

void
scm_malloc_reregister (void *old, void *new, const char *newwhat)
{
  hash_entry_t *object, *type;

  if (old == NULL)
    scm_malloc_register (new, newwhat);
  else
    {
      GET_CREATE_HASH_ENTRY (object, object, old, l1);
      type = (hash_entry_t *) object->data;
      if (type == 0)
	{
	  fprintf (stderr,
		   "scm_gc_realloc called on object not allocated "
		   "with scm_gc_malloc\n");
	  abort ();
	}
      if (strcmp ((char *) type->key, newwhat) != 0)
	{
	  if (strcmp (newwhat, "vector-set-length!") != 0)
	    {
	      fprintf (stderr,
		       "scm_gc_realloc called with arg %s, was %s\n",
		       newwhat,
		       (char *) type->key);
	      abort ();
	    }
	}
      if (new != old)
	{
	  object->key = 0;
	  CREATE_HASH_ENTRY (object, new, type, l2);
	}
    }
}

SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
	    (),
	    "Return an alist ((@var{what} . @var{n}) ...) describing number\n"
	    "of malloced objects.\n"
	    "@var{what} is the second argument to @code{scm_gc_malloc},\n"
	    "@var{n} is the number of objects of that type currently\n"
	    "allocated.")
#define FUNC_NAME s_scm_malloc_stats
{
  SCM res = SCM_EOL;
  int i;
  for (i = 0; i < malloc_type_size + N_SEEK; ++i)
    if (malloc_type[i].key)
      res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key),
		       scm_from_int ((int) malloc_type[i].data),
		       res);
  return res;
}
#undef FUNC_NAME

void
scm_debug_malloc_prehistory ()
{
  malloc_type = malloc (sizeof (hash_entry_t)
			* (malloc_type_size + N_SEEK));
  memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
  malloc_object = malloc (sizeof (hash_entry_t)
			  * (malloc_object_size + N_SEEK));
  memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
}

void
scm_init_debug_malloc ()
{
#include "libguile/debug-malloc.x"
}


code:
/* classes: h_files */

#ifndef SCM_DEBUG_MALLOC_H
#define SCM_DEBUG_MALLOC_H

/* Copyright (C) 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 void scm_malloc_register (void *obj, const char *what);
SCM_API void scm_malloc_unregister (void *obj);
SCM_API void scm_malloc_reregister (void *obj, void *new, const char *what);

SCM_API SCM scm_malloc_stats (void);

SCM_INTERNAL void scm_debug_malloc_prehistory (void);
SCM_INTERNAL void scm_init_debug_malloc (void);

#endif  /* SCM_DEBUG_MALLOC_H */

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


code:
/* Debugging extensions for Guile
 * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010 Free Software Foundation
 *
 * 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

#ifdef HAVE_GETRLIMIT
#include <sys/time.h>
#include <sys/resource.h>
#endif

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
#include "libguile/list.h"
#include "libguile/stackchk.h"
#include "libguile/throw.h"
#include "libguile/macros.h"
#include "libguile/smob.h"
#include "libguile/struct.h"
#include "libguile/procprop.h"
#include "libguile/srcprop.h"
#include "libguile/alist.h"
#include "libguile/continuations.h"
#include "libguile/strports.h"
#include "libguile/read.h"
#include "libguile/feature.h"
#include "libguile/dynwind.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/fluids.h"
#include "libguile/programs.h"
#include "libguile/memoize.h"
#include "libguile/vm.h"

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

#include "libguile/private-options.h"

/* {Run time control of the debugging evaluator}
 */

SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
            (SCM setting),
	    "Option interface for the debug options. Instead of using\n"
	    "this procedure directly, use the procedures @code{debug-enable},\n"
	    "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
#define FUNC_NAME s_scm_debug_options
{
  SCM ans;

  scm_dynwind_begin (0);
  scm_dynwind_critical_section (SCM_BOOL_F);

  ans = scm_options (setting, scm_debug_opts, FUNC_NAME);
  if (SCM_N_FRAMES < 1)
    {
      scm_options (ans, scm_debug_opts, FUNC_NAME);
      SCM_OUT_OF_RANGE (1, setting);
    }
#ifdef STACK_CHECKING
  scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif

  scm_dynwind_end ();
  return ans;
}
#undef FUNC_NAME

static void
with_traps_before (void *data)
{
  int *trap_flag = data;
  *trap_flag = SCM_TRAPS_P;
  SCM_TRAPS_P = 1;
}

static void
with_traps_after (void *data)
{
  int *trap_flag = data;
  SCM_TRAPS_P = *trap_flag;
}

static SCM
with_traps_inner (void *data)
{
  SCM thunk = SCM_PACK ((scm_t_bits) data);
  return scm_call_0 (thunk);
}

SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
            (SCM thunk),
	    "Call @var{thunk} with traps enabled.")
#define FUNC_NAME s_scm_with_traps
{
  int trap_flag;
  SCM_VALIDATE_THUNK (1, thunk);
  return scm_internal_dynamic_wind (with_traps_before,
				    with_traps_inner,
				    with_traps_after,
				    (void *) SCM_UNPACK (thunk),
				    &trap_flag);
}
#undef FUNC_NAME

SCM_SYMBOL (scm_sym_source, "source");

SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
            (SCM proc),
	    "Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
  SCM_VALIDATE_PROC (1, proc);
  while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
    proc = SCM_STRUCT_PROCEDURE (proc);
  return scm_procedure_property (proc, scm_sym_name);
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
            (SCM proc),
	    "Return the source of the procedure @var{proc}.")
#define FUNC_NAME s_scm_procedure_source
{
  SCM src;
  SCM_VALIDATE_PROC (1, proc);

  do
    {
      src = scm_procedure_property (proc, scm_sym_source);
      if (scm_is_true (src))
        return src;

      switch (SCM_TYP7 (proc)) {
      case scm_tcs_struct:
        if (!SCM_STRUCT_APPLICABLE_P (proc)
            || SCM_IMP (SCM_STRUCT_PROCEDURE (proc)))
          break;
        proc = SCM_STRUCT_PROCEDURE (proc);
        continue;
      default:
        break;
      }
    }
  while (0);

  return SCM_BOOL_F;
}
#undef FUNC_NAME

#if 0
SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
#endif

SCM
scm_reverse_lookup (SCM env, SCM data)
{
  while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
    {
      SCM names = SCM_CAAR (env);
      SCM values = SCM_CDAR (env);
      while (scm_is_pair (names))
	{
	  if (scm_is_eq (SCM_CAR (values), data))
	    return SCM_CAR (names);
	  names = SCM_CDR (names);
	  values = SCM_CDR (values);
	}
      if (!scm_is_null (names) && scm_is_eq (values, data))
	return names;
      env = SCM_CDR (env);
    }
  return SCM_BOOL_F;
}

/* Undocumented debugging procedure */
#ifdef GUILE_DEBUG
SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
            (SCM obj),
	    "Go into an endless loop, which can be only terminated with\n"
	    "a debugger.")
#define FUNC_NAME s_scm_debug_hang
{
  int go = 0;
  while (!go) ;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

static void
init_stack_limit (void)
{
#ifdef HAVE_GETRLIMIT
  struct rlimit lim;
  if (getrlimit (RLIMIT_STACK, &lim) == 0)
      {
        rlim_t bytes = lim.rlim_cur;

        /* set our internal stack limit to 80% of the rlimit. */
        if (bytes == RLIM_INFINITY)
          bytes = lim.rlim_max;

        if (bytes != RLIM_INFINITY)
          SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
      }
  errno = 0;
#endif
}

void
scm_init_debug ()
{
  init_stack_limit ();
  scm_init_opts (scm_debug_options, scm_debug_opts);

  scm_add_feature ("debug-extensions");

#include "libguile/debug.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_DEBUG_H
#define SCM_DEBUG_H

/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,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
 */

#include "libguile/__scm.h"

#include "libguile/options.h"

/* {Evaluator}
 */

typedef union scm_t_debug_info
{
  struct { SCM exp, env; } e;
  struct { SCM proc, args; } a;
  SCM id;
} scm_t_debug_info;

SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
SCM_API SCM scm_evaluator_traps (SCM setting);
SCM_API SCM scm_debug_options (SCM setting);

SCM_INTERNAL void scm_init_debug (void);

#ifdef GUILE_DEBUG
SCM_API SCM scm_debug_hang (SCM obj);
#endif /*GUILE_DEBUG*/

#if SCM_ENABLE_DEPRECATED == 1

#define CHECK_ENTRY      scm_check_entry_p
#define CHECK_APPLY	 scm_check_apply_p
#define CHECK_EXIT       scm_check_exit_p

/* Deprecated in guile 1.7.0 on 2004-03-29.  */
#define SCM_DEBUGGINGP scm_debug_mode_p
#define scm_debug_mode scm_debug_mode_p

#endif

#endif  /* SCM_DEBUG_H */

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