code:
/* This file defines the procedures related to one type of uniform
   numeric vector.  It is included multiple time in srfi-4.c, once for
   each type.

   Before inclusion, the following macros must be defined.  They are
   undefined at the end of this file to get back to a clean slate for
   the next inclusion.

   - TYPE

   The type tag of the vector, for example SCM_UVEC_U8

   - TAG

   The tag name of the vector, for example u8.  The tag is used to
   form the function names and is included in the docstrings, for
   example.

   - CTYPE

   The C type of the elements, for example scm_t_uint8.  The code
   below will never do sizeof (CTYPE), thus you can use just 'float'
   for the c32 type, for example.

   When CTYPE is not defined, the functions using it are excluded.
*/

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

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

SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
	    "@code{#f} otherwise.")
#define FUNC_NAME s_F(scm_, TAG, vector_p)
{
  return uvec_p (TYPE, obj);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
            (SCM len, SCM fill),
	    "Return a newly allocated uniform numeric vector which can\n"
	    "hold @var{len} elements.  If @var{fill} is given, it is used to\n"
	    "initialize the elements, otherwise the contents of the vector\n"
	    "is unspecified.")
#define FUNC_NAME s_S(scm_make_,TAG,vector)
{
  return make_uvec (TYPE, len, fill);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
            (SCM l),
	    "Return a newly allocated uniform numeric vector containing\n"
	    "all argument values.")
#define FUNC_NAME s_F(scm_,TAG,vector)
{
  return list_to_uvec (TYPE, l);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
            (SCM uvec),
	    "Return the number of elements in the uniform numeric vector\n"
	    "@var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_length)
{
  return uvec_length (TYPE, uvec);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
            (SCM uvec, SCM index),
	    "Return the element at @var{index} in the uniform numeric\n"
	    "vector @var{uvec}.")
#define FUNC_NAME s_F(scm_,TAG,vector_ref)
{
  return uvec_ref (TYPE, uvec, index);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
            (SCM uvec, SCM index, SCM value),
	    "Set the element at @var{index} in the uniform numeric\n"
	    "vector @var{uvec} to @var{value}.  The return value is not\n"
	    "specified.")
#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
{
  return uvec_set_x (TYPE, uvec, index, value);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
            (SCM uvec),
	    "Convert the uniform numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
{
  return uvec_to_list (TYPE, uvec);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
            (SCM l),
	    "Convert the list @var{l} to a numeric uniform vector.")
#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
{
  return list_to_uvec (TYPE, l);
}
#undef FUNC_NAME

SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
	    (SCM obj),
	    "Convert @var{obj}, which can be a list, vector, or\n"
	    "uniform vector, to a numeric uniform vector of\n"
	    "type " S(TAG)".")
#define FUNC_NAME s_F(scm_any_to_,TAG,vector)
{
  return coerce_to_uvec (TYPE, obj);
}
#undef FUNC_NAME

#ifdef CTYPE

SCM
F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
{
  scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE],
				      uvec_names[TYPE]);
  return take_uvec (TYPE, data, n);
}

const CTYPE *
F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
{
  return F(scm_array_handle_,TAG,_writable_elements) (h);
}

CTYPE *
F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
{
  SCM vec = h->array;
  if (SCM_I_ARRAYP (vec))
    vec = SCM_I_ARRAY_V (vec);
  uvec_assert (TYPE, vec);
  if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
    return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
  else
    return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
}

const CTYPE *
F(scm_,TAG,vector_elements) (SCM uvec,
			     scm_t_array_handle *h,
			     size_t *lenp, ssize_t *incp)
{
  return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
}

CTYPE *
F(scm_,TAG,vector_writable_elements) (SCM uvec,
				      scm_t_array_handle *h,
				      size_t *lenp, ssize_t *incp)
{
  scm_generalized_vector_get_handle (uvec, h);
  if (lenp)
    {
      scm_t_array_dim *dim = scm_array_handle_dims (h);
      *lenp = dim->ubnd - dim->lbnd + 1;
      *incp = dim->inc;
    }
  return F(scm_array_handle_,TAG,_writable_elements) (h);
}

#endif

static SCM
F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos)
{
  return uvec_fast_ref (TYPE, handle->elements, pos);
}

static void
F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val)
{
  uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
}

#undef paste
#undef s_paste
#undef stringify
#undef F
#undef s_F
#undef S

#undef TYPE
#undef TAG
#undef CTYPE


code:
/*	Copyright (C) 1995,1996,1997, 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/ports.h"
#include "libguile/root.h"
#include "libguile/threads.h"

#include "libguile/stackchk.h"

/* {Stack Checking}
 */

#ifdef STACK_CHECKING
int scm_stack_checking_enabled_p;

SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");

void
scm_report_stack_overflow ()
{
  scm_stack_checking_enabled_p = 0;
  scm_error (scm_stack_overflow_key,
	     NULL,
	     "Stack overflow",
	     SCM_BOOL_F,
	     SCM_BOOL_F);
}

#endif

long
scm_stack_size (SCM_STACKITEM *start)
{
  SCM_STACKITEM stack;
#if SCM_STACK_GROWS_UP
  return &stack - start;
#else
  return start - &stack;
#endif /* SCM_STACK_GROWS_UP */
}

void
scm_stack_report ()
{
  SCM port = scm_current_error_port ();
  SCM_STACKITEM stack;
  scm_i_thread *thread = SCM_I_CURRENT_THREAD;

  scm_uintprint ((scm_stack_size (thread->continuation_base)
		  * sizeof (SCM_STACKITEM)),
		 16, port);
  scm_puts (" of stack: 0x", port);
  scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
  scm_puts (" - 0x", port);
  scm_uintprint ((scm_t_bits) &stack, 16, port);
  scm_puts ("\n", port);
}

SCM_DEFINE (scm_sys_get_stack_size, "%get-stack-size", 0, 0, 0,
	    (),
	    "Return the current thread's C stack size (in Scheme objects).")
#define FUNC_NAME s_scm_sys_get_stack_size
{
  return scm_from_long (scm_stack_size (SCM_I_CURRENT_THREAD->base));
}
#undef FUNC_NAME

void
scm_init_stackchk ()
{
#include "libguile/stackchk.x"
}

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

license: unknown


code:
/* classes: h_files */

#ifndef SCM_STACKCHK_H
#define SCM_STACKCHK_H

/* Copyright (C) 1995,1996,1998,2000, 2003, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 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/continuations.h"
#include "libguile/debug.h"

/* With debug options we have the possibility to disable stack checking.
 */
#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT

#ifdef STACK_CHECKING
# if SCM_STACK_GROWS_UP
#  define SCM_STACK_OVERFLOW_P(s)\
   (SCM_STACK_PTR (s) \
    > (SCM_I_CURRENT_THREAD->base + SCM_STACK_LIMIT))
# else
#  define SCM_STACK_OVERFLOW_P(s)\
   (SCM_STACK_PTR (s) \
    < (SCM_I_CURRENT_THREAD->base - SCM_STACK_LIMIT))
# endif
# define SCM_CHECK_STACK\
    {\
       SCM_STACKITEM stack;\
       if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
	 scm_report_stack_overflow ();\
    }
#else
# define SCM_CHECK_STACK /**/
#endif /* STACK_CHECKING */

SCM_API int scm_stack_checking_enabled_p;

SCM_API void scm_report_stack_overflow (void);
SCM_API long scm_stack_size (SCM_STACKITEM *start);
SCM_API void scm_stack_report (void);
SCM_API SCM scm_sys_get_stack_size (void);
SCM_API void scm_init_stackchk (void);

#endif  /* SCM_STACKCHK_H */

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


code:
/* Representation of stack frame debug information
 * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 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 "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/debug.h"
#include "libguile/continuations.h"
#include "libguile/struct.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/modules.h"
#include "libguile/root.h"
#include "libguile/strings.h"

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

/* {Frames and stacks}
 *
 * The debugging evaluator creates debug frames on the stack.  These
 * are linked from the innermost frame and outwards.  The last frame
 * created can always be accessed as SCM_LAST_DEBUG_FRAME.
 * Continuations contain a pointer to the innermost debug frame on the
 * continuation stack.
 *
 * Each debug frame contains a set of flags and information about one
 * or more stack frames.  The case of multiple frames occurs due to
 * tail recursion.  The maximal number of stack frames which can be
 * recorded in one debug frame can be set dynamically with the debug
 * option FRAMES.
 *
 * Stack frame information is of two types: eval information (the
 * expression being evaluated and its environment) and apply
 * information (the procedure being applied and its arguments).  A
 * stack frame normally corresponds to an eval/apply pair, but macros
 * and special forms (which are implemented as macros in Guile) only
 * have eval information and apply calls leads to apply only frames.
 *
 * Since we want to record the total stack information and later
 * manipulate this data at the scheme level in the debugger, we need
 * to transform it into a new representation.  In the following code
 * section you'll find the functions implementing this data type.
 *
 * Representation:
 *
 * The stack is represented as a struct with an id slot and a tail
 * array of scm_t_info_frame structs.
 *
 * A frame is represented as a pair where the car contains a stack and
 * the cdr an inum.  The inum is an index to the first SCM value of
 * the scm_t_info_frame struct.
 *
 * Stacks
 *   Constructor
 *     make-stack
 *   Selectors
 *     stack-id
 *     stack-ref
 *   Inspector
 *     stack-length
 *
 * Frames
 *   Constructor
 *     last-stack-frame
 *   Selectors
 *     frame-number
 *     frame-source
 *     frame-procedure
 *     frame-arguments
 *     frame-previous
 *     frame-next
 *   Predicates
 *     frame-real?
 *     frame-procedure?
 *     frame-evaluating-args?
 *     frame-overflow?  */

/* Some auxiliary functions for reading debug frames off the stack.
 */

/* Stacks often contain pointers to other items on the stack; for
   example, each scm_t_debug_frame structure contains a pointer to the
   next frame out.  When we capture a continuation, we copy the stack
   into the heap, and just leave all the pointers unchanged.  This
   makes it simple to restore the continuation --- just copy the stack
   back!  However, if we retrieve a pointer from the heap copy to
   another item that was originally on the stack, we have to add an
   offset to the pointer to discover the new referent.

   If PTR is a pointer retrieved from a continuation, whose original
   target was on the stack, and OFFSET is the appropriate offset from
   the original stack to the continuation, then RELOC_MUMBLE (PTR,
   OFFSET) is a pointer to the copy in the continuation of the
   original referent, cast to an scm_debug_MUMBLE *.  */
#define RELOC_INFO(ptr, offset) \
  ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
#define RELOC_FRAME(ptr, offset) \
  ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))

/* Count number of debug info frames on a stack, beginning with
 * DFRAME.  OFFSET is used for relocation of pointers when the stack
 * is read from a continuation.
 */
static scm_t_bits
stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
	     SCM *id, int *maxp)
{
  long n;
  long max_depth = SCM_BACKTRACE_MAXDEPTH;
  for (n = 0;
       dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
       dframe = RELOC_FRAME (dframe->prev, offset))
    {
      if (SCM_EVALFRAMEP (*dframe))
	{
	  scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
	  scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
	  n += (info - vect) / 2 + 1;
	  /* Data in the apply part of an eval info frame comes from previous
	     stack frame if the scm_t_debug_info vector is overflowed. */
	  if ((((info - vect) & 1) == 0)
	      && SCM_OVERFLOWP (*dframe)
	      && !SCM_UNBNDP (info[1].a.proc))
	    ++n;
	}
      else
	++n;
    }
  if (dframe && SCM_VOIDFRAMEP (*dframe))
    *id = RELOC_INFO(dframe->vect, offset)[0].id;
  else if (dframe)
    *maxp = 1;
  return n;
}

/* Read debug info from DFRAME into IFRAME.
 */
static void
read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
	    scm_t_info_frame *iframe)
{
  scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
  if (SCM_EVALFRAMEP (*dframe))
    {
      scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
      scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
      if ((info - vect) & 1)
	{
	  /* Debug.vect ends with apply info. */
	  --info;
	  if (!SCM_UNBNDP (info[1].a.proc))
	    {
	      flags |= SCM_FRAMEF_PROC;
	      iframe->proc = info[1].a.proc;
	      iframe->args = info[1].a.args;
	      if (!SCM_ARGS_READY_P (*dframe))
		flags |= SCM_FRAMEF_EVAL_ARGS;
	    }
	}
      iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
    }
  else
    {
      scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
      flags |= SCM_FRAMEF_PROC;
      iframe->proc = vect[0].a.proc;
      iframe->args = vect[0].a.args;
    }
  iframe->flags = flags;
}

/* Look up the first body form of the apply closure.  We'll use this
   below to prevent it from being displayed.
*/
static SCM
get_applybody ()
{
  SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
  if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
    return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
  else
    return SCM_UNDEFINED;
}

#define NEXT_FRAME(iframe, n, quit) \
do { \
  if (SCM_MEMOIZEDP (iframe->source) \
      && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
    { \
      iframe->source = SCM_BOOL_F; \
      if (scm_is_false (iframe->proc)) \
	{ \
	  --iframe; \
	  ++n; \
	} \
    } \
  ++iframe; \
  if (--n == 0) \
    goto quit; \
} while (0)

/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
 * starting with the first stack frame represented by debug frame
 * DFRAME.
 */

static scm_t_bits
read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
	     long n, scm_t_info_frame *iframes)
{
  scm_t_info_frame *iframe = iframes;
  scm_t_debug_info *info, *vect;
  static SCM applybody = SCM_UNDEFINED;

  /* The value of applybody has to be setup after r4rs.scm has executed. */
  if (SCM_UNBNDP (applybody))
    applybody = get_applybody ();
  for (;
       dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
       dframe = RELOC_FRAME (dframe->prev, offset))
    {
      read_frame (dframe, offset, iframe);
      if (SCM_EVALFRAMEP (*dframe))
	{
	  /* If current frame is a macro during expansion, we should
	     skip the previously recorded macro transformer
	     application frame.  */
	  if (SCM_MACROEXPP (*dframe) && iframe > iframes)
	    {
	      *(iframe - 1) = *iframe;
	      --iframe;
	    }
	  info =  RELOC_INFO (dframe->info, offset);
	  vect =  RELOC_INFO (dframe->vect, offset);
	  if ((info - vect) & 1)
	    --info;
	  /* Data in the apply part of an eval info frame comes from
	     previous stack frame if the scm_t_debug_info vector is
	     overflowed. */
	  else if (SCM_OVERFLOWP (*dframe)
		   && !SCM_UNBNDP (info[1].a.proc))
	    {
	      NEXT_FRAME (iframe, n, quit);
	      iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
	      iframe->proc = info[1].a.proc;
	      iframe->args = info[1].a.args;
	    }
	  if (SCM_OVERFLOWP (*dframe))
	    iframe->flags |= SCM_FRAMEF_OVERFLOW;
	  info -= 2;
	  NEXT_FRAME (iframe, n, quit);
	  while (info >= vect)
	    {
	      if (!SCM_UNBNDP (info[1].a.proc))
		{
		  iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
		  iframe->proc = info[1].a.proc;
		  iframe->args = info[1].a.args;
		}
	      else
		iframe->flags = SCM_UNPACK (SCM_INUM0);
	      iframe->source = scm_make_memoized (info[0].e.exp,
						  info[0].e.env);
	      info -= 2;
	      NEXT_FRAME (iframe, n, quit);
	    }
	}
      else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
	/* Skip gsubr apply frames. */
	continue;
      else
	{
	  NEXT_FRAME (iframe, n, quit);
	}
    quit:
      if (iframe > iframes)
	(iframe - 1) -> flags |= SCM_FRAMEF_REAL;
    }
  return iframe - iframes;  /* Number of frames actually read */
}

/* Narrow STACK by cutting away stackframes (mutatingly).
 *
 * Inner frames (most recent) are cut by advancing the frames pointer.
 * Outer frames are cut by decreasing the recorded length.
 *
 * Cut maximally INNER inner frames and OUTER outer frames using
 * the keys INNER_KEY and OUTER_KEY.
 *
 * Frames are cut away starting at the end points and moving towards
 * the center of the stack.  The key is normally compared to the
 * operator in application frames.  Frames up to and including the key
 * are cut.
 *
 * If INNER_KEY is #t a different scheme is used for inner frames:
 *
 * Frames up to but excluding the first source frame originating from
 * a user module are cut, except for possible application frames
 * between the user frame and the last system frame previously
 * encountered.
 */

static void
narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
{
  scm_t_stack *s = SCM_STACK (stack);
  unsigned long int i;
  long n = s->length;

  /* Cut inner part. */
  if (scm_is_eq (inner_key, SCM_BOOL_T))
    {
      /* Cut all frames up to user module code */
      for (i = 0; inner; ++i, --inner)
	{
	  SCM m = s->frames[i].source;
	  if (SCM_MEMOIZEDP (m)
	      && !SCM_IMP (SCM_MEMOIZED_ENV (m))
	      && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
	    {
	      /* Back up in order to include any non-source frames */
	      while (i > 0)
		{
		  m = s->frames[i - 1].source;
		  if (SCM_MEMOIZEDP (m))
		    break;

		  m = s->frames[i - 1].proc;
		  if (scm_is_true (scm_procedure_p (m))
		      && scm_is_true (scm_procedure_property
				      (m, scm_sym_system_procedure)))
		    break;

		  --i;
		  ++inner;
		}
	      break;
	    }
	}
    }
  else
    /* Use standard cutting procedure. */
    {
      for (i = 0; inner; --inner)
	if (scm_is_eq (s->frames[i++].proc, inner_key))
	  break;
    }
  s->frames = &s->frames[i];
  n -= i;

  /* Cut outer part. */
  for (; n && outer; --outer)
    if (scm_is_eq (s->frames[--n].proc, outer_key))
      break;

  s->length = n;
}

/* Stacks
 */

SCM scm_stack_type;

SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a calling stack.")
#define FUNC_NAME s_scm_stack_p
{
  return scm_from_bool(SCM_STACKP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
            (SCM obj, SCM args),
	    "Create a new stack. If @var{obj} is @code{#t}, the current\n"
	    "evaluation stack is used for creating the stack frames,\n"
	    "otherwise the frames are taken from @var{obj} (which must be\n"
	    "either a debug object or a continuation).\n\n"
	    "@var{args} should be a list containing any combination of\n"
	    "integer, procedure and @code{#t} values.\n\n"
	    "These values specify various ways of cutting away uninteresting\n"
	    "stack frames from the top and bottom of the stack that\n"
	    "@code{make-stack} returns.  They come in pairs like this:\n"
	    "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
	    "@var{outer_cut_2} @dots{})}.\n\n"
	    "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
	    "procedure.  @code{#t} means to cut away all frames up to but\n"
	    "excluding the first user module frame.  An integer means to cut\n"
	    "away exactly that number of frames.  A procedure means to cut\n"
	    "away all frames up to but excluding the application frame whose\n"
	    "procedure matches the specified one.\n\n"
	    "Each @var{outer_cut_N} can be an integer or a procedure.  An\n"
	    "integer means to cut away that number of frames.  A procedure\n"
	    "means to cut away frames down to but excluding the application\n"
	    "frame whose procedure matches the specified one.\n\n"
	    "If the @var{outer_cut_N} of the last pair is missing, it is\n"
	    "taken as 0.")
#define FUNC_NAME s_scm_make_stack
{
  long n, size;
  int maxp;
  scm_t_debug_frame *dframe;
  scm_t_info_frame *iframe;
  long offset = 0;
  SCM stack, id;
  SCM inner_cut, outer_cut;

  /* Extract a pointer to the innermost frame of whatever object
     scm_make_stack was given.  */
  if (scm_is_eq (obj, SCM_BOOL_T))
    {
      dframe = scm_i_last_debug_frame ();
    }
  else if (SCM_DEBUGOBJP (obj))
    {
      dframe = SCM_DEBUGOBJ_FRAME (obj);
    }
  else if (SCM_CONTINUATIONP (obj))
    {
      scm_t_contregs *cont = SCM_CONTREGS (obj);
      offset = cont->offset;
      dframe = RELOC_FRAME (cont->dframe, offset);
    }
  else
    {
      SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
      /* not reached */
    }

  /* Count number of frames.  Also get stack id tag and check whether
     there are more stackframes than we want to record
     (SCM_BACKTRACE_MAXDEPTH). */
  id = SCM_BOOL_F;
  maxp = 0;
  n = stack_depth (dframe, offset, &id, &maxp);
  size = n * SCM_FRAME_N_SLOTS;

  /* Make the stack object. */
  stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
  SCM_STACK (stack) -> id = id;
  iframe = &SCM_STACK (stack) -> tail[0];
  SCM_STACK (stack) -> frames = iframe;

  /* Translate the current chain of stack frames into debugging information. */
  n = read_frames (dframe, offset, n, iframe);
  SCM_STACK (stack) -> length = n;

  /* Narrow the stack according to the arguments given to scm_make_stack. */
  SCM_VALIDATE_REST_ARGUMENT (args);
  while (n > 0 && !scm_is_null (args))
    {
      inner_cut = SCM_CAR (args);
      args = SCM_CDR (args);
      if (scm_is_null (args))
	{
	  outer_cut = SCM_INUM0;
	}
      else
	{
	  outer_cut = SCM_CAR (args);
	  args = SCM_CDR (args);
	}

      narrow_stack (stack,
		    scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
		    scm_is_integer (inner_cut) ? 0 : inner_cut,
		    scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
		    scm_is_integer (outer_cut) ? 0 : outer_cut);

      n = SCM_STACK (stack) -> length;
    }

  if (n > 0)
    {
      if (maxp)
	iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
      return stack;
    }
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
            (SCM stack),
	    "Return the identifier given to @var{stack} by @code{start-stack}.")
#define FUNC_NAME s_scm_stack_id
{
  scm_t_debug_frame *dframe;
  long offset = 0;
  if (scm_is_eq (stack, SCM_BOOL_T))
    {
      dframe = scm_i_last_debug_frame ();
    }
  else if (SCM_DEBUGOBJP (stack))
    {
      dframe = SCM_DEBUGOBJ_FRAME (stack);
    }
  else if (SCM_CONTINUATIONP (stack))
    {
      scm_t_contregs *cont = SCM_CONTREGS (stack);
      offset = cont->offset;
      dframe = RELOC_FRAME (cont->dframe, offset);
    }
  else if (SCM_STACKP (stack))
    {
      return SCM_STACK (stack) -> id;
    }
  else
    {
      SCM_WRONG_TYPE_ARG (1, stack);
    }

  while (dframe && !SCM_VOIDFRAMEP (*dframe))
    dframe = RELOC_FRAME (dframe->prev, offset);
  if (dframe && SCM_VOIDFRAMEP (*dframe))
    return RELOC_INFO (dframe->vect, offset)[0].id;
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
            (SCM stack, SCM index),
	    "Return the @var{index}'th frame from @var{stack}.")
#define FUNC_NAME s_scm_stack_ref
{
  unsigned long int c_index;

  SCM_VALIDATE_STACK (1, stack);
  c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
  return scm_cons (stack, index);
}
#undef FUNC_NAME

SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
	    (SCM stack),
	    "Return the length of @var{stack}.")
#define FUNC_NAME s_scm_stack_length
{
  SCM_VALIDATE_STACK (1, stack);
  return scm_from_int (SCM_STACK_LENGTH (stack));
}
#undef FUNC_NAME

/* Frames
 */

SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a stack frame.")
#define FUNC_NAME s_scm_frame_p
{
  return scm_from_bool(SCM_FRAMEP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
	    (SCM obj),
	    "Return a stack which consists of a single frame, which is the\n"
	    "last stack frame for @var{obj}. @var{obj} must be either a\n"
	    "debug object or a continuation.")
#define FUNC_NAME s_scm_last_stack_frame
{
  scm_t_debug_frame *dframe;
  long offset = 0;
  SCM stack;

  if (SCM_DEBUGOBJP (obj))
    {
      dframe = SCM_DEBUGOBJ_FRAME (obj);
    }
  else if (SCM_CONTINUATIONP (obj))
    {
      scm_t_contregs *cont = SCM_CONTREGS (obj);
      offset = cont->offset;
      dframe = RELOC_FRAME (cont->dframe, offset);
    }
  else
    {
      SCM_WRONG_TYPE_ARG (1, obj);
      /* not reached */
    }

  if (!dframe || SCM_VOIDFRAMEP (*dframe))
    return SCM_BOOL_F;

  stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
			   SCM_EOL);
  SCM_STACK (stack) -> length = 1;
  SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
  read_frame (dframe, offset,
	      (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);

  return scm_cons (stack, SCM_INUM0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
	    (SCM frame),
	    "Return the frame number of @var{frame}.")
#define FUNC_NAME s_scm_frame_number
{
  SCM_VALIDATE_FRAME (1, frame);
  return scm_from_int (SCM_FRAME_NUMBER (frame));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
	    (SCM frame),
	    "Return the source of @var{frame}.")
#define FUNC_NAME s_scm_frame_source
{
  SCM_VALIDATE_FRAME (1, frame);
  return SCM_FRAME_SOURCE (frame);
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
	    (SCM frame),
	    "Return the procedure for @var{frame}, or @code{#f} if no\n"
	    "procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure
{
  SCM_VALIDATE_FRAME (1, frame);
  return (SCM_FRAME_PROC_P (frame)
	  ? SCM_FRAME_PROC (frame)
	  : SCM_BOOL_F);
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
	    (SCM frame),
	    "Return the arguments of @var{frame}.")
#define FUNC_NAME s_scm_frame_arguments
{
  SCM_VALIDATE_FRAME (1, frame);
  return SCM_FRAME_ARGS (frame);
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
	    (SCM frame),
	    "Return the previous frame of @var{frame}, or @code{#f} if\n"
	    "@var{frame} is the first frame in its stack.")
#define FUNC_NAME s_scm_frame_previous
{
  unsigned long int n;
  SCM_VALIDATE_FRAME (1, frame);
  n = scm_to_ulong (SCM_CDR (frame)) + 1;
  if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
    return SCM_BOOL_F;
  else
    return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
           (SCM frame),
	    "Return the next frame of @var{frame}, or @code{#f} if\n"
	    "@var{frame} is the last frame in its stack.")
#define FUNC_NAME s_scm_frame_next
{
  unsigned long int n;
  SCM_VALIDATE_FRAME (1, frame);
  n = scm_to_ulong (SCM_CDR (frame));
  if (n == 0)
    return SCM_BOOL_F;
  else
    return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
	    (SCM frame),
	    "Return @code{#t} if @var{frame} is a real frame.")
#define FUNC_NAME s_scm_frame_real_p
{
  SCM_VALIDATE_FRAME (1, frame);
  return scm_from_bool(SCM_FRAME_REAL_P (frame));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
	    (SCM frame),
	    "Return @code{#t} if a procedure is associated with @var{frame}.")
#define FUNC_NAME s_scm_frame_procedure_p
{
  SCM_VALIDATE_FRAME (1, frame);
  return scm_from_bool(SCM_FRAME_PROC_P (frame));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
	    (SCM frame),
	    "Return @code{#t} if @var{frame} contains evaluated arguments.")
#define FUNC_NAME s_scm_frame_evaluating_args_p
{
  SCM_VALIDATE_FRAME (1, frame);
  return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
}
#undef FUNC_NAME

SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
	    (SCM frame),
	    "Return @code{#t} if @var{frame} is an overflow frame.")
#define FUNC_NAME s_scm_frame_overflow_p
{
  SCM_VALIDATE_FRAME (1, frame);
  return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
}
#undef FUNC_NAME

void
scm_init_stacks ()
{
  scm_stack_type =
    scm_permanent_object
    (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
                      SCM_UNDEFINED));
  scm_set_struct_vtable_name_x (scm_stack_type,
				scm_from_locale_symbol ("stack"));
#include "libguile/stacks.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_STACKS_H
#define SCM_STACKS_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"

/* {Frames and stacks}
 */

typedef struct scm_t_info_frame {
  /* SCM flags; */
  scm_t_bits flags;
  SCM source;
  SCM proc;
  SCM args;
} scm_t_info_frame;
#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM))

#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj))
#define SCM_STACK_LAYOUT "pwuourpW"
typedef struct scm_t_stack {
  SCM id;			/* Stack id */
  scm_t_info_frame *frames;	/* Info frames */
  unsigned long length;		/* Stack length */
  unsigned long tail_length;
  scm_t_info_frame tail[1];
} scm_t_stack;

SCM_API SCM scm_stack_type;

#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type))
#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)

#define SCM_FRAMEP(obj) \
  (scm_is_pair (obj) && SCM_STACKP (SCM_CAR (obj)) \
   && scm_is_unsigned_integer (SCM_CDR (obj), \
                               0, SCM_STACK_LENGTH (SCM_CAR (obj))-1))

#define SCM_FRAME_REF(frame, slot) \
(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot)

#define SCM_FRAME_NUMBER(frame) \
(SCM_BACKWARDS_P \
 ? scm_to_size_t (SCM_CDR (frame)) \
 : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
    - scm_to_size_t (SCM_CDR (frame)) \
    - 1)) \

#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)

#define SCM_FRAMEF_VOID		(1L << 2)
#define SCM_FRAMEF_REAL		(1L << 3)
#define SCM_FRAMEF_PROC 	(1L << 4)
#define SCM_FRAMEF_EVAL_ARGS 	(1L << 5)
#define SCM_FRAMEF_OVERFLOW	(1L << 6)

#define SCM_FRAME_VOID_P(f)       (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_VOID)
#define SCM_FRAME_REAL_P(f)       (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_REAL)
#define SCM_FRAME_PROC_P(f)       (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_PROC)
#define SCM_FRAME_EVAL_ARGS_P(f)  (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_EVAL_ARGS)
#define SCM_FRAME_OVERFLOW_P(f)   (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_OVERFLOW)

SCM_API SCM scm_stack_p (SCM obj);
SCM_API SCM scm_make_stack (SCM obj, SCM args);
SCM_API SCM scm_stack_id (SCM stack);
SCM_API SCM scm_stack_ref (SCM stack, SCM i);
SCM_API SCM scm_stack_length (SCM stack);

SCM_API SCM scm_frame_p (SCM obj);
SCM_API SCM scm_last_stack_frame (SCM obj);
SCM_API SCM scm_frame_number (SCM frame);
SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_procedure (SCM frame);
SCM_API SCM scm_frame_arguments (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);
SCM_API SCM scm_frame_next (SCM frame);
SCM_API SCM scm_frame_real_p (SCM frame);
SCM_API SCM scm_frame_procedure_p (SCM frame);
SCM_API SCM scm_frame_evaluating_args_p (SCM frame);
SCM_API SCM scm_frame_overflow_p (SCM frame);

SCM_API void scm_init_stacks (void);

#endif  /* SCM_STACKS_H */

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


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 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
 */

/* _POSIX_C_SOURCE is not defined always, because it causes problems on some
   systems, notably

       - FreeBSD loses all BSD and XOPEN defines.
       - glibc loses some things like CLK_TCK.
       - On MINGW it conflicts with the pthread headers.

   But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r.

   Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and
   what it takes away, and decide from that whether to use it, instead of
   hard coding __hpux.  */

#ifndef _REENTRANT
# define _REENTRANT   /* ask solaris for gmtime_r prototype */
#endif
#ifdef __hpux
#define _POSIX_C_SOURCE 199506L  /* for gmtime_r prototype */
#endif

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

#include <stdio.h>
#include <errno.h>

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/feature.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/dynwind.h"

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

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

# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.h>
# endif

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

#ifdef HAVE_SYS_TIMES_H
# include <sys/times.h>
#endif

#ifdef HAVE_SYS_TIMEB_H
# include <sys/timeb.h>
#endif

#if HAVE_CRT_EXTERNS_H
#include <crt_externs.h>  /* for Darwin _NSGetEnviron */
#endif

#if defined (__MINGW32__)
# define tzname _tzname
#else
#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif
#endif

#if ! HAVE_DECL_STRPTIME
extern char *strptime ();
#endif

#ifdef __STDC__
# define timet time_t
#else
# define timet long
#endif

extern char ** environ;

/* On Apple Darwin in a shared library there's no "environ" to access
   directly, instead the address of that variable must be obtained with
   _NSGetEnviron().  */
#if HAVE__NSGETENVIRON && defined (PIC)
#define environ (*_NSGetEnviron())
#endif

#ifdef HAVE_TIMES
static
timet mytime()
{
  struct tms time_buffer;
  times(&time_buffer);
  return time_buffer.tms_utime + time_buffer.tms_stime;
}
#else
# ifdef LACK_CLOCK
#    define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
# else
#  define mytime clock
# endif
#endif

#ifdef HAVE_FTIME
struct timeb scm_your_base = {0};
#else
timet scm_your_base = 0;
#endif

SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
           (),
	    "Return the number of time units since the interpreter was\n"
	    "started.")
#define FUNC_NAME s_scm_get_internal_real_time
{
#ifdef HAVE_FTIME
  struct timeb time_buffer;

  SCM tmp;
  ftime (&time_buffer);
  time_buffer.time -= scm_your_base.time;
  tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
  tmp = scm_sum (tmp,
		 scm_product (scm_from_int (1000),
			      scm_from_int (time_buffer.time)));
  return scm_quotient (scm_product (tmp,
				    scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
		       scm_from_int (1000));
#else
  return scm_from_long ((time((timet*)0) - scm_your_base)
			* (int)SCM_TIME_UNITS_PER_SECOND);
#endif /* HAVE_FTIME */
}
#undef FUNC_NAME

#ifdef HAVE_TIMES
SCM_DEFINE (scm_times, "times", 0, 0, 0,
            (void),
	    "Return an object with information about real and processor\n"
	    "time.  The following procedures accept such an object as an\n"
	    "argument and return a selected component:\n"
	    "\n"
	    "@table @code\n"
	    "@item tms:clock\n"
	    "The current real time, expressed as time units relative to an\n"
	    "arbitrary base.\n"
	    "@item tms:utime\n"
	    "The CPU time units used by the calling process.\n"
	    "@item tms:stime\n"
	    "The CPU time units used by the system on behalf of the calling\n"
	    "process.\n"
	    "@item tms:cutime\n"
	    "The CPU time units used by terminated child processes of the\n"
	    "calling process, whose status has been collected (e.g., using\n"
	    "@code{waitpid}).\n"
	    "@item tms:cstime\n"
	    "Similarly, the CPU times units used by the system on behalf of\n"
	    "terminated child processes.\n"
	    "@end table")
#define FUNC_NAME s_scm_times
{
  struct tms t;
  clock_t rv;

  SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
  rv = times (&t);
  if (rv == -1)
    SCM_SYSERROR;
  SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
  SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
  SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
  SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
  SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
  return result;
}
#undef FUNC_NAME
#endif /* HAVE_TIMES */

static long scm_my_base = 0;

long
scm_c_get_internal_run_time ()
{
  return mytime () - scm_my_base;
}

SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
           (void),
	    "Return the number of time units of processor time used by the\n"
	    "interpreter.  Both @emph{system} and @emph{user} time are\n"
	    "included but subprocesses are not.")
#define FUNC_NAME s_scm_get_internal_run_time
{
  return scm_from_long (scm_c_get_internal_run_time ());
}
#undef FUNC_NAME

/* For reference, note that current-time and gettimeofday both should be
   protected against setzone/restorezone changes in another thread, since on
   DOS the system time is normally kept as local time, which means TZ
   affects the return from current-time and gettimeofday.  Not sure if DJGPP
   etc actually has concurrent multi-threading, but it seems prudent not to
   make assumptions about this.  */

SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
           (void),
	    "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
	    "excluding leap seconds.")
#define FUNC_NAME s_scm_current_time
{
  timet timv;

  SCM_CRITICAL_SECTION_START;
  timv = time (NULL);
  SCM_CRITICAL_SECTION_END;
  if (timv == -1)
    SCM_MISC_ERROR ("current time not available", SCM_EOL);
  return scm_from_long (timv);
}
#undef FUNC_NAME

SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
            (void),
	    "Return a pair containing the number of seconds and microseconds\n"
	    "since 1970-01-01 00:00:00 UTC, excluding leap seconds.  Note:\n"
	    "whether true microsecond resolution is available depends on the\n"
	    "operating system.")
#define FUNC_NAME s_scm_gettimeofday
{
#ifdef HAVE_GETTIMEOFDAY
  struct timeval time;
  int ret, err;

  SCM_CRITICAL_SECTION_START;
  ret = gettimeofday (&time, NULL);
  err = errno;
  SCM_CRITICAL_SECTION_END;
  if (ret == -1)
    {
      errno = err;
      SCM_SYSERROR;
    }
  return scm_cons (scm_from_long (time.tv_sec),
		   scm_from_long (time.tv_usec));
#else
# ifdef HAVE_FTIME
  struct timeb time;

  ftime(&time);
  return scm_cons (scm_from_long (time.time),
		   scm_from_int (time.millitm * 1000));
# else
  timet timv;
  int err;

  SCM_CRITICAL_SECTION_START;
  timv = time (NULL);
  err = errno;
  SCM_CRITICAL_SECTION_END;
  if (timv == -1)
    {
      errno = err;
      SCM_SYSERROR;
    }
  return scm_cons (scm_from_long (timv), scm_from_int (0));
# endif
#endif
}
#undef FUNC_NAME

static SCM
filltime (struct tm *bd_time, int zoff, const char *zname)
{
  SCM result = scm_c_make_vector (11, SCM_UNDEFINED);

  SCM_SIMPLE_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec));
  SCM_SIMPLE_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min));
  SCM_SIMPLE_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour));
  SCM_SIMPLE_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday));
  SCM_SIMPLE_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon));
  SCM_SIMPLE_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year));
  SCM_SIMPLE_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday));
  SCM_SIMPLE_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday));
  SCM_SIMPLE_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst));
  SCM_SIMPLE_VECTOR_SET (result,9, scm_from_int (zoff));
  SCM_SIMPLE_VECTOR_SET (result,10, (zname
				     ? scm_from_locale_string (zname)
				     : SCM_BOOL_F));
  return result;
}

static char tzvar[3] = "TZ";

/* if zone is set, create a temporary environment with only a TZ
   string.  other threads or interrupt handlers shouldn't be allowed
   to run until the corresponding restorezone is called.  hence the use
   of a static variable for tmpenv is no big deal.  */
static char **
setzone (SCM zone, int pos, const char *subr)
{
  char **oldenv = 0;

  if (!SCM_UNBNDP (zone))
    {
      static char *tmpenv[2];
      char *buf;
      size_t zone_len;

      zone_len = scm_to_locale_stringbuf (zone, NULL, 0);
      buf = scm_malloc (zone_len + sizeof (tzvar) + 1);
      strcpy (buf, tzvar);
      buf[sizeof(tzvar)-1] = '=';
      scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len);
      buf[sizeof(tzvar)+zone_len] = '\0';
      oldenv = environ;
      tmpenv[0] = buf;
      tmpenv[1] = 0;
      environ = tmpenv;
    }
  return oldenv;
}

static void
restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
{
  if (!SCM_UNBNDP (zone))
    {
      free (environ[0]);
      environ = oldenv;
#ifdef HAVE_TZSET
      /* for the possible benefit of user code linked with libguile.  */
      tzset();
#endif
    }
}

SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
            (SCM time, SCM zone),
	    "Return an object representing the broken down components of\n"
	    "@var{time}, an integer like the one returned by\n"
	    "@code{current-time}.  The time zone for the calculation is\n"
	    "optionally specified by @var{zone} (a string), otherwise the\n"
	    "@code{TZ} environment variable or the system default is used.")
#define FUNC_NAME s_scm_localtime
{
  timet itime;
  struct tm *ltptr, lt, *utc;
  SCM result;
  int zoff;
  char *zname = 0;
  char **oldenv;
  int err;

  itime = SCM_NUM2LONG (1, time);

  /* deferring interupts is essential since a) setzone may install a temporary
     environment b) localtime uses a static buffer.  */
  SCM_CRITICAL_SECTION_START;
  oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
#ifdef LOCALTIME_CACHE
  tzset ();
#endif
  /* POSIX says localtime sets errno, but C99 doesn't say that.
     Give a sensible default value in case localtime doesn't set it.  */
  errno = EINVAL;
  ltptr = localtime (&itime);
  err = errno;
  if (ltptr)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or restoring zone.  */
#if defined (HAVE_TM_ZONE)
      ptr = ltptr->tm_zone;
#elif defined (HAVE_TZNAME)
      ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
#else
      ptr = "";
#endif
      zname = scm_malloc (strlen (ptr) + 1);
      strcpy (zname, ptr);
    }
  /* the struct is copied in case localtime and gmtime share a buffer.  */
  if (ltptr)
    lt = *ltptr;
  /* POSIX says gmtime sets errno, but C99 doesn't say that.
     Give a sensible default value in case gmtime doesn't set it.  */
  errno = EINVAL;
  utc = gmtime (&itime);
  if (utc == NULL)
    err = errno;
  restorezone (zone, oldenv, FUNC_NAME);
  /* delayed until zone has been restored.  */
  errno = err;
  if (utc == NULL || ltptr == NULL)
    SCM_SYSERROR;

  /* calculate timezone offset in seconds west of UTC.  */
  zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
    + utc->tm_sec - lt.tm_sec;
  if (utc->tm_year < lt.tm_year)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_year > lt.tm_year)
    zoff += 24 * 60 * 60;
  else if (utc->tm_yday < lt.tm_yday)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_yday > lt.tm_yday)
    zoff += 24 * 60 * 60;

  result = filltime (&lt, zoff, zname);
  SCM_CRITICAL_SECTION_END;
  if (zname)
    free (zname);
  return result;
}
#undef FUNC_NAME

/* tm_zone is normally a pointer, not an array within struct tm, so we might
   have to worry about the lifespan of what it points to.  The posix specs
   don't seem to say anything about this, let's assume here that tm_zone
   will be a constant and therefore no protection or anything is needed
   until we copy it in filltime().  */

SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
            (SCM time),
	    "Return an object representing the broken down components of\n"
	    "@var{time}, an integer like the one returned by\n"
	    "@code{current-time}.  The values are calculated for UTC.")
#define FUNC_NAME s_scm_gmtime
{
  timet itime;
  struct tm bd_buf, *bd_time;
  const char *zname;

  itime = SCM_NUM2LONG (1, time);

  /* POSIX says gmtime sets errno, but C99 doesn't say that.
     Give a sensible default value in case gmtime doesn't set it.  */
  errno = EINVAL;

#if HAVE_GMTIME_R
  bd_time = gmtime_r (&itime, &bd_buf);
#else
  SCM_CRITICAL_SECTION_START;
  bd_time = gmtime (&itime);
  if (bd_time != NULL)
    bd_buf = *bd_time;
  SCM_CRITICAL_SECTION_END;
#endif
  if (bd_time == NULL)
    SCM_SYSERROR;

#if HAVE_STRUCT_TM_TM_ZONE
  zname = bd_buf.tm_zone;
#else
  zname = "GMT";
#endif
  return filltime (&bd_buf, 0, zname);
}
#undef FUNC_NAME

/* copy time components from a Scheme object to a struct tm.  */
static void
bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
{
  SCM_ASSERT (scm_is_simple_vector (sbd_time)
	      && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
	      sbd_time, pos, subr);

  lt->tm_sec = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 0));
  lt->tm_min = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 1));
  lt->tm_hour = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 2));
  lt->tm_mday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 3));
  lt->tm_mon = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 4));
  lt->tm_year = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 5));
  lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6));
  lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
  lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8));
#if HAVE_STRUCT_TM_TM_GMTOFF
  lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
#endif
#ifdef HAVE_TM_ZONE
  if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
    lt->tm_zone = NULL;
  else
    lt->tm_zone  = scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time, 10));
#endif
}

SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
            (SCM sbd_time, SCM zone),
	    "@var{bd-time} is an object representing broken down time and @code{zone}\n"
	    "is an optional time zone specifier (otherwise the TZ environment variable\n"
	    "or the system default is used).\n\n"
	    "Returns a pair: the car is a corresponding\n"
	    "integer time value like that returned\n"
	    "by @code{current-time}; the cdr is a broken down time object, similar to\n"
	    "as @var{bd-time} but with normalized values.")
#define FUNC_NAME s_scm_mktime
{
  timet itime;
  struct tm lt, *utc;
  SCM result;
  int zoff;
  char *zname = 0;
  char **oldenv;
  int err;

  scm_dynwind_begin (0);

  bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
#if HAVE_STRUCT_TM_TM_ZONE
  scm_dynwind_free ((char *)lt.tm_zone);
#endif

  scm_dynwind_critical_section (SCM_BOOL_F);

  oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
#ifdef LOCALTIME_CACHE
  tzset ();
#endif
  itime = mktime (&lt);
  /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
     doesn't.  Force a sensible value for our error message.  */
  err = EINVAL;

  if (itime != -1)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or restoring the zone.  */
#if defined (HAVE_TM_ZONE)
      ptr = lt.tm_zone;
#elif defined (HAVE_TZNAME)
      ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
#else
      ptr = "";
#endif
      zname = scm_malloc (strlen (ptr) + 1);
      strcpy (zname, ptr);
    }

  /* get timezone offset in seconds west of UTC.  */
  /* POSIX says gmtime sets errno, but C99 doesn't say that.
     Give a sensible default value in case gmtime doesn't set it.  */
  errno = EINVAL;
  utc = gmtime (&itime);
  if (utc == NULL)
    err = errno;

  restorezone (zone, oldenv, FUNC_NAME);
  /* delayed until zone has been restored.  */
  errno = err;
  if (utc == NULL || itime == -1)
    SCM_SYSERROR;

  zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
    + utc->tm_sec - lt.tm_sec;
  if (utc->tm_year < lt.tm_year)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_year > lt.tm_year)
    zoff += 24 * 60 * 60;
  else if (utc->tm_yday < lt.tm_yday)
    zoff -= 24 * 60 * 60;
  else if (utc->tm_yday > lt.tm_yday)
    zoff += 24 * 60 * 60;

  result = scm_cons (scm_from_long (itime),
		     filltime (&lt, zoff, zname));
  if (zname)
    free (zname);

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

#ifdef HAVE_TZSET
SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
            (void),
	    "Initialize the timezone from the TZ environment variable\n"
	    "or the system default.  It's not usually necessary to call this procedure\n"
	    "since it's done automatically by other procedures that depend on the\n"
	    "timezone.")
#define FUNC_NAME s_scm_tzset
{
  tzset();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#endif /* HAVE_TZSET */

SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
            (SCM format, SCM stime),
	    "Return a string which is broken-down time structure @var{stime}\n"
	    "formatted according to the given @var{format} string.\n"
	    "\n"
	    "@var{format} contains field specifications introduced by a\n"
	    "@samp{%} character.  See @ref{Formatting Calendar Time,,, libc,\n"
	    "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
	    "for the available formatting.\n"
	    "\n"
	    "@lisp\n"
	    "(strftime \"%c\" (localtime (current-time)))\n"
	    "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
	    "@end lisp\n"
	    "\n"
	    "If @code{setlocale} has been called (@pxref{Locales}), month\n"
	    "and day names are from the current locale and in the locale\n"
	    "character set.")
#define FUNC_NAME s_scm_strftime
{
  struct tm t;

  char *tbuf;
  int size = 50;
  const char *fmt;
  char *myfmt;
  int len;
  SCM result;

  SCM_VALIDATE_STRING (1, format);
  bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);

  fmt = scm_i_string_chars (format);
  len = scm_i_string_length (format);

  /* Ugly hack: strftime can return 0 if its buffer is too small,
     but some valid time strings (e.g. "%p") can sometimes produce
     a zero-byte output string!  Workaround is to prepend a junk
     character to the format string, so that valid returns are always
     nonzero. */
  myfmt = scm_malloc (len+2);
  *myfmt = 'x';
  strncpy(myfmt+1, fmt, len);
  myfmt[len+1] = 0;

  tbuf = scm_malloc (size);
  {
#if !defined (HAVE_TM_ZONE)
    /* it seems the only way to tell non-GNU versions of strftime what
       zone to use (for the %Z format) is to set TZ in the
       environment.  interrupts and thread switching must be deferred
       until TZ is restored.  */
    char **oldenv = NULL;
    SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10);
    int have_zone = 0;

    if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0)
      {
	/* it's not required that the TZ setting be correct, just that
	   it has the right name.  so try something like TZ=EST0.
	   using only TZ=EST would be simpler but it doesn't work on
	   some OSs, e.g., Solaris.  */
	SCM zone =
	  scm_string_append (scm_list_2 (zone_spec,
					 scm_from_locale_string ("0")));

	have_zone = 1;
	SCM_CRITICAL_SECTION_START;
	oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
      }
#endif

#ifdef LOCALTIME_CACHE
    tzset ();
#endif

    /* POSIX says strftime returns 0 on buffer overrun, but old
       systems (i.e. libc 4 on GNU/Linux) might return `size' in that
       case. */
    while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
      {
	free (tbuf);
	size *= 2;
	tbuf = scm_malloc (size);
      }

#if !defined (HAVE_TM_ZONE)
    if (have_zone)
      {
	restorezone (zone_spec, oldenv, FUNC_NAME);
	SCM_CRITICAL_SECTION_END;
      }
#endif
    }

  result = scm_from_locale_stringn (tbuf + 1, len - 1);
  free (tbuf);
  free (myfmt);
#if HAVE_STRUCT_TM_TM_ZONE
  free ((char *) t.tm_zone);
#endif
  return result;
}
#undef FUNC_NAME

#ifdef HAVE_STRPTIME
SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
            (SCM format, SCM string),
	    "Performs the reverse action to @code{strftime}, parsing\n"
	    "@var{string} according to the specification supplied in\n"
	    "@var{template}.  The interpretation of month and day names is\n"
	    "dependent on the current locale.  The value returned is a pair.\n"
	    "The car has an object with time components\n"
	    "in the form returned by @code{localtime} or @code{gmtime},\n"
	    "but the time zone components\n"
	    "are not usefully set.\n"
	    "The cdr reports the number of characters from @var{string}\n"
	    "which were used for the conversion.")
#define FUNC_NAME s_scm_strptime
{
  struct tm t;
  const char *fmt, *str, *rest;
  long zoff;

  SCM_VALIDATE_STRING (1, format);
  SCM_VALIDATE_STRING (2, string);

  fmt = scm_i_string_chars (format);
  str = scm_i_string_chars (string);

  /* initialize the struct tm */
#define tm_init(field) t.field = 0
  tm_init (tm_sec);
  tm_init (tm_min);
  tm_init (tm_hour);
  tm_init (tm_mday);
  tm_init (tm_mon);
  tm_init (tm_year);
  tm_init (tm_wday);
  tm_init (tm_yday);
#if HAVE_STRUCT_TM_TM_GMTOFF
  tm_init (tm_gmtoff);
#endif
#undef tm_init

  /* GNU glibc strptime() "%s" is affected by the current timezone, since it
     reads a UTC time_t value and converts with localtime_r() to set the tm
     fields, hence the use of SCM_CRITICAL_SECTION_START.  */
  t.tm_isdst = -1;
  SCM_CRITICAL_SECTION_START;
  rest = strptime (str, fmt, &t);
  SCM_CRITICAL_SECTION_END;
  if (rest == NULL)
    {
      /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
         instance it doesn't.  Force a sensible value for our error
         message.  */
      errno = EINVAL;
      SCM_SYSERROR;
    }

  /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
     available */
#if HAVE_STRUCT_TM_TM_GMTOFF
  zoff = - t.tm_gmtoff;  /* seconds west, not east */
#else
  zoff = 0;
#endif

  return scm_cons (filltime (&t, zoff, NULL),
		   scm_from_signed_integer (rest - str));
}
#undef FUNC_NAME
#endif /* HAVE_STRPTIME */

void
scm_init_stime()
{
  scm_c_define ("internal-time-units-per-second",
		scm_from_long (SCM_TIME_UNITS_PER_SECOND));

#ifdef HAVE_FTIME
  if (!scm_your_base.time) ftime(&scm_your_base);
#else
  if (!scm_your_base) time(&scm_your_base);
#endif

  if (!scm_my_base) scm_my_base = mytime();

  scm_add_feature ("current-time");
#include "libguile/stime.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_STIME_H
#define SCM_STIME_H

/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 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 <unistd.h>  /* for sysconf */

/* This should be figured out by autoconf.

   sysconf(_SC_CLK_TCK) is best, since it's the actual running kernel, not
   some compile-time CLK_TCK.  On glibc 2.3.2 CLK_TCK (when defined) is in
   fact sysconf(_SC_CLK_TCK) anyway.

   CLK_TCK is obsolete in POSIX.  In glibc 2.3.2 it's defined by default,
   but if you define _GNU_SOURCE or _POSIX_C_SOURCE to get other features
   then it goes away.  */

#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(_SC_CLK_TCK)
#  define SCM_TIME_UNITS_PER_SECOND ((int) sysconf (_SC_CLK_TCK))
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLK_TCK)
#  define SCM_TIME_UNITS_PER_SECOND ((int) CLK_TCK)
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLOCKS_PER_SEC)
#  define SCM_TIME_UNITS_PER_SECOND ((int) CLOCKS_PER_SEC)
#endif
#if ! defined(SCM_TIME_UNITS_PER_SECOND)
#  define SCM_TIME_UNITS_PER_SECOND 60
#endif

SCM_API long scm_c_get_internal_run_time (void);
SCM_API SCM scm_get_internal_real_time (void);
SCM_API SCM scm_get_internal_run_time (void);
SCM_API SCM scm_current_time (void);
SCM_API SCM scm_gettimeofday (void);
SCM_API SCM scm_localtime (SCM time, SCM zone);
SCM_API SCM scm_gmtime (SCM time);
SCM_API SCM scm_mktime (SCM sbd_time, SCM zone);
SCM_API SCM scm_tzset (void);
SCM_API SCM scm_times (void);
SCM_API SCM scm_strftime (SCM format, SCM stime);
SCM_API SCM scm_strptime (SCM format, SCM string);
SCM_API void scm_init_stime (void);

#endif  /* SCM_STIME_H */

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


code:
/* Turning errno values into English error messages.
   Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 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
*/

char *
strerror (int errnum)
{
  extern char *sys_errlist[];
  extern int sys_nerr;

  if (errnum >= 0 && errnum < sys_nerr)
    return sys_errlist[errnum];
  return (char *) "Unknown error";
}

/*
  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 <string.h>
#include <stdio.h>

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/deprecation.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"

/* {Strings}
 */

/* Stringbufs
 *
 * XXX - keeping an accurate refcount during GC seems to be quite
 * tricky, so we just keep score of whether a stringbuf might be
 * shared, not wether it definitely is.
 *
 * The scheme I (mvo) tried to keep an accurate reference count would
 * recount all strings that point to a stringbuf during the mark-phase
 * of the GC.  This was done since one cannot access the stringbuf of
 * a string when that string is freed (in order to decrease the
 * reference count).  The memory of the stringbuf might have been
 * reused already for something completely different.
 *
 * This recounted worked for a small number of threads beating on
 * cow-strings, but it failed randomly with more than 10 threads, say.
 * I couldn't figure out what went wrong, so I used the conservative
 * approach implemented below.
 *
 * A stringbuf needs to know its length, but only so that it can be
 * reported when the stringbuf is freed.
 *
 * Stringbufs (and strings) are not stored very compactly: a stringbuf
 * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
 * information.  As a compensation, the code below is made more
 * complicated by storing small strings inline in the double cell of a
 * stringbuf.  So we have fixstrings and bigstrings...
 */

#define STRINGBUF_F_SHARED      0x100
#define STRINGBUF_F_INLINE      0x200

#define STRINGBUF_TAG           scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
#define STRINGBUF_INLINE(buf)   (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)

#define STRINGBUF_OUTLINE_CHARS(buf)   ((char *)SCM_CELL_WORD_1(buf))
#define STRINGBUF_OUTLINE_LENGTH(buf)  (SCM_CELL_WORD_2(buf))
#define STRINGBUF_INLINE_CHARS(buf)    ((char *)SCM_CELL_OBJECT_LOC(buf,1))
#define STRINGBUF_INLINE_LENGTH(buf)   (((size_t)SCM_CELL_WORD_0(buf))>>16)

#define STRINGBUF_CHARS(buf)  (STRINGBUF_INLINE (buf) \
                               ? STRINGBUF_INLINE_CHARS (buf) \
                               : STRINGBUF_OUTLINE_CHARS (buf))
#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
                               ? STRINGBUF_INLINE_LENGTH (buf) \
                               : STRINGBUF_OUTLINE_LENGTH (buf))

#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))

#define SET_STRINGBUF_SHARED(buf) \
  (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))

#if SCM_DEBUG
static size_t lenhist[1001];
#endif

static SCM
make_stringbuf (size_t len)
{
  /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
     scm_i_symbol_chars, all stringbufs are null-terminated.  Once
     SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
     has been changed for scm_i_symbol_chars, this null-termination
     can be dropped.
  */

#if SCM_DEBUG
  if (len < 1000)
    lenhist[len]++;
  else
    lenhist[1000]++;
#endif

  if (len <= STRINGBUF_MAX_INLINE_LEN-1)
    {
      return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
			      0, 0, 0);
    }
  else
    {
      char *mem = scm_gc_malloc (len+1, "string");
      mem[len] = '\0';
      return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
			      (scm_t_bits) len, (scm_t_bits) 0);
    }
}

/* Return a new stringbuf whose underlying storage consists of the LEN+1
   octets pointed to by STR (the last octet is zero).  */
SCM
scm_i_take_stringbufn (char *str, size_t len)
{
  scm_gc_register_collectable_memory (str, len + 1, "stringbuf");

  return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
			  (scm_t_bits) len, (scm_t_bits) 0);
}

SCM
scm_i_stringbuf_mark (SCM buf)
{
  return SCM_BOOL_F;
}

void
scm_i_stringbuf_free (SCM buf)
{
  if (!STRINGBUF_INLINE (buf))
    scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
		 STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
}

scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

/* Copy-on-write strings.
 */

#define STRING_TAG            scm_tc7_string

#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
#define STRING_START(str)     ((size_t)SCM_CELL_WORD_2(str))
#define STRING_LENGTH(str)    ((size_t)SCM_CELL_WORD_3(str))

#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))

#define IS_STRING(str)        (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)

/* Read-only strings.
 */

#define RO_STRING_TAG         (scm_tc7_string + 0x200)
#define IS_RO_STRING(str)     (SCM_CELL_TYPE(str)==RO_STRING_TAG)

/* Mutation-sharing substrings
 */

#define SH_STRING_TAG       (scm_tc7_string + 0x100)

#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
/* START and LENGTH as for STRINGs. */

#define IS_SH_STRING(str)   (SCM_CELL_TYPE(str)==SH_STRING_TAG)

SCM
scm_i_make_string (size_t len, char **charsp)
{
  SCM buf = make_stringbuf (len);
  SCM res;
  if (charsp)
    *charsp = STRINGBUF_CHARS (buf);
  res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
			 (scm_t_bits)0, (scm_t_bits) len);
  return res;
}

static void
validate_substring_args (SCM str, size_t start, size_t end)
{
  if (!IS_STRING (str))
    scm_wrong_type_arg_msg (NULL, 0, str, "string");
  if (start > STRING_LENGTH (str))
    scm_out_of_range (NULL, scm_from_size_t (start));
  if (end > STRING_LENGTH (str) || end < start)
    scm_out_of_range (NULL, scm_from_size_t (end));
}

static inline void
get_str_buf_start (SCM *str, SCM *buf, size_t *start)
{
  *start = STRING_START (*str);
  if (IS_SH_STRING (*str))
    {
      *str = SH_STRING_STRING (*str);
      *start += STRING_START (*str);
    }
  *buf = STRING_STRINGBUF (*str);
}

SCM
scm_i_substring (SCM str, size_t start, size_t end)
{
  SCM buf;
  size_t str_start;
  get_str_buf_start (&str, &buf, &str_start);
  scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  SET_STRINGBUF_SHARED (buf);
  scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
			  (scm_t_bits)str_start + start,
			  (scm_t_bits) end - start);
}

SCM
scm_i_substring_read_only (SCM str, size_t start, size_t end)
{
  SCM buf;
  size_t str_start;
  get_str_buf_start (&str, &buf, &str_start);
  scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  SET_STRINGBUF_SHARED (buf);
  scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
			  (scm_t_bits)str_start + start,
			  (scm_t_bits) end - start);
}

SCM
scm_i_substring_copy (SCM str, size_t start, size_t end)
{
  size_t len = end - start;
  SCM buf, my_buf;
  size_t str_start;
  get_str_buf_start (&str, &buf, &str_start);
  my_buf = make_stringbuf (len);
  memcpy (STRINGBUF_CHARS (my_buf),
	  STRINGBUF_CHARS (buf) + str_start + start, len);
  scm_remember_upto_here_1 (buf);
  return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
			  (scm_t_bits)0, (scm_t_bits) len);
}

SCM
scm_i_substring_shared (SCM str, size_t start, size_t end)
{
  if (start == 0 && end == STRING_LENGTH (str))
    return str;
  else
    {
      size_t len = end - start;
      if (IS_SH_STRING (str))
	{
	  start += STRING_START (str);
	  str = SH_STRING_STRING (str);
	}
      return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
			      (scm_t_bits)start, (scm_t_bits) len);
    }
}

SCM
scm_c_substring (SCM str, size_t start, size_t end)
{
  validate_substring_args (str, start, end);
  return scm_i_substring (str, start, end);
}

SCM
scm_c_substring_read_only (SCM str, size_t start, size_t end)
{
  validate_substring_args (str, start, end);
  return scm_i_substring_read_only (str, start, end);
}

SCM
scm_c_substring_copy (SCM str, size_t start, size_t end)
{
  validate_substring_args (str, start, end);
  return scm_i_substring_copy (str, start, end);
}

SCM
scm_c_substring_shared (SCM str, size_t start, size_t end)
{
  validate_substring_args (str, start, end);
  return scm_i_substring_shared (str, start, end);
}

SCM
scm_i_string_mark (SCM str)
{
  if (IS_SH_STRING (str))
    return SH_STRING_STRING (str);
  else
    return STRING_STRINGBUF (str);
}

void
scm_i_string_free (SCM str)
{
}

/* Internal accessors
 */

size_t
scm_i_string_length (SCM str)
{
  return STRING_LENGTH (str);
}

const char *
scm_i_string_chars (SCM str)
{
  SCM buf;
  size_t start;
  get_str_buf_start (&str, &buf, &start);
  return STRINGBUF_CHARS (buf) + start;
}

char *
scm_i_string_writable_chars (SCM orig_str)
{
  SCM buf, str = orig_str;
  size_t start;

  get_str_buf_start (&str, &buf, &start);
  if (IS_RO_STRING (str))
    scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));

  scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  if (STRINGBUF_SHARED (buf))
    {
      /* Clone stringbuf.  For this, we put all threads to sleep.
       */

      size_t len = STRING_LENGTH (str);
      SCM new_buf;

      scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);

      new_buf = make_stringbuf (len);
      memcpy (STRINGBUF_CHARS (new_buf),
	      STRINGBUF_CHARS (buf) + STRING_START (str), len);

      scm_i_thread_put_to_sleep ();
      SET_STRING_STRINGBUF (str, new_buf);
      start -= STRING_START (str);
      SET_STRING_START (str, 0);
      scm_i_thread_wake_up ();

      buf = new_buf;

      scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
    }

  return STRINGBUF_CHARS (buf) + start;
}

void
scm_i_string_stop_writing (void)
{
  scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}

/* Symbols.

   Basic symbol creation and accessing is done here, the rest is in
   symbols.[hc].  This has been done to keep stringbufs and the
   internals of strings and string-like objects confined to this file.
*/

#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1

SCM
scm_i_make_symbol (SCM name, scm_t_bits flags,
		   unsigned long hash, SCM props)
{
  SCM buf;
  size_t start = STRING_START (name);
  size_t length = STRING_LENGTH (name);

  if (IS_SH_STRING (name))
    {
      name = SH_STRING_STRING (name);
      start += STRING_START (name);
    }
  buf = SYMBOL_STRINGBUF (name);

  if (start == 0 && length == STRINGBUF_LENGTH (buf))
    {
      /* reuse buf. */
      scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
      SET_STRINGBUF_SHARED (buf);
      scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
    }
  else
    {
      /* make new buf. */
      SCM new_buf = make_stringbuf (length);
      memcpy (STRINGBUF_CHARS (new_buf),
	      STRINGBUF_CHARS (buf) + start, length);
      buf = new_buf;
    }
  return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
			  (scm_t_bits) hash, SCM_UNPACK (props));
}

SCM
scm_i_c_make_symbol (const char *name, size_t len,
		     scm_t_bits flags, unsigned long hash, SCM props)
{
  SCM buf = make_stringbuf (len);
  memcpy (STRINGBUF_CHARS (buf), name, len);

  return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
			  (scm_t_bits) hash, SCM_UNPACK (props));
}

/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
   underlying storage.  */
SCM
scm_i_c_take_symbol (char *name, size_t len,
		     scm_t_bits flags, unsigned long hash, SCM props)
{
  SCM buf = scm_i_take_stringbufn (name, len);

  return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
			  (scm_t_bits) hash, SCM_UNPACK (props));
}

size_t
scm_i_symbol_length (SCM sym)
{
  return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
}

size_t
scm_c_symbol_length (SCM sym)
#define FUNC_NAME "scm_c_symbol_length"
{
  SCM_VALIDATE_SYMBOL (1, sym);

  return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
}
#undef FUNC_NAME

const char *
scm_i_symbol_chars (SCM sym)
{
  SCM buf = SYMBOL_STRINGBUF (sym);
  return STRINGBUF_CHARS (buf);
}

SCM
scm_i_symbol_mark (SCM sym)
{
  scm_gc_mark (SYMBOL_STRINGBUF (sym));
  return SCM_CELL_OBJECT_3 (sym);
}

void
scm_i_symbol_free (SCM sym)
{
}

SCM
scm_i_symbol_substring (SCM sym, size_t start, size_t end)
{
  SCM buf = SYMBOL_STRINGBUF (sym);
  scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
  SET_STRINGBUF_SHARED (buf);
  scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
  return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
			  (scm_t_bits)start, (scm_t_bits) end - start);
}

/* Debugging
 */

#if SCM_DEBUG

SCM scm_sys_string_dump (SCM);
SCM scm_sys_symbol_dump (SCM);
SCM scm_sys_stringbuf_hist (void);

SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
	    (SCM str),
	    "")
#define FUNC_NAME s_scm_sys_string_dump
{
  SCM_VALIDATE_STRING (1, str);
  fprintf (stderr, "%p:\n", str);
  fprintf (stderr, " start: %u\n", STRING_START (str));
  fprintf (stderr, " len:   %u\n", STRING_LENGTH (str));
  if (IS_SH_STRING (str))
    {
      fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
      fprintf (stderr, "\n");
      scm_sys_string_dump (SH_STRING_STRING (str));
    }
  else
    {
      SCM buf = STRING_STRINGBUF (str);
      fprintf (stderr, " buf:   %p\n", buf);
      fprintf (stderr, "  chars:  %p\n", STRINGBUF_CHARS (buf));
      fprintf (stderr, "  length: %u\n", STRINGBUF_LENGTH (buf));
      fprintf (stderr, "  flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
	    (SCM sym),
	    "")
#define FUNC_NAME s_scm_sys_symbol_dump
{
  SCM_VALIDATE_SYMBOL (1, sym);
  fprintf (stderr, "%p:\n", sym);
  fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
  {
    SCM buf = SYMBOL_STRINGBUF (sym);
    fprintf (stderr, " buf: %p\n", buf);
    fprintf (stderr, "  chars:  %p\n", STRINGBUF_CHARS (buf));
    fprintf (stderr, "  length: %u\n", STRINGBUF_LENGTH (buf));
    fprintf (stderr, "  shared: %u\n", STRINGBUF_SHARED (buf));
  }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
	    (void),
	    "")
#define FUNC_NAME s_scm_sys_stringbuf_hist
{
  int i;
  for (i = 0; i < 1000; i++)
    if (lenhist[i])
      fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
  fprintf (stderr, ">999: %u\n", lenhist[1000]);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

#endif

SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
#define FUNC_NAME s_scm_string_p
{
  return scm_from_bool (IS_STRING (obj));
}
#undef FUNC_NAME

SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);

SCM_DEFINE (scm_string, "string", 0, 0, 1,
            (SCM chrs),
	    "@deffnx {Scheme Procedure} list->string chrs\n"
	    "Return a newly allocated string composed of the arguments,\n"
	    "@var{chrs}.")
#define FUNC_NAME s_scm_string
{
  SCM result;
  size_t len;
  char *data;

  {
    long i = scm_ilength (chrs);

    SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
    len = i;
  }

  result = scm_i_make_string (len, &data);
  while (len > 0 && scm_is_pair (chrs))
    {
      SCM elt = SCM_CAR (chrs);

      SCM_VALIDATE_CHAR (SCM_ARGn, elt);
      *data++ = SCM_CHAR (elt);
      chrs = SCM_CDR (chrs);
      len--;
    }
  if (len > 0)
    scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
  if (!scm_is_null (chrs))
    scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");

  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
            (SCM k, SCM chr),
	    "Return a newly allocated string of\n"
            "length @var{k}.  If @var{chr} is given, then all elements of\n"
	    "the string are initialized to @var{chr}, otherwise the contents\n"
	    "of the @var{string} are unspecified.")
#define FUNC_NAME s_scm_make_string
{
  return scm_c_make_string (scm_to_size_t (k), chr);
}
#undef FUNC_NAME

SCM
scm_c_make_string (size_t len, SCM chr)
#define FUNC_NAME NULL
{
  char *dst;
  SCM res = scm_i_make_string (len, &dst);

  if (!SCM_UNBNDP (chr))
    {
      SCM_VALIDATE_CHAR (0, chr);
      memset (dst, SCM_CHAR (chr), len);
    }

  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
	    (SCM string),
	    "Return the number of characters in @var{string}.")
#define FUNC_NAME s_scm_string_length
{
  SCM_VALIDATE_STRING (1, string);
  return scm_from_size_t (STRING_LENGTH (string));
}
#undef FUNC_NAME

size_t
scm_c_string_length (SCM string)
{
  if (!IS_STRING (string))
    scm_wrong_type_arg_msg (NULL, 0, string, "string");
  return STRING_LENGTH (string);
}

SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
            (SCM str, SCM k),
	    "Return character @var{k} of @var{str} using zero-origin\n"
	    "indexing. @var{k} must be a valid index of @var{str}.")
#define FUNC_NAME s_scm_string_ref
{
  size_t len;
  unsigned long idx;

  SCM_VALIDATE_STRING (1, str);

  len = scm_i_string_length (str);
  if (SCM_LIKELY (len > 0))
    idx = scm_to_unsigned_integer (k, 0, len - 1);
  else
    scm_out_of_range (NULL, k);

  return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
}
#undef FUNC_NAME

SCM
scm_c_string_ref (SCM str, size_t p)
{
  if (p >= scm_i_string_length (str))
    scm_out_of_range (NULL, scm_from_size_t (p));
  return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
}

SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
            (SCM str, SCM k, SCM chr),
	    "Store @var{chr} in element @var{k} of @var{str} and return\n"
	    "an unspecified value. @var{k} must be a valid index of\n"
	    "@var{str}.")
#define FUNC_NAME s_scm_string_set_x
{
  size_t len;
  unsigned long idx;

  SCM_VALIDATE_STRING (1, str);

  len = scm_i_string_length (str);
  if (SCM_LIKELY (len > 0))
    idx = scm_to_unsigned_integer (k, 0, len - 1);
  else
    scm_out_of_range (NULL, k);

  SCM_VALIDATE_CHAR (3, chr);
  {
    char *dst = scm_i_string_writable_chars (str);
    dst[idx] = SCM_CHAR (chr);
    scm_i_string_stop_writing ();
  }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_c_string_set_x (SCM str, size_t p, SCM chr)
{
  if (p >= scm_i_string_length (str))
    scm_out_of_range (NULL, scm_from_size_t (p));
  {
    char *dst = scm_i_string_writable_chars (str);
    dst[p] = SCM_CHAR (chr);
    scm_i_string_stop_writing ();
  }
}

SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
	    (SCM str, SCM start, SCM end),
	    "Return a newly allocated string formed from the characters\n"
            "of @var{str} beginning with index @var{start} (inclusive) and\n"
	    "ending with index @var{end} (exclusive).\n"
            "@var{str} must be a string, @var{start} and @var{end} must be\n"
	    "exact integers satisfying:\n\n"
            "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
#define FUNC_NAME s_scm_substring
{
  size_t len, from, to;

  SCM_VALIDATE_STRING (1, str);
  len = scm_i_string_length (str);
  from = scm_to_unsigned_integer (start, 0, len);
  if (SCM_UNBNDP (end))
    to = len;
  else
    to = scm_to_unsigned_integer (end, from, len);
  return scm_i_substring (str, from, to);
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0,
	    (SCM str, SCM start, SCM end),
	    "Return a newly allocated string formed from the characters\n"
            "of @var{str} beginning with index @var{start} (inclusive) and\n"
	    "ending with index @var{end} (exclusive).\n"
            "@var{str} must be a string, @var{start} and @var{end} must be\n"
	    "exact integers satisfying:\n"
	    "\n"
            "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
	    "\n"
	    "The returned string is read-only.\n")
#define FUNC_NAME s_scm_substring_read_only
{
  size_t len, from, to;

  SCM_VALIDATE_STRING (1, str);
  len = scm_i_string_length (str);
  from = scm_to_unsigned_integer (start, 0, len);
  if (SCM_UNBNDP (end))
    to = len;
  else
    to = scm_to_unsigned_integer (end, from, len);
  return scm_i_substring_read_only (str, from, to);
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
	    (SCM str, SCM start, SCM end),
	    "Return a newly allocated string formed from the characters\n"
            "of @var{str} beginning with index @var{start} (inclusive) and\n"
	    "ending with index @var{end} (exclusive).\n"
            "@var{str} must be a string, @var{start} and @var{end} must be\n"
	    "exact integers satisfying:\n\n"
            "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
#define FUNC_NAME s_scm_substring_copy
{
  /* For the Scheme version, START is mandatory, but for the C
     version, it is optional.  See scm_string_copy in srfi-13.c for a
     rationale.
  */

  size_t from, to;

  SCM_VALIDATE_STRING (1, str);
  scm_i_get_substring_spec (scm_i_string_length (str),
			    start, &from, end, &to);
  return scm_i_substring_copy (str, from, to);
}
#undef FUNC_NAME

SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
	    (SCM str, SCM start, SCM end),
	    "Return string that indirectly refers to the characters\n"
            "of @var{str} beginning with index @var{start} (inclusive) and\n"
	    "ending with index @var{end} (exclusive).\n"
            "@var{str} must be a string, @var{start} and @var{end} must be\n"
	    "exact integers satisfying:\n\n"
            "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
#define FUNC_NAME s_scm_substring_shared
{
  size_t len, from, to;

  SCM_VALIDATE_STRING (1, str);
  len = scm_i_string_length (str);
  from = scm_to_unsigned_integer (start, 0, len);
  if (SCM_UNBNDP (end))
    to = len;
  else
    to = scm_to_unsigned_integer (end, from, len);
  return scm_i_substring_shared (str, from, to);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
            (SCM args),
	    "Return a newly allocated string whose characters form the\n"
            "concatenation of the given strings, @var{args}.")
#define FUNC_NAME s_scm_string_append
{
  SCM res;
  size_t i = 0;
  SCM l, s;
  char *data;

  SCM_VALIDATE_REST_ARGUMENT (args);
  for (l = args; !scm_is_null (l); l = SCM_CDR (l))
    {
      s = SCM_CAR (l);
      SCM_VALIDATE_STRING (SCM_ARGn, s);
      i += scm_i_string_length (s);
    }
  res = scm_i_make_string (i, &data);
  for (l = args; !scm_is_null (l); l = SCM_CDR (l))
    {
      size_t len;
      s = SCM_CAR (l);
      SCM_VALIDATE_STRING (SCM_ARGn, s);
      len = scm_i_string_length (s);
      memcpy (data, scm_i_string_chars (s), len);
      data += len;
      scm_remember_upto_here_1 (s);
    }
  return res;
}
#undef FUNC_NAME

int
scm_is_string (SCM obj)
{
  return IS_STRING (obj);
}

SCM
scm_from_locale_stringn (const char *str, size_t len)
{
  SCM res;
  char *dst;

  if (len == (size_t)-1)
    len = strlen (str);
  res = scm_i_make_string (len, &dst);
  memcpy (dst, str, len);
  return res;
}

SCM
scm_from_locale_string (const char *str)
{
  return scm_from_locale_stringn (str, -1);
}

SCM
scm_take_locale_stringn (char *str, size_t len)
{
  SCM buf, res;

  if (len == (size_t)-1)
    len = strlen (str);
  else
    {
      /* Ensure STR is null terminated.  A realloc for 1 extra byte should
         often be satisfied from the alignment padding after the block, with
         no actual data movement.  */
      str = scm_realloc (str, len+1);
      str[len] = '\0';
    }

  buf = scm_i_take_stringbufn (str, len);
  res = scm_double_cell (STRING_TAG,
                         SCM_UNPACK (buf),
                         (scm_t_bits) 0, (scm_t_bits) len);
  return res;
}

SCM
scm_take_locale_string (char *str)
{
  return scm_take_locale_stringn (str, -1);
}

char *
scm_to_locale_stringn (SCM str, size_t *lenp)
{
  char *res;
  size_t len;

  if (!scm_is_string (str))
    scm_wrong_type_arg_msg (NULL, 0, str, "string");
  len = scm_i_string_length (str);
  res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
  memcpy (res, scm_i_string_chars (str), len);
  if (lenp == NULL)
    {
      res[len] = '\0';
      if (strlen (res) != len)
	{
	  free (res);
	  scm_misc_error (NULL,
			  "string contains #\\nul character: ~S",
			  scm_list_1 (str));
	}
    }
  else
    *lenp = len;

  scm_remember_upto_here_1 (str);
  return res;
}

char *
scm_to_locale_string (SCM str)
{
  return scm_to_locale_stringn (str, NULL);
}

size_t
scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
{
  size_t len;

  if (!scm_is_string (str))
    scm_wrong_type_arg_msg (NULL, 0, str, "string");
  len = scm_i_string_length (str);
  memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
  scm_remember_upto_here_1 (str);
  return len;
}

/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
SCM
scm_makfromstrs (int argc, char **argv)
{
  int i = argc;
  SCM lst = SCM_EOL;
  if (0 > i)
    for (i = 0; argv[i]; i++);
  while (i--)
    lst = scm_cons (scm_from_locale_string (argv[i]), lst);
  return lst;
}

/* Return a newly allocated array of char pointers to each of the strings
   in args, with a terminating NULL pointer.  */

char **
scm_i_allocate_string_pointers (SCM list)
{
  char **result;
  int len = scm_ilength (list);
  int i;

  if (len < 0)
    scm_wrong_type_arg_msg (NULL, 0, list, "proper list");

  scm_dynwind_begin (0);

  result = (char **) scm_malloc ((len + 1) * sizeof (char *));
  result[len] = NULL;
  scm_dynwind_unwind_handler (free, result, 0);

  /* The list might be have been modified in another thread, so
     we check LIST before each access.
   */
  for (i = 0; i < len && scm_is_pair (list); i++)
    {
      result[i] = scm_to_locale_string (SCM_CAR (list));
      list = SCM_CDR (list);
    }

  scm_dynwind_end ();
  return result;
}

void
scm_i_free_string_pointers (char **pointers)
{
  int i;

  for (i = 0; pointers[i]; i++)
    free (pointers[i]);
  free (pointers);
}

void
scm_i_get_substring_spec (size_t len,
			  SCM start, size_t *cstart,
			  SCM end, size_t *cend)
{
  if (SCM_UNBNDP (start))
    *cstart = 0;
  else
    *cstart = scm_to_unsigned_integer (start, 0, len);

  if (SCM_UNBNDP (end))
    *cend = len;
  else
    *cend = scm_to_unsigned_integer (end, *cstart, len);
}

#if SCM_ENABLE_DEPRECATED

/* When these definitions are removed, it becomes reasonable to use
   read-only strings for string literals.  For that, change the reader
   to create string literals with scm_c_substring_read_only instead of
   with scm_c_substring_copy.
*/

int
scm_i_deprecated_stringp (SCM str)
{
  scm_c_issue_deprecation_warning
    ("SCM_STRINGP is deprecated.  Use scm_is_string instead.");

  return scm_is_string (str);
}

char *
scm_i_deprecated_string_chars (SCM str)
{
  char *chars;

  scm_c_issue_deprecation_warning
    ("SCM_STRING_CHARS is deprecated.  See the manual for alternatives.");

  /* We don't accept shared substrings here since they are not
     null-terminated.
  */
  if (IS_SH_STRING (str))
    scm_misc_error (NULL,
		    "SCM_STRING_CHARS does not work with shared substrings.",
		    SCM_EOL);

  /* We explicitly test for read-only strings to produce a better
     error message.
  */

  if (IS_RO_STRING (str))
    scm_misc_error (NULL,
		    "SCM_STRING_CHARS does not work with read-only strings.",
		    SCM_EOL);

  /* The following is still wrong, of course...
   */
  chars = scm_i_string_writable_chars (str);
  scm_i_string_stop_writing ();
  return chars;
}

size_t
scm_i_deprecated_string_length (SCM str)
{
  scm_c_issue_deprecation_warning
    ("SCM_STRING_LENGTH is deprecated.  Use scm_c_string_length instead.");
  return scm_c_string_length (str);
}

#endif

void
scm_init_strings ()
{
  scm_nullstr = scm_i_make_string (0, NULL);

#include "libguile/strings.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H

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

/* String representation.

   A string is a piece of a stringbuf.  A stringbuf can be used by
   more than one string.  When a string is written to and the
   stringbuf of that string is used by more than one string, a new
   stringbuf is created.  That is, strings are copy-on-write.  This
   behavior can be used to make the substring operation quite
   efficient.

   The implementation is tuned so that mutating a string is costly,
   but just reading it is cheap and lock-free.

   There are also mutation-sharing strings.  They refer to a part of
   an ordinary string.  Writing to a mutation-sharing string just
   writes to the ordinary string.

   Internal, low level interface to the character arrays

   - Use scm_i_string_chars to get a pointer to the byte array of a
     string for reading.  Use scm_i_string_length to get the number of
     bytes in that array.  The array is not null-terminated.

   - The array is valid as long as the corresponding SCM object is
     protected but only until the next SCM_TICK.  During such a 'safe
     point', strings might change their representation.

   - Use scm_i_string_writable_chars to get the same pointer as with
     scm_i_string_chars, but for reading and writing.  This is a
     potentially costly operation since it implements the
     copy-on-write behavior.  When done with the writing, call
     scm_i_string_stop_writing.  You must do this before the next
     SCM_TICK.  (This means, before calling almost any other scm_
     function and you can't allow throws, of course.)

   - New strings can be created with scm_i_make_string.  This gives
     access to a writable pointer that remains valid as long as nobody
     else makes a copy-on-write substring of the string.  Do not call
     scm_i_string_stop_writing for this pointer.

   Legacy interface

   - SCM_STRINGP is just scm_is_string.

   - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
     calls scm_i_stop_writing, hoping for the best.  SCM_STRING_LENGTH
     is the same as scm_i_string_length.  SCM_STRING_CHARS will throw
     an error for for strings that are not null-terminated.
*/

SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_string_length (SCM str);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_read_only (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append (SCM args);

SCM_API SCM scm_c_make_string (size_t len, SCM chr);
SCM_API size_t scm_c_string_length (SCM str);
SCM_API size_t scm_c_symbol_length (SCM sym);
SCM_API SCM scm_c_string_ref (SCM str, size_t pos);
SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr);
SCM_API SCM scm_c_substring (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_read_only (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_shared (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end);

SCM_API int scm_is_string (SCM x);
SCM_API SCM scm_from_locale_string (const char *str);
SCM_API SCM scm_from_locale_stringn (const char *str, size_t len);
SCM_API SCM scm_take_locale_string (char *str);
SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
SCM_API char *scm_to_locale_string (SCM str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);

SCM_API SCM scm_makfromstrs (int argc, char **argv);

/* internal accessor functions.  Arguments must be valid. */

SCM_API SCM scm_i_make_string (size_t len, char **datap);
SCM_API SCM scm_i_substring (SCM str, size_t start, size_t end);
SCM_API SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
SCM_API SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
SCM_API SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
SCM_API size_t scm_i_string_length (SCM str);
SCM_API const char *scm_i_string_chars (SCM str);
SCM_API char *scm_i_string_writable_chars (SCM str);
SCM_API void scm_i_string_stop_writing (void);

/* internal functions related to symbols. */

SCM_API SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
			       unsigned long hash, SCM props);
SCM_API SCM
scm_i_c_make_symbol (const char *name, size_t len,
		     scm_t_bits flags, unsigned long hash, SCM props);
SCM_API SCM
scm_i_c_take_symbol (char *name, size_t len,
		     scm_t_bits flags, unsigned long hash, SCM props);
SCM_API const char *scm_i_symbol_chars (SCM sym);
SCM_API size_t scm_i_symbol_length (SCM sym);
SCM_API SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);

/* internal GC functions. */

SCM_API SCM scm_i_string_mark (SCM str);
SCM_API SCM scm_i_stringbuf_mark (SCM buf);
SCM_API SCM scm_i_symbol_mark (SCM buf);
SCM_API void scm_i_string_free (SCM str);
SCM_API void scm_i_stringbuf_free (SCM buf);
SCM_API void scm_i_symbol_free (SCM sym);

/* internal utility functions. */

SCM_API char **scm_i_allocate_string_pointers (SCM list);
SCM_API void scm_i_free_string_pointers (char **pointers);
SCM_API void scm_i_get_substring_spec (size_t len,
				       SCM start, size_t *cstart,
				       SCM end, size_t *cend);
SCM_API SCM scm_i_take_stringbufn (char *str, size_t len);

/* deprecated stuff */

#if SCM_ENABLE_DEPRECATED

SCM_API int scm_i_deprecated_stringp (SCM obj);
SCM_API char *scm_i_deprecated_string_chars (SCM str);
SCM_API size_t scm_i_deprecated_string_length (SCM str);

#define SCM_STRINGP(x)       scm_i_deprecated_stringp(x)
#define SCM_STRING_CHARS(x)  scm_i_deprecated_string_chars(x)
#define SCM_STRING_LENGTH(x) scm_i_deprecated_string_length(x)
#define SCM_STRING_UCHARS(str) ((unsigned char *)SCM_STRING_CHARS (str))

#endif

SCM_API void scm_init_strings (void);

#endif  /* SCM_STRINGS_H */

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