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

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

#include <stdio.h>
#include <stdarg.h>

#include "libguile/_scm.h"
#include "libguile/gsubr.h"
#include "libguile/foreign.h"
#include "libguile/instructions.h"
#include "libguile/objcodes.h"
#include "libguile/srfi-4.h"
#include "libguile/programs.h"

#include "libguile/private-options.h"

/*
 * gsubr.c
 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
 * and rest arguments.
 */

/* #define GSUBR_TEST */

/* OK here goes nothing: we're going to define VM assembly trampolines for
   invoking subrs, along with their meta-information, and then wrap them into
   statically allocated objcode values. Ready? Right!
*/

/* There's a maximum of 10 args, so the number of possible combinations is:
   (REQ-OPT-REST)
   for 0 args: 1 (000) (1 + 0)
   for 1 arg: 3 (100, 010, 001) (2 + 1)
   for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
   for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
   for N args: 2N+1

   and the index at which N args starts:
   for 0 args: 0
   for 1 args: 1
   for 2 args: 4
   for 3 args: 9
   for N args: N^2

   One can prove this:

   (1 + 3 + 5 + ... + (2N+1))
     = ((2N+1)+1)/2 * (N+1)
     = 2(N+1)/2 * (N+1)
     = (N+1)^2

   Thus the total sum is 11^2 = 121. Let's just generate all of them as
   read-only data.
*/

#ifdef WORDS_BIGENDIAN
#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
#define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
#else
#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
#define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
#endif

/* A: req; B: opt; C: rest */
#define A(nreq)                                                         \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
  /* 7 */ scm_op_nop,                                                   \
  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (3, 7, nreq, 0, 0)

#define B(nopt)                                                         \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
  /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */  \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, 0, nopt, 0)

#define C()                                                             \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */       \
  /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
  /* 7 */ scm_op_nop,                                                   \
  /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (3, 7, 0, 0, 1)

#define AB(nreq, nopt)                                                  \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
  /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as well) */ \
  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
  /* 16 */ META (9, 13, nreq, nopt, 0)

#define AC(nreq)                                                        \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */               \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, nreq, 0, 1)

#define BC(nopt)                                                        \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
  /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */               \
  /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */ \
  /* 10 */ scm_op_nop, scm_op_nop,                                      \
  /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  /* 16 */ META (6, 10, 0, nopt, 1)

#define ABC(nreq, nopt)                                                 \
  OBJCODE_HEADER,                                                       \
  /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
  /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
  /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */          \
  /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as well) */ \
  /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
  /* 16 */ META (9, 13, nreq, nopt, 1)

#define META(start, end, nreq, nopt, rest)                              \
  META_HEADER,                                                          \
  /* 0 */ scm_op_make_eol, /* bindings */                               \
  /* 1 */ scm_op_make_eol, /* sources */                                \
  /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
  /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
  /* 8 */ scm_op_make_int8, nopt, /* N optionals */                     \
  /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
  /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */         \
  /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
  /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
  /* 25 */ scm_op_object_ref, 1, /* the name from the object table */   \
  /* 27 */ scm_op_cons, /* make a pair for the properties */            \
  /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
  /* 31 */ scm_op_return /* and return */                               \
  /* 32 */

/*
 (defun generate-bytecode (n)
   "Generate bytecode for N arguments"
   (interactive "p")
   (insert (format "/\* %d arguments *\/\n  " n))
   (let ((nreq n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq)))
         (insert
          (if (< 0 nreq)
              (if (< 0 nopt)
                  (format "AB(%d,%d), " nreq nopt)
                  (format "A(%d), " nreq))
              (if (< 0 nopt)
                  (format "B(%d), " nopt)
                  (format "A(0), "))))
         (setq nreq (1- nreq))))
     (insert "\n  ")
     (setq nreq (1- n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq 1)))
         (insert
          (if (< 0 nreq)
              (if (< 0 nopt)
                  (format "ABC(%d,%d), " nreq nopt)
                  (format "AC(%d), " nreq))
              (if (< 0 nopt)
                  (format "BC(%d), " nopt)
                  (format "C(), "))))
         (setq nreq (1- nreq))))
     (insert "\n\n  ")))

 (defun generate-bytecodes (n)
   "Generate bytecodes for up to N arguments"
   (interactive "p")
   (let ((i 0))
     (while (<= i n)
       (generate-bytecode i)
       (setq i (1+ i)))))
*/
static const struct
{
  scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
  const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
                                 + sizeof (struct scm_objcode) + 32)];
} raw_bytecode = {
  0,
  {
    /* C-u 1 0 M-x generate-bytecodes RET */
    /* 0 arguments */
    A(0),

    /* 1 arguments */
    A(1), B(1),
    C(),

    /* 2 arguments */
    A(2), AB(1,1), B(2),
    AC(1), BC(1),

    /* 3 arguments */
    A(3), AB(2,1), AB(1,2), B(3),
    AC(2), ABC(1,1), BC(2),

    /* 4 arguments */
    A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
    AC(3), ABC(2,1), ABC(1,2), BC(3),

    /* 5 arguments */
    A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
    AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),

    /* 6 arguments */
    A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
    AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),

    /* 7 arguments */
    A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
    AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),

    /* 8 arguments */
    A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
    AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),

    /* 9 arguments */
    A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7), AB(1,8), B(9),
    AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6), ABC(1,7), BC(8),

    /* 10 arguments */
    A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7), AB(2,8), AB(1,9), B(10),
    AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6), ABC(2,7), ABC(1,8), BC(9)
  }
};

#undef A
#undef B
#undef C
#undef AB
#undef AC
#undef BC
#undef ABC
#undef OBJCODE_HEADER
#undef META_HEADER
#undef META

/*
 ;; (nargs * nargs) + nopt + rest * (nargs + 1)
 (defun generate-objcode-cells-helper (n)
   "Generate objcode cells for N arguments"
   (interactive "p")
   (insert (format "    /\* %d arguments *\/\n" n))
   (let ((nreq n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq)))
         (insert
          (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
                  (* (+ 4 4 16 4 4 32)
                     (+ (* n n) nopt))))
         (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
         (setq nreq (1- nreq))))
     (insert "\n")
     (setq nreq (1- n))
     (while (<= 0 nreq)
       (let ((nopt (- n nreq 1)))
         (insert
          (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
                  (* (+ 4 4 16 4 4 32)
                     (+ (* n n) nopt n 1))))
         (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
         (setq nreq (1- nreq))))
     (insert "\n")))

 (defun generate-objcode-cells (n)
   "Generate objcode cells for up to N arguments"
   (interactive "p")
   (let ((i 0))
     (while (<= i n)
       (generate-objcode-cells-helper i)
       (setq i (1+ i)))))
*/

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

static const struct
{
  scm_t_uint64 dummy; /* alignment */
  scm_t_cell cells[121 * 2]; /* 11*11 double cells */
} objcode_cells = {
  0,
  /* C-u 1 0 M-x generate-objcode-cells RET */
  {
    /* 0 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 1 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 2 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 3 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 4 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 5 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 6 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 7 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 8 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 9 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
    { SCM_BOOL_F, SCM_PACK (0) },

    /* 10 arguments */
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
    { SCM_BOOL_F, SCM_PACK (0) },

    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
    { SCM_BOOL_F, SCM_PACK (0) },
    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
    { SCM_BOOL_F, SCM_PACK (0) }
  }
};

/*
 (defun generate-objcode (n)
   "Generate objcode for N arguments"
   (interactive "p")
   (insert (format "  /\* %d arguments *\/\n" n))
   (let ((i (* n n)))
     (while (< i (* (1+ n) (1+ n)))
       (insert (format "  SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
       (setq i (1+ i)))
     (insert "\n")))

 (defun generate-objcodes (n)
   "Generate objcodes for up to N arguments"
   (interactive "p")
   (let ((i 0))
     (while (<= i n)
       (generate-objcode i)
       (setq i (1+ i)))))
*/
static const SCM scm_subr_objcode_trampolines[121] = {
  /* C-u 1 0 M-x generate-objcodes RET */
  /* 0 arguments */
  SCM_PACK (objcode_cells.cells+0),

  /* 1 arguments */
  SCM_PACK (objcode_cells.cells+2),
  SCM_PACK (objcode_cells.cells+4),
  SCM_PACK (objcode_cells.cells+6),

  /* 2 arguments */
  SCM_PACK (objcode_cells.cells+8),
  SCM_PACK (objcode_cells.cells+10),
  SCM_PACK (objcode_cells.cells+12),
  SCM_PACK (objcode_cells.cells+14),
  SCM_PACK (objcode_cells.cells+16),

  /* 3 arguments */
  SCM_PACK (objcode_cells.cells+18),
  SCM_PACK (objcode_cells.cells+20),
  SCM_PACK (objcode_cells.cells+22),
  SCM_PACK (objcode_cells.cells+24),
  SCM_PACK (objcode_cells.cells+26),
  SCM_PACK (objcode_cells.cells+28),
  SCM_PACK (objcode_cells.cells+30),

  /* 4 arguments */
  SCM_PACK (objcode_cells.cells+32),
  SCM_PACK (objcode_cells.cells+34),
  SCM_PACK (objcode_cells.cells+36),
  SCM_PACK (objcode_cells.cells+38),
  SCM_PACK (objcode_cells.cells+40),
  SCM_PACK (objcode_cells.cells+42),
  SCM_PACK (objcode_cells.cells+44),
  SCM_PACK (objcode_cells.cells+46),
  SCM_PACK (objcode_cells.cells+48),

  /* 5 arguments */
  SCM_PACK (objcode_cells.cells+50),
  SCM_PACK (objcode_cells.cells+52),
  SCM_PACK (objcode_cells.cells+54),
  SCM_PACK (objcode_cells.cells+56),
  SCM_PACK (objcode_cells.cells+58),
  SCM_PACK (objcode_cells.cells+60),
  SCM_PACK (objcode_cells.cells+62),
  SCM_PACK (objcode_cells.cells+64),
  SCM_PACK (objcode_cells.cells+66),
  SCM_PACK (objcode_cells.cells+68),
  SCM_PACK (objcode_cells.cells+70),

  /* 6 arguments */
  SCM_PACK (objcode_cells.cells+72),
  SCM_PACK (objcode_cells.cells+74),
  SCM_PACK (objcode_cells.cells+76),
  SCM_PACK (objcode_cells.cells+78),
  SCM_PACK (objcode_cells.cells+80),
  SCM_PACK (objcode_cells.cells+82),
  SCM_PACK (objcode_cells.cells+84),
  SCM_PACK (objcode_cells.cells+86),
  SCM_PACK (objcode_cells.cells+88),
  SCM_PACK (objcode_cells.cells+90),
  SCM_PACK (objcode_cells.cells+92),
  SCM_PACK (objcode_cells.cells+94),
  SCM_PACK (objcode_cells.cells+96),

  /* 7 arguments */
  SCM_PACK (objcode_cells.cells+98),
  SCM_PACK (objcode_cells.cells+100),
  SCM_PACK (objcode_cells.cells+102),
  SCM_PACK (objcode_cells.cells+104),
  SCM_PACK (objcode_cells.cells+106),
  SCM_PACK (objcode_cells.cells+108),
  SCM_PACK (objcode_cells.cells+110),
  SCM_PACK (objcode_cells.cells+112),
  SCM_PACK (objcode_cells.cells+114),
  SCM_PACK (objcode_cells.cells+116),
  SCM_PACK (objcode_cells.cells+118),
  SCM_PACK (objcode_cells.cells+120),
  SCM_PACK (objcode_cells.cells+122),
  SCM_PACK (objcode_cells.cells+124),
  SCM_PACK (objcode_cells.cells+126),

  /* 8 arguments */
  SCM_PACK (objcode_cells.cells+128),
  SCM_PACK (objcode_cells.cells+130),
  SCM_PACK (objcode_cells.cells+132),
  SCM_PACK (objcode_cells.cells+134),
  SCM_PACK (objcode_cells.cells+136),
  SCM_PACK (objcode_cells.cells+138),
  SCM_PACK (objcode_cells.cells+140),
  SCM_PACK (objcode_cells.cells+142),
  SCM_PACK (objcode_cells.cells+144),
  SCM_PACK (objcode_cells.cells+146),
  SCM_PACK (objcode_cells.cells+148),
  SCM_PACK (objcode_cells.cells+150),
  SCM_PACK (objcode_cells.cells+152),
  SCM_PACK (objcode_cells.cells+154),
  SCM_PACK (objcode_cells.cells+156),
  SCM_PACK (objcode_cells.cells+158),
  SCM_PACK (objcode_cells.cells+160),

  /* 9 arguments */
  SCM_PACK (objcode_cells.cells+162),
  SCM_PACK (objcode_cells.cells+164),
  SCM_PACK (objcode_cells.cells+166),
  SCM_PACK (objcode_cells.cells+168),
  SCM_PACK (objcode_cells.cells+170),
  SCM_PACK (objcode_cells.cells+172),
  SCM_PACK (objcode_cells.cells+174),
  SCM_PACK (objcode_cells.cells+176),
  SCM_PACK (objcode_cells.cells+178),
  SCM_PACK (objcode_cells.cells+180),
  SCM_PACK (objcode_cells.cells+182),
  SCM_PACK (objcode_cells.cells+184),
  SCM_PACK (objcode_cells.cells+186),
  SCM_PACK (objcode_cells.cells+188),
  SCM_PACK (objcode_cells.cells+190),
  SCM_PACK (objcode_cells.cells+192),
  SCM_PACK (objcode_cells.cells+194),
  SCM_PACK (objcode_cells.cells+196),
  SCM_PACK (objcode_cells.cells+198),

  /* 10 arguments */
  SCM_PACK (objcode_cells.cells+200),
  SCM_PACK (objcode_cells.cells+202),
  SCM_PACK (objcode_cells.cells+204),
  SCM_PACK (objcode_cells.cells+206),
  SCM_PACK (objcode_cells.cells+208),
  SCM_PACK (objcode_cells.cells+210),
  SCM_PACK (objcode_cells.cells+212),
  SCM_PACK (objcode_cells.cells+214),
  SCM_PACK (objcode_cells.cells+216),
  SCM_PACK (objcode_cells.cells+218),
  SCM_PACK (objcode_cells.cells+220),
  SCM_PACK (objcode_cells.cells+222),
  SCM_PACK (objcode_cells.cells+224),
  SCM_PACK (objcode_cells.cells+226),
  SCM_PACK (objcode_cells.cells+228),
  SCM_PACK (objcode_cells.cells+230),
  SCM_PACK (objcode_cells.cells+232),
  SCM_PACK (objcode_cells.cells+234),
  SCM_PACK (objcode_cells.cells+236),
  SCM_PACK (objcode_cells.cells+238),
  SCM_PACK (objcode_cells.cells+240)
};

/* (nargs * nargs) + nopt + rest * (nargs + 1) */
#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest)                     \
  scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
                               + nopt + rest * (nreq + nopt + rest + 1)]

SCM
scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
                             unsigned int rest)
{
  if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
    scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));

  return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
}

static SCM
create_gsubr (int define, const char *name,
	      unsigned int nreq, unsigned int nopt, unsigned int rest,
	      SCM (*fcn) (), SCM *generic_loc)
{
  SCM ret;
  SCM sname;
  SCM table;
  scm_t_bits flags;

  /* make objtable */
  sname = scm_from_locale_symbol (name);
  table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
  SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
  SCM_SIMPLE_VECTOR_SET (table, 1, sname);
  if (generic_loc)
    SCM_SIMPLE_VECTOR_SET (table, 2,
                           scm_from_pointer (generic_loc, NULL));

  /* make program */
  ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
                          table, SCM_BOOL_F);

  /* set flags */
  flags = SCM_F_PROGRAM_IS_PRIMITIVE;
  flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
  SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);

  /* define, if needed */
  if (define)
    scm_define (sname, ret);

  /* et voila. */
  return ret;
}

SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (0, name, req, opt, rst, fcn, NULL);
}

SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (1, name, req, opt, rst, fcn, NULL);
}

SCM
scm_c_make_gsubr_with_generic (const char *name,
			       int req,
			       int opt,
			       int rst,
			       SCM (*fcn)(),
			       SCM *gf)
{
  return create_gsubr (0, name, req, opt, rst, fcn, gf);
}

SCM
scm_c_define_gsubr_with_generic (const char *name,
				 int req,
				 int opt,
				 int rst,
				 SCM (*fcn)(),
				 SCM *gf)
{
  return create_gsubr (1, name, req, opt, rst, fcn, gf);
}

#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
   a scm_list of rest args
   */
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
  scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
  scm_display(req1, scm_cur_outp);
  scm_puts ("\n req2: ", scm_cur_outp);
  scm_display(req2, scm_cur_outp);
  scm_puts ("\n opt: ", scm_cur_outp);
  scm_display(opt, scm_cur_outp);
  scm_puts ("\n rest: ", scm_cur_outp);
  scm_display(rst, scm_cur_outp);
  scm_newline(scm_cur_outp);
  return SCM_UNSPECIFIED;
}
#endif

void
scm_init_gsubr()
{
#ifdef GSUBR_TEST
  scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif

#include "libguile/gsubr.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
                                         unsigned int nopt,
                                         unsigned int rest);

/* Subrs
 */

/* Max number of args to the C procedure backing a gsubr */
#define SCM_GSUBR_MAX 10

#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))

#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))

#define SCM_SUBRF(x)							\
  ((SCM (*) (void))							\
   SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0)))

#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))

#define SCM_SUBR_GENERIC(x)						\
  ((SCM *)								\
   SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2)))

#define SCM_SET_SUBR_GENERIC(x, g) \
  (*SCM_SUBR_GENERIC (x) = (g))

SCM_API SCM scm_c_make_gsubr (const char *name,
			      int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
					   int req, int opt, int rst,
					   SCM (*fcn) (), SCM *gf);
SCM_API SCM scm_c_define_gsubr (const char *name,
				int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
					     int req, int opt, int rst,
					     SCM (*fcn) (), SCM *gf);

SCM_INTERNAL void scm_init_gsubr (void);

#endif  /* SCM_GSUBR_H */

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

license: mit


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

/* This is an implementation of guardians as described in
 * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
 * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
 * Programming Language Design and Implementation, June 1993
 * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
 *
 * Original design:          Mikael Djurfeldt
 * Original implementation:  Michael Livshin
 * Hacked on since by:       everybody
 *
 * By this point, the semantics are actually quite different from
 * those described in the abovementioned paper.  The semantic changes
 * are there to improve safety and intuitiveness.  The interface is
 * still (mostly) the one described by the paper, however.
 *
 * Boiled down again:        Marius Vollmer
 *
 * Now they should again behave like those described in the paper.
 * Scheme guardians should be simple and friendly, not like the greedy
 * monsters we had...
 *
 * Rewritten for the Boehm-Demers-Weiser GC by Ludovic Court�s.
 * FIXME: This is currently not thread-safe.
 */

/* Uncomment the following line to debug guardian finalization.  */
/* #define DEBUG_GUARDIANS 1 */

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

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/smob.h"
#include "libguile/validate.h"
#include "libguile/root.h"
#include "libguile/hashtab.h"
#include "libguile/weaks.h"
#include "libguile/deprecation.h"
#include "libguile/eval.h"

#include "libguile/guardians.h"
#include "libguile/bdw-gc.h"

static scm_t_bits tc16_guardian;

typedef struct t_guardian
{
  unsigned long live;
  SCM zombies;
  struct t_guardian *next;
} t_guardian;

#define GUARDIAN_P(x)    SCM_SMOB_PREDICATE(tc16_guardian, x)
#define GUARDIAN_DATA(x) ((t_guardian *) SCM_SMOB_DATA_1 (x))

static int
guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  t_guardian *g = GUARDIAN_DATA (guardian);

  scm_puts ("#<guardian ", port);
  scm_uintprint ((scm_t_bits) g, 16, port);

  scm_puts (" (reachable: ", port);
  scm_display (scm_from_uint (g->live), port);
  scm_puts (" unreachable: ", port);
  scm_display (scm_length (g->zombies), port);
  scm_puts (")", port);

  scm_puts (">", port);

  return 1;
}

/* Handle finalization of OBJ which is guarded by the guardians listed in
   GUARDIAN_LIST.  */
static void
finalize_guarded (GC_PTR ptr, GC_PTR finalizer_data)
{
  SCM cell_pool;
  SCM obj, guardian_list, proxied_finalizer;

  obj = PTR2SCM (ptr);
  guardian_list = SCM_CDR (PTR2SCM (finalizer_data));
  proxied_finalizer = SCM_CAR (PTR2SCM (finalizer_data));

#ifdef DEBUG_GUARDIANS
  printf ("finalizing guarded %p (%u guardians)\n",
	  ptr, scm_to_uint (scm_length (guardian_list)));
#endif

  /* Preallocate a bunch of cells so that we can make sure that no garbage
     collection (and, thus, nested calls to `finalize_guarded ()') occurs
     while executing the following loop.  This is quite inefficient (call to
     `scm_length ()') but that shouldn't be a problem in most cases.  */
  cell_pool = scm_make_list (scm_length (guardian_list), SCM_UNSPECIFIED);

  /* Tell each guardian interested in OBJ that OBJ is no longer
     reachable.  */
  for (;
       guardian_list != SCM_EOL;
       guardian_list = SCM_CDR (guardian_list))
    {
      SCM zombies;
      t_guardian *g;

      if (SCM_WEAK_PAIR_CAR_DELETED_P (guardian_list))
	{
	  /* The guardian itself vanished in the meantime.  */
#ifdef DEBUG_GUARDIANS
	  printf ("  guardian for %p vanished\n", ptr);
#endif
	  continue;
	}

      g = GUARDIAN_DATA (SCM_CAR (guardian_list));
      if (g->live == 0)
	abort ();

      /* Get a fresh cell from CELL_POOL.  */
      zombies = cell_pool;
      cell_pool = SCM_CDR (cell_pool);

      /* Compute and update G's zombie list.  */
      SCM_SETCAR (zombies, SCM_PACK (obj));
      SCM_SETCDR (zombies, g->zombies);
      g->zombies = zombies;

      g->live--;
      g->zombies = zombies;
    }

  if (proxied_finalizer != SCM_BOOL_F)
    {
      /* Re-register the finalizer that was in place before we installed this
	 one.  */
      GC_finalization_proc finalizer, prev_finalizer;
      GC_PTR finalizer_data, prev_finalizer_data;

      finalizer = (GC_finalization_proc) SCM2PTR (SCM_CAR (proxied_finalizer));
      finalizer_data = SCM2PTR (SCM_CDR (proxied_finalizer));

      if (finalizer == NULL)
	abort ();

      GC_REGISTER_FINALIZER_NO_ORDER (ptr, finalizer, finalizer_data,
				      &prev_finalizer, &prev_finalizer_data);

#ifdef DEBUG_GUARDIANS
      printf ("  reinstalled proxied finalizer %p for %p\n", finalizer, ptr);
#endif
    }

#ifdef DEBUG_GUARDIANS
  printf ("end of finalize (%p)\n", ptr);
#endif
}

/* Add OBJ as a guarded object of GUARDIAN.  */
static void
scm_i_guard (SCM guardian, SCM obj)
{
  t_guardian *g = GUARDIAN_DATA (guardian);

  if (SCM_NIMP (obj))
    {
      /* Register a finalizer and pass a pair as the ``client data''
	 argument.  The pair contains in its car `#f' or a pair describing a
	 ``proxied'' finalizer (see below); its cdr contains a list of
	 guardians interested in OBJ.

	 A ``proxied'' finalizer is a finalizer that was registered for OBJ
	 before OBJ became guarded (e.g., a SMOB `free' function).  We are
	 assuming here that finalizers are only used internally, either at
	 the very beginning of an object's lifetime (e.g., see `SCM_NEWSMOB')
	 or by this function.  */
      GC_finalization_proc prev_finalizer;
      GC_PTR prev_data;
      SCM guardians_for_obj, finalizer_data;

      g->live++;

      /* Note: GUARDIANS_FOR_OBJ is a weak list so that a guardian can be
	 collected before the objects it guards (see `guardians.test').  */
      guardians_for_obj = scm_weak_car_pair (guardian, SCM_EOL);
      finalizer_data = scm_cons (SCM_BOOL_F, guardians_for_obj);

      GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (obj), finalize_guarded,
				      SCM2PTR (finalizer_data),
				      &prev_finalizer, &prev_data);

      if (prev_finalizer == finalize_guarded)
	{
	  /* OBJ is already guarded by another guardian: add GUARDIAN to its
	     list of guardians.  */
	  SCM prev_guardian_list, prev_finalizer_data;

	  if (prev_data == NULL)
	    abort ();

	  prev_finalizer_data = PTR2SCM (prev_data);
	  if (!scm_is_pair (prev_finalizer_data))
	    abort ();

	  prev_guardian_list = SCM_CDR (prev_finalizer_data);
	  SCM_SETCDR (guardians_for_obj, prev_guardian_list);

	  /* Also copy information about proxied finalizers.  */
	  SCM_SETCAR (finalizer_data, SCM_CAR (prev_finalizer_data));
	}
      else if (prev_finalizer != NULL)
	{
	  /* There was already a finalizer registered for OBJ so we will
	     ``proxy'' it, i.e., record it so that we can re-register it once
	     `finalize_guarded ()' has finished.  */
	  SCM proxied_finalizer;

	  proxied_finalizer = scm_cons (PTR2SCM (prev_finalizer),
					PTR2SCM (prev_data));
	  SCM_SETCAR (finalizer_data, proxied_finalizer);
	}
    }
}

static SCM
scm_i_get_one_zombie (SCM guardian)
{
  t_guardian *g = GUARDIAN_DATA (guardian);
  SCM res = SCM_BOOL_F;

  if (g->zombies != SCM_EOL)
    {
      /* Note: We return zombies in reverse order.  */
      res = SCM_CAR (g->zombies);
      g->zombies = SCM_CDR (g->zombies);
    }

  return res;
}

/* This is the Scheme entry point for each guardian: If OBJ is an
 * object, it's added to the guardian's live list.  If OBJ is unbound,
 * the next available unreachable object (or #f if none) is returned.
 *
 * If the second optional argument THROW_P is true (the default), then
 * an error is raised if GUARDIAN is greedy and OBJ is already greedily
 * guarded.  If THROW_P is false, #f is returned instead of raising the
 * error, and #t is returned if everything is fine.
 */
static SCM
guardian_apply (SCM guardian, SCM obj, SCM throw_p)
{
  if (!SCM_UNBNDP (obj))
    {
      scm_i_guard (guardian, obj);
      return SCM_UNSPECIFIED;
    }
  else
    return scm_i_get_one_zombie (guardian);
}

SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
	    (),
"Create a new guardian.  A guardian protects a set of objects from\n"
"garbage collection, allowing a program to apply cleanup or other\n"
"actions.\n"
"\n"
"@code{make-guardian} returns a procedure representing the guardian.\n"
"Calling the guardian procedure with an argument adds the argument to\n"
"the guardian's set of protected objects.  Calling the guardian\n"
"procedure without an argument returns one of the protected objects\n"
"which are ready for garbage collection, or @code{#f} if no such object\n"
"is available.  Objects which are returned in this way are removed from\n"
"the guardian.\n"
"\n"
"You can put a single object into a guardian more than once and you can\n"
"put a single object into more than one guardian.  The object will then\n"
"be returned multiple times by the guardian procedures.\n"
"\n"
"An object is eligible to be returned from a guardian when it is no\n"
"longer referenced from outside any guardian.\n"
"\n"
"There is no guarantee about the order in which objects are returned\n"
"from a guardian.  If you want to impose an order on finalization\n"
"actions, for example, you can do that by keeping objects alive in some\n"
"global data structure until they are no longer needed for finalizing\n"
"other objects.\n"
"\n"
"Being an element in a weak vector, a key in a hash table with weak\n"
"keys, or a value in a hash table with weak value does not prevent an\n"
"object from being returned by a guardian.  But as long as an object\n"
"can be returned from a guardian it will not be removed from such a\n"
"weak vector or hash table.  In other words, a weak link does not\n"
"prevent an object from being considered collectable, but being inside\n"
"a guardian prevents a weak link from being broken.\n"
"\n"
"A key in a weak key hash table can be though of as having a strong\n"
"reference to its associated value as long as the key is accessible.\n"
"Consequently, when the key only accessible from within a guardian, the\n"
"reference from the key to the value is also considered to be coming\n"
"from within a guardian.  Thus, if there is no other reference to the\n"
	    "value, it is eligible to be returned from a guardian.\n")
#define FUNC_NAME s_scm_make_guardian
{
  t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
  SCM z;

  /* A tconc starts out with one tail pair. */
  g->live = 0;
  g->zombies = SCM_EOL;

  g->next = NULL;

  SCM_NEWSMOB (z, tc16_guardian, g);

  return z;
}
#undef FUNC_NAME

void
scm_init_guardians ()
{
  /* We use unordered finalization `a la Java.  */
  GC_java_finalization = 1;

  tc16_guardian = scm_make_smob_type ("guardian", 0);

  scm_set_smob_print (tc16_guardian, guardian_print);
  scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);

#include "libguile/guardians.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_GUARDIANS_H
#define SCM_GUARDIANS_H

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

#include "libguile/__scm.h"

SCM_API SCM scm_make_guardian (void);

SCM_INTERNAL void scm_i_init_guardians_for_gc (void);
SCM_INTERNAL void scm_i_identify_inaccessible_guardeds (void);
SCM_INTERNAL int scm_i_mark_inaccessible_guardeds (void);

SCM_INTERNAL void scm_init_guardians (void);

#endif  /* SCM_GUARDIANS_H */

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


code:
#!/usr/bin/awk -f
#
#  Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation; either version 3, or (at
# your option) any later version.
#
# This program 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 software; see the file COPYING.LESSER.  If
# not, write to the Free Software Foundation, Inc., 51 Franklin
# Street, Fifth Floor, Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 11-Jan-2000

BEGIN {
  filename = ARGV[1];
  in_a_func = 0;
}

/^SCM_DEFINE/ {
  func_name = $0;
  sub(/^[^\(\n]*\([ \t]*/,"", func_name);
  sub(/[ \t]*,.*/,"", func_name);
#  print func_name;  # GJB:FIXME:: flag to do this to list primitives?
  in_a_func = 1;
}

/^\{/ && in_a_func {
  if (!match(last_line,/^#define[ \t]+FUNC_NAME[ \t]+/)) {
    printf filename ":" NR ":***" > "/dev/stderr";
    print "Missing or erroneous `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
  } else {
    sub(/^#define[ \t]+FUNC_NAME[ \t]+s_/, "", last_line);
    sub(/[ \t]*$/,"",last_line);
    if (last_line != func_name) {
      printf filename ":" NR ":***" > "/dev/stderr";
      print "Mismatching FUNC_NAME.  Should be: `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
    }
  }
}

1 == next_line_better_be_undef {
  if (!match($0,/^#undef FUNC_NAME[ \t]*$/)) {
    printf filename ":" NR ":***" > "/dev/stderr";
    print "Missing or erroneous #undef for " func_name ": "
          "Got `" $0 "' instead." > "/dev/stderr";
  }
  in_a_func = "";
  func_name = "";
  next_line_better_be_undef = 0;
}

/^\}/ && in_a_func {
  next_line_better_be_undef = 1;
}

{ last_line = $0; }

path: libguile/guile-func-name-check


code:
#!/bin/sh
# Extract the doc stuff for builtin things.
#
#  Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation; either version 3, or (at
# your option) any later version.
#
# This program 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 software; see the file COPYING.LESSER.  If
# not, write to the Free Software Foundation, Inc., 51 Franklin
# Street, Fifth Floor, Boston, MA 02110-1301 USA

bindir=`dirname $0`

## Let the user override the preprocessor autoconf found.
test -n "${CPP+set}" || CPP="@CPP@"

${CPP} -DSCM_MAGIC_SNARF_DOCS "$@"


code:
#  Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation; either version 3, or (at
# your option) any later version.
#
# This program 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 software; see the file COPYING.LESSER.  If
# not, write to the Free Software Foundation, Inc., 51 Franklin
# Street, Fifth Floor, Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 12-Dec-1999

BEGIN { FS="|";
        dot_doc_file = ARGV[1]; ARGV[1] = "-";
        std_err = "/dev/stderr";
        # be sure to put something in the files to help make out
        print "";
        printf "" > dot_doc_file;
}

/^[ \t]*SCM_SNARF_INIT_START/ { copy = $0;
               gsub(/[ \t]*SCM_SNARF_INIT_START/, "", copy);
               gsub(/SCM_SNARF_DOC_START.*$/, "", copy);
               print copy; }

/SCM_SNARF_DOC_START/,/SCM_SNARF_DOCSTRING_START/ { copy = $0;
                 if (match(copy,/SCM_SNARF_DOC_STARTR/)) { registering = 1; }
                 else {registering = 0; }
                 gsub(/.*SCM_SNARF_DOC_START./,"", copy);
                 gsub(/SCM_SNARF_DOCSTRING_START.*/,"",copy);
                 gsub(/[ \t]+/," ", copy);
		 sub(/^[ \t]*/,"(", copy);
                 gsub(/\"/,"",copy);
		 sub(/\([ \t]*void[ \t]*\)/,"()", copy);
		 sub(/ \(/," ",copy);
		 numargs = gsub(/SCM /,"", copy);
		 numcommas = gsub(/,/,"", copy);
		 numactuals = $2 + $3 + $4;
		 location = $5;
		 gsub(/\"/,"",location);
		 sub(/^[ \t]*/,"",location);
		 sub(/[ \t]*$/,"",location);
		 sub(/: /,":",location);
		 sub(/^\.\//,"",location);
		 # Now whittle copy down to just the $1 field
		 #   (but do not use $1, since it hasn't been
                 #    altered by the above regexps)
		 gsub(/[ \t]*\|.*$/,"",copy);
		 sub(/ \)/,")",copy);
		 # Now `copy' contains the nice scheme proc "prototype", e.g.
		 # (set-car! pair value)
                 # Since this is destined to become Texinfo source,
                 # quote any `@'s that occur in the prototype.
                 gsub(/\@/,"@@",copy);
		 # print copy > "/dev/stderr";  # for debugging
		 sub(/^\(/,"",copy);
		 sub(/\)[ \t]*$/,"",copy);
		 proc_and_args = copy;
		 curr_function_proto = copy;
		 proc_name = copy;
		 sub(/ .*$/,"",proc_name);
		 sub(/[^ \n]* /,"",proc_and_args);
		 split(proc_and_args,args," ");
		 # now args is an array of the arguments
		 # args[1] is the formal name of the first argument, etc.
		 if (numargs != numactuals && !registering)
		   { print location ":*** `" curr_function_proto "' is improperly registered as having " numactuals " arguments" > std_err; }
		 # Build a nicer function prototype than curr_function_proto
		 # that shows optional and rest arguments.
		 nicer_function_proto = proc_name;
		 if (!registering) {
    		   optional_args_tail = "";
		   for (i = 1; i <= $2; i++) {
		     nicer_function_proto = nicer_function_proto " " args[i];
		   }
		   for (; i <= $2 + $3; i++) {
		     nicer_function_proto = nicer_function_proto " [" args[i];
		     optional_args_tail = optional_args_tail "]";
		   }
		   nicer_function_proto = nicer_function_proto optional_args_tail;
		   if ($4 != 0) {
		     nicer_function_proto = nicer_function_proto " . " args[i];
		   }
                 }
		 # Now produce Texinfo format output.
		 print "\n" proc_name > dot_doc_file;
		 print "@c snarfed from " location > dot_doc_file;
		 print "@deffn primitive " nicer_function_proto > dot_doc_file;
}

/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0;

                 # Trim everything up to and including
                 # SCM_SNARF_DOCSTRING_START marker.
                 gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy);

		 # Trim leading whitespace and opening quote.
		 sub(/^[ \t]*\"?/,"", copy);

		 # Trim closing quote and trailing whitespace, or
                 # closing quote and whitespace followed by the
                 # SCM_SNARF_DOCSTRING_END marker.
                 sub(/[ \t]*\"?[ \t]*$/,"", copy);
		 sub(/[ \t]*\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy);

		 # Replace escaped characters.
		 gsub(/\\n/,"\n",copy);
                 gsub(/\\\"/,"\"",copy);
                 gsub(/\\\\/,"\\",copy);

		 # Some docstrings end each line with "\n", while
                 # others don't.  Therefore we always strip off one "\n"
                 # if present at the end of the line.  Docstrings must
		 # therefore always use "\n\n" to indicate a blank line.
                 if (copy != "")
		   {
		     sub(/[ \t]*\n$/, "", copy);
		     print copy > dot_doc_file;
		   }
                }

/SCM_SNARF_DOCSTRING_END[ \t]*/ { print "@end deffn" >> dot_doc_file; }

/\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0;
         sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy);
         if (copy ~ /\"/) { next }
         gsub(/[ \t]*,[ \t]*/,":",copy);
         sub(/[ \t]*\).*/,"",copy);
         split(copy,argpos,":");
         argname = argpos[1];
         pos = argpos[2];
         if (pos ~ /[A-Za-z]/) { next }
         if (pos ~ /^[ \t]*$/) { next }
         if (argname ~ / /) { next }
         line = argpos[3];
#         print pos " " args[pos] " vs. " argname > "/dev/stderr";
         if (args[pos] != argname) { print filename ":" line ":*** Argument name/number mismatch in `" curr_function_proto "' -- " argname " is not formal #" pos > "/dev/stderr"; }
      }


code:
#!/bin/sh
# Extract the initialization actions from source files.
#
#  Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation; either version 3, or (at
# your option) any later version.
#
# This program 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 software; see the file COPYING.LESSER.  If
# not, write to the Free Software Foundation, Inc., 51 Franklin
# Street, Fifth Floor, Boston, MA 02110-1301 USA

# Commentary:

# Usage: guile-snarf [-o OUTFILE] [CPP-ARGS ...]

# Initialization actions are extracted to OUTFILE or to standard
# output when no OUTFILE has been specified or when OUTFILE is "-".
# The C preprocessor is called with CPP-ARGS (which usually include a
# input file) and the output is filtered for the actions.
#
# If there are errors during processing, OUTFILE is deleted and the
# program exits with non-zero status.
#
# During snarfing, the pre-processor macro SCM_MAGIC_SNARFER is
# defined.  You can use this to avoid including snarfer output files
# that don't yet exist by writing code like this:
#
#   #ifndef SCM_MAGIC_SNARFER
#   #include "foo.x"
#   #endif
#
# If the environment variable CPP is set, use its value instead of the
# C pre-processor determined at Guile configure-time: "@CPP@".

# Code:

## funcs

modern_snarf ()                         # writes stdout
{
    ## Apparently, AIX's preprocessor is unhappy if you try to #include an
    ## empty file.
    echo "/* cpp arguments: $@ */" ;
    ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
    grep "^ *\^ *\^" ${temp} | sed -e "s/ *\^ *\^//g" -e "s/\^ *: *\^/;/g"
}

## main

# process command line
if [ x"$1" = x--help ] ; then
    @AWK@ '/^#.Commentary:/,/^#.Code:/' $0 | grep -v Code: \
        | sed -e 1,2d -e 's/^. *//g'
    exit 0
fi
if [ x"$1" = x-o ]
    then outfile="$2" ; shift ; shift ;
    else  outfile="-" ;
fi

# set vars and handler -- handle CPP override
cpp_ok_p=false

if [ x"$TMPDIR" = x ]; then TMPDIR="/tmp" ; else : ; fi
tempdir="$TMPDIR/guile-snarf.$$"
(umask 077 && mkdir $tempdir) || exit 1
temp="$tempdir/tmp"

if [ x"$CPP" = x ] ; then cpp="@CPP@" ; else cpp="$CPP" ; fi

trap "rm -rf $tempdir" 0 1 2 15

if [ ! "$outfile" = "-" ] ; then
    modern_snarf "$@" > $outfile
else
    modern_snarf "$@"
fi

# zonk outfile if errors occurred
if $cpp_ok_p ; then
    exit 0
else
    [ ! "$outfile" = "-" ] && rm -f $outfile
    exit 1
fi

# guile-snarf ends here


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

/* This is the 'main' function for the `guile' executable.  It is not
   included in libguile.a.

   Eventually, we hope this file will be automatically generated,
   based on the list of installed, statically linked libraries on the
   system.  For now, please don't put interesting code in here.  */

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

#ifdef __MINGW32__
# define SCM_IMPORT 1
#endif
#include <libguile.h>

#ifdef HAVE_CONFIG_H
#include <libguile/scmconfig.h>
#endif
#include <ltdl.h>

#ifdef HAVE_WINSOCK2_H
#include <winsock2.h>
#endif

/* Debugger interface (don't change the order of the following lines) */
#define GDB_TYPE SCM
#include <libguile/gdb_interface.h>
GDB_INTERFACE;

static void
inner_main (void *closure SCM_UNUSED, int argc, char **argv)
{
#ifdef __MINGW32__
  /* This is necessary to startup the Winsock API under Win32. */
  WSADATA WSAData;
  WSAStartup (0x0202, &WSAData);
  GDB_INTERFACE_INIT;
#endif /* __MINGW32__ */

  /* module initializations would go here */
  scm_shell (argc, argv);

#ifdef __MINGW32__
  WSACleanup ();
#endif /* __MINGW32__ */
}

int
main (int argc, char **argv)
{
  scm_boot_guile (argc, argv, inner_main, 0);
  return 0; /* never reached */
}

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


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

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

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/ports.h"
#include "libguile/strings.h"
#include "libguile/symbols.h"
#include "libguile/vectors.h"

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

#ifndef floor
extern double floor();
#endif

unsigned long
scm_string_hash (const unsigned char *str, size_t len)
{
  /* from suggestion at: */
  /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */

  unsigned long h = 0;
  while (len-- > 0)
    h = *str++ + h*37;
  return h;
}

unsigned long
scm_i_string_hash (SCM str)
{
  size_t len = scm_i_string_length (str);
  size_t i = 0;

  unsigned long h = 0;
  while (len-- > 0)
    h = (unsigned long) scm_i_string_ref (str, i++) + h * 37;

  scm_remember_upto_here_1 (str);
  return h;
}

/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
/* Dirk:FIXME:: scm_hasher could be made static. */

unsigned long
scm_hasher(SCM obj, unsigned long n, size_t d)
{
  switch (SCM_ITAG3 (obj)) {
  case scm_tc3_int_1:
  case scm_tc3_int_2:
    return SCM_I_INUM(obj) % n;   /* SCM_INUMP(obj) */
  case scm_tc3_imm24:
    if (SCM_CHARP(obj))
      return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
    switch (SCM_UNPACK (obj)) {
#ifndef SICP
    case SCM_UNPACK(SCM_EOL):
      d = 256;
      break;
#endif
    case SCM_UNPACK(SCM_BOOL_T):
      d = 257;
      break;
    case SCM_UNPACK(SCM_BOOL_F):
      d = 258;
      break;
    case SCM_UNPACK(SCM_EOF_VAL):
      d = 259;
      break;
    default:
      d = 263;		/* perhaps should be error */
    }
    return d % n;
  default:
    return 263 % n;	/* perhaps should be error */
  case scm_tc3_cons:
    switch SCM_TYP7(obj) {
    default:
      return 263 % n;
    case scm_tc7_smob:
      return 263 % n;
    case scm_tc7_number:
      switch SCM_TYP16 (obj) {
      case scm_tc16_big:
        return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
      case scm_tc16_real:
	{
	  double r = SCM_REAL_VALUE (obj);
	  if (floor (r) == r)
	    {
	      obj = scm_inexact_to_exact (obj);
	      return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
	    }
	}
        /* Fall through */
      case scm_tc16_complex:
      case scm_tc16_fraction:
	obj = scm_number_to_string (obj, scm_from_int (10));
        /* Fall through */
      }
      /* Fall through */
    case scm_tc7_string:
      {
	unsigned long hash =
	  scm_i_string_hash (obj) % n;
	scm_remember_upto_here_1 (obj);
	return hash;
      }
    case scm_tc7_symbol:
      return scm_i_symbol_hash (obj) % n;
    case scm_tc7_wvect:
    case scm_tc7_vector:
      {
	size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
	if (len > 5)
	  {
	    size_t i = d/2;
	    unsigned long h = 1;
	    while (i--)
	      {
		SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
		h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
	      }
	    return h;
	  }
	else
	  {
	    size_t i = len;
	    unsigned long h = (n)-1;
	    while (i--)
	      {
		SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
		h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
	      }
	    return h;
	  }
      }
    case scm_tcs_cons_imcar:
    case scm_tcs_cons_nimcar:
      if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
                     + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
      else return 1;
    case scm_tc7_port:
      return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
    case scm_tc7_program:
      return 262 % n;
    }
  }
}

unsigned long
scm_ihashq (SCM obj, unsigned long n)
{
  return (SCM_UNPACK (obj) >> 1) % n;
}

SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
	    "used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.  Note that\n"
	    "@code{hashq} may use internal addresses.  Thus two calls to\n"
	    "hashq where the keys are @code{eq?} are not guaranteed to\n"
	    "deliver the same value if the key object gets garbage collected\n"
	    "in between.  This can happen, for example with symbols:\n"
	    "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
	    "different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashq
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihashq (key, sz));
}
#undef FUNC_NAME

unsigned long
scm_ihashv (SCM obj, unsigned long n)
{
  if (SCM_CHARP(obj))
    return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */

  if (SCM_NUMP(obj))
    return (unsigned long) scm_hasher(obj, n, 10);
  else
    return SCM_UNPACK (obj) % n;
}

SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
	    "used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.  Note that\n"
	    "@code{(hashv key)} may use internal addresses.  Thus two calls\n"
	    "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
	    "deliver the same value if the key object gets garbage collected\n"
	    "in between.  This can happen, for example with symbols:\n"
	    "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
	    "different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashv
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihashv (key, sz));
}
#undef FUNC_NAME

unsigned long
scm_ihash (SCM obj, unsigned long n)
{
  return (unsigned long) scm_hasher (obj, n, 10);
}

SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
           (SCM key, SCM size),
	    "Determine a hash value for @var{key} that is suitable for\n"
	    "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
	    "is used as the equality predicate.  The function returns an\n"
	    "integer in the range 0 to @var{size} - 1.")
#define FUNC_NAME s_scm_hash
{
  unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
  return scm_from_ulong (scm_ihash (key, sz));
}
#undef FUNC_NAME

void
scm_init_hash ()
{
#include "libguile/hash.x"
}

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


code:
/* classes: h_files */

#ifndef SCM_HASH_H
#define SCM_HASH_H

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

#include "libguile/__scm.h"

SCM_API unsigned long scm_string_hash (const unsigned char *str, size_t len);
SCM_INTERNAL unsigned long scm_i_string_hash (SCM str);
SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);
SCM_API SCM scm_hashv (SCM obj, SCM n);
SCM_API unsigned long scm_ihash (SCM obj, unsigned long n);
SCM_API SCM scm_hash (SCM obj, SCM n);
SCM_INTERNAL void scm_init_hash (void);

#endif  /* SCM_HASH_H */

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