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

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

#include <errno.h>
#include <uniconv.h>
#include <unictype.h>

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/smob.h"
#include "libguile/control.h"
#include "libguile/eval.h"
#include "libguile/macros.h"
#include "libguile/procprop.h"
#include "libguile/read.h"
#include "libguile/weaks.h"
#include "libguile/programs.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/strports.h"
#include "libguile/vectors.h"
#include "libguile/numbers.h"
#include "libguile/vm.h"

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

#include "libguile/private-options.h"

/* {Names of immediate symbols}
 *
 * This table must agree with the declarations in scm.h: {Immediate Symbols}.
 */

/* This table must agree with the list of flags in tags.h.  */
static const char *iflagnames[] =
{
  "#f",
  "#nil",  /* Elisp nil value. Should print from elisp as symbol `nil'. */
  "#<XXX UNUSED LISP FALSE -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  "()",
  "#t",
  "#<XXX UNUSED BOOLEAN 0 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  "#<XXX UNUSED BOOLEAN 1 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  "#<XXX UNUSED BOOLEAN 2 -- DO NOT USE -- SHOULD NEVER BE SEEN XXX>",
  "#<unspecified>",
  "#<undefined>",
  "#<eof>",

  /* Unbound slot marker for GOOPS.  For internal use in GOOPS only.  */
  "#<unbound>",
};

SCM_SYMBOL (sym_reader, "reader");

scm_t_option scm_print_opts[] = {
  { SCM_OPTION_SCM, "closure-hook", (unsigned long) SCM_BOOL_F,
    "Hook for printing closures (should handle macros as well)." },
  { SCM_OPTION_BOOLEAN, "source", 0,
    "Print closures with source." },
  { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F,
    "The string to print before highlighted values." },
  { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F,
    "The string to print after highlighted values." },
  { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F,
    "How to print symbols that have a colon as their first or last character. "
    "The value '#f' does not quote the colons; '#t' quotes them; "
    "'reader' quotes them when the reader option 'keywords' is not '#f'."
  },
  { 0 },
};

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

/* {Printing of Scheme Objects}
 */

/* Detection of circular references.
 *
 * Due to other constraints in the implementation, this code has bad
 * time complexity (O (depth * N)), The printer code can be
 * rewritten to be O(N).
 */
#define PUSH_REF(pstate, obj)			\
do						\
{						\
  PSTATE_STACK_SET (pstate, pstate->top, obj);	\
  pstate->top++;				\
  if (pstate->top == pstate->ceiling)		\
    grow_ref_stack (pstate);			\
} while(0)

#define ENTER_NESTED_DATA(pstate, obj, label)			\
do								\
{								\
  register unsigned long i;					\
  for (i = 0; i < pstate->top; ++i)				\
    if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj)))	\
      goto label;						\
  if (pstate->fancyp)						\
    {								\
      if (pstate->top - pstate->list_offset >= pstate->level)	\
	{							\
	  scm_putc ('#', port);					\
	  return;						\
	}							\
    }								\
  PUSH_REF(pstate, obj);					\
} while(0)

#define EXIT_NESTED_DATA(pstate)				\
do								\
{								\
  --pstate->top;						\
  PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED);	\
}								\
while (0)

SCM scm_print_state_vtable = SCM_BOOL_F;
static SCM print_state_pool = SCM_EOL;
scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;

#ifdef GUILE_DEBUG /* Used for debugging purposes */

SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
           (),
	    "Return the current-pstate -- the car of the\n"
	    "@code{print_state_pool}.  @code{current-pstate} is only\n"
	    "included in @code{--enable-guile-debug} builds.")
#define FUNC_NAME s_scm_current_pstate
{
  if (!scm_is_null (print_state_pool))
    return SCM_CAR (print_state_pool);
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

#endif

#define PSTATE_SIZE 50L

static SCM
make_print_state (void)
{
  SCM print_state
    = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
  scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
  pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
  pstate->highlight_objects = SCM_EOL;
  return print_state;
}

SCM
scm_make_print_state ()
{
  SCM answer = SCM_BOOL_F;

  /* First try to allocate a print state from the pool */
  scm_i_pthread_mutex_lock (&print_state_mutex);
  if (!scm_is_null (print_state_pool))
    {
      answer = SCM_CAR (print_state_pool);
      print_state_pool = SCM_CDR (print_state_pool);
    }
  scm_i_pthread_mutex_unlock (&print_state_mutex);

  return scm_is_false (answer) ? make_print_state () : answer;
}

void
scm_free_print_state (SCM print_state)
{
  SCM handle;
  scm_print_state *pstate = SCM_PRINT_STATE (print_state);
  /* Cleanup before returning print state to pool.
   * It is better to do it here.  Doing it in scm_prin1
   * would cost more since that function is called much more
   * often.
   */
  pstate->fancyp = 0;
  pstate->revealed = 0;
  pstate->highlight_objects = SCM_EOL;
  scm_i_pthread_mutex_lock (&print_state_mutex);
  handle = scm_cons (print_state, print_state_pool);
  print_state_pool = handle;
  scm_i_pthread_mutex_unlock (&print_state_mutex);
}

SCM
scm_i_port_with_print_state (SCM port, SCM print_state)
{
  if (SCM_UNBNDP (print_state))
    {
      if (SCM_PORT_WITH_PS_P (port))
	return port;
      else
	print_state = scm_make_print_state ();
      /* port does not need to be coerced since it doesn't have ps */
    }
  else
    port = SCM_COERCE_OUTPORT (port);
  SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps,
		      SCM_UNPACK (scm_cons (port, print_state)));
}

static void
grow_ref_stack (scm_print_state *pstate)
{
  SCM old_vect = pstate->ref_vect;
  size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect);
  size_t new_size = 2 * pstate->ceiling;
  SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
  unsigned long int i;

  for (i = 0; i != old_size; ++i)
    SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i));

  pstate->ref_vect = new_vect;
  pstate->ceiling = new_size;
}

#define PSTATE_STACK_REF(p,i)   SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i))
#define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v))

static void
print_circref (SCM port, scm_print_state *pstate, SCM ref)
{
  register long i;
  long self = pstate->top - 1;
  i = pstate->top - 1;
  if (scm_is_pair (PSTATE_STACK_REF (pstate, i)))
    {
      while (i > 0)
	{
	  if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1))
	      || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)),
			     SCM_CDR (PSTATE_STACK_REF (pstate, i))))
	    break;
	  --i;
	}
      self = i;
    }
  for (i = pstate->top - 1; 1; --i)
    if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
      break;
  scm_putc ('#', port);
  scm_intprint (i - self, 10, port);
  scm_putc ('#', port);
}

/* Print the name of a symbol. */

static int
quote_keywordish_symbol (SCM symbol)
{
  SCM option;

  if (scm_i_symbol_ref (symbol, 0) != ':'
      && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) !=  ':')
    return 0;

  option = SCM_PRINT_KEYWORD_STYLE;
  if (scm_is_false (option))
    return 0;
  if (scm_is_eq (option, sym_reader))
    return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE));
  return 1;
}

void
scm_i_print_symbol_name (SCM str, SCM port)
{
  /* This points to the first character that has not yet been written to the
   * port. */
  size_t pos = 0;
  /* This points to the character we're currently looking at. */
  size_t end;
  /* If the name contains weird characters, we'll escape them with
   * backslashes and set this flag; it indicates that we should surround the
   * name with "#{" and "}#". */
  int weird = 0;
  /* Backslashes are not sufficient to make a name weird, but if a name is
   * weird because of other characters, backslahes need to be escaped too.
   * The first time we see a backslash, we set maybe_weird, and mw_pos points
   * to the backslash.  Then if the name turns out to be weird, we re-process
   * everything starting from mw_pos.
   * We could instead make backslashes always weird.  This is not necessary
   * to ensure that the output is (read)-able, but it would make this code
   * simpler and faster. */
  int maybe_weird = 0;
  size_t mw_pos = 0;
  size_t len = scm_i_symbol_length (str);
  scm_t_wchar str0 = scm_i_symbol_ref (str, 0);

  if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ','
      || quote_keywordish_symbol (str)
      || (str0 == '.' && len == 1)
      || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10)))
    {
      scm_lfwrite ("#{", 2, port);
      weird = 1;
    }

  for (end = pos; end < len; ++end)
    switch (scm_i_symbol_ref (str, end))
      {
#ifdef BRACKETS_AS_PARENS
      case '[':
      case ']':
#endif
      case '(':
      case ')':
      case '"':
      case ';':
      case '#':
      case SCM_WHITE_SPACES:
      case SCM_LINE_INCREMENTORS:
      weird_handler:
	if (maybe_weird)
	  {
	    end = mw_pos;
	    maybe_weird = 0;
	  }
	if (!weird)
	  {
	    scm_lfwrite ("#{", 2, port);
	    weird = 1;
	  }
	if (pos < end)
	  scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
	{
	  char buf[2];
	  buf[0] = '\\';
	  buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end);
	  scm_lfwrite (buf, 2, port);
	}
	pos = end + 1;
	break;
      case '\\':
	if (weird)
	  goto weird_handler;
	if (!maybe_weird)
	  {
	    maybe_weird = 1;
	    mw_pos = pos;
	  }
	break;
      default:
	break;
      }
  if (pos < end)
    scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port);
  if (weird)
    scm_lfwrite ("}#", 2, port);
}

void
scm_print_symbol_name (const char *str, size_t len, SCM port)
{
  SCM symbol = scm_from_locale_symboln (str, len);
  scm_i_print_symbol_name (symbol, port);
}

/* Print generally.  Handles both write and display according to PSTATE.
 */
SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);

static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);

/* Print a character as an octal or hex escape.  */
#define PRINT_CHAR_ESCAPE(i, port)              \
  do                                            \
    {                                           \
      if (!SCM_R6RS_ESCAPES_P)                  \
        scm_intprint (i, 8, port);              \
      else                                      \
        {                                       \
          scm_puts ("x", port);                 \
          scm_intprint (i, 16, port);           \
        }                                       \
    }                                           \
  while (0)

void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
  if (pstate->fancyp
      && scm_is_true (scm_memq (exp, pstate->highlight_objects)))
    {
      scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
      iprin1 (exp, port, pstate);
      scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
    }
  else
    iprin1 (exp, port, pstate);
}

static void
iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
  switch (SCM_ITAG3 (exp))
    {
    case scm_tc3_tc7_1:
    case scm_tc3_tc7_2:
      /* These tc3 tags should never occur in an immediate value.  They are
       * only used in cell types of non-immediates, i. e. the value returned
       * by SCM_CELL_TYPE (exp) can use these tags.
       */
      scm_ipruk ("immediate", exp, port);
      break;
    case scm_tc3_int_1:
    case scm_tc3_int_2:
      scm_intprint (SCM_I_INUM (exp), 10, port);
      break;
    case scm_tc3_imm24:
      if (SCM_CHARP (exp))
	{
	  scm_t_wchar i = SCM_CHAR (exp);
          const char *name;

	  if (SCM_WRITINGP (pstate))
	    {
	      scm_puts ("#\\", port);
	      name = scm_i_charname (exp);
	      if (name != NULL)
		scm_puts (name, port);
	      else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L
                                                         | UC_CATEGORY_MASK_M
                                                         | UC_CATEGORY_MASK_N
                                                         | UC_CATEGORY_MASK_P
                                                         | UC_CATEGORY_MASK_S))
                /* Print the character if is graphic character.  */
                {
                  scm_t_wchar *wbuf;
                  SCM wstr;
                  char *buf;
                  size_t len;
                  const char *enc;

                  enc = scm_i_get_port_encoding (port);
                  if (uc_combining_class (i) == UC_CCC_NR)
                    {
                      wstr = scm_i_make_wide_string (1, &wbuf);
                      wbuf[0] = i;
                    }
                  else
                    {
                      /* Character is a combining character: print it connected
                         to a dotted circle instead of connecting it to the
                         backslash in '#\'  */
                      wstr = scm_i_make_wide_string (2, &wbuf);
                      wbuf[0] = SCM_CODEPOINT_DOTTED_CIRCLE;
                      wbuf[1] = i;
                    }
                  if (enc == NULL)
                    {
                      if (i <= 0xFF)
                        /* Character is graphic and Latin-1.  Print it  */
                        scm_lfwrite_str (wstr, port);
                      else
                        /* Character is graphic but unrepresentable in
                           this port's encoding.  */
                        PRINT_CHAR_ESCAPE (i, port);
                    }
                  else
                    {
                      buf = u32_conv_to_encoding (enc,
                                                  iconveh_error,
                                                  (scm_t_uint32 *) wbuf,
                                                  1,
                                                  NULL,
                                                  NULL, &len);
                      if (buf != NULL)
                        {
                          /* Character is graphic.  Print it.  */
                          scm_lfwrite_str (wstr, port);
                          free (buf);
                        }
                      else
                        /* Character is graphic but unrepresentable in
                           this port's encoding.  */
                        PRINT_CHAR_ESCAPE (i, port);
                    }
                }
              else
                /* Character is a non-graphical character.  */
                PRINT_CHAR_ESCAPE (i, port);
	    }
	  else
	    scm_i_charprint (i, port);
	}
      else if (SCM_IFLAGP (exp)
	       && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
        {
          scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
        }
      else
	{
	  /* unknown immediate value */
	  scm_ipruk ("immediate", exp, port);
	}
      break;
    case scm_tc3_cons:
      switch (SCM_TYP7 (exp))
	{
	case scm_tcs_struct:
	  {
	    ENTER_NESTED_DATA (pstate, exp, circref);
	    if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
	      {
		SCM pwps, print = pstate->writingp ? g_write : g_display;
		if (!print)
		  goto print_struct;
		pwps = scm_i_port_with_print_state (port, pstate->handle);
		pstate->revealed = 1;
		scm_call_generic_2 (print, exp, pwps);
	      }
	    else
	      {
	      print_struct:
		scm_print_struct (exp, port, pstate);
	      }
	    EXIT_NESTED_DATA (pstate);
	  }
	  break;
	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	  ENTER_NESTED_DATA (pstate, exp, circref);
	  scm_iprlist ("(", exp, ')', port, pstate);
	  EXIT_NESTED_DATA (pstate);
	  break;
	circref:
	  print_circref (port, pstate, exp);
	  break;
	case scm_tc7_number:
          switch SCM_TYP16 (exp) {
          case scm_tc16_big:
            scm_bigprint (exp, port, pstate);
            break;
          case scm_tc16_real:
            scm_print_real (exp, port, pstate);
            break;
          case scm_tc16_complex:
            scm_print_complex (exp, port, pstate);
            break;
          case scm_tc16_fraction:
            scm_i_print_fraction (exp, port, pstate);
            break;
          }
	  break;
        case scm_tc7_string:
          if (SCM_WRITINGP (pstate))
            {
              size_t i, len;
              static char const hex[] = "0123456789abcdef";
              char buf[9];

              scm_putc ('"', port);
              len = scm_i_string_length (exp);
              for (i = 0; i < len; ++i)
                {
                  scm_t_wchar ch = scm_i_string_ref (exp, i);
                  int printed = 0;

                  if (ch == ' ' || ch == '\n')
                    {
                      scm_putc (ch, port);
                      printed = 1;
                    }
                  else if (ch == '"' || ch == '\\')
                    {
                      scm_putc ('\\', port);
                      scm_i_charprint (ch, port);
                      printed = 1;
                    }
                  else
                    if (uc_is_general_category_withtable
                        (ch,
                         UC_CATEGORY_MASK_L | UC_CATEGORY_MASK_M |
                         UC_CATEGORY_MASK_N | UC_CATEGORY_MASK_P |
                         UC_CATEGORY_MASK_S))
                    {
                      /* Print the character since it is a graphic
                         character.  */
                      scm_t_wchar *wbuf;
                      SCM wstr = scm_i_make_wide_string (1, &wbuf);
                      char *buf;
                      size_t len;

                      if (scm_i_get_port_encoding (port))
                        {
                          wstr = scm_i_make_wide_string (1, &wbuf);
                          wbuf[0] = ch;
                          buf = u32_conv_to_encoding (scm_i_get_port_encoding (port),
                                                      iconveh_error,
                                                      (scm_t_uint32 *) wbuf,
                                                      1   ,
                                                      NULL,
                                                      NULL, &len);
                          if (buf != NULL)
                            {
                              /* Character is graphic and representable in
                                 this encoding.  Print it.  */
                              scm_lfwrite_str (wstr, port);
                              free (buf);
                              printed = 1;
                            }
                        }
                      else
                        if (ch <= 0xFF)
                          {
                            scm_putc (ch, port);
                            printed = 1;
                          }
                    }

                  if (!printed)
                    {
                      /* Character is graphic but unrepresentable in
                         this port's encoding or is not graphic.  */
                      if (!SCM_R6RS_ESCAPES_P)
                        {
                          if (ch <= 0xFF)
                            {
                              buf[0] = '\\';
                              buf[1] = 'x';
                              buf[2] = hex[ch / 16];
                              buf[3] = hex[ch % 16];
                              scm_lfwrite (buf, 4, port);
                            }
                          else if (ch <= 0xFFFF)
                            {
                              buf[0] = '\\';
                              buf[1] = 'u';
                              buf[2] = hex[(ch & 0xF000) >> 12];
                              buf[3] = hex[(ch & 0xF00) >> 8];
                              buf[4] = hex[(ch & 0xF0) >> 4];
                              buf[5] = hex[(ch & 0xF)];
                              scm_lfwrite (buf, 6, port);
                            }
                          else if (ch > 0xFFFF)
                            {
                              buf[0] = '\\';
                              buf[1] = 'U';
                              buf[2] = hex[(ch & 0xF00000) >> 20];
                              buf[3] = hex[(ch & 0xF0000) >> 16];
                              buf[4] = hex[(ch & 0xF000) >> 12];
                              buf[5] = hex[(ch & 0xF00) >> 8];
                              buf[6] = hex[(ch & 0xF0) >> 4];
                              buf[7] = hex[(ch & 0xF)];
                              scm_lfwrite (buf, 8, port);
                            }
                        }
                      else
                        {
                          scm_t_wchar ch2 = ch;

                          /* Print an R6RS variable-length hex escape: "\xNNNN;"
                          */
                          int i = 8;
                          buf[i] = ';';
                          i --;
                          if (ch == 0)
                            buf[i--] = '0';
                          else
                            while (ch2 > 0)
                              {
                                buf[i] = hex[ch2 & 0xF];
                                ch2 >>= 4;
                                i --;
                              }
                          buf[i] = 'x';
                          i --;
                          buf[i] = '\\';
                          scm_lfwrite (buf + i, 9 - i, port);
                        }
                    }
                }
              scm_putc ('"', port);
              scm_remember_upto_here_1 (exp);
            }
          else
            scm_lfwrite_str (exp, port);
          scm_remember_upto_here_1 (exp);
          break;
	case scm_tc7_symbol:
	  if (scm_i_symbol_is_interned (exp))
	    {
	      scm_i_print_symbol_name (exp, port);
	      scm_remember_upto_here_1 (exp);
	    }
	  else
	    {
	      scm_puts ("#<uninterned-symbol ", port);
	      scm_i_print_symbol_name (exp, port);
	      scm_putc (' ', port);
	      scm_uintprint (SCM_UNPACK (exp), 16, port);
	      scm_putc ('>', port);
	    }
	  break;
	case scm_tc7_variable:
	  scm_i_variable_print (exp, port, pstate);
	  break;
	case scm_tc7_program:
	  scm_i_program_print (exp, port, pstate);
	  break;
	case scm_tc7_pointer:
	  scm_i_pointer_print (exp, port, pstate);
	  break;
	case scm_tc7_hashtable:
	  scm_i_hashtable_print (exp, port, pstate);
	  break;
	case scm_tc7_fluid:
	  scm_i_fluid_print (exp, port, pstate);
	  break;
	case scm_tc7_dynamic_state:
	  scm_i_dynamic_state_print (exp, port, pstate);
	  break;
	case scm_tc7_frame:
	  scm_i_frame_print (exp, port, pstate);
	  break;
	case scm_tc7_objcode:
	  scm_i_objcode_print (exp, port, pstate);
	  break;
	case scm_tc7_vm:
	  scm_i_vm_print (exp, port, pstate);
	  break;
	case scm_tc7_vm_cont:
	  scm_i_vm_cont_print (exp, port, pstate);
	  break;
	case scm_tc7_prompt:
	  scm_i_prompt_print (exp, port, pstate);
	  break;
	case scm_tc7_with_fluids:
	  scm_i_with_fluids_print (exp, port, pstate);
	  break;
	case scm_tc7_wvect:
	  ENTER_NESTED_DATA (pstate, exp, circref);
	  if (SCM_IS_WHVEC (exp))
	    scm_puts ("#wh(", port);
	  else
	    scm_puts ("#w(", port);
	  goto common_vector_printer;

	case scm_tc7_bytevector:
	  scm_i_print_bytevector (exp, port, pstate);
	  break;
	case scm_tc7_vector:
	  ENTER_NESTED_DATA (pstate, exp, circref);
	  scm_puts ("#(", port);
	common_vector_printer:
	  {
	    register long i;
	    long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
	    int cutp = 0;
	    if (pstate->fancyp
		&& SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
	      {
		last = pstate->length - 1;
		cutp = 1;
	      }
	    if (SCM_I_WVECTP (exp))
	      {
		/* Elements of weak vectors may not be accessed via the
		   `SIMPLE_VECTOR_REF ()' macro.  */
		for (i = 0; i < last; ++i)
		  {
		    scm_iprin1 (scm_c_vector_ref (exp, i),
				port, pstate);
		    scm_putc (' ', port);
		  }
	      }
	    else
	      {
		for (i = 0; i < last; ++i)
		  {
		    scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
		    scm_putc (' ', port);
		  }
	      }

	    if (i == last)
	      {
		/* CHECK_INTS; */
		scm_iprin1 (scm_c_vector_ref (exp, i), port, pstate);
	      }
	    if (cutp)
	      scm_puts (" ...", port);
	    scm_putc (')', port);
	  }
	  EXIT_NESTED_DATA (pstate);
	  break;
	case scm_tc7_port:
	  {
	    register long i = SCM_PTOBNUM (exp);
	    if (i < scm_numptob
		&& scm_ptobs[i].print
		&& (scm_ptobs[i].print) (exp, port, pstate))
	      break;
	    goto punk;
	  }
	case scm_tc7_smob:
	  ENTER_NESTED_DATA (pstate, exp, circref);
	  SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
	  EXIT_NESTED_DATA (pstate);
	  break;
	default:
          /* case scm_tcs_closures: */
	punk:
	  scm_ipruk ("type", exp, port);
	}
    }
}

/* Print states are necessary for circular reference safe printing.
 * They are also expensive to allocate.  Therefore print states are
 * kept in a pool so that they can be reused.
 */

/* The PORT argument can also be a print-state/port pair, which will
 * then be used instead of allocating a new print state.  This is
 * useful for continuing a chain of print calls from Scheme.  */

void
scm_prin1 (SCM exp, SCM port, int writingp)
{
  SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
  SCM pstate_scm;
  scm_print_state *pstate;
  int old_writingp;

  /* If PORT is a print-state/port pair, use that.  Else create a new
     print-state. */

  if (SCM_PORT_WITH_PS_P (port))
    {
      pstate_scm = SCM_PORT_WITH_PS_PS (port);
      port = SCM_PORT_WITH_PS_PORT (port);
    }
  else
    {
      /* First try to allocate a print state from the pool */
      scm_i_pthread_mutex_lock (&print_state_mutex);
      if (!scm_is_null (print_state_pool))
	{
	  handle = print_state_pool;
	  print_state_pool = SCM_CDR (print_state_pool);
	}
      scm_i_pthread_mutex_unlock (&print_state_mutex);
      if (scm_is_false (handle))
	handle = scm_list_1 (make_print_state ());
      pstate_scm = SCM_CAR (handle);
    }

  pstate = SCM_PRINT_STATE (pstate_scm);
  old_writingp = pstate->writingp;
  pstate->writingp = writingp;
  scm_iprin1 (exp, port, pstate);
  pstate->writingp = old_writingp;

  /* Return print state to pool if it has been created above and
     hasn't escaped to Scheme. */

  if (scm_is_true (handle) && !pstate->revealed)
    {
      scm_i_pthread_mutex_lock (&print_state_mutex);
      SCM_SETCDR (handle, print_state_pool);
      print_state_pool = handle;
      scm_i_pthread_mutex_unlock (&print_state_mutex);
    }
}

/* Print a character.
 */
void
scm_i_charprint (scm_t_wchar ch, SCM port)
{
  scm_t_wchar *wbuf;
  SCM wstr = scm_i_make_wide_string (1, &wbuf);

  wbuf[0] = ch;
  scm_lfwrite_str (wstr, port);
}

/* Print an integer.
 */

void
scm_intprint (scm_t_intmax n, int radix, SCM port)
{
  char num_buf[SCM_INTBUFLEN];
  scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
}

void
scm_uintprint (scm_t_uintmax n, int radix, SCM port)
{
  char num_buf[SCM_INTBUFLEN];
  scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
}

/* Print an object of unrecognized type.
 */

void
scm_ipruk (char *hdr, SCM ptr, SCM port)
{
  scm_puts ("#<unknown-", port);
  scm_puts (hdr, port);
  if (1) /* (scm_in_heap_p (ptr)) */ /* FIXME */
    {
      scm_puts (" (0x", port);
      scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
      scm_puts (" . 0x", port);
      scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
      scm_puts (") @", port);
    }
  scm_puts (" 0x", port);
  scm_uintprint (SCM_UNPACK (ptr), 16, port);
  scm_putc ('>', port);
}

/* Print a list.
 */
void
scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
{
  register SCM hare, tortoise;
  long floor = pstate->top - 2;
  scm_puts (hdr, port);
  /* CHECK_INTS; */
  if (pstate->fancyp)
    goto fancy_printing;

  /* Run a hare and tortoise so that total time complexity will be
     O(depth * N) instead of O(N^2). */
  hare = SCM_CDR (exp);
  tortoise = exp;
  while (scm_is_pair (hare))
    {
      if (scm_is_eq (hare, tortoise))
	goto fancy_printing;
      hare = SCM_CDR (hare);
      if (!scm_is_pair (hare))
	break;
      hare = SCM_CDR (hare);
      tortoise = SCM_CDR (tortoise);
    }

  /* No cdr cycles intrinsic to this list */
  scm_iprin1 (SCM_CAR (exp), port, pstate);
  for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp))
    {
      register long i;

      for (i = floor; i >= 0; --i)
	if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
	  goto circref;
      PUSH_REF (pstate, exp);
      scm_putc (' ', port);
      /* CHECK_INTS; */
      scm_iprin1 (SCM_CAR (exp), port, pstate);
    }
  if (!SCM_NULL_OR_NIL_P (exp))
    {
      scm_puts (" . ", port);
      scm_iprin1 (exp, port, pstate);
    }

end:
  scm_putc (tlr, port);
  pstate->top = floor + 2;
  return;

fancy_printing:
  {
    long n = pstate->length;

    scm_iprin1 (SCM_CAR (exp), port, pstate);
    exp = SCM_CDR (exp); --n;
    for (; scm_is_pair (exp); exp = SCM_CDR (exp))
      {
	register unsigned long i;

	for (i = 0; i < pstate->top; ++i)
	  if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
	    goto fancy_circref;
	if (pstate->fancyp)
	  {
	    if (n == 0)
	      {
		scm_puts (" ...", port);
		goto skip_tail;
	      }
	    else
	      --n;
	  }
	PUSH_REF(pstate, exp);
	++pstate->list_offset;
	scm_putc (' ', port);
	/* CHECK_INTS; */
	scm_iprin1 (SCM_CAR (exp), port, pstate);
      }
  }
  if (!SCM_NULL_OR_NIL_P (exp))
    {
      scm_puts (" . ", port);
      scm_iprin1 (exp, port, pstate);
    }
skip_tail:
  pstate->list_offset -= pstate->top - floor - 2;
  goto end;

fancy_circref:
  pstate->list_offset -= pstate->top - floor - 2;

circref:
  scm_puts (" . ", port);
  print_circref (port, pstate, exp);
  goto end;
}

int
scm_valid_oport_value_p	(SCM val)
{
  return (SCM_OPOUTPORTP (val)
          || (SCM_PORT_WITH_PS_P (val)
              && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
}

/* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */

SCM
scm_write (SCM obj, SCM port)
{
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();

  SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);

  scm_prin1 (obj, port, 1);
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
#endif
  return SCM_UNSPECIFIED;
}

/* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */

SCM
scm_display (SCM obj, SCM port)
{
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();

  SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);

  scm_prin1 (obj, port, 0);
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
#endif
  return SCM_UNSPECIFIED;
}

SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
            (SCM destination, SCM message, SCM args),
	    "Write @var{message} to @var{destination}, defaulting to\n"
	    "the current output port.\n"
	    "@var{message} can contain @code{~A} (was @code{%s}) and\n"
	    "@code{~S} (was @code{%S}) escapes.  When printed,\n"
	    "the escapes are replaced with corresponding members of\n"
	    "@var{ARGS}:\n"
	    "@code{~A} formats using @code{display} and @code{~S} formats\n"
	    "using @code{write}.\n"
	    "If @var{destination} is @code{#t}, then use the current output\n"
	    "port, if @var{destination} is @code{#f}, then return a string\n"
	    "containing the formatted text. Does not add a trailing newline.")
#define FUNC_NAME s_scm_simple_format
{
  SCM port, answer = SCM_UNSPECIFIED;
  int fReturnString = 0;
  int writingp;
  size_t start, p, end;

  if (scm_is_eq (destination, SCM_BOOL_T))
    {
      destination = port = scm_current_output_port ();
    }
  else if (scm_is_false (destination))
    {
      fReturnString = 1;
      port = scm_mkstrport (SCM_INUM0,
			    scm_make_string (SCM_INUM0, SCM_UNDEFINED),
			    SCM_OPN | SCM_WRTNG,
			    FUNC_NAME);
      destination = port;
    }
  else
    {
      SCM_VALIDATE_OPORT_VALUE (1, destination);
      port = SCM_COERCE_OUTPORT (destination);
    }
  SCM_VALIDATE_STRING (2, message);
  SCM_VALIDATE_REST_ARGUMENT (args);

  p = 0;
  start = 0;
  end = scm_i_string_length (message);
  for (p = start; p != end; ++p)
    if (scm_i_string_ref (message, p) == '~')
      {
	if (++p == end)
	  break;

	switch (scm_i_string_ref (message, p))
	  {
	  case 'A': case 'a':
	    writingp = 0;
	    break;
	  case 'S': case 's':
	    writingp = 1;
	    break;
	  case '~':
	    scm_lfwrite_substr (message, start, p, port);
	    start = p + 1;
	    continue;
	  case '%':
	    scm_lfwrite_substr (message, start, p - 1, port);
	    scm_newline (port);
	    start = p + 1;
	    continue;
	  default:
	    SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
			    scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));

	  }

	if (!scm_is_pair (args))
	  SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
			  scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p))));

	scm_lfwrite_substr (message, start, p - 1, port);
	/* we pass destination here */
	scm_prin1 (SCM_CAR (args), destination, writingp);
	args = SCM_CDR (args);
	start = p + 1;
      }

  scm_lfwrite_substr (message, start, p, port);
  if (!scm_is_eq (args, SCM_EOL))
    SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
		    scm_list_1 (scm_length (args)));

  if (fReturnString)
    answer = scm_strport_to_string (destination);

  return scm_return_first (answer, message);
}
#undef FUNC_NAME

SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
            (SCM port),
	    "Send a newline to @var{port}.\n"
	    "If @var{port} is omitted, send to the current output port.")
#define FUNC_NAME s_scm_newline
{
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();

  SCM_VALIDATE_OPORT_VALUE (1, port);

  scm_putc ('\n', SCM_COERCE_OUTPORT (port));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
            (SCM chr, SCM port),
	    "Send character @var{chr} to @var{port}.")
#define FUNC_NAME s_scm_write_char
{
  if (SCM_UNBNDP (port))
    port = scm_current_output_port ();

  SCM_VALIDATE_CHAR (1, chr);
  SCM_VALIDATE_OPORT_VALUE (2, port);

  scm_i_charprint (SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
#if 0
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
#endif
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

/* Call back to Scheme code to do the printing of special objects
 * (like structs).  SCM_PRINTER_APPLY applies PROC to EXP and a smob
 * containing PORT and PSTATE.  This object can be used as the port for
 * display/write etc to continue the current print chain.  The REVEALED
 * field of PSTATE is set to true to indicate that the print state has
 * escaped to Scheme and thus has to be freed by the GC.
 */

scm_t_bits scm_tc16_port_with_ps;

/* Print exactly as the port itself would */

static int
port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
  obj = SCM_PORT_WITH_PS_PORT (obj);
  return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
}

SCM
scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
{
  pstate->revealed = 1;
  return scm_call_2 (proc, exp,
		     scm_i_port_with_print_state (port, pstate->handle));
}

SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
            (SCM port, SCM pstate),
	    "Create a new port which behaves like @var{port}, but with an\n"
	    "included print state @var{pstate}.  @var{pstate} is optional.\n"
	    "If @var{pstate} isn't supplied and @var{port} already has\n"
	    "a print state, the old print state is reused.")
#define FUNC_NAME s_scm_port_with_print_state
{
  SCM_VALIDATE_OPORT_VALUE (1, port);
  if (!SCM_UNBNDP (pstate))
    SCM_VALIDATE_PRINTSTATE (2, pstate);
  return scm_i_port_with_print_state (port, pstate);
}
#undef FUNC_NAME

SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
            (SCM port),
	    "Return the print state of the port @var{port}. If @var{port}\n"
	    "has no associated print state, @code{#f} is returned.")
#define FUNC_NAME s_scm_get_print_state
{
  if (SCM_PORT_WITH_PS_P (port))
    return SCM_PORT_WITH_PS_PS (port);
  if (SCM_OUTPUT_PORT_P (port))
    return SCM_BOOL_F;
  SCM_WRONG_TYPE_ARG (1, port);
}
#undef FUNC_NAME

void
scm_init_print ()
{
  SCM vtable, layout, type;

  scm_init_opts (scm_print_options, scm_print_opts);

  scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
				 scm_from_locale_string ("{"),
				 scm_from_locale_symbol ("highlight-suffix"),
				 scm_from_locale_string ("}")));

  scm_gc_register_root (&print_state_pool);
  scm_gc_register_root (&scm_print_state_vtable);
  vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
  layout =
    scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
  type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
  scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state"));
  scm_print_state_vtable = type;

  /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
  scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
  scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);

#include "libguile/print.x"

  scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
}

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


code:
/* classes: h_files */

#ifndef SCM_PRINT_H
#define SCM_PRINT_H

/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 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 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#include "libguile/__scm.h"

#include "libguile/chars.h"
#include "libguile/options.h"

/* State information passed around during printing.
 */
#define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \
				&& (scm_is_eq (SCM_STRUCT_VTABLE(obj), \
				               scm_print_state_vtable)))
#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))

#define RESET_PRINT_STATE(pstate) \
do { \
  pstate->list_offset = 0; \
  pstate->top = 0; \
} while (0)

#define SCM_WRITINGP(pstate) ((pstate)->writingp)
#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }

#define SCM_PORT_WITH_PS_P(p)    SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p)
#define SCM_PORT_WITH_PS_PORT(p) SCM_CAR (SCM_CELL_OBJECT_1 (p))
#define SCM_PORT_WITH_PS_PS(p)   SCM_CDR (SCM_CELL_OBJECT_1 (p))

#define SCM_COERCE_OUTPORT(p) \
  (SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p)

#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwurprpw"
typedef struct scm_print_state {
  SCM handle;			/* Struct handle */
  int revealed;                 /* Has the state escaped to Scheme? */
  unsigned long writingp;	/* Writing? */
  unsigned long fancyp;		/* Fancy printing? */
  unsigned long level;		/* Max level */
  unsigned long length;		/* Max number of objects per level */
  SCM hot_ref;			/* Hot reference */
  unsigned long list_offset;
  unsigned long top;		/* Top of reference stack */
  unsigned long ceiling;	/* Max size of reference stack */
  SCM ref_vect;	 	        /* Stack of references used during
				   circular reference detection;
				   a simple vector. */
  SCM highlight_objects;        /* List of objects to be highlighted */
} scm_print_state;

SCM_API SCM scm_print_state_vtable;

SCM_API scm_t_bits scm_tc16_port_with_ps;

SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
SCM_INTERNAL void scm_i_charprint (scm_t_wchar c, SCM port);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_i_print_symbol_name (SCM sym, SCM port);
SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port);
SCM_API void scm_prin1 (SCM exp, SCM port, int writingp);
SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
SCM_API SCM scm_write (SCM obj, SCM port);
SCM_API SCM scm_display (SCM obj, SCM port);
SCM_API SCM scm_simple_format (SCM port, SCM message, SCM args);
SCM_API SCM scm_newline (SCM port);
SCM_API SCM scm_write_char (SCM chr, SCM port);
SCM_API SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *);
SCM_API SCM scm_port_with_print_state (SCM port, SCM pstate);
SCM_API SCM scm_get_print_state (SCM port);
SCM_API int scm_valid_oport_value_p (SCM val);
SCM_INTERNAL void scm_init_print (void);

#ifdef GUILE_DEBUG
SCM_API SCM scm_current_pstate (void);
#endif

#endif  /* SCM_PRINT_H */

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

license: mit


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

#ifndef SCM_PRIVATE_GC
#define SCM_PRIVATE_GC

#include  "_scm.h"

/* {heap tuning parameters}
 *
 * These are parameters for controlling memory allocation.  The heap
 * is the area out of which scm_cons, and object headers are allocated.
 *
 * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
 * 64 bit machine.  The units of the _SIZE parameters are bytes.
 * Cons pairs and object headers occupy one heap cell.
 */

#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024

#define SCM_DOUBLECELL_ALIGNED_P(x)  (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)

SCM_INTERNAL int scm_getenv_int (const char *var, int def);

typedef enum { return_on_error, abort_on_error } policy_on_error;

#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))

/* CELL_P checks a random word whether it has the right form for a
   pointer to a cell.  Use scm_i_find_heap_segment_containing_object
   to find out whether it actually points to a real cell.

   The right form for a cell pointer is this: the low three bits must
   be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
   resulting pointer must be correctly aligned.
   scm_i_initialize_heap_segment_data guarantees that the test below
   works.
*/
#define CELL_P(x)  ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)

SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */

#endif


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

#ifndef PRIVATE_OPTIONS
#define PRIVATE_OPTIONS

/*
  evaluator
 */
SCM_API scm_t_option scm_eval_opts[];

SCM_API scm_t_option scm_evaluator_trap_table[];

SCM_API SCM scm_eval_options_interface (SCM setting);

#define SCM_EVAL_STACK         scm_eval_opts[0].val

#define SCM_TRAPS_P            scm_evaluator_trap_table[0].val
#define SCM_ENTER_FRAME_P      scm_evaluator_trap_table[1].val
#define SCM_APPLY_FRAME_P      scm_evaluator_trap_table[2].val
#define SCM_EXIT_FRAME_P       scm_evaluator_trap_table[3].val
#define SCM_ENTER_FRAME_HDLR   (SCM_PACK (scm_evaluator_trap_table[4].val))
#define SCM_APPLY_FRAME_HDLR   (SCM_PACK (scm_evaluator_trap_table[5].val))
#define SCM_EXIT_FRAME_HDLR    (SCM_PACK (scm_evaluator_trap_table[6].val))
#define SCM_MEMOIZE_P       scm_evaluator_trap_table[7].val
#define SCM_MEMOIZE_HDLR    (SCM_PACK (scm_evaluator_trap_table[8].val))

/*
  debugging.
 */
SCM_API scm_t_option scm_debug_opts[];

#define SCM_BREAKPOINTS_P	scm_debug_opts[1].val
#define SCM_TRACE_P		scm_debug_opts[2].val
#define SCM_REC_PROCNAMES_P	scm_debug_opts[3].val
#define SCM_BACKWARDS_P		scm_debug_opts[4].val
#define SCM_BACKTRACE_WIDTH   	scm_debug_opts[5].val
#define SCM_BACKTRACE_INDENT   	scm_debug_opts[6].val
#define SCM_N_FRAMES		scm_debug_opts[7].val
#define SCM_BACKTRACE_MAXDEPTH	scm_debug_opts[8].val
#define SCM_BACKTRACE_DEPTH	scm_debug_opts[9].val
#define SCM_BACKTRACE_P		scm_debug_opts[10].val
#define SCM_DEVAL_P		scm_debug_opts[11].val
#define SCM_STACK_LIMIT		scm_debug_opts[12].val
#define SCM_SHOW_FILE_NAME	scm_debug_opts[13].val
#define SCM_WARN_DEPRECATED	scm_debug_opts[14].val
#define SCM_N_DEBUG_OPTIONS 15

/*
  printing
*/
SCM_API scm_t_option scm_print_opts[];

#define SCM_PRINT_CLOSURE	    (SCM_PACK (scm_print_opts[0].val))
#define SCM_PRINT_SOURCE_P	    ((int) scm_print_opts[1].val)
#define SCM_PRINT_HIGHLIGHT_PREFIX  (SCM_PACK (scm_print_opts[2].val))
#define SCM_PRINT_HIGHLIGHT_SUFFIX  (SCM_PACK (scm_print_opts[3].val))
#define SCM_PRINT_KEYWORD_STYLE_I   4
#define SCM_PRINT_KEYWORD_STYLE     (SCM_PACK (scm_print_opts[4].val))
#define SCM_N_PRINT_OPTIONS 5

/*
  read
 */
SCM_API scm_t_option scm_read_opts[];

#define SCM_COPY_SOURCE_P      scm_read_opts[0].val
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
#define SCM_KEYWORD_STYLE      scm_read_opts[3].val
#define SCM_ELISP_VECTORS_P    scm_read_opts[4].val
#define SCM_ESCAPED_PARENS_P   scm_read_opts[5].val
#define SCM_R6RS_ESCAPES_P     scm_read_opts[6].val
#define SCM_SQUARE_BRACKETS_P  scm_read_opts[7].val

#define SCM_N_READ_OPTIONS 8

#endif  /* PRIVATE_OPTIONS */


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

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

#define SCM_BUILDING_DEPRECATED_CODE

#include "libguile/_scm.h"

#include "libguile/alist.h"
#include "libguile/deprecation.h"
#include "libguile/deprecated.h"
#include "libguile/eval.h"
#include "libguile/procs.h"
#include "libguile/gsubr.h"
#include "libguile/smob.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
#include "libguile/programs.h"

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

SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
#endif
SCM_GLOBAL_SYMBOL (scm_sym_name, "name");

static SCM overrides;
static scm_i_pthread_mutex_t overrides_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;

int
scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
{
  while (!SCM_PROGRAM_P (proc))
    {
      if (SCM_IMP (proc))
        return 0;
      switch (SCM_TYP7 (proc))
        {
        case scm_tc7_smob:
          if (!SCM_SMOB_APPLICABLE_P (proc))
            return 0;
          proc = scm_i_smob_apply_trampoline (proc);
          break;
        case scm_tcs_struct:
          if (!SCM_STRUCT_APPLICABLE_P (proc))
            return 0;
          proc = SCM_STRUCT_PROCEDURE (proc);
          break;
        default:
          return 0;
        }
    }
  return scm_i_program_arity (proc, req, opt, rest);
}

SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
           (SCM proc),
	    "Return the \"minimum arity\" of a procedure.\n\n"
            "If the procedure has only one arity, that arity is returned\n"
            "as a list of three values: the number of required arguments,\n"
            "the number of optional arguments, and a boolean indicating\n"
            "whether or not the procedure takes rest arguments.\n\n"
            "For a case-lambda procedure, the arity returned is the one\n"
            "with the lowest minimum number of arguments, and the highest\n"
            "maximum number of arguments.\n\n"
            "If it was not possible to determine the arity of the procedure,\n"
            "@code{#f} is returned.")
#define FUNC_NAME s_scm_procedure_minimum_arity
{
  int req, opt, rest;

  if (scm_i_procedure_arity (proc, &req, &opt, &rest))
    return scm_list_3 (scm_from_int (req),
                       scm_from_int (opt),
                       scm_from_bool (rest));
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
           (SCM proc),
	    "Return @var{obj}'s property list.")
#define FUNC_NAME s_scm_procedure_properties
{
  SCM ret;

  SCM_VALIDATE_PROC (1, proc);

  scm_i_pthread_mutex_lock (&overrides_lock);
  ret = scm_hashq_ref (overrides, proc, SCM_BOOL_F);
  scm_i_pthread_mutex_unlock (&overrides_lock);

  if (scm_is_false (ret))
    {
      if (SCM_PROGRAM_P (proc))
        ret = scm_i_program_properties (proc);
      else
        ret = SCM_EOL;
    }

#if (SCM_ENABLE_DEPRECATED == 1)
  ret = scm_acons (scm_sym_arity, scm_procedure_minimum_arity (proc), ret);
#endif

  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
           (SCM proc, SCM alist),
	    "Set @var{proc}'s property list to @var{alist}.")
#define FUNC_NAME s_scm_set_procedure_properties_x
{
  SCM_VALIDATE_PROC (1, proc);

#if (SCM_ENABLE_DEPRECATED == 1)
  if (scm_assq (alist, scm_sym_arity))
    SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
#endif

  scm_i_pthread_mutex_lock (&overrides_lock);
  scm_hashq_set_x (overrides, proc, alist);
  scm_i_pthread_mutex_unlock (&overrides_lock);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
           (SCM proc, SCM key),
	    "Return the property of @var{proc} with name @var{key}.")
#define FUNC_NAME s_scm_procedure_property
{
  SCM_VALIDATE_PROC (1, proc);

#if (SCM_ENABLE_DEPRECATED == 1)
  if (scm_is_eq (key, scm_sym_arity))
    scm_c_issue_deprecation_warning
      ("Accessing a procedure's arity via `procedure-property' is deprecated.\n"
       "Use `procedure-minimum-arity instead.");
#endif

  return scm_assq_ref (scm_procedure_properties (proc), key);
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
           (SCM proc, SCM key, SCM val),
	    "In @var{proc}'s property list, set the property named @var{key} to\n"
	    "@var{val}.")
#define FUNC_NAME s_scm_set_procedure_property_x
{
  SCM props;

  SCM_VALIDATE_PROC (1, proc);

#if (SCM_ENABLE_DEPRECATED == 1)
  if (scm_is_eq (key, scm_sym_arity))
    SCM_MISC_ERROR ("arity is a deprecated read-only property", SCM_EOL);
#endif

  props = scm_procedure_properties (proc);

#if (SCM_ENABLE_DEPRECATED == 1)
  /* cdr past the consed-on arity. */
  props = scm_cdr (props);
#endif

  scm_i_pthread_mutex_lock (&overrides_lock);
  scm_hashq_set_x (overrides, proc, scm_assq_set_x (props, key, val));
  scm_i_pthread_mutex_unlock (&overrides_lock);

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_procprop ()
{
  overrides = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/procprop.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROCPROP_H
#define SCM_PROCPROP_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_sym_name;
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_DEPRECATED SCM scm_sym_arity;
#endif
SCM_API SCM scm_sym_system_procedure;

SCM_INTERNAL int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest);
SCM_API SCM scm_procedure_minimum_arity (SCM proc);
SCM_API SCM scm_procedure_properties (SCM proc);
SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM alist);
SCM_API SCM scm_procedure_property (SCM proc, SCM key);
SCM_API SCM scm_set_procedure_property_x (SCM proc, SCM key, SCM val);
SCM_INTERNAL void scm_init_procprop (void);

#endif  /* SCM_PROCPROP_H */

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


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

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

#include "libguile/_scm.h"

#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/smob.h"
#include "libguile/deprecation.h"

#include "libguile/validate.h"
#include "libguile/procs.h"
#include "libguile/procprop.h"
#include "libguile/objcodes.h"
#include "libguile/programs.h"

/* {Procedures}
 */

SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p
{
  if (SCM_NIMP (obj))
    switch (SCM_TYP7 (obj))
      {
      case scm_tcs_struct:
	if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
              || SCM_STRUCT_APPLICABLE_P (obj)))
	  break;
      case scm_tc7_program:
	return SCM_BOOL_T;
      case scm_tc7_smob:
	return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
      default:
	return SCM_BOOL_F;
      }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a thunk.")
#define FUNC_NAME s_scm_thunk_p
{
  int req, opt, rest;
  return scm_from_bool (scm_i_procedure_arity (obj, &req, &opt, &rest)
                        && req == 0);
}
#undef FUNC_NAME

SCM_SYMBOL (sym_documentation, "documentation");

SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
           (SCM proc),
	    "Return the documentation string associated with @code{proc}.  By\n"
	    "convention, if a procedure contains more than one expression and the\n"
	    "first expression is a string constant, that string is assumed to contain\n"
	    "documentation for that procedure.")
#define FUNC_NAME s_scm_procedure_documentation
{
  SCM_VALIDATE_PROC (SCM_ARG1, proc);
  return scm_procedure_property (proc, sym_documentation);
}
#undef FUNC_NAME

/* Procedure-with-setter
 */

static SCM pws_vtable;

SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a procedure with an\n"
	    "associated setter procedure.")
#define FUNC_NAME s_scm_procedure_with_setter_p
{
  return scm_from_bool (SCM_STRUCTP (obj) && SCM_STRUCT_SETTER_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
            (SCM procedure, SCM setter),
	    "Create a new procedure which behaves like @var{procedure}, but\n"
	    "with the associated setter @var{setter}.")
#define FUNC_NAME s_scm_make_procedure_with_setter
{
  SCM name, ret;
  SCM_VALIDATE_PROC (1, procedure);
  SCM_VALIDATE_PROC (2, setter);
  ret = scm_make_struct (pws_vtable, SCM_INUM0,
                         scm_list_2 (procedure, setter));

  /* don't use procedure_name, because don't care enough to do a reverse
     lookup */
  name = scm_procedure_property (procedure, scm_sym_name);
  if (scm_is_true (name))
    scm_set_procedure_property_x (ret, scm_sym_name, name);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
            (SCM proc),
	    "Return the procedure of @var{proc}, which must be an\n"
	    "applicable struct.")
#define FUNC_NAME s_scm_procedure
{
  SCM_VALIDATE_NIM (1, proc);
  SCM_ASSERT (SCM_STRUCT_APPLICABLE_P (proc), proc, SCM_ARG1, FUNC_NAME);
  return SCM_STRUCT_PROCEDURE (proc);
}
#undef FUNC_NAME

SCM_PRIMITIVE_GENERIC (scm_setter, "setter", 1, 0, 0,
                       (SCM proc),
                       "Return the setter of @var{proc}, which must be an\n"
                       "applicable struct with a setter.")
#define FUNC_NAME s_scm_setter
{
  SCM_GASSERT1 (SCM_STRUCTP (proc), g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
  if (SCM_STRUCT_SETTER_P (proc))
    return SCM_STRUCT_SETTER (proc);
  if (SCM_PUREGENERICP (proc))
    /* FIXME: might not be an accessor */
    return SCM_GENERIC_SETTER (proc);
  SCM_WTA_DISPATCH_1 (g_scm_setter, proc, SCM_ARG1, FUNC_NAME);
  return SCM_BOOL_F; /* not reached */
}
#undef FUNC_NAME

void
scm_init_procs ()
{
  pws_vtable =
    scm_c_make_struct (scm_applicable_struct_with_setter_vtable_vtable,
                       0,
                       1,
                       SCM_UNPACK (scm_from_locale_symbol ("pwpw")));

#include "libguile/procs.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROCS_H
#define SCM_PROCS_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_procedure_p (SCM obj);
SCM_API SCM scm_thunk_p (SCM obj);
SCM_API SCM scm_procedure_documentation (SCM proc);
SCM_API SCM scm_procedure_with_setter_p (SCM obj);
SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
SCM_API SCM scm_procedure (SCM proc);
SCM_API SCM scm_setter (SCM proc);
SCM_INTERNAL void scm_init_procs (void);

#endif  /* SCM_PROCS_H */

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


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

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

#include <string.h>
#include "_scm.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
#include "procprop.h" /* scm_sym_name */
#include "srcprop.h"  /* scm_sym_filename */
#include "vm.h"

static SCM write_program = SCM_BOOL_F;

SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
	    (SCM objcode, SCM objtable, SCM free_variables),
	    "")
#define FUNC_NAME s_scm_make_program
{
  SCM_VALIDATE_OBJCODE (1, objcode);
  if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
    objtable = SCM_BOOL_F;
  else if (scm_is_true (objtable))
    SCM_VALIDATE_VECTOR (2, objtable);

  if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
    {
      SCM ret = scm_words (scm_tc7_program, 3);
      SCM_SET_CELL_OBJECT_1 (ret, objcode);
      SCM_SET_CELL_OBJECT_2 (ret, objtable);
      return ret;
    }
  else
    {
      size_t i, len;
      SCM ret;
      SCM_VALIDATE_VECTOR (3, free_variables);
      len = scm_c_vector_length (free_variables);
      if (SCM_UNLIKELY (len >> 16))
        SCM_OUT_OF_RANGE (3, free_variables);
      ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
      SCM_SET_CELL_OBJECT_1 (ret, objcode);
      SCM_SET_CELL_OBJECT_2 (ret, objtable);
      for (i = 0; i < len; i++)
        SCM_SET_CELL_OBJECT (ret, 3+i,
                             SCM_SIMPLE_VECTOR_REF (free_variables, i));
      return ret;
    }
}
#undef FUNC_NAME

void
scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
{
  static int print_error = 0;

  if (scm_is_false (write_program) && scm_module_system_booted_p)
    write_program = scm_module_local_variable
      (scm_c_resolve_module ("system vm program"),
       scm_from_locale_symbol ("write-program"));

  if (SCM_PROGRAM_IS_CONTINUATION (program))
    {
      /* twingliness */
      scm_puts ("#<continuation ", port);
      scm_uintprint (SCM_UNPACK (program), 16, port);
      scm_putc ('>', port);
    }
  else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
    {
      /* twingliness */
      scm_puts ("#<partial-continuation ", port);
      scm_uintprint (SCM_UNPACK (program), 16, port);
      scm_putc ('>', port);
    }
  else if (scm_is_false (write_program) || print_error)
    {
      scm_puts ("#<program ", port);
      scm_uintprint (SCM_UNPACK (program), 16, port);
      scm_putc ('>', port);
    }
  else
    {
      print_error = 1;
      scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
      print_error = 0;
    }
}

/*
 * Scheme interface
 */

SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_program_p
{
  return scm_from_bool (SCM_PROGRAM_P (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_base
{
  const struct scm_objcode *c_objcode;

  SCM_VALIDATE_PROGRAM (1, program);

  c_objcode = SCM_PROGRAM_DATA (program);
  return scm_from_ulong ((unsigned long) SCM_C_OBJCODE_BASE (c_objcode));
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_objects
{
  SCM_VALIDATE_PROGRAM (1, program);
  return SCM_PROGRAM_OBJTABLE (program);
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_module
{
  SCM objs;
  SCM_VALIDATE_PROGRAM (1, program);
  objs = SCM_PROGRAM_OBJTABLE (program);
  return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_meta
{
  SCM metaobj;

  SCM_VALIDATE_PROGRAM (1, program);

  metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
  if (scm_is_true (metaobj))
    return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
                             SCM_BOOL_F);
  else
    return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_bindings
{
  SCM meta;

  SCM_VALIDATE_PROGRAM (1, program);

  meta = scm_program_meta (program);
  if (scm_is_false (meta))
    return SCM_BOOL_F;

  return scm_car (scm_call_0 (meta));
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_sources
{
  SCM meta, sources, ret, filename;

  SCM_VALIDATE_PROGRAM (1, program);

  meta = scm_program_meta (program);
  if (scm_is_false (meta))
    return SCM_EOL;

  filename = SCM_BOOL_F;
  ret = SCM_EOL;
  for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
       sources = scm_cdr (sources))
    {
      SCM x = scm_car (sources);
      if (scm_is_pair (x))
        {
          if (scm_is_number (scm_car (x)))
            {
              SCM addr = scm_car (x);
              ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
                               ret);
            }
          else if (scm_is_eq (scm_car (x), scm_sym_filename))
            filename = scm_cdr (x);
        }
    }
  return scm_reverse_x (ret, SCM_UNDEFINED);
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_arities
{
  SCM meta;

  SCM_VALIDATE_PROGRAM (1, program);

  meta = scm_program_meta (program);
  if (scm_is_false (meta))
    return SCM_BOOL_F;

  return scm_caddr (scm_call_0 (meta));
}
#undef FUNC_NAME

SCM
scm_i_program_properties (SCM program)
#define FUNC_NAME "%program-properties"
{
  SCM meta;

  SCM_VALIDATE_PROGRAM (1, program);

  meta = scm_program_meta (program);
  if (scm_is_false (meta))
    return SCM_EOL;

  return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
	    (SCM program, SCM ip),
	    "")
#define FUNC_NAME s_scm_program_source
{
  SCM_VALIDATE_PROGRAM (1, program);
  return scm_c_program_source (program, scm_to_size_t (ip));
}
#undef FUNC_NAME

extern SCM
scm_c_program_source (SCM program, size_t ip)
{
  SCM sources, source = SCM_BOOL_F;

  for (sources = scm_program_sources (program);
       !scm_is_null (sources)
         && scm_to_size_t (scm_caar (sources)) <= ip;
       sources = scm_cdr (sources))
    source = scm_car (sources);

  return source; /* (addr . (filename . (line . column))) */
}

SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
	    (SCM program),
	    "")
#define FUNC_NAME s_scm_program_num_free_variables
{
  SCM_VALIDATE_PROGRAM (1, program);
  return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
	    (SCM program, SCM i),
	    "")
#define FUNC_NAME s_scm_program_free_variable_ref
{
  unsigned long idx;
  SCM_VALIDATE_PROGRAM (1, program);
  SCM_VALIDATE_ULONG_COPY (2, i, idx);
  if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
    SCM_OUT_OF_RANGE (2, i);
  return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
	    (SCM program, SCM i, SCM x),
	    "")
#define FUNC_NAME s_scm_program_free_variable_set_x
{
  unsigned long idx;
  SCM_VALIDATE_PROGRAM (1, program);
  SCM_VALIDATE_ULONG_COPY (2, i, idx);
  if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
    SCM_OUT_OF_RANGE (2, i);
  SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
	    (SCM program),
	    "Return a @var{program}'s object code.")
#define FUNC_NAME s_scm_program_objcode
{
  SCM_VALIDATE_PROGRAM (1, program);

  return SCM_PROGRAM_OBJCODE (program);
}
#undef FUNC_NAME

/* procedure-minimum-arity support. */
static void
parse_arity (SCM arity, int *req, int *opt, int *rest)
{
  SCM x = scm_cddr (arity);

  if (scm_is_pair (x))
    {
      *req = scm_to_int (scm_car (x));
      x = scm_cdr (x);
      if (scm_is_pair (x))
        {
          *opt = scm_to_int (scm_car (x));
          x = scm_cdr (x);
          if (scm_is_pair (x))
            *rest = scm_is_true (scm_car (x));
          else
            *rest = 0;
        }
      else
        *opt = *rest = 0;
    }
  else
    *req = *opt = *rest = 0;
}

int
scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
{
  SCM arities;

  arities = scm_program_arities (program);
  if (!scm_is_pair (arities))
    return 0;

  parse_arity (scm_car (arities), req, opt, rest);
  arities = scm_cdr (arities);

  for (; scm_is_pair (arities); arities = scm_cdr (arities))
    {
      int thisreq, thisopt, thisrest;

      parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);

      if (thisreq < *req
          || (thisreq == *req
              && ((thisrest && (!*rest || thisopt > *opt))
                  || (!thisrest && !*rest && thisopt > *opt))))
        {
          *req = thisreq;
          *opt = thisopt;
          *rest = thisrest;
        }
    }

  return 1;
}

void
scm_bootstrap_programs (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_programs",
                            (scm_t_extension_init_func)scm_init_programs, NULL);
}

void
scm_init_programs (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/programs.x"
#endif
}

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


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

#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_

#include <libguile.h>
#include <libguile/objcodes.h>

/*
 * Programs
 */

#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000

#define SCM_PROGRAM_P(x)	(!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
#define SCM_PROGRAM_OBJCODE(x)	(SCM_CELL_OBJECT_1 (x))
#define SCM_PROGRAM_OBJTABLE(x)	(SCM_CELL_OBJECT_2 (x))
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 3))
#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v))
#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
#define SCM_PROGRAM_DATA(x)	(SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x)	(SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_CONTINUATION)
#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)

SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);

SCM_API SCM scm_program_p (SCM obj);
SCM_API SCM scm_program_base (SCM program);
SCM_API SCM scm_program_meta (SCM program);
SCM_API SCM scm_program_bindings (SCM program);
SCM_API SCM scm_program_sources (SCM program);
SCM_API SCM scm_program_source (SCM program, SCM ip);
SCM_API SCM scm_program_arities (SCM program);
SCM_API SCM scm_program_objects (SCM program);
SCM_API SCM scm_program_module (SCM program);
SCM_API SCM scm_program_num_free_variables (SCM program);
SCM_API SCM scm_program_free_variable_ref (SCM program, SCM i);
SCM_API SCM scm_program_free_variable_set_x (SCM program, SCM i, SCM x);
SCM_API SCM scm_program_objcode (SCM program);

SCM_API SCM scm_c_program_source (SCM program, size_t ip);

SCM_INTERNAL SCM scm_i_program_properties (SCM program);
SCM_INTERNAL int scm_i_program_arity (SCM program, int *req, int *opt, int *rest);
SCM_INTERNAL void scm_i_program_print (SCM program, SCM port,
                                       scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_programs (void);
SCM_INTERNAL void scm_init_programs (void);

#endif /* _SCM_PROGRAMS_H_ */

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


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

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

#include <alloca.h>

#include "libguile/__scm.h"

#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/async.h"
#include "libguile/continuations.h"
#include "libguile/debug.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
#include "libguile/eq.h"
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/programs.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/strings.h"
#include "libguile/threads.h"
#include "libguile/throw.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/promises.h"

scm_t_bits scm_tc16_promise;

SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0,
	    (SCM thunk),
	    "Create a new promise object.\n\n"
            "@code{make-promise} is a procedural form of @code{delay}.\n"
            "These two expressions are equivalent:\n"
            "@lisp\n"
	    "(delay @var{exp})\n"
	    "(make-promise (lambda () @var{exp}))\n"
            "@end lisp\n")
#define FUNC_NAME s_scm_make_promise
{
  SCM_VALIDATE_THUNK (1, thunk);
  SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
		       SCM_UNPACK (thunk),
		       scm_make_recursive_mutex ());
}
#undef FUNC_NAME

static int
promise_print (SCM exp, SCM port, scm_print_state *pstate)
{
  int writingp = SCM_WRITINGP (pstate);
  scm_puts ("#<promise ", port);
  SCM_SET_WRITINGP (pstate, 1);
  scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
  SCM_SET_WRITINGP (pstate, writingp);
  scm_putc ('>', port);
  return !0;
}

SCM_DEFINE (scm_force, "force", 1, 0, 0,
	    (SCM promise),
	    "If the promise @var{x} has not been computed yet, compute and\n"
	    "return @var{x}, otherwise just return the previously computed\n"
	    "value.")
#define FUNC_NAME s_scm_force
{
  SCM_VALIDATE_SMOB (1, promise, promise);
  scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
  if (!SCM_PROMISE_COMPUTED_P (promise))
    {
      SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
      if (!SCM_PROMISE_COMPUTED_P (promise))
	{
	  SCM_SET_PROMISE_DATA (promise, ans);
	  SCM_SET_PROMISE_COMPUTED (promise);
	}
    }
  scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
  return SCM_PROMISE_DATA (promise);
}
#undef FUNC_NAME

SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
            (SCM obj),
	    "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
	    "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
#define FUNC_NAME s_scm_promise_p
{
  return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
}
#undef FUNC_NAME

void
scm_init_promises ()
{
  scm_tc16_promise = scm_make_smob_type ("promise", 0);
  scm_set_smob_print (scm_tc16_promise, promise_print);

#include "libguile/promises.x"

  scm_add_feature ("delay");
}

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


code:
/* classes: h_files */

#ifndef SCM_PROMISES_H
#define SCM_PROMISES_H

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

#include "libguile/__scm.h"

/* {Promises}
 */

#define SCM_F_PROMISE_COMPUTED (1L << 0)
#define SCM_PROMISE_COMPUTED_P(promise) \
  (SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
#define SCM_SET_PROMISE_COMPUTED(promise) \
  SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
#define SCM_PROMISE_MUTEX     SCM_SMOB_OBJECT_2
#define SCM_PROMISE_DATA      SCM_SMOB_OBJECT
#define SCM_SET_PROMISE_DATA  SCM_SET_SMOB_OBJECT

SCM_API scm_t_bits scm_tc16_promise;

SCM_API SCM scm_make_promise (SCM thunk);
SCM_API SCM scm_force (SCM x);
SCM_API SCM scm_promise_p (SCM x);

SCM_INTERNAL void scm_init_promises (void);

#endif  /* SCM_PROMISES_H */

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


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

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

#include "libguile/_scm.h"
#include "libguile/hashtab.h"
#include "libguile/alist.h"
#include "libguile/root.h"
#include "libguile/weaks.h"
#include "libguile/validate.h"
#include "libguile/eval.h"

#include "libguile/properties.h"

/* {Properties}
 */

static SCM properties_whash;

SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
	    (SCM not_found_proc),
	    "Create a @dfn{property token} that can be used with\n"
	    "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
	    "See @code{primitive-property-ref} for the significance of\n"
	    "@var{not_found_proc}.")
#define FUNC_NAME s_scm_primitive_make_property
{
  if (not_found_proc != SCM_BOOL_F)
    SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
  return scm_cons (not_found_proc, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
	    (SCM prop, SCM obj),
	    "Return the property @var{prop} of @var{obj}.\n"
	    "\n"
	    "When no value has yet been associated with @var{prop} and\n"
	    "@var{obj}, the @var{not-found-proc} from @var{prop} is used.  A\n"
	    "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
	    "and the result set as the property value.  If\n"
	    "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
	    "property value.")
#define FUNC_NAME s_scm_primitive_property_ref
{
  SCM h;

  SCM_VALIDATE_CONS (SCM_ARG1, prop);

  h = scm_hashq_get_handle (properties_whash, obj);
  if (scm_is_true (h))
    {
      SCM assoc = scm_assq (prop, SCM_CDR (h));
      if (scm_is_true (assoc))
	return SCM_CDR (assoc);
    }

  if (scm_is_false (SCM_CAR (prop)))
    return SCM_BOOL_F;
  else
    {
      SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
      if (scm_is_false (h))
	h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
      SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
      return val;
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
	    (SCM prop, SCM obj, SCM val),
	    "Set the property @var{prop} of @var{obj} to @var{val}.")
#define FUNC_NAME s_scm_primitive_property_set_x
{
  SCM h, assoc;
  SCM_VALIDATE_CONS (SCM_ARG1, prop);
  h = scm_hashq_create_handle_x (properties_whash, obj, SCM_EOL);
  assoc = scm_assq (prop, SCM_CDR (h));
  if (SCM_NIMP (assoc))
    SCM_SETCDR (assoc, val);
  else
    {
      assoc = scm_acons (prop, val, SCM_CDR (h));
      SCM_SETCDR (h, assoc);
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
	    (SCM prop, SCM obj),
	    "Remove any value associated with @var{prop} and @var{obj}.")
#define FUNC_NAME s_scm_primitive_property_del_x
{
  SCM h;
  SCM_VALIDATE_CONS (SCM_ARG1, prop);
  h = scm_hashq_get_handle (properties_whash, obj);
  if (scm_is_true (h))
    SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_init_properties ()
{
  properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
#include "libguile/properties.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_PROPERTIES_H
#define SCM_PROPERTIES_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_primitive_make_property (SCM not_found_proc);
SCM_API SCM scm_primitive_property_ref (SCM prop, SCM obj);
SCM_API SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
SCM_API SCM scm_primitive_property_del_x (SCM prop, SCM obj);

SCM_INTERNAL void scm_init_properties (void);

#endif  /* SCM_PROPERTIES_H */

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


code:
/* classes: h_files */

#ifndef SCM_PTHREADS_THREADS_H
#define SCM_PTHREADS_THREADS_H

/* Copyright (C) 2002, 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 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

/* The pthreads-threads implementation.  This is a direct mapping.
*/

#include <pthread.h>
#include <sched.h>

/* `libgc' intercepts pthread calls by defining wrapping macros.  */
#include "libguile/bdw-gc.h"

/* Threads
*/
#define scm_i_pthread_t                     pthread_t
#define scm_i_pthread_self                  pthread_self
#define scm_i_pthread_create                pthread_create
#define scm_i_pthread_detach                pthread_detach
#define scm_i_pthread_exit                  pthread_exit
#define scm_i_pthread_cancel                pthread_cancel
#define scm_i_pthread_cleanup_push          pthread_cleanup_push
#define scm_i_pthread_cleanup_pop           pthread_cleanup_pop
#define scm_i_sched_yield                   sched_yield

/* Signals
 */
#define scm_i_pthread_sigmask               pthread_sigmask

/* Mutexes
 */
#if SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER
# define SCM_I_PTHREAD_MUTEX_INITIALIZER     { PTHREAD_MUTEX_INITIALIZER }
#else
# define SCM_I_PTHREAD_MUTEX_INITIALIZER     PTHREAD_MUTEX_INITIALIZER
#endif
#define scm_i_pthread_mutex_t               pthread_mutex_t
#define scm_i_pthread_mutex_init            pthread_mutex_init
#define scm_i_pthread_mutex_destroy         pthread_mutex_destroy
#define scm_i_pthread_mutex_trylock         pthread_mutex_trylock
#define scm_i_pthread_mutex_lock            pthread_mutex_lock
#define scm_i_pthread_mutex_unlock          pthread_mutex_unlock
extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];

/* Condition variables
 */
#define SCM_I_PTHREAD_COND_INITIALIZER      PTHREAD_COND_INITIALIZER
#define scm_i_pthread_cond_t                pthread_cond_t
#define scm_i_pthread_cond_init             pthread_cond_init
#define scm_i_pthread_cond_destroy          pthread_cond_destroy
#define scm_i_pthread_cond_signal           pthread_cond_signal
#define scm_i_pthread_cond_broadcast        pthread_cond_broadcast
#define scm_i_pthread_cond_wait             pthread_cond_wait
#define scm_i_pthread_cond_timedwait        pthread_cond_timedwait

/* Onces
 */
#define scm_i_pthread_once_t                pthread_once_t
#define scm_i_pthread_once                  pthread_once
#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT
#define SCM_I_PTHREAD_ONCE_INIT             { PTHREAD_ONCE_INIT }
#else
#define SCM_I_PTHREAD_ONCE_INIT             PTHREAD_ONCE_INIT
#endif

/* Thread specific storage
 */
#define scm_i_pthread_key_t                 pthread_key_t
#define scm_i_pthread_key_create            pthread_key_create
#define scm_i_pthread_setspecific           pthread_setspecific
#define scm_i_pthread_getspecific           pthread_getspecific

/* Convenience functions
 */
#define scm_i_scm_pthread_mutex_lock        scm_pthread_mutex_lock
#define scm_i_dynwind_pthread_mutex_lock    scm_dynwind_pthread_mutex_lock
#define scm_i_scm_pthread_cond_wait         scm_pthread_cond_wait
#define scm_i_scm_pthread_cond_timedwait    scm_pthread_cond_timedwait

#endif  /* SCM_PTHREADS_THREADS_H */

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


code:
/* The routine quicksort was extracted from the GNU C Library qsort.c
   written by Douglas C. Schmidt (schmidt@ics.uci.edu)
   and adapted to guile by adding an extra pointer less
   to quicksort by Roland Orre <orre@nada.kth.se>.

   The reason to do this instead of using the library function qsort
   was to avoid dependency of the ANSI-C extensions for local functions
   and also to avoid obscure pool based solutions.

   This sorting routine is not much more efficient than the stable
   version but doesn't consume extra memory.
 */

#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)

/* Order using quicksort.  This implementation incorporates four
   optimizations discussed in Sedgewick:

   1. Non-recursive, using an explicit stack of pointer that store the next
   array partition to sort.  To save time, this maximum amount of space
   required to store an array of MAX_SIZE_T is allocated on the stack.
   Assuming a bit width of 32 bits for size_t, this needs only
   32 * sizeof (stack_node) == 128 bytes.  Pretty cheap, actually.

   2. Chose the pivot element using a median-of-three decision tree.  This
   reduces the probability of selecting a bad pivot value and eliminates
   certain extraneous comparisons.

   3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
   to order the MAX_THRESH items within each partition.  This is a big win,
   since insertion sort is faster for small, mostly sorted array segments.

   4. The larger of the two sub-partitions is always pushed onto the
   stack first, with the algorithm then concentrating on the
   smaller partition.  This *guarantees* no more than log (n)
   stack size is needed (actually O(1) in this case)!  */

/* Discontinue quicksort algorithm when partition gets below this size.
 * This particular magic number was chosen to work best on a Sun 4/260. */
#define MAX_THRESH 4

/* Inline stack abstraction:  The stack size for quicksorting at most as many
 * elements as can be given by a value of type size_t is, as described above,
 * log (MAX_SIZE_T), which is the number of bits of size_t.  More accurately,
 * we would only need ceil (log (MAX_SIZE_T / MAX_THRESH)), but this is
 * ignored below. */

#define STACK_SIZE       (8 * sizeof (size_t))  /* assume 8 bit char */
#define PUSH(low, high)  ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
#define	POP(low, high)	 ((void) (--top, (low = top->lo), (high = top->hi)))
#define	STACK_NOT_EMPTY	 (stack < top)

static void
NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
      SCM less)
{
  /* Stack node declarations used to store unfulfilled partition obligations. */
  typedef struct {
    size_t lo;
    size_t hi;
  } stack_node;

  static const char s_buggy_less[] = "buggy less predicate used when sorting";

#define ELT(i) base_ptr[(i)*INC]

  if (nr_elems == 0)
    /* Avoid lossage with unsigned arithmetic below.  */
    return;

  if (nr_elems > MAX_THRESH)
    {
      size_t lo = 0;
      size_t hi = nr_elems-1;

      stack_node stack[STACK_SIZE];
      stack_node *top = stack + 1;

      while (STACK_NOT_EMPTY)
	{
	  size_t left;
	  size_t right;
	  size_t mid = lo + (hi - lo) / 2;
	  SCM pivot;

	  /* Select median value from among LO, MID, and HI. Rearrange
	     LO and HI so the three values are sorted. This lowers the
	     probability of picking a pathological pivot value and
	     skips a comparison for both the left and right. */

	  SCM_TICK;

	  if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
	    SWAP (ELT(mid), ELT(lo));
	  if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid))))
	    SWAP (ELT(mid), ELT(hi));
	  else
	    goto jump_over;
	  if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo))))
	    SWAP (ELT(mid), ELT(lo));
	jump_over:;

	  pivot = ELT(mid);
	  left = lo + 1;
	  right = hi - 1;

	  /* Here's the famous ``collapse the walls'' section of quicksort.
	     Gotta like those tight inner loops!  They are the main reason
	     that this algorithm runs much faster than others. */
	  do
	    {
	      while (scm_is_true (scm_call_2 (less, ELT(left), pivot)))
		{
		  left += 1;
		  /* The comparison predicate may be buggy */
		  if (left > hi)
		    scm_misc_error (NULL, s_buggy_less, SCM_EOL);
		}

	      while (scm_is_true (scm_call_2 (less, pivot, ELT(right))))
		{
		  right -= 1;
		  /* The comparison predicate may be buggy */
		  if (right < lo)
		    scm_misc_error (NULL, s_buggy_less, SCM_EOL);
		}

	      if (left < right)
		{
		  SWAP (ELT(left), ELT(right));
		  left += 1;
		  right -= 1;
		}
	      else if (left == right)
		{
		  left += 1;
		  right -= 1;
		  break;
		}
	    }
	  while (left <= right);

	  /* Set up pointers for next iteration.  First determine whether
	     left and right partitions are below the threshold size.  If so,
	     ignore one or both.  Otherwise, push the larger partition's
	     bounds on the stack and continue sorting the smaller one. */

	  if ((size_t) (right - lo) <= MAX_THRESH)
	    {
	      if ((size_t) (hi - left) <= MAX_THRESH)
		/* Ignore both small partitions. */
		POP (lo, hi);
	      else
		/* Ignore small left partition. */
		lo = left;
	    }
	  else if ((size_t) (hi - left) <= MAX_THRESH)
	    /* Ignore small right partition. */
	    hi = right;
	  else if ((right - lo) > (hi - left))
	    {
	      /* Push larger left partition indices. */
	      PUSH (lo, right);
	      lo = left;
	    }
	  else
	    {
	      /* Push larger right partition indices. */
	      PUSH (left, hi);
	      hi = right;
	    }
	}
    }

  /* Once the BASE_PTR array is partially sorted by quicksort the rest is
     completely sorted using insertion sort, since this is efficient for
     partitions below MAX_THRESH size. BASE_PTR points to the beginning of the
     array to sort, and END idexes the very last element in the array (*not*
     one beyond it!). */

  {
    size_t tmp = 0;
    size_t end = nr_elems-1;
    size_t thresh = min (end, MAX_THRESH);
    size_t run;

    /* Find smallest element in first threshold and place it at the
       array's beginning.  This is the smallest array element,
       and the operation speeds up insertion sort's inner loop. */

    for (run = tmp + 1; run <= thresh; run += 1)
      if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
	tmp = run;

    if (tmp != 0)
      SWAP (ELT(tmp), ELT(0));

    /* Insertion sort, running from left-hand-side up to right-hand-side.  */

    run = 1;
    while (++run <= end)
      {
	SCM_TICK;

	tmp = run - 1;
	while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp))))
	  {
	    /* The comparison predicate may be buggy */
	    if (tmp == 0)
	      scm_misc_error (NULL, s_buggy_less, SCM_EOL);

	    tmp -= 1;
	  }

	tmp += 1;
	if (tmp != run)
	  {
            SCM to_insert = ELT(run);
            size_t hi, lo;

            for (hi = lo = run; --lo >= tmp; hi = lo)
              ELT(hi) = ELT(lo);
            ELT(hi) = to_insert;
	  }
      }
  }
}

#undef SWAP
#undef MAX_THRESH
#undef STACK_SIZE
#undef PUSH
#undef POP
#undef STACK_NOT_EMPTY
#undef ELT

#undef NAME
#undef INC_PARAM
#undef INC