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

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

#include <stdio.h>
#include "libguile/_scm.h"

#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/procprop.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/strings.h"

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

/* C level hooks
 *
 * Currently, this implementation is separate from the Scheme level
 * hooks.  The possibility exists to implement the Scheme level hooks
 * using C level hooks.
 */

void
scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
{
  hook->first = 0;
  hook->type = type;
  hook->data = hook_data;
}

void
scm_c_hook_add (scm_t_c_hook *hook,
		scm_t_c_hook_function func,
		void *fn_data,
		int appendp)
{
  scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry));
  scm_t_c_hook_entry **loc = &hook->first;
  if (appendp)
    while (*loc)
      loc = &(*loc)->next;
  entry->next = *loc;
  entry->func = func;
  entry->data = fn_data;
  *loc = entry;
}

void
scm_c_hook_remove (scm_t_c_hook *hook,
		   scm_t_c_hook_function func,
		   void *fn_data)
{
  scm_t_c_hook_entry **loc = &hook->first;
  while (*loc)
    {
      if ((*loc)->func == func && (*loc)->data == fn_data)
	{
	  scm_t_c_hook_entry *entry = *loc;
	  *loc = (*loc)->next;
	  free (entry);
	  return;
	}
      loc = &(*loc)->next;
    }
  fprintf (stderr, "Attempt to remove non-existent hook function\n");
  abort ();
}

void *
scm_c_hook_run (scm_t_c_hook *hook, void *data)
{
  scm_t_c_hook_entry *entry = hook->first;
  scm_t_c_hook_type type = hook->type;
  void *res = 0;
  while (entry)
    {
      res = (entry->func) (hook->data, entry->data, data);
      if (res)
	{
	  if (type == SCM_C_HOOK_OR)
	    break;
	}
      else
	{
	  if (type == SCM_C_HOOK_AND)
	    break;
	}
      entry = entry->next;
    }
  return res;
}

/* Scheme level hooks
 *
 * A hook is basically a list of procedures to be called at well defined
 * points in time.
 *
 * Hook arity is not a full member of this type and therefore lacks an
 * accessor.  It exists to aid debugging and is not intended to be used in
 * programs.
 */

scm_t_bits scm_tc16_hook;

static int
hook_print (SCM hook, SCM port, scm_print_state *pstate)
{
  SCM ls, name;
  scm_puts ("#<hook ", port);
  scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
  scm_putc (' ', port);
  scm_uintprint (SCM_UNPACK (hook), 16, port);
  ls = SCM_HOOK_PROCEDURES (hook);
  while (SCM_NIMP (ls))
    {
      scm_putc (' ', port);
      name = scm_procedure_name (SCM_CAR (ls));
      if (scm_is_true (name))
	scm_iprin1 (name, port, pstate);
      else
	scm_putc ('?', port);
      ls = SCM_CDR (ls);
    }
  scm_putc ('>', port);
  return 1;
}

SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0,
            (SCM n_args),
	    "Create a hook for storing procedure of arity @var{n_args}.\n"
	    "@var{n_args} defaults to zero.  The returned value is a hook\n"
	    "object to be used with the other hook procedures.")
#define FUNC_NAME s_scm_make_hook
{
  unsigned int n;

  if (SCM_UNBNDP (n_args))
    n = 0;
  else
    n = scm_to_unsigned_integer (n_args, 0, 16);

  SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL));
}
#undef FUNC_NAME

SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0,
            (SCM x),
	    "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
#define FUNC_NAME s_scm_hook_p
{
  return scm_from_bool (SCM_HOOKP (x));
}
#undef FUNC_NAME

SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0,
            (SCM hook),
	    "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
	    "otherwise.")
#define FUNC_NAME s_scm_hook_empty_p
{
  SCM_VALIDATE_HOOK (1, hook);
  return scm_from_bool (scm_is_null (SCM_HOOK_PROCEDURES (hook)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
            (SCM hook, SCM proc, SCM append_p),
	    "Add the procedure @var{proc} to the hook @var{hook}. The\n"
	    "procedure is added to the end if @var{append_p} is true,\n"
	    "otherwise it is added to the front.  The return value of this\n"
	    "procedure is not specified.")
#define FUNC_NAME s_scm_add_hook_x
{
  SCM arity, rest;
  int n_args;
  SCM_VALIDATE_HOOK (1, hook);
  SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
	      proc, SCM_ARG2, FUNC_NAME);
  n_args = SCM_HOOK_ARITY (hook);
  if (scm_to_int (SCM_CAR (arity)) > n_args
      || (scm_is_false (SCM_CADDR (arity))
	  && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
	      < n_args)))
    scm_wrong_type_arg (FUNC_NAME, 2, proc);
  rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
  SCM_SET_HOOK_PROCEDURES (hook,
			   (!SCM_UNBNDP (append_p) && scm_is_true (append_p)
			    ? scm_append_x (scm_list_2 (rest, scm_list_1 (proc)))
			    : scm_cons (proc, rest)));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0,
            (SCM hook, SCM proc),
	    "Remove the procedure @var{proc} from the hook @var{hook}.  The\n"
	    "return value of this procedure is not specified.")
#define FUNC_NAME s_scm_remove_hook_x
{
  SCM_VALIDATE_HOOK (1, hook);
  SCM_SET_HOOK_PROCEDURES (hook,
			   scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0,
            (SCM hook),
	    "Remove all procedures from the hook @var{hook}.  The return\n"
	    "value of this procedure is not specified.")
#define FUNC_NAME s_scm_reset_hook_x
{
  SCM_VALIDATE_HOOK (1, hook);
  SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1,
            (SCM hook, SCM args),
	    "Apply all procedures from the hook @var{hook} to the arguments\n"
	    "@var{args}.  The order of the procedure application is first to\n"
	    "last.  The return value of this procedure is not specified.")
#define FUNC_NAME s_scm_run_hook
{
  SCM_VALIDATE_HOOK (1, hook);
  if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
    SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
		    scm_list_2 (hook, scm_from_int (SCM_HOOK_ARITY (hook))));
  scm_c_run_hook (hook, args);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_c_run_hook (SCM hook, SCM args)
{
  SCM procs = SCM_HOOK_PROCEDURES (hook);
  while (SCM_NIMP (procs))
    {
      scm_apply_0 (SCM_CAR (procs), args);
      procs = SCM_CDR (procs);
    }
}

SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0,
            (SCM hook),
	    "Convert the procedure list of @var{hook} to a list.")
#define FUNC_NAME s_scm_hook_to_list
{
  SCM_VALIDATE_HOOK (1, hook);
  return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
}
#undef FUNC_NAME

void
scm_init_hooks ()
{
  scm_tc16_hook = scm_make_smob_type ("hook", 0);
  scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
  scm_set_smob_print (scm_tc16_hook, hook_print);
#include "libguile/hooks.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_HOOKS_H
#define SCM_HOOKS_H

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

#include "libguile/__scm.h"

/*
 * C level hooks
 */

/*
 * The interface is designed for and- and or-type hooks which
 * both may want to indicate success/failure and return a result.
 */

typedef enum scm_t_c_hook_type {
  SCM_C_HOOK_NORMAL,
  SCM_C_HOOK_OR,
  SCM_C_HOOK_AND
} scm_t_c_hook_type;

typedef void  *(*scm_t_c_hook_function) (void *hook_data,
					 void *fn_data,
					 void *data);

typedef struct scm_t_c_hook_entry {
  struct scm_t_c_hook_entry *next;
  scm_t_c_hook_function func;
  void *data;
} scm_t_c_hook_entry;

typedef struct scm_t_c_hook {
  scm_t_c_hook_entry *first;
  scm_t_c_hook_type type;
  void *data;
} scm_t_c_hook;

SCM_API void scm_c_hook_init (scm_t_c_hook *hook,
			      void *hook_data,
			      scm_t_c_hook_type type);
SCM_API void scm_c_hook_add (scm_t_c_hook *hook,
			     scm_t_c_hook_function func,
			     void *fn_data,
			     int appendp);
SCM_API void scm_c_hook_remove (scm_t_c_hook *hook,
				scm_t_c_hook_function func,
				void *fn_data);
SCM_API void *scm_c_hook_run (scm_t_c_hook *hook, void *data);

/*
 * Scheme level hooks
 */

SCM_API scm_t_bits scm_tc16_hook;

#define SCM_HOOKP(x)			SCM_SMOB_PREDICATE (scm_tc16_hook, x)
#define SCM_HOOK_ARITY(hook)		SCM_SMOB_FLAGS (hook)
#define SCM_HOOK_PROCEDURES(hook)	SCM_SMOB_OBJECT (hook)
#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_SMOB_OBJECT ((hook), (procs))

SCM_API SCM scm_make_hook (SCM n_args);
SCM_API SCM scm_hook_p (SCM x);
SCM_API SCM scm_hook_empty_p (SCM hook);
SCM_API SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp);
SCM_API SCM scm_remove_hook_x (SCM hook, SCM thunk);
SCM_API SCM scm_reset_hook_x (SCM hook);
SCM_API SCM scm_run_hook (SCM hook, SCM args);
SCM_API void scm_c_run_hook (SCM hook, SCM args);
SCM_API SCM scm_hook_to_list (SCM hook);
SCM_API void scm_init_hooks (void);

#endif  /* SCM_HOOKS_H */

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

license: unknown


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

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

#include "libguile/_scm.h"
#include "libguile/feature.h"
#include "libguile/i18n.h"
#include "libguile/strings.h"
#include "libguile/dynwind.h"

#include "gettext.h"
#include <locale.h>

int
scm_i_to_lc_category (SCM category, int allow_lc_all)
{
  int c_category = scm_to_int (category);
  switch (c_category)
    {
#ifdef LC_CTYPE
    case LC_CTYPE:
#endif
#ifdef LC_NUMERIC
    case LC_NUMERIC:
#endif
#ifdef LC_COLLATE
    case LC_COLLATE:
#endif
#ifdef LC_TIME
    case LC_TIME:
#endif
#ifdef LC_MONETARY
    case LC_MONETARY:
#endif
#ifdef LC_MESSAGES
    case LC_MESSAGES:
#endif
#ifdef LC_PAPER
    case LC_PAPER:
#endif
#ifdef LC_NAME
    case LC_NAME:
#endif
#ifdef LC_ADDRESS
    case LC_ADDRESS:
#endif
#ifdef LC_TELEPHONE
    case LC_TELEPHONE:
#endif
#ifdef LC_MEASUREMENT
    case LC_MEASUREMENT:
#endif
#ifdef LC_IDENTIFICATION
    case LC_IDENTIFICATION:
#endif
      return c_category;
#ifdef LC_ALL
    case LC_ALL:
      if (allow_lc_all)
	return c_category;
#endif
    }
  scm_wrong_type_arg (0, 0, category);
}

SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0,
	    (SCM msgid, SCM domain, SCM category),
	    "Return the translation of @var{msgid} in the message domain "
	    "@var{domain}. @var{domain} is optional and defaults to the "
	    "domain set through (textdomain).  @var{category} is optional "
	    "and defaults to LC_MESSAGES.")
#define FUNC_NAME s_scm_gettext
{
  char *c_msgid;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  c_msgid = scm_to_locale_string (msgid);
  scm_dynwind_free (c_msgid);

  if (SCM_UNBNDP (domain))
    {
      /* 1 argument case.  */
      c_result = gettext (c_msgid);
    }
  else
    {
      char *c_domain;

      c_domain = scm_to_locale_string (domain);
      scm_dynwind_free (c_domain);

      if (SCM_UNBNDP (category))
	{
	  /* 2 argument case.  */
	  c_result = dgettext (c_domain, c_msgid);
	}
      else
	{
	  /* 3 argument case.  */
	  int c_category;

	  c_category = scm_i_to_lc_category (category, 0);
	  c_result = dcgettext (c_domain, c_msgid, c_category);
	}
    }

  if (c_result == c_msgid)
    result = msgid;
  else
    result = scm_from_locale_string (c_result);

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0,
	    (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category),
	    "Return the translation of @var{msgid}/@var{msgid_plural} in the "
	    "message domain @var{domain}, with the plural form being chosen "
	    "appropriately for the number @var{n}.  @var{domain} is optional "
	    "and defaults to the domain set through (textdomain). "
	    "@var{category} is optional and defaults to LC_MESSAGES.")
#define FUNC_NAME s_scm_ngettext
{
  char *c_msgid;
  char *c_msgid_plural;
  unsigned long c_n;
  const char *c_result;
  SCM result;

  scm_dynwind_begin (0);

  c_msgid = scm_to_locale_string (msgid);
  scm_dynwind_free (c_msgid);

  c_msgid_plural = scm_to_locale_string (msgid_plural);
  scm_dynwind_free (c_msgid_plural);

  c_n = scm_to_ulong (n);

  if (SCM_UNBNDP (domain))
    {
      /* 3 argument case.  */
      c_result = ngettext (c_msgid, c_msgid_plural, c_n);
    }
  else
    {
      char *c_domain;

      c_domain = scm_to_locale_string (domain);
      scm_dynwind_free (c_domain);

      if (SCM_UNBNDP (category))
	{
	  /* 4 argument case.  */
	  c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n);
	}
      else
	{
	  /* 5 argument case.  */
	  int c_category;

	  c_category = scm_i_to_lc_category (category, 0);
	  c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n,
				 c_category);
	}
    }

  if (c_result == c_msgid)
    result = msgid;
  else if (c_result == c_msgid_plural)
    result = msgid_plural;
  else
    result = scm_from_locale_string (c_result);

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0,
	    (SCM domainname),
	    "If optional parameter @var{domainname} is supplied, "
	    "set the textdomain.  "
	    "Return the textdomain.")
#define FUNC_NAME s_scm_textdomain
{
  char const *c_result;
  char *c_domain;
  SCM result = SCM_BOOL_F;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (domainname))
    c_domain = NULL;
  else
    {
      c_domain = scm_to_locale_string (domainname);
      scm_dynwind_free (c_domain);
    }

  c_result = textdomain (c_domain);
  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (domainname))
    SCM_SYSERROR;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0,
	    (SCM domainname, SCM directory),
	    "If optional parameter @var{directory} is supplied, "
	    "set message catalogs to directory @var{directory}.  "
	    "Return the directory bound to @var{domainname}.")
#define FUNC_NAME s_scm_bindtextdomain
{
  char *c_domain;
  char *c_directory;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (directory))
    c_directory = NULL;
  else
    {
      c_directory = scm_to_locale_string (directory);
      scm_dynwind_free (c_directory);
    }

  c_domain = scm_to_locale_string (domainname);
  scm_dynwind_free (c_domain);

  c_result = bindtextdomain (c_domain, c_directory);

  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (directory))
    SCM_SYSERROR;
  else
    result = SCM_BOOL_F;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0,
	    (SCM domainname, SCM encoding),
	    "If optional parameter @var{encoding} is supplied, "
	    "set encoding for message catalogs of @var{domainname}.  "
	    "Return the encoding of @var{domainname}.")
#define FUNC_NAME s_scm_bind_textdomain_codeset
{
  char *c_domain;
  char *c_encoding;
  char const *c_result;
  SCM result;

  scm_dynwind_begin (0);

  if (SCM_UNBNDP (encoding))
    c_encoding = NULL;
  else
    {
      c_encoding = scm_to_locale_string (encoding);
      scm_dynwind_free (c_encoding);
    }

  c_domain = scm_to_locale_string (domainname);
  scm_dynwind_free (c_domain);

  c_result = bind_textdomain_codeset (c_domain, c_encoding);

  if (c_result != NULL)
    result = scm_from_locale_string (c_result);
  else if (!SCM_UNBNDP (encoding))
    SCM_SYSERROR;
  else
    result = SCM_BOOL_F;

  scm_dynwind_end ();
  return result;
}
#undef FUNC_NAME

void
scm_init_i18n ()
{
  scm_add_feature ("i18n");
#include "libguile/i18n.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_I18N_H
#define SCM_I18N_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category);
SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category);
SCM_API SCM scm_textdomain (SCM domainname);
SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory);
SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding);

SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all);

SCM_API void scm_init_i18n (void);

#endif  /* SCM_I18N_H */

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


code:
/*
 * Copyright (c) 1983, 1990, 1993
 *	The Regents of the University of California.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *	This product includes software developed by the University of
 *	California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

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

#if defined(LIBC_SCCS) && !defined(lint)
static char sccsid[] = "@(#)inet_addr.c	8.1 (Berkeley) 6/17/93";
#endif /* LIBC_SCCS and not lint */

#include <ctype.h>

#ifdef __MINGW32__
/* Include for MinGW only.  Cygwin will have the latter. */
#include <winsock2.h>
#else
#include <sys/param.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#endif

#if 0

/*
 * Ascii internet address interpretation routine.
 * The value returned is in network order.
 */
u_long
inet_addr(const char *cp)
{
	struct in_addr val;

	if (inet_aton(cp, &val))
		return (val.s_addr);
	return (INADDR_NONE);
}

#endif

/* We provide this prototype to avoid compiler warnings.  If this ever
   conflicts with a declaration in a system header file, we'll find
   out, because we should include that header file here.  */
int inet_aton (const char *cp, struct in_addr *addr);

/*
 * Check whether "cp" is a valid ascii representation
 * of an Internet address and convert to a binary address.
 * Returns 1 if the address is valid, 0 if not.
 * This replaces inet_addr, the return value from which
 * cannot distinguish between failure and a local broadcast address.  */
int
inet_aton(const char *cp_arg, struct in_addr *addr)
{
	register unsigned long val;
	register int base, n;
	register unsigned char c;
	register unsigned const char *cp = (unsigned const char *) cp_arg;
	unsigned int parts[4];
	register unsigned int *pp = parts;

	for (;;) {
		/*
		 * Collect number up to ``.''.
		 * Values are specified as for C:
		 * 0x=hex, 0=octal, other=decimal.
		 */
		val = 0; base = 10;
		if (*cp == '0') {
			if (*++cp == 'x' || *cp == 'X')
				base = 16, cp++;
			else
				base = 8;
		}
		while ((c = *cp) != '\0') {
			if (isascii(c) && isdigit(c)) {
				val = (val * base) + (c - '0');
				cp++;
				continue;
			}
			if (base == 16 && isascii(c) && isxdigit(c)) {
				val = (val << 4) +
					(c + 10 - (islower(c) ? 'a' : 'A'));
				cp++;
				continue;
			}
			break;
		}
		if (*cp == '.') {
			/*
			 * Internet format:
			 *	a.b.c.d
			 *	a.b.c	(with c treated as 16-bits)
			 *	a.b	(with b treated as 24 bits)
			 */
			if (pp >= parts + 3 || val > 0xff)
				return (0);
			*pp++ = val, cp++;
		} else
			break;
	}
	/*
	 * Check for trailing characters.
	 */
	if (*cp && (!isascii(*cp) || !isspace(*cp)))
		return (0);
	/*
	 * Concoct the address according to
	 * the number of parts specified.
	 */
	n = pp - parts + 1;
	switch (n) {

	case 1:				/* a -- 32 bits */
		break;

	case 2:				/* a.b -- 8.24 bits */
		if (val > 0xffffff)
			return (0);
		val |= parts[0] << 24;
		break;

	case 3:				/* a.b.c -- 8.8.16 bits */
		if (val > 0xffff)
			return (0);
		val |= (parts[0] << 24) | (parts[1] << 16);
		break;

	case 4:				/* a.b.c.d -- 8.8.8.8 bits */
		if (val > 0xff)
			return (0);
		val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
		break;
	}
	if (addr)
		addr->s_addr = htonl(val);
	return (1);
}

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


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

/* Include the headers for just about everything.
   We call all their initialization functions.  */

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

#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <gmp.h>

#include "libguile/_scm.h"

/* Everybody has an init function.  */
#include "libguile/alist.h"
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/backtrace.h"
#include "libguile/boolean.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/debug.h"
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
#include "libguile/environments.h"
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/evalext.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
#include "libguile/i18n.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/lang.h"
#include "libguile/list.h"
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
#include "libguile/objects.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/ports.h"
#include "libguile/posix.h"
#ifdef HAVE_REGCOMP
#include "libguile/regex-posix.h"
#endif
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
#include "libguile/properties.h"
#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/rdelim.h"
#include "libguile/read.h"
#include "libguile/rw.h"
#include "libguile/scmsigs.h"
#include "libguile/script.h"
#include "libguile/simpos.h"
#include "libguile/smob.h"
#include "libguile/socket.h"
#include "libguile/sort.h"
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/stime.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/strorder.h"
#include "libguile/strports.h"
#include "libguile/struct.h"
#include "libguile/symbols.h"
#include "libguile/throw.h"
#include "libguile/unif.h"
#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
#include "libguile/extensions.h"
#include "libguile/srfi-4.h"
#include "libguile/discouraged.h"
#include "libguile/deprecated.h"

#include "libguile/init.h"

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

#if 0
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";

static void
fixconfig (char *s1, char *s2, int s)
{
  fputs (s1, stderr);
  fputs (s2, stderr);
  fputs ("\nin ", stderr);
  fputs (s ? "setjump" : "scmfig", stderr);
  fputs (".h and recompile scm\n", stderr);
  exit (1);
}

static void
check_config (void)
{
  size_t j;

  j = HEAP_SEG_SIZE;
  if (HEAP_SEG_SIZE != j)
    fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);

#if SCM_STACK_GROWS_UP
  if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
    fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
#else
  if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
    fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
#endif
}
#endif

/* initializing standard and current I/O ports */

typedef struct
{
  int fdes;
  char *mode;
  char *name;
} stream_body_data;

/* proc to be called in scope of exception handler stream_handler. */
static SCM
stream_body (void *data)
{
  stream_body_data *body_data = (stream_body_data *) data;
  SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
			       scm_from_locale_string (body_data->name));

  SCM_REVEALED (port) = 1;
  return port;
}

/* exception handler for stream_body.  */
static SCM
stream_handler (void *data SCM_UNUSED,
		SCM tag SCM_UNUSED,
		SCM throw_args SCM_UNUSED)
{
  return SCM_BOOL_F;
}

/* Convert a file descriptor to a port, using scm_fdes_to_port.
   - NAME is a C string, not a Guile string
   - set the revealed count for FILE's file descriptor to 1, so
   that fdes won't be closed when the port object is GC'd.
   - catch exceptions: allow Guile to be able to start up even
   if it has been handed bogus stdin/stdout/stderr.  replace the
   bad ports with void ports.  */
static SCM
scm_standard_stream_to_port (int fdes, char *mode, char *name)
{
  SCM port;
  stream_body_data body_data;

  body_data.fdes = fdes;
  body_data.mode = mode;
  body_data.name = name;
  port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
			     stream_handler, NULL);
  if (scm_is_false (port))
    port = scm_void_port (mode);
  return port;
}

/* Create standard ports from stdin, stdout, and stderr.  */
static void
scm_init_standard_ports ()
{
  /* From the SCSH manual:

     It can be useful to turn I/O buffering off in some cases, for
     example when an I/O stream is to be shared by multiple
     subprocesses.  For this reason, scsh allocates an unbuffered port
     for file descriptor 0 at start-up time.

     Because shells frequently share stdin with subprocesses, if the
     shell does buffered reads, it might ``steal'' input intended for
     a subprocess.  For this reason, all shells, including sh, csh,
     and scsh, read stdin unbuffered.  Applications that can tolerate
     buffered input on stdin can reset \ex{(current-input-port)} to
     block buffering for higher performance.  */

  scm_set_current_input_port
    (scm_standard_stream_to_port (0,
				  isatty (0) ? "r0" : "r",
				  "standard input"));
  scm_set_current_output_port
    (scm_standard_stream_to_port (1,
				  isatty (1) ? "w0" : "w",
				  "standard output"));
  scm_set_current_error_port
    (scm_standard_stream_to_port (2,
				  isatty (2) ? "w0" : "w",
				  "standard error"));
}

/* Loading the startup Scheme files.  */

/* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
   this is false.  The unexec code uses this, to keep ice_9 from being
   loaded into dumped guile executables.  */
int scm_ice_9_already_loaded = 0;

void
scm_load_startup_files ()
{
  /* We want a path only containing directories from GUILE_LOAD_PATH,
     SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
     file, so we do this before loading Ice-9.  */
  SCM init_path =
    scm_sys_search_load_path (scm_from_locale_string ("init.scm"));

  /* Load Ice-9.  */
  if (!scm_ice_9_already_loaded)
    {
      scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm"));

      /* Load the init.scm file.  */
      if (scm_is_true (init_path))
	scm_primitive_load (init_path);
    }
}

/* The main init code.  */

#ifdef _UNICOS
typedef int setjmp_type;
#else
typedef long setjmp_type;
#endif

/* All the data needed to invoke the main function.  */
struct main_func_closure
{
  /* the function to call */
  void (*main_func)(void *closure, int argc, char **argv);
  void *closure;		/* dummy data to pass it */
  int argc;
  char **argv;			/* the argument list it should receive */
};

static void *invoke_main_func(void *body_data);

/* Fire up the Guile Scheme interpreter.

   Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
   should do all the work of the program (initializing other packages,
   reading user input, etc.) before returning.  When MAIN_FUNC
   returns, call exit (0); this function never returns.  If you want
   some other exit value, MAIN_FUNC may call exit itself.

   scm_boot_guile arranges for program-arguments to return the strings
   given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
   call scm_set_program_arguments with the final list, so Scheme code
   will know which arguments have been processed.

   scm_boot_guile establishes a catch-all catch handler which prints
   an error message and exits the process.  This means that Guile
   exits in a coherent way when system errors occur and the user isn't
   prepared to handle it.  If the user doesn't like this behavior,
   they can establish their own universal catcher to shadow this one.

   Why must the caller do all the real work from MAIN_FUNC?  The
   garbage collector assumes that all local variables of type SCM will
   be above scm_boot_guile's stack frame on the stack.  If you try to
   manipulate SCM values after this function returns, it's the luck of
   the draw whether the GC will be able to find the objects you
   allocate.  So, scm_boot_guile function exits, rather than
   returning, to discourage people from making that mistake.  */

void
scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
{
  void *res;
  struct main_func_closure c;

  c.main_func = main_func;
  c.closure = closure;
  c.argc = argc;
  c.argv = argv;

  res = scm_with_guile (invoke_main_func, &c);

  /* If the caller doesn't want this, they should exit from main_func
     themselves.
  */
  if (res == NULL)
    exit (EXIT_FAILURE);
  else
    exit (0);
}

static void *
invoke_main_func (void *body_data)
{
  struct main_func_closure *closure = (struct main_func_closure *) body_data;

  scm_set_program_arguments (closure->argc, closure->argv, 0);
  (*closure->main_func) (closure->closure, closure->argc, closure->argv);

  scm_restore_signals ();

  /* This tick gives any pending
   * asyncs a chance to run.  This must be done after
   * the call to scm_restore_signals.
   */
  SCM_ASYNC_TICK;

  /* Indicate success by returning non-NULL.
   */
  return (void *)1;
}

scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
int scm_initialized_p = 0;

static void *
really_cleanup_for_exit (void *unused)
{
  scm_flush_all_ports ();
  return NULL;
}

static void
cleanup_for_exit ()
{
  /* This function might be called in non-guile mode, so we need to
     enter it temporarily.
  */
  scm_with_guile (really_cleanup_for_exit, NULL);
}

void
scm_i_init_guile (SCM_STACKITEM *base)
{
  if (scm_initialized_p)
    return;

  if (base == NULL)
    {
      fprintf (stderr, "cannot determine stack base!\n");
      abort ();
    }

  if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
    {
      fprintf (stderr,
               "GMP's mpz_t must fit into a double_cell,"
               "but doesn't seem to here.\n");
    }

  scm_storage_prehistory ();
  scm_threads_prehistory (base);
  scm_ports_prehistory ();
  scm_smob_prehistory ();
  scm_fluids_prehistory ();
  scm_hashtab_prehistory ();	/* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
  scm_debug_malloc_prehistory ();
#endif
  if (scm_init_storage ())        /* requires threads_prehistory,
				     smob_prehistory and
				     hashtab_prehistory */
    abort ();

  scm_struct_prehistory ();	  /* requires storage */
  scm_symbols_prehistory ();      /* requires storage */
  scm_init_subr_table ();
  scm_environments_prehistory (); /* requires storage */
  scm_modules_prehistory ();      /* requires storage and hash tables */
  scm_init_variable ();           /* all bindings need variables */
  scm_init_continuations ();
  scm_init_root ();		  /* requires continuations */
  scm_init_threads ();            /* requires fluids */
  scm_init_gsubr ();
  scm_init_thread_procs ();       /* requires gsubrs */
  scm_init_procprop ();
  scm_init_environments ();
  scm_init_alist ();
  scm_init_arbiters ();
  scm_init_async ();
  scm_init_boolean ();
  scm_init_chars ();
#ifdef GUILE_DEBUG_MALLOC
  scm_init_debug_malloc ();
#endif
  scm_init_dynwind ();
  scm_init_eq ();
  scm_init_error ();
#if 0
  /* See futures.h for a comment why futures are not enabled.
   */
  scm_init_futures ();
#endif
  scm_init_fluids ();
  scm_init_feature ();          /* Requires fluids */
  scm_init_backtrace ();	/* Requires fluids */
  scm_init_fports ();
  scm_init_strports ();
  scm_init_gdbint ();           /* Requires strports */
  scm_init_hash ();
  scm_init_hashtab ();
  scm_init_deprecation ();      /* Requires hashtabs */
  scm_init_objprop ();
  scm_init_properties ();
  scm_init_hooks ();            /* Requires smob_prehistory */
  scm_init_gc ();		/* Requires hooks, async */
  scm_init_i18n ();
  scm_init_ioext ();
  scm_init_keywords ();
  scm_init_list ();
  scm_init_macros ();
  scm_init_mallocs ();
  scm_init_modules ();
  scm_init_numbers ();
  scm_init_options ();
  scm_init_pairs ();
  scm_init_ports ();
#ifdef HAVE_POSIX
  scm_init_filesys ();
  scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
  scm_init_regex_posix ();
#endif
  scm_init_procs ();
  scm_init_scmsigs ();
#ifdef HAVE_NETWORKING
  scm_init_net_db ();
  scm_init_socket ();
#endif
  scm_init_sort ();
  scm_init_srcprop ();
  scm_init_stackchk ();
  scm_init_strings ();
  scm_init_struct ();   /* Requires strings */
  scm_init_stacks ();   /* Requires strings, struct */
  scm_init_symbols ();
  scm_init_values ();   /* Requires struct */
  scm_init_load ();     /* Requires strings */
  scm_init_objects ();	/* Requires struct */
  scm_init_print ();	/* Requires strings, struct */
  scm_init_read ();
  scm_init_stime ();
  scm_init_strorder ();
  scm_init_srfi_13 ();
  scm_init_srfi_14 ();
  scm_init_throw ();
  scm_init_vectors ();
  scm_init_version ();
  scm_init_weaks ();
  scm_init_guardians ();
  scm_init_vports ();
  scm_init_eval ();
  scm_init_evalext ();
  scm_init_debug ();	/* Requires macro smobs */
  scm_init_random ();
  scm_init_ramap ();
  scm_init_unif ();
  scm_init_simpos ();
  scm_init_load_path ();
  scm_init_standard_ports ();  /* Requires fports */
  scm_init_dynamic_linking ();
#if SCM_ENABLE_ELISP
  scm_init_lang ();
#endif /* SCM_ENABLE_ELISP */
  scm_init_script ();
  scm_init_srfi_4 ();

  scm_init_goops ();

#if SCM_ENABLE_DISCOURAGED == 1
  scm_i_init_discouraged ();
#endif

#if SCM_ENABLE_DEPRECATED == 1
  scm_i_init_deprecated ();
#endif

  scm_init_threads_default_dynamic_state ();

  scm_initialized_p = 1;

#ifdef STACK_CHECKING
  scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif

  scm_init_rdelim ();
  scm_init_rw ();
  scm_init_extensions ();

  atexit (cleanup_for_exit);
  scm_load_startup_files ();
}

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


code:
/* classes: h_files */

#ifndef SCM_INIT_H
#define SCM_INIT_H

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

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

SCM_API scm_i_pthread_mutex_t scm_i_init_mutex;
SCM_API int scm_initialized_p;

SCM_API void scm_init_guile (void);

SCM_API void scm_boot_guile (int argc, char **argv,
			     void (*main_func) (void *closure,
						int argc,
						char **argv),
			     void *closure);

SCM_API void scm_i_init_guile (SCM_STACKITEM *base);

SCM_API void scm_load_startup_files (void);

#endif  /* SCM_INIT_H */

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


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

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

#define SCM_INLINE_C_INCLUDING_INLINE_H 1
#include "libguile/inline.h"


code:
/* classes: h_files */

#ifndef SCM_INLINE_H
#define SCM_INLINE_H

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

/* This file is for inline functions.  On platforms that don't support
   inlining functions, they are turned into ordinary functions.  See
   "inline.c".
*/

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

#include "libguile/__scm.h"

#include "libguile/pairs.h"
#include "libguile/gc.h"
#include "libguile/threads.h"
#include "libguile/unif.h"
#include "libguile/ports.h"
#include "libguile/error.h"

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H

/* GCC has `__inline__' in all modes, including strict ansi.  GCC 4.3 and
   above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
   unless `-fgnu89-inline' is used.  Here we want GNU "extern inline"
   semantics, hence the `__gnu_inline__' attribute, in accordance with:
   http://gcc.gnu.org/gcc-4.3/porting_to.html .

   With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
   semantics are not supported), but a warning is issued in C99 mode if
   `__gnu_inline__' is not used.

   Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
   C99 mode and doesn't define `__GNUC_STDC_INLINE__'.  Fall back to "static
   inline" in that case.  */

# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
#  define SCM_C_USE_EXTERN_INLINE 1
#  if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
#   define SCM_C_EXTERN_INLINE					\
           extern __inline__ __attribute__ ((__gnu_inline__))
#  else
#   define SCM_C_EXTERN_INLINE extern __inline__
#  endif
# elif (defined SCM_C_INLINE)
#  define SCM_C_EXTERN_INLINE static SCM_C_INLINE
# endif

#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */

#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
    || (defined SCM_C_USE_EXTERN_INLINE)

/* The `extern' declarations.  They should only appear when used from
   "inline.c", when `inline' is not supported at all or when "extern inline"
   is used.  */

SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
			     scm_t_bits ccr, scm_t_bits cdr);

SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);

SCM_API int scm_is_pair (SCM x);

SCM_API int scm_getc (SCM port);
SCM_API void scm_putc (char c, SCM port);
SCM_API void scm_puts (const char *str_data, SCM port);

#endif

#if defined SCM_C_EXTERN_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H
/* either inlining, or being included from inline.c.  We use (and
   repeat) this long #if test here and below so that we don't have to
   introduce any extraneous symbols into the public namespace.  We
   only need SCM_C_INLINE to be seen publically . */

extern unsigned scm_newcell2_count;
extern unsigned scm_newcell_count;

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
  SCM z;
#ifdef __MINGW32__
  SCM *freelist = SCM_FREELIST_LOC (*scm_i_freelist_ptr);
#else
  SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
#endif

  if (scm_is_null (*freelist))
#ifdef __MINGW32__
    z = scm_gc_for_newcell (scm_i_master_freelist_ptr, freelist);
#else
    z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
#endif
  else
    {
      z = *freelist;
      *freelist = SCM_FREE_CELL_CDR (*freelist);
    }

  /*
    We update scm_cells_allocated from this function. If we don't
    update this explicitly, we will have to walk a freelist somewhere
    later on, which seems a lot more expensive.
   */
  scm_cells_allocated += 1;

#if (SCM_DEBUG_CELL_ACCESSES == 1)
    if (scm_debug_cell_accesses_p)
      {
	if (SCM_GC_MARK_P (z))
	  {
	    fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
	    abort();
	  }
	else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell)
	  {
	    fprintf(stderr, "cell from freelist is not a free cell.\n");
	    abort();
	  }
      }

    /*
      Always set mark. Otherwise cells that are alloced before
      scm_debug_cell_accesses_p is toggled seem invalid.
    */
    SCM_SET_GC_MARK (z);

    /*
      TODO: figure out if this use of mark bits is valid with
      threading. What if another thread is doing GC at this point
      ... ?
     */

#endif

  /* Initialize the type slot last so that the cell is ignored by the
     GC until it is completely initialized.  This is only relevant
     when the GC can actually run during this code, which it can't
     since the GC only runs when all other threads are stopped.
  */
  SCM_GC_SET_CELL_WORD (z, 1, cdr);
  SCM_GC_SET_CELL_WORD (z, 0, car);

#if (SCM_DEBUG_CELL_ACCESSES == 1)
  if (scm_expensive_debug_cell_accesses_p )
    scm_i_expensive_validation_check (z);
#endif

  return z;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_double_cell (scm_t_bits car, scm_t_bits cbr,
		 scm_t_bits ccr, scm_t_bits cdr)
{
  SCM z;
#ifdef __MINGW32__
  SCM *freelist = SCM_FREELIST_LOC (*scm_i_freelist2_ptr);
#else
  SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2);
#endif

  if (scm_is_null (*freelist))
#ifdef __MINGW32__
    z = scm_gc_for_newcell (scm_i_master_freelist2_ptr, freelist);
#else
    z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist);
#endif
  else
    {
      z = *freelist;
      *freelist = SCM_FREE_CELL_CDR (*freelist);
    }

  scm_cells_allocated += 2;

  /* Initialize the type slot last so that the cell is ignored by the
     GC until it is completely initialized.  This is only relevant
     when the GC can actually run during this code, which it can't
     since the GC only runs when all other threads are stopped.
  */
  SCM_GC_SET_CELL_WORD (z, 1, cbr);
  SCM_GC_SET_CELL_WORD (z, 2, ccr);
  SCM_GC_SET_CELL_WORD (z, 3, cdr);
  SCM_GC_SET_CELL_WORD (z, 0, car);

#if (SCM_DEBUG_CELL_ACCESSES == 1)
  if (scm_debug_cell_accesses_p)
    {
      if (SCM_GC_MARK_P (z))
	{
	  fprintf(stderr,
		  "scm_double_cell tried to allocate a marked cell.\n");
	  abort();
	}
    }

  /* see above. */
  SCM_SET_GC_MARK (z);

#endif

  /* When this function is inlined, it's possible that the last
     SCM_GC_SET_CELL_WORD above will be adjacent to a following
     initialization of z.  E.g., it occurred in scm_make_real.  GCC
     from around version 3 (e.g., certainly 3.2) began taking
     advantage of strict C aliasing rules which say that it's OK to
     interchange the initialization above and the one below when the
     pointer types appear to differ sufficiently.  We don't want that,
     of course.  GCC allows this behaviour to be disabled with the
     -fno-strict-aliasing option, but would also need to be supplied
     by Guile users.  Instead, the following statements prevent the
     reordering.
   */
#ifdef __GNUC__
  __asm__ volatile ("" : : : "memory");
#else
  /* portable version, just in case any other compiler does the same
     thing.  */
  scm_remember_upto_here_1 (z);
#endif

  return z;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
  return h->ref (h, p);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
  h->set (h, p, v);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
int
scm_is_pair (SCM x)
{
  /* The following "workaround_for_gcc_295" avoids bad code generated by
     i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).

     Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
     the fetch of the tag word from x is done before confirming it's a
     non-immediate (SCM_NIMP).  Needless to say that bombs badly if x is a
     immediate.  This was seen to afflict scm_srfi1_split_at and something
     deep in the bowels of ceval().  In both cases segvs resulted from
     deferencing a random immediate value.  srfi-1.test exposes the problem
     through a short list, the immediate being SCM_EOL in that case.
     Something in syntax.test exposed the ceval() problem.

     Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
     problem, without even using that variable.  The "w=w" is just to
     prevent a warning about it being unused.
     */
#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
  volatile SCM workaround_for_gcc_295 = x;
  workaround_for_gcc_295 = workaround_for_gcc_295;
#endif

  return SCM_I_CONSP (x);
}

/* Port I/O.  */

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
int
scm_getc (SCM port)
{
  int c;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->rw_active == SCM_PORT_WRITE)
    /* may be marginally faster than calling scm_flush.  */
    scm_ptobs[SCM_PTOBNUM (port)].flush (port);

  if (pt->rw_random)
    pt->rw_active = SCM_PORT_READ;

  if (pt->read_pos >= pt->read_end)
    {
      if (scm_fill_input (port) == EOF)
	return EOF;
    }

  c = *(pt->read_pos++);

  switch (c)
    {
      case '\a':
        break;
      case '\b':
        SCM_DECCOL (port);
        break;
      case '\n':
        SCM_INCLINE (port);
        break;
      case '\r':
        SCM_ZEROCOL (port);
        break;
      case '\t':
        SCM_TABCOL (port);
        break;
      default:
        SCM_INCCOL (port);
        break;
    }

  return c;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_putc (char c, SCM port)
{
  SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
  scm_lfwrite (&c, 1, port);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_puts (const char *s, SCM port)
{
  SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
  scm_lfwrite (s, strlen (s), port);
}

#endif
#endif


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

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

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

#include "libguile/_scm.h"
#include "libguile/ioext.h"
#include "libguile/fports.h"
#include "libguile/feature.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/dynwind.h"

#include <fcntl.h>

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

SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
            (SCM fd_port),
	    "Return an integer representing the current position of\n"
	    "@var{fd/port}, measured from the beginning.  Equivalent to:\n"
	    "\n"
	    "@lisp\n"
	    "(seek port 0 SEEK_CUR)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_ftell
{
  return scm_seek (fd_port, SCM_INUM0, scm_from_int (SEEK_CUR));
}
#undef FUNC_NAME

SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
            (SCM old, SCM new),
	    "This procedure takes two ports and duplicates the underlying file\n"
	    "descriptor from @var{old-port} into @var{new-port}.  The\n"
	    "current file descriptor in @var{new-port} will be closed.\n"
	    "After the redirection the two ports will share a file position\n"
	    "and file status flags.\n\n"
	    "The return value is unspecified.\n\n"
	    "Unexpected behaviour can result if both ports are subsequently used\n"
	    "and the original and/or duplicate ports are buffered.\n\n"
	    "This procedure does not have any side effects on other ports or\n"
	    "revealed counts.")
#define FUNC_NAME s_scm_redirect_port
{
  int ans, oldfd, newfd;
  scm_t_fport *fp;

  old = SCM_COERCE_OUTPORT (old);
  new = SCM_COERCE_OUTPORT (new);

  SCM_VALIDATE_OPFPORT (1, old);
  SCM_VALIDATE_OPFPORT (2, new);
  oldfd = SCM_FPORT_FDES (old);
  fp = SCM_FSTREAM (new);
  newfd = fp->fdes;
  if (oldfd != newfd)
    {
      scm_t_port *pt = SCM_PTAB_ENTRY (new);
      scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
      scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];

      /* must flush to old fdes.  */
      if (pt->rw_active == SCM_PORT_WRITE)
	ptob->flush (new);
      else if (pt->rw_active == SCM_PORT_READ)
	scm_end_input (new);
      ans = dup2 (oldfd, newfd);
      if (ans == -1)
	SCM_SYSERROR;
      pt->rw_random = old_pt->rw_random;
      /* continue using existing buffers, even if inappropriate.  */
    }
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
            (SCM fd_or_port, SCM fd),
	    "Return a new integer file descriptor referring to the open file\n"
	    "designated by @var{fd_or_port}, which must be either an open\n"
	    "file port or a file descriptor.")
#define FUNC_NAME s_scm_dup_to_fdes
{
  int oldfd, newfd, rv;

  fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);

  if (scm_is_integer (fd_or_port))
    oldfd = scm_to_int (fd_or_port);
  else
    {
      SCM_VALIDATE_OPFPORT (1, fd_or_port);
      oldfd = SCM_FPORT_FDES (fd_or_port);
    }

  if (SCM_UNBNDP (fd))
    {
      newfd = dup (oldfd);
      if (newfd == -1)
	SCM_SYSERROR;
      fd = scm_from_int (newfd);
    }
  else
    {
      newfd = scm_to_int (fd);
      if (oldfd != newfd)
	{
	  scm_evict_ports (newfd);	/* see scsh manual.  */
	  rv = dup2 (oldfd, newfd);
	  if (rv == -1)
	    SCM_SYSERROR;
	}
    }
  return fd;
}
#undef FUNC_NAME

SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
            (SCM oldfd, SCM newfd),
	    "A simple wrapper for the @code{dup2} system call.\n"
	    "Copies the file descriptor @var{oldfd} to descriptor\n"
	    "number @var{newfd}, replacing the previous meaning\n"
	    "of @var{newfd}.  Both @var{oldfd} and @var{newfd} must\n"
	    "be integers.\n"
	    "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
	    "is made to move away ports which are using @var{newfd}.\n"
	    "The return value is unspecified.")
#define FUNC_NAME s_scm_dup2
{
  int c_oldfd;
  int c_newfd;
  int rv;

  c_oldfd = scm_to_int (oldfd);
  c_newfd = scm_to_int (newfd);
  rv = dup2 (c_oldfd, c_newfd);
  if (rv == -1)
    SCM_SYSERROR;
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
            (SCM port),
	    "Return the integer file descriptor underlying @var{port}.  Does\n"
	    "not change its revealed count.")
#define FUNC_NAME s_scm_fileno
{
  port = SCM_COERCE_OUTPORT (port);
  SCM_VALIDATE_OPFPORT (1, port);
  return scm_from_int (SCM_FPORT_FDES (port));
}
#undef FUNC_NAME

/* GJB:FIXME:: why does this not throw
   an error if the arg is not a port?
   This proc as is would be better names isattyport?
   if it is not going to assume that the arg is a port

   [cmm] I don't see any problem with the above.  why should a type
   predicate assume _anything_ about its argument?
*/
SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
            (SCM port),
	    "Return @code{#t} if @var{port} is using a serial non--file\n"
	    "device, otherwise @code{#f}.")
#define FUNC_NAME s_scm_isatty_p
{
  int rv;

  port = SCM_COERCE_OUTPORT (port);

  if (!SCM_OPFPORTP (port))
    return SCM_BOOL_F;

  rv = isatty (SCM_FPORT_FDES (port));
  return  scm_from_bool(rv);
}
#undef FUNC_NAME

SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
            (SCM fdes, SCM modes),
	    "Return a new port based on the file descriptor @var{fdes}.\n"
	    "Modes are given by the string @var{modes}.  The revealed count\n"
	    "of the port is initialized to zero.  The modes string is the\n"
	    "same as that accepted by @ref{File Ports, open-file}.")
#define FUNC_NAME s_scm_fdopen
{
  return scm_i_fdes_to_port (scm_to_int (fdes),
			     scm_i_mode_bits (modes), SCM_BOOL_F);
}
#undef FUNC_NAME

/* Move a port's underlying file descriptor to a given value.
 * Returns  #f if fdes is already the given value.
 *          #t if fdes moved.
 * MOVE->FDES is implemented in Scheme and calls this primitive.
 */
SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
            (SCM port, SCM fd),
	    "Moves the underlying file descriptor for @var{port} to the integer\n"
	    "value @var{fdes} without changing the revealed count of @var{port}.\n"
	    "Any other ports already using this descriptor will be automatically\n"
	    "shifted to new descriptors and their revealed counts reset to zero.\n"
	    "The return value is @code{#f} if the file descriptor already had the\n"
	    "required value or @code{#t} if it was moved.")
#define FUNC_NAME s_scm_primitive_move_to_fdes
{
  scm_t_fport *stream;
  int old_fd;
  int new_fd;
  int rv;

  port = SCM_COERCE_OUTPORT (port);

  SCM_VALIDATE_OPFPORT (1, port);
  stream = SCM_FSTREAM (port);
  old_fd = stream->fdes;
  new_fd = scm_to_int (fd);
  if  (old_fd == new_fd)
    {
      return SCM_BOOL_F;
    }
  scm_evict_ports (new_fd);
  rv = dup2 (old_fd, new_fd);
  if (rv == -1)
    SCM_SYSERROR;
  stream->fdes = new_fd;
  SCM_SYSCALL (close (old_fd));
  return SCM_BOOL_T;
}
#undef FUNC_NAME

/* Return a list of ports using a given file descriptor.  */
SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
           (SCM fd),
	    "Return a list of existing ports which have @var{fdes} as an\n"
	    "underlying file descriptor, without changing their revealed\n"
	    "counts.")
#define FUNC_NAME s_scm_fdes_to_ports
{
  SCM result = SCM_EOL;
  int int_fd;
  long i;

  int_fd = scm_to_int (fd);

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
  for (i = 0; i < scm_i_port_table_size; i++)
    {
      if (SCM_OPFPORTP (scm_i_port_table[i]->port)
	  && ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
	result = scm_cons (scm_i_port_table[i]->port, result);
    }
  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
  return result;
}
#undef FUNC_NAME

void
scm_init_ioext ()
{
  scm_add_feature ("i/o-extensions");

#include "libguile/ioext.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_IOEXT_H
#define SCM_IOEXT_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_ftell (SCM object);
SCM_API SCM scm_redirect_port (SCM into_pt, SCM from_pt);
SCM_API SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd);
SCM_API SCM scm_dup2 (SCM oldfd, SCM newfd);
SCM_API SCM scm_fileno (SCM port);
SCM_API SCM scm_isatty_p (SCM port);
SCM_API SCM scm_fdopen (SCM fdes, SCM modes);
SCM_API SCM scm_primitive_move_to_fdes (SCM port, SCM fd);
SCM_API SCM scm_fdes_to_ports (SCM fd);
SCM_API void scm_init_ioext (void);

#endif  /* SCM_IOEXT_H */

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


code:
/* classes: h_files */

#ifndef SCM_ISELECT_H
#define SCM_ISELECT_H

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

#include "libguile/__scm.h"

/* Needed for FD_SET on some systems.  */
#include <sys/types.h>

#if SCM_HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif

#if SCM_HAVE_WINSOCK2_H
# include <winsock2.h>
#endif

#ifdef FD_SET

#define SELECT_TYPE fd_set
#if defined(__INTERIX) && FD_SETSIZE == 4096
/* Interix defines FD_SETSIZE 4096 but select rejects that. */
#define SELECT_SET_SIZE 1024
#else
#define SELECT_SET_SIZE FD_SETSIZE
#endif

#else /* no FD_SET */

/* Define the macros to access a single-int bitmap of descriptors.  */
#define SELECT_SET_SIZE 32
#define SELECT_TYPE int
#define FD_SET(n, p) (*(p) |= (1 << (n)))
#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
#define FD_ISSET(n, p) (*(p) & (1 << (n)))
#define FD_ZERO(p) (*(p) = 0)

#endif /* no FD_SET */

SCM_API int scm_std_select (int fds,
			    SELECT_TYPE *rfds,
			    SELECT_TYPE *wfds,
			    SELECT_TYPE *efds,
			    struct timeval *timeout);

#endif  /* SCM_ISELECT_H */

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


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

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

#include <string.h>

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/hashtab.h"

#include "libguile/validate.h"
#include "libguile/keywords.h"
#include "libguile/strings.h"

scm_t_bits scm_tc16_keyword;

#define KEYWORDP(X)	(SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
#define KEYWORDSYM(X)	(SCM_SMOB_OBJECT (X))

static int
keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#:", port);
  scm_display (KEYWORDSYM (exp), port);
  return 1;
}

SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
            (SCM obj),
	    "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_keyword_p
{
  return scm_from_bool (KEYWORDP (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
	    (SCM symbol),
	    "Return the keyword with the same name as @var{symbol}.")
#define FUNC_NAME s_scm_symbol_to_keyword
{
  SCM keyword;

  SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");

  SCM_CRITICAL_SECTION_START;
  /* njrev: NEWSMOB and hashq_set_x can raise errors */
  keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
  if (scm_is_false (keyword))
    {
      SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
      scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
    }
  SCM_CRITICAL_SECTION_END;
  return keyword;
}
#undef FUNC_NAME

SCM_DEFINE (scm_keyword_to_symbol, "keyword->symbol", 1, 0, 0,
	    (SCM keyword),
	    "Return the symbol with the same name as @var{keyword}.")
#define FUNC_NAME s_scm_keyword_to_symbol
{
  scm_assert_smob_type (scm_tc16_keyword, keyword);
  return KEYWORDSYM (keyword);
}
#undef FUNC_NAME

int
scm_is_keyword (SCM val)
{
  return KEYWORDP (val);
}

SCM
scm_from_locale_keyword (const char *str)
{
  return scm_symbol_to_keyword (scm_from_locale_symbol (str));
}

SCM
scm_from_locale_keywordn (const char *str, size_t len)
{
  return scm_symbol_to_keyword (scm_from_locale_symboln (str, len));
}

/* njrev: critical sections reviewed so far up to here */
void
scm_init_keywords ()
{
  scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
  scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
  scm_set_smob_print (scm_tc16_keyword, keyword_print);

  scm_keyword_obarray = scm_c_make_hash_table (0);
#include "libguile/keywords.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_KEYWORDS_H
#define SCM_KEYWORDS_H

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

#include "libguile/__scm.h"

SCM_API scm_t_bits scm_tc16_keyword;

SCM_API SCM scm_keyword_p (SCM obj);
SCM_API SCM scm_symbol_to_keyword (SCM symbol);
SCM_API SCM scm_keyword_to_symbol (SCM keyword);

SCM_API int scm_is_keyword (SCM val);
SCM_API SCM scm_from_locale_keyword (const char *str);
SCM_API SCM scm_from_locale_keywordn (const char *str, size_t len);

SCM_API void scm_init_keywords (void);

#endif  /* SCM_KEYWORDS_H */

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


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

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

#include "libguile/_scm.h"

#include "libguile/eval.h"
#include "libguile/macros.h"
#include "libguile/root.h"

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

/* {Multi-language support}
 */

#if SCM_ENABLE_ELISP

void
scm_init_lang ()
{
#include "libguile/lang.x"

  scm_c_define ("%nil", SCM_ELISP_NIL);
}

#endif /* SCM_ENABLE_ELISP */

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


code:
/* classes: h_files */

#ifndef SCM_LANG_H
#define SCM_LANG_H

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

#include "libguile/__scm.h"

#if SCM_ENABLE_ELISP

#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))

SCM_API void scm_init_lang (void);

#else  /* ! SCM_ENABLE_ELISP */

#define SCM_NILP(x) 0

#endif /* ! SCM_ENABLE_ELISP */

#define SCM_NULL_OR_NIL_P(x) (scm_is_null (x) || SCM_NILP (x))

#endif  /* SCM_LANG_H */

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


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

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

#include "libguile/_scm.h"
#include "libguile/eq.h"
#include "libguile/lang.h"

#include "libguile/validate.h"
#include "libguile/list.h"
#include "libguile/eval.h"

#include <stdarg.h>

/* creating lists */

#define SCM_I_CONS(cell, x, y)			\
do {						\
  cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y);			\
} while (0)

SCM
scm_list_1 (SCM e1)
{
  SCM c1;
  SCM_I_CONS (c1, e1, SCM_EOL);
  return c1;
}

SCM
scm_list_2 (SCM e1, SCM e2)
{
  SCM c1, c2;
  SCM_I_CONS (c2, e2, SCM_EOL);
  SCM_I_CONS (c1, e1, c2);
  return c1;
}

SCM
scm_list_3 (SCM e1, SCM e2, SCM e3)
{
  SCM c1, c2, c3;
  SCM_I_CONS (c3, e3, SCM_EOL);
  SCM_I_CONS (c2, e2, c3);
  SCM_I_CONS (c1, e1, c2);
  return c1;
}

SCM
scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
{
  return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
}

SCM
scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
{
  return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
}

SCM
scm_list_n (SCM elt, ...)
{
  va_list foo;
  SCM answer = SCM_EOL;
  SCM *pos = &answer;

  va_start (foo, elt);
  while (! SCM_UNBNDP (elt))
    {
#if (SCM_DEBUG_CELL_ACCESSES == 1)
      if (SCM_NIMP (elt))
	SCM_VALIDATE_CELL(elt, 0);
#endif
      *pos = scm_cons (elt, SCM_EOL);
      pos = SCM_CDRLOC (*pos);
      elt = va_arg (foo, SCM);
    }
  va_end (foo);
  return answer;
}

SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
            (SCM n, SCM init),
	    "Create a list containing of @var{n} elements, where each\n"
	    "element is initialized to @var{init}.  @var{init} defaults to\n"
	    "the empty list @code{()} if not given.")
#define FUNC_NAME s_scm_make_list
{
  unsigned nn = scm_to_uint (n);
  unsigned i;
  SCM ret = SCM_EOL;

  if (SCM_UNBNDP (init))
    init = SCM_EOL;

  for (i = 0; i < nn; i++)
    ret = scm_cons (init, ret);
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
            (SCM arg, SCM rest),
	    "Like @code{list}, but the last arg provides the tail of the\n"
	    "constructed list, returning @code{(cons @var{arg1} (cons\n"
	    "@var{arg2} (cons @dots{} @var{argn})))}.  Requires at least one\n"
	    "argument.  If given one argument, that argument is returned as\n"
	    "result.  This function is called @code{list*} in some other\n"
	    "Schemes and in Common LISP.")
#define FUNC_NAME s_scm_cons_star
{
  SCM ret = SCM_EOL;
  SCM *p = &ret;

  SCM_VALIDATE_REST_ARGUMENT (rest);

  for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
    {
      *p = scm_cons (arg, SCM_EOL);
      p = SCM_CDRLOC (*p);
      arg = SCM_CAR (rest);
    }

  *p = arg;
  return ret;
}
#undef FUNC_NAME

/* general questions about lists --- null?, list?, length, etc.  */

SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
           (SCM x),
	    "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
#define FUNC_NAME s_scm_null_p
{
  return scm_from_bool (SCM_NULL_OR_NIL_P (x));
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
           (SCM x),
	    "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
#define FUNC_NAME s_scm_list_p
{
  return scm_from_bool (scm_ilength (x) >= 0);
}
#undef FUNC_NAME

/* Return the length of SX, or -1 if it's not a proper list.
   This uses the "tortoise and hare" algorithm to detect "infinitely
   long" lists (i.e. lists with cycles in their cdrs), and returns -1
   if it does find one.  */
long
scm_ilength(SCM sx)
{
  long i = 0;
  SCM tortoise = sx;
  SCM hare = sx;

  do {
    if (SCM_NULL_OR_NIL_P(hare)) return i;
    if (!scm_is_pair (hare)) return -1;
    hare = SCM_CDR(hare);
    i++;
    if (SCM_NULL_OR_NIL_P(hare)) return i;
    if (!scm_is_pair (hare)) return -1;
    hare = SCM_CDR(hare);
    i++;
    /* For every two steps the hare takes, the tortoise takes one.  */
    tortoise = SCM_CDR(tortoise);
  }
  while (!scm_is_eq (hare, tortoise));

  /* If the tortoise ever catches the hare, then the list must contain
     a cycle.  */
  return -1;
}

SCM_DEFINE (scm_length, "length", 1, 0, 0,
           (SCM lst),
	    "Return the number of elements in list @var{lst}.")
#define FUNC_NAME s_scm_length
{
  long i;
  SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
  return scm_from_long (i);
}
#undef FUNC_NAME

/* appending lists */

SCM_DEFINE (scm_append, "append", 0, 0, 1,
            (SCM args),
	    "Return a list consisting of the elements the lists passed as\n"
	    "arguments.\n"
	    "@lisp\n"
	    "(append '(x) '(y))          @result{}  (x y)\n"
	    "(append '(a) '(b c d))      @result{}  (a b c d)\n"
	    "(append '(a (b)) '((c)))    @result{}  (a (b) (c))\n"
	    "@end lisp\n"
	    "The resulting list is always newly allocated, except that it\n"
	    "shares structure with the last list argument.  The last\n"
	    "argument may actually be any object; an improper list results\n"
	    "if the last argument is not a proper list.\n"
	    "@lisp\n"
	    "(append '(a b) '(c . d))    @result{}  (a b c . d)\n"
	    "(append '() 'a)             @result{}  a\n"
	    "@end lisp")
#define FUNC_NAME s_scm_append
{
  SCM_VALIDATE_REST_ARGUMENT (args);
  if (scm_is_null (args)) {
    return SCM_EOL;
  } else {
    SCM res = SCM_EOL;
    SCM *lloc = &res;
    SCM arg = SCM_CAR (args);
    int argnum = 1;
    args = SCM_CDR (args);
    while (!scm_is_null (args)) {
      while (scm_is_pair (arg)) {
	*lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
	lloc = SCM_CDRLOC (*lloc);
	arg = SCM_CDR (arg);
      }
      SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
      arg = SCM_CAR (args);
      args = SCM_CDR (args);
      argnum++;
    };
    *lloc = arg;
    return res;
  }
}
#undef FUNC_NAME

SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
            (SCM lists),
	    "A destructive version of @code{append} (@pxref{Pairs and\n"
	    "Lists,,,r5rs, The Revised^5 Report on Scheme}).  The cdr field\n"
	    "of each list's final pair is changed to point to the head of\n"
	    "the next list, so no consing is performed.  Return\n"
	    "the mutated list.")
#define FUNC_NAME s_scm_append_x
{
  SCM ret, *loc;
  SCM_VALIDATE_REST_ARGUMENT (lists);

  if (scm_is_null (lists))
    return SCM_EOL;

  loc = &ret;
  for (;;)
    {
      SCM arg = SCM_CAR (lists);
      *loc = arg;

      lists = SCM_CDR (lists);
      if (scm_is_null (lists))
        return ret;

      if (!SCM_NULL_OR_NIL_P (arg))
        {
          SCM_VALIDATE_CONS (SCM_ARG1, arg);
          loc = SCM_CDRLOC (scm_last_pair (arg));
        }
    }
}
#undef FUNC_NAME

SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
           (SCM lst),
	    "Return the last pair in @var{lst}, signalling an error if\n"
	    "@var{lst} is circular.")
#define FUNC_NAME s_scm_last_pair
{
  SCM tortoise = lst;
  SCM hare = lst;

  if (SCM_NULL_OR_NIL_P (lst))
    return lst;

  SCM_VALIDATE_CONS (SCM_ARG1, lst);
  do {
    SCM ahead = SCM_CDR(hare);
    if (!scm_is_pair (ahead)) return hare;
    hare = ahead;
    ahead = SCM_CDR(hare);
    if (!scm_is_pair (ahead)) return hare;
    hare = ahead;
    tortoise = SCM_CDR(tortoise);
  }
  while (!scm_is_eq (hare, tortoise));
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME

/* reversing lists */

SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
            (SCM lst),
	    "Return a new list that contains the elements of @var{lst} but\n"
	    "in reverse order.")
#define FUNC_NAME s_scm_reverse
{
  SCM result = SCM_EOL;
  SCM tortoise = lst;
  SCM hare = lst;

  do {
      if (SCM_NULL_OR_NIL_P(hare)) return result;
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
      result = scm_cons (SCM_CAR (hare), result);
      hare = SCM_CDR (hare);
      if (SCM_NULL_OR_NIL_P(hare)) return result;
      SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
      result = scm_cons (SCM_CAR (hare), result);
      hare = SCM_CDR (hare);
      tortoise = SCM_CDR (tortoise);
    }
  while (!scm_is_eq (hare, tortoise));
  SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
}
#undef FUNC_NAME

SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
            (SCM lst, SCM new_tail),
	    "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
	    "The Revised^5 Report on Scheme}).  The cdr of each cell in @var{lst} is\n"
	    "modified to point to the previous list element.  Return the\n"
	    "reversed list.\n\n"
	    "Caveat: because the list is modified in place, the tail of the original\n"
	    "list now becomes its head, and the head of the original list now becomes\n"
	    "the tail.  Therefore, the @var{lst} symbol to which the head of the\n"
	    "original list was bound now points to the tail.  To ensure that the head\n"
	    "of the modified list is not lost, it is wise to save the return value of\n"
	    "@code{reverse!}")
#define FUNC_NAME s_scm_reverse_x
{
  SCM_VALIDATE_LIST (1, lst);
  if (SCM_UNBNDP (new_tail))
    new_tail = SCM_EOL;
  else
    SCM_VALIDATE_LIST (2, new_tail);

  while (!SCM_NULL_OR_NIL_P (lst))
    {
      SCM old_tail = SCM_CDR (lst);
      SCM_SETCDR (lst, new_tail);
      new_tail = lst;
      lst = old_tail;
    }
  return new_tail;
}
#undef FUNC_NAME

/* indexing lists by element number */

SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
	    (SCM list, SCM k),
	    "Return the @var{k}th element from @var{list}.")
#define FUNC_NAME s_scm_list_ref
{
  SCM lst = list;
  unsigned long int i;
  i = scm_to_ulong (k);
  while (scm_is_pair (lst)) {
    if (i == 0)
      return SCM_CAR (lst);
    else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
	    (SCM list, SCM k, SCM val),
	    "Set the @var{k}th element of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_set_x
{
  SCM lst = list;
  unsigned long int i = scm_to_ulong (k);
  while (scm_is_pair (lst)) {
    if (i == 0) {
      SCM_SETCAR (lst, val);
      return val;
    } else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);

SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
           (SCM lst, SCM k),
	    "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
	    "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
	    "The first element of the list is considered to be element 0.\n\n"
	    "@code{list-tail} and @code{list-cdr-ref} are identical.  It may help to\n"
	    "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
	    "or returning the results of cdring @var{k} times down @var{lst}.")
#define FUNC_NAME s_scm_list_tail
{
  size_t i = scm_to_size_t (k);
  while (i-- > 0) {
    SCM_VALIDATE_CONS (1, lst);
    lst = SCM_CDR(lst);
  }
  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
           (SCM list, SCM k, SCM val),
	    "Set the @var{k}th cdr of @var{list} to @var{val}.")
#define FUNC_NAME s_scm_list_cdr_set_x
{
  SCM lst = list;
  size_t i = scm_to_size_t (k);
  while (scm_is_pair (lst)) {
    if (i == 0) {
      SCM_SETCDR (lst, val);
      return val;
    } else {
      --i;
      lst = SCM_CDR (lst);
    }
  };
  if (SCM_NULL_OR_NIL_P (lst))
    SCM_OUT_OF_RANGE (2, k);
  else
    SCM_WRONG_TYPE_ARG (1, list);
}
#undef FUNC_NAME

/* copying lists, perhaps partially */

SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
           (SCM lst, SCM k),
	    "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
	    "return it.")
#define FUNC_NAME s_scm_list_head
{
  SCM answer;
  SCM * pos;
  size_t i = scm_to_size_t (k);

  answer = SCM_EOL;
  pos = &answer;
  while (i-- > 0)
    {
      SCM_VALIDATE_CONS (1, lst);
      *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
      pos = SCM_CDRLOC (*pos);
      lst = SCM_CDR(lst);
    }
  return answer;
}
#undef FUNC_NAME

/* Copy a list which is known to be finite.  The last pair may or may not have
 * a '() in its cdr.  That is, improper lists are accepted.  */
SCM
scm_i_finite_list_copy (SCM list)
{
  if (!scm_is_pair (list))
    {
      return list;
    }
  else
    {
      SCM tail;
      const SCM result = tail = scm_list_1 (SCM_CAR (list));
      list = SCM_CDR (list);
      while (scm_is_pair (list))
        {
          const SCM new_tail = scm_list_1 (SCM_CAR (list));
          SCM_SETCDR (tail, new_tail);
          tail = new_tail;
          list = SCM_CDR (list);
        }
      SCM_SETCDR (tail, list);

      return result;
    }
}

SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
            (SCM lst),
	    "Return a (newly-created) copy of @var{lst}.")
#define FUNC_NAME s_scm_list_copy
{
  SCM newlst;
  SCM * fill_here;
  SCM from_here;

  SCM_VALIDATE_LIST (1, lst);

  newlst = SCM_EOL;
  fill_here = &newlst;
  from_here = lst;

  while (scm_is_pair (from_here))
    {
      SCM c;
      c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
      *fill_here = c;
      fill_here = SCM_CDRLOC (c);
      from_here = SCM_CDR (from_here);
    }
  return newlst;
}
#undef FUNC_NAME

SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
                "Return a list containing @var{objs}, the arguments to\n"
                "@code{list}.")

/* This used to be the code for "list", but it's wrong when used via apply
   (it should copy the list).  It seems pretty unlikely anyone would have
   been using this from C code, since it's a no-op, but keep it for strict
   binary compatibility.  */
SCM
scm_list (SCM objs)
{
  return objs;
}

/* membership tests (memq, memv, etc.) */

/* The function scm_c_memq returns the first sublist of list whose car is
 * 'eq?' obj, where the sublists of list are the non-empty lists returned by
 * (list-tail list k) for k less than the length of list.  If obj does not
 * occur in list, then #f (not the empty list) is returned.
 * List must be a proper list, otherwise scm_c_memq may crash or loop
 * endlessly.
 */
SCM
scm_c_memq (SCM obj, SCM list)
{
  for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
    {
      if (scm_is_eq (SCM_CAR (list), obj))
	return list;
    }
  return SCM_BOOL_F;
}

SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
	    "to @var{x} where the sublists of @var{lst} are the non-empty\n"
	    "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
	    "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
	    "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
	    "returned.")
#define FUNC_NAME s_scm_memq
{
  SCM_VALIDATE_LIST (2, lst);
  return scm_c_memq (x, lst);
}
#undef FUNC_NAME

SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
	    "to @var{x} where the sublists of @var{lst} are the non-empty\n"
	    "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
	    "@var{k} less than the length of @var{lst}.  If @var{x} does not\n"
	    "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
	    "returned.")
#define FUNC_NAME s_scm_memv
{
  SCM_VALIDATE_LIST (2, lst);
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
	return lst;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_member, "member", 2, 0, 0,
           (SCM x, SCM lst),
	    "Return the first sublist of @var{lst} whose car is\n"
	    "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
	    "the non-empty lists returned by @code{(list-tail @var{lst}\n"
	    "@var{k})} for @var{k} less than the length of @var{lst}.  If\n"
	    "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
	    "empty list) is returned.")
#define FUNC_NAME s_scm_member
{
  SCM_VALIDATE_LIST (2, lst);
  for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
	return lst;
    }
  return SCM_BOOL_F;
}
#undef FUNC_NAME

/* deleting elements from a list (delq, etc.) */

SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
           (SCM item, SCM lst),
	    "@deffnx {Scheme Procedure} delv! item lst\n"
	    "@deffnx {Scheme Procedure} delete! item lst\n"
	    "These procedures are destructive versions of @code{delq}, @code{delv}\n"
	    "and @code{delete}: they modify the existing @var{lst}\n"
	    "rather than creating a new list.  Caveat evaluator: Like other\n"
	    "destructive list functions, these functions cannot modify the binding of\n"
	    "@var{lst}, and so cannot be used to delete the first element of\n"
	    "@var{lst} destructively.")
#define FUNC_NAME s_scm_delq_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_eq (SCM_CAR (walk), item))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
	    (SCM item, SCM lst),
	    "Destructively remove all elements from @var{lst} that are\n"
	    "@code{eqv?} to @var{item}.")
#define FUNC_NAME s_scm_delv_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
	    (SCM item, SCM lst),
	    "Destructively remove all elements from @var{lst} that are\n"
	    "@code{equal?} to @var{item}.")
#define FUNC_NAME s_scm_delete_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
	*prev = SCM_CDR (walk);
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{eq?} to @var{item} removed.  This procedure mirrors\n"
	    "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
	    "@var{item} with @code{eq?}.")
#define FUNC_NAME s_scm_delq
{
  SCM copy = scm_list_copy (lst);
  return scm_delq_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{eqv?}  to @var{item} removed.  This procedure mirrors\n"
	    "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
	    "@var{item} with @code{eqv?}.")
#define FUNC_NAME s_scm_delv
{
  SCM copy = scm_list_copy (lst);
  return scm_delv_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
            (SCM item, SCM lst),
	    "Return a newly-created copy of @var{lst} with elements\n"
	    "@code{equal?}  to @var{item} removed.  This procedure mirrors\n"
	    "@code{member}: @code{delete} compares elements of @var{lst}\n"
	    "against @var{item} with @code{equal?}.")
#define FUNC_NAME s_scm_delete
{
  SCM copy = scm_list_copy (lst);
  return scm_delete_x (item, copy);
}
#undef FUNC_NAME

SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
           (SCM item, SCM lst),
	    "Like @code{delq!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{eq?}.  See also @code{delv1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delq1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_eq (SCM_CAR (walk), item))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
            (SCM item, SCM lst),
	    "Like @code{delv!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{eqv?}.  See also @code{delq1!} and @code{delete1!}.")
#define FUNC_NAME s_scm_delv1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
            (SCM item, SCM lst),
	    "Like @code{delete!}, but only deletes the first occurrence of\n"
	    "@var{item} from @var{lst}.  Tests for equality using\n"
	    "@code{equal?}.  See also @code{delq1!} and @code{delv1!}.")
#define FUNC_NAME s_scm_delete1_x
{
  SCM walk;
  SCM *prev;

  for (prev = &lst, walk = lst;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
	{
	  *prev = SCM_CDR (walk);
	  break;
	}
      else
	prev = SCM_CDRLOC (walk);
    }

  return lst;
}
#undef FUNC_NAME

SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
	    (SCM pred, SCM list),
	    "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
	    "The list is not disordered -- elements that appear in the result list occur\n"
	    "in the same order as they occur in the argument list. The returned list may\n"
	    "share a common tail with the argument list. The dynamic order in which the\n"
	    "various applications of pred are made is not specified.\n\n"
	    "@lisp\n"
	    "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
	    "@end lisp")
#define FUNC_NAME s_scm_filter
{
  scm_t_trampoline_1 call = scm_trampoline_1 (pred);
  SCM walk;
  SCM *prev;
  SCM res = SCM_EOL;
  SCM_ASSERT (call, pred, 1, FUNC_NAME);
  SCM_VALIDATE_LIST (2, list);

  for (prev = &res, walk = list;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_true (call (pred, SCM_CAR (walk))))
	{
	  *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
	  prev = SCM_CDRLOC (*prev);
	}
    }

  return res;
}
#undef FUNC_NAME

SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
	    (SCM pred, SCM list),
	    "Linear-update variant of @code{filter}.")
#define FUNC_NAME s_scm_filter_x
{
  scm_t_trampoline_1 call = scm_trampoline_1 (pred);
  SCM walk;
  SCM *prev;
  SCM_ASSERT (call, pred, 1, FUNC_NAME);
  SCM_VALIDATE_LIST (2, list);

  for (prev = &list, walk = list;
       scm_is_pair (walk);
       walk = SCM_CDR (walk))
    {
      if (scm_is_true (call (pred, SCM_CAR (walk))))
	prev = SCM_CDRLOC (walk);
      else
	*prev = SCM_CDR (walk);
    }

  return list;
}
#undef FUNC_NAME

void
scm_init_list ()
{
#include "libguile/list.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_LIST_H
#define SCM_LIST_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_list_1 (SCM e1);
SCM_API SCM scm_list_2 (SCM e1, SCM e2);
SCM_API SCM scm_list_3 (SCM e1, SCM e2, SCM e3);
SCM_API SCM scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4);
SCM_API SCM scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5);
SCM_API SCM scm_list_n (SCM elt, ...);
SCM_API SCM scm_list (SCM objs);
SCM_API SCM scm_list_head (SCM lst, SCM k);
SCM_API SCM scm_make_list (SCM n, SCM init);
SCM_API SCM scm_cons_star (SCM arg, SCM objs);
SCM_API SCM scm_null_p (SCM x);
SCM_API SCM scm_list_p (SCM x);
SCM_API long scm_ilength (SCM sx);
SCM_API SCM scm_length (SCM x);
SCM_API SCM scm_append (SCM args);
SCM_API SCM scm_append_x (SCM args);
SCM_API SCM scm_reverse (SCM lst);
SCM_API SCM scm_reverse_x (SCM lst, SCM newtail);
SCM_API SCM scm_list_ref (SCM lst, SCM k);
SCM_API SCM scm_list_set_x (SCM lst, SCM k, SCM val);
SCM_API SCM scm_list_cdr_set_x (SCM lst, SCM k, SCM val);
SCM_API SCM scm_last_pair (SCM sx);
SCM_API SCM scm_list_tail (SCM lst, SCM k);
SCM_API SCM scm_c_memq (SCM x, SCM lst);
SCM_API SCM scm_memq (SCM x, SCM lst);
SCM_API SCM scm_memv (SCM x, SCM lst);
SCM_API SCM scm_member (SCM x, SCM lst);
SCM_API SCM scm_delq_x (SCM item, SCM lst);
SCM_API SCM scm_delv_x (SCM item, SCM lst);
SCM_API SCM scm_delete_x (SCM item, SCM lst);
SCM_API SCM scm_list_copy (SCM lst);
SCM_API SCM scm_delq (SCM item, SCM lst);
SCM_API SCM scm_delv (SCM item, SCM lst);
SCM_API SCM scm_delete (SCM item, SCM lst);
SCM_API SCM scm_delq1_x (SCM item, SCM lst);
SCM_API SCM scm_delv1_x (SCM item, SCM lst);
SCM_API SCM scm_delete1_x (SCM item, SCM lst);
SCM_API SCM scm_filter (SCM pred, SCM list);
SCM_API SCM scm_filter_x (SCM pred, SCM list);

/* Guile internal functions */

SCM_API SCM scm_i_finite_list_copy (SCM /* a list known to be finite */);
SCM_API void scm_init_list (void);

#endif  /* SCM_LIST_H */

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