code:
/* classes: h_files */

#ifndef SCM_ASYNC_H
#define SCM_ASYNC_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 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 2.1 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/root.h"
#include "libguile/threads.h"

#define scm_mask_ints (SCM_I_CURRENT_THREAD->block_asyncs != 0)

SCM_API void scm_async_click (void);
SCM_API void scm_switch (void);
SCM_API SCM scm_async (SCM thunk);
SCM_API SCM scm_async_mark (SCM a);
SCM_API SCM scm_system_async_mark (SCM a);
SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread);
SCM_API void scm_i_queue_async_cell (SCM cell, scm_i_thread *);
SCM_API int scm_i_setup_sleep (scm_i_thread *,
			       SCM obj, scm_i_pthread_mutex_t *m, int fd);
SCM_API void scm_i_reset_sleep (scm_i_thread *);
SCM_API SCM scm_run_asyncs (SCM list_of_a);
SCM_API SCM scm_noop (SCM args);
SCM_API SCM scm_call_with_blocked_asyncs (SCM proc);
SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc);
void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
void scm_dynwind_block_asyncs (void);
void scm_dynwind_unblock_asyncs (void);

/* Critical sections */

/* XXX - every critical section needs to be examined whether the
   requirements for SCM_CRITICAL_SECTION_START/END are fulfilled.  See
   the manual.
*/

/* Defined in threads.c. */
extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;

#define SCM_CRITICAL_SECTION_START \
  do { \
    scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex);\
    SCM_I_CURRENT_THREAD->block_asyncs++; \
    SCM_I_CURRENT_THREAD->critical_section_level++; \
  } while (0)
#define SCM_CRITICAL_SECTION_END \
  do { \
    SCM_I_CURRENT_THREAD->critical_section_level--; \
    SCM_I_CURRENT_THREAD->block_asyncs--; \
    scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
    scm_async_click ();	\
  } while (0)

SCM_API void scm_init_async (void);

#if (SCM_ENABLE_DEPRECATED == 1)

SCM_API SCM scm_system_async (SCM thunk);
SCM_API SCM scm_unmask_signals (void);
SCM_API SCM scm_mask_signals (void);

#endif

#endif  /* SCM_ASYNC_H */

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


code:
/* Printing of backtraces and error messages
 * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 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 2.1 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 <assert.h>

#include "libguile/_scm.h"

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

#include "libguile/stacks.h"
#include "libguile/srcprop.h"
#include "libguile/struct.h"
#include "libguile/strports.h"
#include "libguile/throw.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"

#include "libguile/validate.h"
#include "libguile/lang.h"
#include "libguile/backtrace.h"
#include "libguile/filesys.h"

/* {Error reporting and backtraces}
 *
 * Note that these functions shouldn't generate errors themselves.
 */

/* Print parameters for error messages. */

#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL   7
#define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10

/* Print parameters for failing expressions in error messages.
 * (See also `print_params' below for backtrace print parameters.)
 */

#define DISPLAY_EXPRESSION_MAX_LEVEL      2
#define DISPLAY_EXPRESSION_MAX_LENGTH     3

#undef SCM_ASSERT
#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
	if (!(_cond)) \
          return SCM_BOOL_F;

SCM scm_the_last_stack_fluid_var;

static void
display_header (SCM source, SCM port)
{
  if (SCM_MEMOIZEDP (source))
    {
      SCM fname = scm_source_property (source, scm_sym_filename);
      SCM line = scm_source_property (source, scm_sym_line);
      SCM col = scm_source_property (source, scm_sym_column);

      /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
       * filename with the source properties?  Then we could in case of
       * non-file ports give at least some more details than just
       * "<unnamed port>". */
      if (scm_is_true (fname))
	scm_prin1 (fname, port, 0);
      else
	scm_puts ("<unnamed port>", port);

      if (scm_is_true (line) && scm_is_true (col))
	{
	  scm_putc (':', port);
	  scm_intprint (scm_to_long (line) + 1, 10, port);
	  scm_putc (':', port);
	  scm_intprint (scm_to_long (col) + 1, 10, port);
	}
    }
  else
    scm_puts ("ERROR", port);
  scm_puts (": ", port);
}

struct display_error_message_data {
  SCM message;
  SCM args;
  SCM port;
  scm_print_state *pstate;
  int old_fancyp;
  int old_level;
  int old_length;
};

static SCM
display_error_message (struct display_error_message_data *d)
{
  if (scm_is_string (d->message) && scm_is_true (scm_list_p (d->args)))
    scm_simple_format (d->port, d->message, d->args);
  else
    scm_display (d->message, d->port);
  scm_newline (d->port);
  return SCM_UNSPECIFIED;
}

static void
before_display_error_message (struct display_error_message_data *d)
{
  scm_print_state *pstate = d->pstate;
  d->old_fancyp = pstate->fancyp;
  d->old_level  = pstate->level;
  d->old_length = pstate->length;
  pstate->fancyp = 1;
  pstate->level  = DISPLAY_ERROR_MESSAGE_MAX_LEVEL;
  pstate->length = DISPLAY_ERROR_MESSAGE_MAX_LENGTH;
}

static void
after_display_error_message (struct display_error_message_data *d)
{
  scm_print_state *pstate = d->pstate;
  pstate->fancyp = d->old_fancyp;
  pstate->level  = d->old_level;
  pstate->length = d->old_length;
}

void
scm_display_error_message (SCM message, SCM args, SCM port)
{
  struct display_error_message_data d;
  SCM print_state;
  scm_print_state *pstate;

  port = scm_i_port_with_print_state (port, SCM_UNDEFINED);
  print_state = SCM_PORT_WITH_PS_PS (port);
  pstate = SCM_PRINT_STATE (print_state);

  d.message = message;
  d.args = args;
  d.port = port;
  d.pstate = pstate;
  scm_internal_dynamic_wind ((scm_t_guard) before_display_error_message,
			     (scm_t_inner) display_error_message,
			     (scm_t_guard) after_display_error_message,
			     &d,
			     &d);
}

static void
display_expression (SCM frame, SCM pname, SCM source, SCM port)
{
  SCM print_state = scm_make_print_state ();
  scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  pstate->writingp = 0;
  pstate->fancyp = 1;
  pstate->level  = DISPLAY_EXPRESSION_MAX_LEVEL;
  pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
  if (scm_is_symbol (pname) || scm_is_string (pname))
    {
      if (SCM_FRAMEP (frame)
	  && SCM_FRAME_EVAL_ARGS_P (frame))
	scm_puts ("While evaluating arguments to ", port);
      else
	scm_puts ("In procedure ", port);
      scm_iprin1 (pname, port, pstate);
      if (SCM_MEMOIZEDP (source))
	{
	  scm_puts (" in expression ", port);
	  pstate->writingp = 1;
	  scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
	}
    }
  else if (SCM_MEMOIZEDP (source))
    {
      scm_puts ("In expression ", port);
      pstate->writingp = 1;
      scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
    }
  scm_puts (":\n", port);
  scm_free_print_state (print_state);
}

struct display_error_args {
  SCM stack;
  SCM port;
  SCM subr;
  SCM message;
  SCM args;
  SCM rest;
};

static SCM
display_error_body (struct display_error_args *a)
{
  SCM current_frame = SCM_BOOL_F;
  SCM source = SCM_BOOL_F;
  SCM prev_frame = SCM_BOOL_F;
  SCM pname = a->subr;

  if (scm_debug_mode_p
      && SCM_STACKP (a->stack)
      && SCM_STACK_LENGTH (a->stack) > 0)
    {
      current_frame = scm_stack_ref (a->stack, SCM_INUM0);
      source = SCM_FRAME_SOURCE (current_frame);
      prev_frame = SCM_FRAME_PREV (current_frame);
      if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame))
	source = SCM_FRAME_SOURCE (prev_frame);
      if (!scm_is_symbol (pname)
	  && !scm_is_string (pname)
	  && SCM_FRAME_PROC_P (current_frame)
	  && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame))))
	pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
    }
  if (scm_is_symbol (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source))
    {
      display_header (source, a->port);
      display_expression (current_frame, pname, source, a->port);
    }
  display_header (source, a->port);
  scm_display_error_message (a->message, a->args, a->port);
  return SCM_UNSPECIFIED;
}

struct display_error_handler_data {
  char *mode;
  SCM port;
};

/* This is the exception handler for error reporting routines.
   Note that it is very important that this handler *doesn't* try to
   print more than the error tag, since the error very probably is
   caused by an erroneous print call-back routine.  If we would
   try to print all objects, we would enter an infinite loop. */
static SCM
display_error_handler (struct display_error_handler_data *data,
		       SCM tag, SCM args SCM_UNUSED)
{
  SCM print_state = scm_make_print_state ();
  scm_puts ("\nException during displaying of ", data->port);
  scm_puts (data->mode, data->port);
  scm_puts (": ", data->port);
  scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
  scm_putc ('\n', data->port);
  return SCM_UNSPECIFIED;
}

/* The function scm_i_display_error prints out a detailed error message.  This
 * function will be called directly within libguile to signal error messages.
 * No parameter checks will be performed by scm_i_display_error.  Thus, User
 * code should rather use the function scm_display_error.
 */
void
scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)
{
  struct display_error_args a;
  struct display_error_handler_data data;
  a.stack = stack;
  a.port  = port;
  a.subr  = subr;
  a.message = message;
  a.args  = args;
  a.rest  = rest;
  data.mode = "error";
  data.port = port;
  scm_internal_catch (SCM_BOOL_T,
		      (scm_t_catch_body) display_error_body, &a,
		      (scm_t_catch_handler) display_error_handler, &data);
}

SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
	    (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
	    "Display an error message to the output port @var{port}.\n"
	    "@var{stack} is the saved stack for the error, @var{subr} is\n"
	    "the name of the procedure in which the error occurred and\n"
	    "@var{message} is the actual error message, which may contain\n"
	    "formatting instructions. These will format the arguments in\n"
	    "the list @var{args} accordingly.  @var{rest} is currently\n"
	    "ignored.")
#define FUNC_NAME s_scm_display_error
{
  SCM_VALIDATE_OUTPUT_PORT (2, port);

  scm_i_display_error (stack, port, subr, message, args, rest);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

typedef struct {
  int level;
  int length;
} print_params_t;

static int n_print_params = 9;
static print_params_t default_print_params[] = {
  { 4, 9 }, { 4, 3 },
  { 3, 4 }, { 3, 3 },
  { 2, 4 }, { 2, 3 },
  { 1, 4 }, { 1, 3 }, { 1, 2 }
};
static print_params_t *print_params = default_print_params;

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0,
           (SCM params),
	    "Set the print parameters to the values from @var{params}.\n"
	    "@var{params} must be a list of two-element lists which must\n"
	    "hold two integer values.")
#define FUNC_NAME s_scm_set_print_params_x
{
  int i;
  int n;
  SCM ls;
  print_params_t *new_params;

  SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n);
  for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls))
    SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
		&& scm_is_unsigned_integer (SCM_CAAR (ls), 0, INT_MAX)
		&& scm_is_unsigned_integer (SCM_CADAR (ls), 0, INT_MAX),
		params,
		SCM_ARG2,
		s_scm_set_print_params_x);
  new_params = scm_malloc (n * sizeof (print_params_t));
  if (print_params != default_print_params)
    free (print_params);
  print_params = new_params;
  for (i = 0; i < n; ++i)
    {
      print_params[i].level = scm_to_int (SCM_CAAR (params));
      print_params[i].length = scm_to_int (SCM_CADAR (params));
      params = SCM_CDR (params);
    }
  n_print_params = n;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif

static void
indent (int n, SCM port)
{
  int i;
  for (i = 0; i < n; ++i)
    scm_putc (' ', port);
}

static void
display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
  int i = 0, n;
  scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
  do
    {
      pstate->length = print_params[i].length;
      ptob->seek (sport, 0, SEEK_SET);
      if (scm_is_pair (exp))
	{
	  pstate->level = print_params[i].level - 1;
	  scm_iprlist (hdr, exp, tlr[0], sport, pstate);
	  scm_puts (&tlr[1], sport);
	}
      else
	{
	  pstate->level = print_params[i].level;
	  scm_iprin1 (exp, sport, pstate);
	}
      ptob->flush (sport);
      n = ptob->seek (sport, 0, SEEK_CUR);
      ++i;
    }
  while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params);
  ptob->truncate (sport, n);

  scm_display (scm_strport_to_string (sport), port);
}

static void
display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
  SCM proc = SCM_FRAME_PROC (frame);
  SCM name = (scm_is_true (scm_procedure_p (proc))
	      ? scm_procedure_name (proc)
	      : SCM_BOOL_F);
  display_frame_expr ("[",
		      scm_cons (scm_is_true (name) ? name : proc,
				SCM_FRAME_ARGS (frame)),
		      SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
		      indentation,
		      sport,
		      port,
		      pstate);
}

SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
           (SCM frame, SCM port, SCM indent),
	    "Display a procedure application @var{frame} to the output port\n"
	    "@var{port}. @var{indent} specifies the indentation of the\n"
	    "output.")
#define FUNC_NAME s_scm_display_application
{
  SCM_VALIDATE_FRAME (1, frame);
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();
  else
    SCM_VALIDATE_OPOUTPORT (2, port);
  if (SCM_UNBNDP (indent))
    indent = SCM_INUM0;

  if (SCM_FRAME_PROC_P (frame))
    /* Display an application. */
    {
      SCM sport, print_state;
      scm_print_state *pstate;

      /* Create a string port used for adaptation of printing parameters. */
      sport = scm_mkstrport (SCM_INUM0,
			     scm_make_string (scm_from_int (240),
					      SCM_UNDEFINED),
			     SCM_OPN | SCM_WRTNG,
			     FUNC_NAME);

      /* Create a print state for printing of frames. */
      print_state = scm_make_print_state ();
      pstate = SCM_PRINT_STATE (print_state);
      pstate->writingp = 1;
      pstate->fancyp = 1;

      display_application (frame, scm_to_int (indent), sport, port, pstate);
      return SCM_BOOL_T;
    }
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_SYMBOL (sym_base, "base");

static void
display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
{
  SCM source = SCM_FRAME_SOURCE (frame);
  *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
  *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
}

static void
display_backtrace_file (frame, last_file, port, pstate)
     SCM frame;
     SCM *last_file;
     SCM port;
     scm_print_state *pstate;
{
  SCM file, line;

  display_backtrace_get_file_line (frame, &file, &line);

  if (scm_is_eq (file, *last_file))
    return;

  *last_file = file;

  scm_puts ("In ", port);
  if (scm_is_false (file))
    if (scm_is_false (line))
      scm_puts ("unknown file", port);
    else
      scm_puts ("current input", port);
  else
    {
      pstate->writingp = 0;
      scm_iprin1 (file, port, pstate);
      pstate->writingp = 1;
    }
  scm_puts (":\n", port);
}

static void
display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
{
  SCM file, line;

  display_backtrace_get_file_line (frame, &file, &line);

  if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
    {
      if (scm_is_false (file))
	{
	  if (scm_is_false (line))
	    scm_putc ('?', port);
	  else
	    scm_puts ("<stdin>", port);
	}
      else
	{
	  pstate -> writingp = 0;
#ifdef HAVE_POSIX
	  scm_iprin1 ((scm_is_string (file)?
		       scm_basename (file, SCM_UNDEFINED) : file),
		      port, pstate);
#else
	  scm_iprin1 (file, port, pstate);
#endif
	  pstate -> writingp = 1;
	}

      scm_putc (':', port);
    }
  else if (scm_is_true (line))
    {
      int i, j=0;
      for (i = scm_to_int (line)+1; i > 0; i = i/10, j++)
	;
      indent (4-j, port);
    }

  if (scm_is_false (line))
    scm_puts ("   ?", port);
  else
    scm_intprint (scm_to_int (line) + 1, 10, port);
  scm_puts (": ", port);
}

static void
display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)
{
  int n, i, j;

  /* Announce missing frames? */
  if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
    {
      indent (nfield + 1 + indentation, port);
      scm_puts ("...\n", port);
    }

  /* display file name and line number */
  if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
    display_backtrace_file_and_line (frame, port, pstate);

  /* Check size of frame number. */
  n = SCM_FRAME_NUMBER (frame);
  for (i = 0, j = n; j > 0; ++i) j /= 10;

  /* Number indentation. */
  indent (nfield - (i ? i : 1), port);

  /* Frame number. */
  scm_iprin1 (scm_from_int (n), port, pstate);

  /* Real frame marker */
  scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);

  /* Indentation. */
  indent (indentation, port);

  if (SCM_FRAME_PROC_P (frame))
    /* Display an application. */
    display_application (frame, nfield + 1 + indentation, sport, port, pstate);
  else
    /* Display a special form. */
    {
      SCM source = SCM_FRAME_SOURCE (frame);
      SCM copy = (scm_is_pair (source)
		  ? scm_source_property (source, scm_sym_copy)
		  : SCM_BOOL_F);
      SCM umcopy = (SCM_MEMOIZEDP (source)
		    ? scm_i_unmemoize_expr (source)
		    : SCM_BOOL_F);
      display_frame_expr ("(",
			  scm_is_pair (copy) ? copy : umcopy,
			  ")",
			  nfield + 1 + indentation,
			  sport,
			  port,
			  pstate);
    }
  scm_putc ('\n', port);

  /* Announce missing frames? */
  if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
    {
      indent (nfield + 1 + indentation, port);
      scm_puts ("...\n", port);
    }
}

struct display_backtrace_args {
  SCM stack;
  SCM port;
  SCM first;
  SCM depth;
  SCM highlight_objects;
};

static SCM
display_backtrace_body (struct display_backtrace_args *a)
#define FUNC_NAME "display_backtrace_body"
{
  int n_frames, beg, end, n, i, j;
  int nfield, indent_p, indentation;
  SCM frame, sport, print_state;
  SCM last_file;
  scm_print_state *pstate;

  a->port = SCM_COERCE_OUTPORT (a->port);

  /* Argument checking and extraction. */
  SCM_VALIDATE_STACK (1, a->stack);
  SCM_VALIDATE_OPOUTPORT (2, a->port);
  n_frames = scm_to_int (scm_stack_length (a->stack));
  n = scm_is_integer (a->depth) ? scm_to_int (a->depth) : SCM_BACKTRACE_DEPTH;
  if (SCM_BACKWARDS_P)
    {
      beg = scm_is_integer (a->first) ? scm_to_int (a->first) : 0;
      end = beg + n - 1;
      if (end >= n_frames)
	end = n_frames - 1;
      n = end - beg + 1;
    }
  else
    {
      if (scm_is_integer (a->first))
	{
	  beg = scm_to_int (a->first);
	  end = beg - n + 1;
	  if (end < 0)
	    end = 0;
	}
      else
	{
	  beg = n - 1;
	  end = 0;
	  if (beg >= n_frames)
	    beg = n_frames - 1;
	}
      n = beg - end + 1;
    }
  SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace);
  SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);

  /* Create a string port used for adaptation of printing parameters. */
  sport = scm_mkstrport (SCM_INUM0,
			 scm_make_string (scm_from_int (240), SCM_UNDEFINED),
			 SCM_OPN | SCM_WRTNG,
			 FUNC_NAME);

  /* Create a print state for printing of frames. */
  print_state = scm_make_print_state ();
  pstate = SCM_PRINT_STATE (print_state);
  pstate->writingp = 1;
  pstate->fancyp = 1;
  pstate->highlight_objects = a->highlight_objects;

  /* First find out if it's reasonable to do indentation. */
  if (SCM_BACKWARDS_P)
    indent_p = 0;
  else
    {
      unsigned int j;

      indent_p = 1;
      frame = scm_stack_ref (a->stack, scm_from_int (beg));
      for (i = 0, j = 0; i < n; ++i)
	{
	  if (SCM_FRAME_REAL_P (frame))
	    ++j;
	  if (j > SCM_BACKTRACE_INDENT)
	    {
	      indent_p = 0;
	      break;
	    }
	  frame = (SCM_BACKWARDS_P
		   ? SCM_FRAME_PREV (frame)
		   : SCM_FRAME_NEXT (frame));
	}
    }

  /* Determine size of frame number field. */
  j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end)));
  for (i = 0; j > 0; ++i) j /= 10;
  nfield = i ? i : 1;

  /* Print frames. */
  frame = scm_stack_ref (a->stack, scm_from_int (beg));
  indentation = 1;
  last_file = SCM_UNDEFINED;
  for (i = 0; i < n; ++i)
    {
      if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
	display_backtrace_file (frame, &last_file, a->port, pstate);

      display_frame (frame, nfield, indentation, sport, a->port, pstate);
      if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
	++indentation;
      frame = (SCM_BACKWARDS_P ?
	       SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
    }

  scm_remember_upto_here_1 (print_state);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0,
	    (SCM stack, SCM port, SCM first, SCM depth, SCM highlights),
	    "Display a backtrace to the output port @var{port}. @var{stack}\n"
	    "is the stack to take the backtrace from, @var{first} specifies\n"
	    "where in the stack to start and @var{depth} how much frames\n"
	    "to display. Both @var{first} and @var{depth} can be @code{#f},\n"
	    "which means that default values will be used.\n"
	    "When @var{highlights} is given,\n"
	    "it should be a list and all members of it are highligthed in\n"
	    "the backtrace.")
#define FUNC_NAME s_scm_display_backtrace_with_highlights
{
  struct display_backtrace_args a;
  struct display_error_handler_data data;
  a.stack = stack;
  a.port  = port;
  a.first = first;
  a.depth = depth;
  if (SCM_UNBNDP (highlights))
    a.highlight_objects = SCM_EOL;
  else
    a.highlight_objects = highlights;
  data.mode = "backtrace";
  data.port = port;
  scm_internal_catch (SCM_BOOL_T,
		      (scm_t_catch_body) display_backtrace_body, &a,
		      (scm_t_catch_handler) display_error_handler, &data);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth)
{
  return scm_display_backtrace_with_highlights (stack, port, first, depth,
						SCM_EOL);
}

SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");

SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0,
	    (SCM highlights),
	    "Display a backtrace of the stack saved by the last error\n"
	    "to the current output port.  When @var{highlights} is given,\n"
	    "it should be a list and all members of it are highligthed in\n"
	    "the backtrace.")
#define FUNC_NAME s_scm_backtrace_with_highlights
{
  SCM port = scm_current_output_port ();
  SCM the_last_stack =
    scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var));

  if (SCM_UNBNDP (highlights))
    highlights = SCM_EOL;

  if (scm_is_true (the_last_stack))
    {
      scm_newline (port);
      scm_puts ("Backtrace:\n", port);
      scm_display_backtrace_with_highlights (the_last_stack,
					     port,
					     SCM_BOOL_F,
					     SCM_BOOL_F,
					     highlights);
      scm_newline (port);
      if (scm_is_false (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var))
	  && !SCM_BACKTRACE_P)
	{
	  scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
		    "a backtrace\n"
		    "automatically if an error occurs in the future.\n",
		    port);
	  SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
	}
    }
  else
    {
      scm_puts ("No backtrace available.\n", port);
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_backtrace (void)
{
  return scm_backtrace_with_highlights (SCM_EOL);
}

void
scm_init_backtrace ()
{
  SCM f = scm_make_fluid ();
  scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f);

#include "libguile/backtrace.x"
}

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

license: unknown


code:
/* classes: h_files */

#ifndef SCM_BACKTRACE_H
#define SCM_BACKTRACE_H

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

SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
SCM_API void scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest);
SCM_API SCM scm_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest);
SCM_API SCM scm_display_application (SCM frame, SCM port, SCM indent);
SCM_API SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth);
SCM_API SCM scm_display_backtrace_with_highlights (SCM stack, SCM port, SCM first, SCM depth, SCM highlights);
SCM_API SCM scm_backtrace (void);
SCM_API SCM scm_backtrace_with_highlights (SCM highlights);
#ifdef GUILE_DEBUG
SCM_API SCM scm_set_print_params_x (SCM params);
#endif

SCM_API void scm_init_backtrace (void);

#endif  /* SCM_BACKTRACE_H */

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


code:
/*	Copyright (C) 1995, 1996, 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 2.1 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 "libguile/validate.h"
#include "libguile/boolean.h"
#include "libguile/lang.h"
#include "libguile/tags.h"

SCM_DEFINE (scm_not, "not", 1, 0, 0,
            (SCM x),
            "Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.")
#define FUNC_NAME s_scm_not
{
  return scm_from_bool (scm_is_false (x) || SCM_NILP (x));
}
#undef FUNC_NAME

SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
           (SCM obj),
            "Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.")
#define FUNC_NAME s_scm_boolean_p
{
  return scm_from_bool (scm_is_bool (obj) || SCM_NILP (obj));
}
#undef FUNC_NAME

int
scm_is_bool (SCM x)
{
  return scm_is_eq (x, SCM_BOOL_F) || scm_is_eq (x, SCM_BOOL_T);
}

int
scm_to_bool (SCM x)
{
  if (scm_is_eq (x, SCM_BOOL_F))
    return 0;
  else if (scm_is_eq (x, SCM_BOOL_T))
    return 1;
  else
    scm_wrong_type_arg (NULL, 0, x);
}

void
scm_init_boolean ()
{
#include "libguile/boolean.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_BOOLEAN_H
#define SCM_BOOLEAN_H

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

/* Boolean Values
 *
 */

#define scm_is_false(x) scm_is_eq ((x), SCM_BOOL_F)
#define scm_is_true(x)  !scm_is_false (x)

SCM_API int scm_is_bool (SCM x);
#define scm_from_bool(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
SCM_API int scm_to_bool (SCM x);

SCM_API SCM scm_not (SCM x);
SCM_API SCM scm_boolean_p (SCM obj);

SCM_API void scm_init_boolean (void);

#endif  /* SCM_BOOLEAN_H */

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


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 yylex(void);

int yyget_lineno (void);
FILE *yyget_in (void);
FILE *yyget_out (void);
int yyget_leng (void);
char *yyget_text (void);
void yyset_lineno (int line_number);
void yyset_in (FILE * in_str);
void yyset_out (FILE * out_str);
int yyget_debug (void);
void yyset_debug (int  bdebug);
int yylex_destroy (void);

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:
*/


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

SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
	     "else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
	     "ASCII sequence, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
	     "sequence, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
	     "ASCII sequence, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
	     "case, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
	     "ignoring case, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
	     "ASCII sequence ignoring case, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
	     "sequence ignoring case, else @code{#f}.")
#define FUNC_NAME s_scm_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

SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
             (SCM x, SCM y),
	     "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
	     "ASCII sequence ignoring case, else @code{#f}.")
#define FUNC_NAME s_scm_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 @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 number corresponding to ordinal position of @var{chr} in the\n"
	    "ASCII sequence.")
#define FUNC_NAME s_scm_char_to_integer
{
  SCM_VALIDATE_CHAR (1, chr);
  return scm_from_ulong (SCM_CHAR(chr));
}
#undef FUNC_NAME

SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
           (SCM n),
	    "Return the character at position @var{n} in the ASCII sequence.")
#define FUNC_NAME s_scm_integer_to_char
{
  return SCM_MAKE_CHAR (scm_to_uchar (n));
}
#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 (toupper (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 (tolower (SCM_CHAR(chr)));
}
#undef FUNC_NAME

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

int
scm_c_upcase (unsigned int c)
{
  if (c <= UCHAR_MAX)
    return toupper (c);
  else
    return c;
}

int
scm_c_downcase (unsigned int c)
{
  if (c <= UCHAR_MAX)
    return tolower (c);
  else
    return c;
}

#ifdef _DCC
# define ASCII
#else
# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
#  define EBCDIC
# endif /*  (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
#  define ASCII
# endif /*  (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
#endif /* def _DCC */

#ifdef EBCDIC
char *const scm_charnames[] =
{
  "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
   0   , 0   , "smm", "vt", "ff", "cr", "so", "si",
  "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
  "can", "em", "cc", 0   , "ifs", "igs", "irs", "ius",
   "ds", "sos", "fs", 0   , "byp", "lf", "eob", "pre",
   0   , 0   , "sm", 0   , 0   , "enq", "ack", "bel",
   0   , 0   , "syn", 0   , "pn", "rs", "uc", "eot",
   0   , 0   , 0   , 0   , "dc4", "nak", 0   , "sub",
   "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};

const char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
\040\041\042\043\044\045\046\047\
\050\051\052\053\054\055\056\057\
\060\061\062\063\064\065\066\067\
\070\071\072\073\074\075\076\077\
 \n\t\b\r\f\0";
#endif /* def EBCDIC */
#ifdef ASCII
char *const scm_charnames[] =
{
  "nul","soh","stx","etx","eot","enq","ack","bel",
   "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
  "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  "can", "em","sub","esc", "fs", "gs", "rs", "us",
  "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
const char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
  \n\t\b\r\f\0\177";
#endif /* def ASCII */

int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);

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 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 2.1 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"

/* Immediate Characters
 */
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x))
#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char)

SCM_API char *const scm_charnames[];
SCM_API int scm_n_charnames;
SCM_API const char scm_charnums[];

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 int scm_c_upcase (unsigned int c);
SCM_API int scm_c_downcase (unsigned int c);
SCM_API 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 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 2.1 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/values.h"
#include "libguile/eval.h"

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

/* {Continuations}
 */

scm_t_bits scm_tc16_continuation;

static SCM
continuation_mark (SCM obj)
{
  scm_t_contregs *continuation = SCM_CONTREGS (obj);

  scm_gc_mark (continuation->root);
  scm_gc_mark (continuation->throw_value);
  scm_mark_locations (continuation->stack, continuation->num_stack_items);
#ifdef __ia64__
  if (continuation->backing_store)
    scm_mark_locations (continuation->backing_store,
                        continuation->backing_store_size /
                        sizeof (SCM_STACKITEM));
#endif /* __ia64__ */
  return continuation->dynenv;
}

static size_t
continuation_free (SCM obj)
{
  scm_t_contregs *continuation = SCM_CONTREGS (obj);
  /* stack array size is 1 if num_stack_items is 0.  */
  size_t extra_items = (continuation->num_stack_items > 0)
    ? (continuation->num_stack_items - 1)
    : 0;
  size_t bytes_free = sizeof (scm_t_contregs)
    + extra_items * sizeof (SCM_STACKITEM);

#ifdef __ia64__
  scm_gc_free (continuation->backing_store, continuation->backing_store_size,
	       "continuation backing store");
#endif /* __ia64__ */
  scm_gc_free (continuation, bytes_free, "continuation");
  return 0;
}

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_CELL_WORD_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 the value to be passed to the
   continuation.  */
#define FUNC_NAME "scm_make_continuation"
SCM
scm_make_continuation (int *first)
{
  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->throw_value = SCM_EOL;
  continuation->root = thread->continuation_root;
  continuation->dframe = scm_i_last_debug_frame ();
  src = thread->continuation_base;
  SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);

#if ! SCM_STACK_GROWS_UP
  src -= stack_size;
#endif
  continuation->offset = continuation->stack - src;
  memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);

  *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 cont;
    }
  else
    {
      SCM ret = continuation->throw_value;
      continuation->throw_value = SCM_BOOL_F;
      return ret;
    }
}
#undef FUNC_NAME

/* 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, 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.
 */

scm_t_bits scm_i_dummy;

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

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

/* 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 val,
		     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_set_last_debug_frame (continuation->dframe);

  continuation->throw_value = val;
  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 val)
{
  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, val);
#else
  dst -= continuation->num_stack_items;
  if (dst <= &stack_top_element)
    grow_stack (cont, val);
#endif /* def SCM_STACK_GROWS_UP */

  SCM_FLUSH_REGISTER_WINDOWS;
  copy_stack_and_call (continuation, val, dst);
}

static SCM
continuation_apply (SCM cont, SCM args)
#define FUNC_NAME "continuation_apply"
{
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  scm_t_contregs *continuation = SCM_CONTREGS (cont);

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

  scm_dynthrow (cont, scm_values (args));
  return SCM_UNSPECIFIED; /* not reached */
}
#undef FUNC_NAME

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_t_debug_frame *old_lastframe;
  SCM result;

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

  /* 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->last_debug_frame = old_lastframe;
  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 ()
{
  scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
  scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
  scm_set_smob_free (scm_tc16_continuation, continuation_free);
  scm_set_smob_print (scm_tc16_continuation, continuation_print);
  scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
#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 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 2.1 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__ */

/* 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.
*/

SCM_API scm_t_bits scm_tc16_continuation;

typedef struct
{
  SCM throw_value;
  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.  */

  /* 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;

  /* The most recently created debug frame on the live stack, before
     it was saved.  This needs to be adjusted with OFFSET, above.
  */
  struct scm_t_debug_frame *dframe;

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

#define SCM_CONTINUATIONP(x)	SCM_TYP16_PREDICATE (scm_tc16_continuation, x)

#define SCM_CONTREGS(x)		((scm_t_contregs *) SCM_CELL_WORD_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_THROW_VALUE(x)	 ((SCM_CONTREGS (x))->throw_value)
#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
#define SCM_DFRAME(x)		 ((SCM_CONTREGS (x))->dframe)

SCM_API SCM scm_make_continuation (int *first);

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

SCM_API 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_API void scm_init_continuations (void);

#endif  /* SCM_CONTINUATIONS_H */

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


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:
/* Copyright (C) 2002, 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 2.1 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 "libguile/validate.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/pairs.h"
#include "libguile/unif.h"
#include "libguile/srfi-4.h"

#include "libguile/convert.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

/* char *scm_c_scm2chars (SCM obj, char *dst);
   SCM   scm_c_chars2scm (const char *src, long n);
   SCM   scm_c_chars2byvect (const char *src, long n);
*/

#define CTYPE            char
#define FROM_CTYPE       scm_from_char
#define SCM2CTYPES       scm_c_scm2chars
#define CTYPES2SCM       scm_c_chars2scm
#define CTYPES2UVECT     scm_c_chars2byvect
#if CHAR_MIN == 0
/* 'char' is unsigned. */
#define UVEC_TAG         u8
#define UVEC_CTYPE       scm_t_uint8
#else
/* 'char' is signed. */
#define UVEC_TAG         s8
#define UVEC_CTYPE       scm_t_int8
#endif
#include "libguile/convert.i.c"

/* short *scm_c_scm2shorts (SCM obj, short *dst);
   SCM scm_c_shorts2scm (const short *src, long n);
   SCM scm_c_shorts2svect (const short *src, long n);
*/

#define CTYPE            short
#define FROM_CTYPE       scm_from_short
#define SCM2CTYPES       scm_c_scm2shorts
#define CTYPES2SCM       scm_c_shorts2scm
#define CTYPES2UVECT     scm_c_shorts2svect
#define UVEC_TAG         s16
#define UVEC_CTYPE       scm_t_int16
#include "libguile/convert.i.c"

/* int *scm_c_scm2ints (SCM obj, int *dst);
   SCM scm_c_ints2scm (const int *src, long n);
   SCM scm_c_ints2ivect (const int *src, long n);
   SCM scm_c_uints2uvect (const unsigned int *src, long n);
*/

#define CTYPE            int
#define FROM_CTYPE       scm_from_int
#define SCM2CTYPES       scm_c_scm2ints
#define CTYPES2SCM       scm_c_ints2scm
#define CTYPES2UVECT     scm_c_ints2ivect
#define UVEC_TAG         s32
#define UVEC_CTYPE       scm_t_int32

#define CTYPES2UVECT_2   scm_c_uints2uvect
#define CTYPE_2          unsigned int
#define UVEC_TAG_2       u32
#define UVEC_CTYPE_2     scm_t_uint32

#include "libguile/convert.i.c"

/* long *scm_c_scm2longs (SCM obj, long *dst);
   SCM scm_c_longs2scm (const long *src, long n);
   SCM scm_c_longs2ivect (const long *src, long n);
   SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
*/

#define CTYPE            long
#define FROM_CTYPE       scm_from_long
#define SCM2CTYPES       scm_c_scm2longs
#define CTYPES2SCM       scm_c_longs2scm
#define CTYPES2UVECT     scm_c_longs2ivect
#define UVEC_TAG         s32
#define UVEC_CTYPE       scm_t_int32

#define CTYPES2UVECT_2   scm_c_ulongs2uvect
#define CTYPE_2          unsigned int
#define UVEC_TAG_2       u32
#define UVEC_CTYPE_2     scm_t_uint32

#include "libguile/convert.i.c"

/* float *scm_c_scm2floats (SCM obj, float *dst);
   SCM scm_c_floats2scm (const float *src, long n);
   SCM scm_c_floats2fvect (const float *src, long n);
*/

#define CTYPE            float
#define FROM_CTYPE       scm_from_double
#define SCM2CTYPES       scm_c_scm2floats
#define CTYPES2SCM       scm_c_floats2scm
#define CTYPES2UVECT     scm_c_floats2fvect
#define UVEC_TAG         f32
#define UVEC_CTYPE       float
#include "libguile/convert.i.c"

/* double *scm_c_scm2doubles (SCM obj, double *dst);
   SCM scm_c_doubles2scm (const double *src, long n);
   SCM scm_c_doubles2dvect (const double *src, long n);
*/

#define CTYPE            double
#define FROM_CTYPE       scm_from_double
#define SCM2CTYPES       scm_c_scm2doubles
#define CTYPES2SCM       scm_c_doubles2scm
#define CTYPES2UVECT     scm_c_doubles2dvect
#define UVEC_TAG         f64
#define UVEC_CTYPE       double
#include "libguile/convert.i.c"

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


code:
/* classes: h_files */

#ifndef SCM_CONVERT_H
#define SCM_CONVERT_H

/* Copyright (C) 2002, 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 2.1 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 char *scm_c_scm2chars (SCM obj, char *dst);
SCM_API short *scm_c_scm2shorts (SCM obj, short *dst);
SCM_API int *scm_c_scm2ints (SCM obj, int *dst);
SCM_API long *scm_c_scm2longs (SCM obj, long *dst);
SCM_API float *scm_c_scm2floats (SCM obj, float *dst);
SCM_API double *scm_c_scm2doubles (SCM obj, double *dst);

SCM_API SCM scm_c_chars2scm (const char *src, long n);
SCM_API SCM scm_c_shorts2scm (const short *src, long n);
SCM_API SCM scm_c_ints2scm (const int *src, long n);
SCM_API SCM scm_c_longs2scm (const long *src, long n);
SCM_API SCM scm_c_floats2scm (const float *src, long n);
SCM_API SCM scm_c_doubles2scm (const double *src, long n);

SCM_API SCM scm_c_chars2byvect (const char *src, long n);
SCM_API SCM scm_c_shorts2svect (const short *src, long n);
SCM_API SCM scm_c_ints2ivect (const int *src, long n);
SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n);
SCM_API SCM scm_c_longs2ivect (const long *src, long n);
SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
SCM_API SCM scm_c_floats2fvect (const float *src, long n);
SCM_API SCM scm_c_doubles2dvect (const double *src, long n);

#endif /* SCM_CONVERT_H */


code:
/* this file is #include'd (x times) by convert.c */

/* 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.

   - CTYPE

   The type of an element of the C array, for example 'char'.

   - FROM_CTYPE

   The function that converts a CTYPE to a SCM, for example
   scm_from_char.

   - UVEC_TAG

   The tag of a suitable uniform vector that can hold the CTYPE, for
   example 's8'.

   - UVEC_CTYPE

   The C type of an element of the uniform vector, for example
   scm_t_int8.

   - SCM2CTYPES

   The name of the 'SCM-to-C' function, for example scm_c_scm2chars.

   - CTYPES2SCM

   The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.

   - CTYPES2UVECT

   The name of the 'C-to-uniform-vector' function, for example
   scm_c_chars2byvect.  It will create a uniform vector of kind
   UVEC_TAG.

   - CTYPES2UVECT_2

   The name of a second 'C-to-uniform-vector' function.  Leave
   undefined if you want only one such function.

   - CTYPE_2
   - UVEC_TAG_2
   - UVEC_CTYPE_2

   The tag and C type of the second kind of uniform vector, for use
   with the function described above.

*/

/* The first level does not expand macros in the arguments. */
#define paste(a1,a2,a3)   a1##a2##a3
#define stringify(a)      #a

/* But the second level does. */
#define F(pre,T,suf)   paste(pre,T,suf)
#define S(T)           stringify(T)

/* Convert a vector, list or uniform vector into a C array.  If the
   result array in argument 2 is NULL, malloc() a new one.
*/

CTYPE *
SCM2CTYPES (SCM obj, CTYPE *data)
{
  scm_t_array_handle handle;
  size_t i, len;
  ssize_t inc;
  const UVEC_CTYPE *uvec_elements;

  obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
  uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc);

  if (data == NULL)
    data = scm_malloc (len * sizeof (CTYPE));
  for (i = 0; i < len; i++, uvec_elements += inc)
    data[i] = uvec_elements[i];

  scm_array_handle_release (&handle);

  return data;
}

/* Converts a C array into a vector. */

SCM
CTYPES2SCM (const CTYPE *data, long n)
{
  long i;
  SCM v;

  v = scm_c_make_vector (n, SCM_UNSPECIFIED);

  for (i = 0; i < n; i++)
    SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i]));

  return v;
}

/* Converts a C array into a uniform vector. */

SCM
CTYPES2UVECT (const CTYPE *data, long n)
{
  scm_t_array_handle handle;
  long i;
  SCM uvec;
  UVEC_CTYPE *uvec_elements;

  uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
  uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle,
							     NULL, NULL);
  for (i = 0; i < n; i++)
    uvec_elements[i] = data[i];

  scm_array_handle_release (&handle);

  return uvec;
}

#ifdef CTYPE2UVECT_2

SCM
CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
{
  scm_t_array_handle handle;
  long i;
  SCM uvec;
  UVEC_CTYPE_2 *uvec_elements;

  uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
  uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle,
							       NULL, NULL);

  for (i = 0; i < n; i++)
    uvec_elements[i] = data[i];

  scm_array_handle_release (&handle);

  return uvec;
}

#endif

#undef paste
#undef stringify
#undef F
#undef S

#undef CTYPE
#undef FROM_CTYPE
#undef UVEC_TAG
#undef UVEC_CTYPE
#undef SCM2CTYPES
#undef CTYPES2SCM
#undef CTYPES2UVECT
#ifdef CTYPES2UVECT_2
#undef CTYPES2UVECT_2
#undef CTYPE_2
#undef UVEC_TAG_2
#undef UVEC_CTYPE_2
#endif

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