libguile/gsubr.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include <stdio.h>
  25 #include <stdarg.h>
  26
  27 #include "libguile/_scm.h"
  28 #include "libguile/gsubr.h"
  29 #include "libguile/foreign.h"
  30 #include "libguile/instructions.h"
  31 #include "libguile/objcodes.h"
  32 #include "libguile/srfi-4.h"
  33 #include "libguile/programs.h"
  34
  35 #include "libguile/private-options.h"
  36 \f
  37 /*
  38  * gsubr.c
  39  * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  40  * and rest arguments.
  41  */
  42
  43 /* #define GSUBR_TEST */
  44
  45 \f
  46
  47 /* OK here goes nothing: we're going to define VM assembly trampolines for
  48    invoking subrs, along with their meta-information, and then wrap them into
  49    statically allocated objcode values. Ready? Right!
  50 */
  51
  52 /* There's a maximum of 10 args, so the number of possible combinations is:
  53    (REQ-OPT-REST)
  54    for 0 args: 1 (000) (1 + 0)
  55    for 1 arg: 3 (100, 010, 001) (2 + 1)
  56    for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
  57    for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
  58    for N args: 2N+1
  59
  60    and the index at which N args starts:
  61    for 0 args: 0
  62    for 1 args: 1
  63    for 2 args: 4
  64    for 3 args: 9
  65    for N args: N^2
  66
  67    One can prove this:
  68
  69    (1 + 3 + 5 + ... + (2N+1))
  70      = ((2N+1)+1)/2 * (N+1)
  71      = 2(N+1)/2 * (N+1)
  72      = (N+1)^2
  73
  74    Thus the total sum is 11^2 = 121. Let's just generate all of them as
  75    read-only data.
  76 */
  77
  78 #ifdef WORDS_BIGENDIAN
  79 #define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
  80 #define META_HEADER    0, 0, 0, 32, 0, 0, 0, 0
  81 #else
  82 #define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
  83 #define META_HEADER    32, 0, 0, 0, 0, 0, 0, 0
  84 #endif
  85
  86 /* A: req; B: opt; C: rest */
  87 #define A(nreq)                                                         \
  88   OBJCODE_HEADER,                                                       \
  89   /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */  \
  90   /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
  91   /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
  92   /* 7 */ scm_op_nop,                                                   \
  93   /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
  94   /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
  95   /* 16 */ META (3, 7, nreq, 0, 0)
  96
  97 #define B(nopt)                                                         \
  98   OBJCODE_HEADER,                                                       \
  99   /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
 100   /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */  \
 101   /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 102   /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
 103   /* 10 */ scm_op_nop, scm_op_nop,                                      \
 104   /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
 105   /* 16 */ META (6, 10, 0, nopt, 0)
 106
 107 #define C()                                                             \
 108   OBJCODE_HEADER,                                                       \
 109   /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */       \
 110   /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 111   /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
 112   /* 7 */ scm_op_nop,                                                   \
 113   /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,               \
 114   /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
 115   /* 16 */ META (3, 7, 0, 0, 1)
 116
 117 #define AB(nreq, nopt)                                                  \
 118   OBJCODE_HEADER,                                                       \
 119   /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
 120   /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
 121   /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
 122   /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 123   /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as well) */ \
 124   /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
 125   /* 16 */ META (9, 13, nreq, nopt, 0)
 126
 127 #define AC(nreq)                                                        \
 128   OBJCODE_HEADER,                                                       \
 129   /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
 130   /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */               \
 131   /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 132   /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */ \
 133   /* 10 */ scm_op_nop, scm_op_nop,                                      \
 134   /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
 135   /* 16 */ META (6, 10, nreq, 0, 1)
 136
 137 #define BC(nopt)                                                        \
 138   OBJCODE_HEADER,                                                       \
 139   /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */          \
 140   /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */               \
 141   /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 142   /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */ \
 143   /* 10 */ scm_op_nop, scm_op_nop,                                      \
 144   /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop,              \
 145   /* 16 */ META (6, 10, 0, nopt, 1)
 146
 147 #define ABC(nreq, nopt)                                                 \
 148   OBJCODE_HEADER,                                                       \
 149   /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */  \
 150   /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */     \
 151   /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */          \
 152   /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr pointer */ \
 153   /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as well) */ \
 154   /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop,                          \
 155   /* 16 */ META (9, 13, nreq, nopt, 1)
 156
 157 #define META(start, end, nreq, nopt, rest)                              \
 158   META_HEADER,                                                          \
 159   /* 0 */ scm_op_make_eol, /* bindings */                               \
 160   /* 1 */ scm_op_make_eol, /* sources */                                \
 161   /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N to ip N */ \
 162   /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */    \
 163   /* 8 */ scm_op_make_int8, nopt, /* N optionals */                     \
 164   /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */ \
 165   /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */         \
 166   /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one list */ \
 167   /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
 168   /* 25 */ scm_op_object_ref, 1, /* the name from the object table */   \
 169   /* 27 */ scm_op_cons, /* make a pair for the properties */            \
 170   /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list */ \
 171   /* 31 */ scm_op_return /* and return */                               \
 172   /* 32 */
 173
 174 /*
 175  (defun generate-bytecode (n)
 176    "Generate bytecode for N arguments"
 177    (interactive "p")
 178    (insert (format "/\* %d arguments *\/\n  " n))
 179    (let ((nreq n))
 180      (while (<= 0 nreq)
 181        (let ((nopt (- n nreq)))
 182          (insert
 183           (if (< 0 nreq)
 184               (if (< 0 nopt)
 185                   (format "AB(%d,%d), " nreq nopt)
 186                   (format "A(%d), " nreq))
 187               (if (< 0 nopt)
 188                   (format "B(%d), " nopt)
 189                   (format "A(0), "))))
 190          (setq nreq (1- nreq))))
 191      (insert "\n  ")
 192      (setq nreq (1- n))
 193      (while (<= 0 nreq)
 194        (let ((nopt (- n nreq 1)))
 195          (insert
 196           (if (< 0 nreq)
 197               (if (< 0 nopt)
 198                   (format "ABC(%d,%d), " nreq nopt)
 199                   (format "AC(%d), " nreq))
 200               (if (< 0 nopt)
 201                   (format "BC(%d), " nopt)
 202                   (format "C(), "))))
 203          (setq nreq (1- nreq))))
 204      (insert "\n\n  ")))
 205
 206  (defun generate-bytecodes (n)
 207    "Generate bytecodes for up to N arguments"
 208    (interactive "p")
 209    (let ((i 0))
 210      (while (<= i n)
 211        (generate-bytecode i)
 212        (setq i (1+ i)))))
 213 */
 214 static const struct
 215 {
 216   scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way */
 217   const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
 218                                  + sizeof (struct scm_objcode) + 32)];
 219 } raw_bytecode = {
 220   0,
 221   {
 222     /* C-u 1 0 M-x generate-bytecodes RET */
 223     /* 0 arguments */
 224     A(0),
 225
 226     /* 1 arguments */
 227     A(1), B(1),
 228     C(),
 229
 230     /* 2 arguments */
 231     A(2), AB(1,1), B(2),
 232     AC(1), BC(1),
 233
 234     /* 3 arguments */
 235     A(3), AB(2,1), AB(1,2), B(3),
 236     AC(2), ABC(1,1), BC(2),
 237
 238     /* 4 arguments */
 239     A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
 240     AC(3), ABC(2,1), ABC(1,2), BC(3),
 241
 242     /* 5 arguments */
 243     A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
 244     AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
 245
 246     /* 6 arguments */
 247     A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
 248     AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
 249
 250     /* 7 arguments */
 251     A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
 252     AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
 253
 254     /* 8 arguments */
 255     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),
 256     AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
 257
 258     /* 9 arguments */
 259     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),
 260     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),
 261
 262     /* 10 arguments */
 263     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),
 264     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)
 265   }
 266 };
 267
 268 #undef A
 269 #undef B
 270 #undef C
 271 #undef AB
 272 #undef AC
 273 #undef BC
 274 #undef ABC
 275 #undef OBJCODE_HEADER
 276 #undef META_HEADER
 277 #undef META
 278
 279 /*
 280  ;; (nargs * nargs) + nopt + rest * (nargs + 1)
 281  (defun generate-objcode-cells-helper (n)
 282    "Generate objcode cells for N arguments"
 283    (interactive "p")
 284    (insert (format "    /\* %d arguments *\/\n" n))
 285    (let ((nreq n))
 286      (while (<= 0 nreq)
 287        (let ((nopt (- n nreq)))
 288          (insert
 289           (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
 290                   (* (+ 4 4 16 4 4 32)
 291                      (+ (* n n) nopt))))
 292          (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
 293          (setq nreq (1- nreq))))
 294      (insert "\n")
 295      (setq nreq (1- n))
 296      (while (<= 0 nreq)
 297        (let ((nopt (- n nreq 1)))
 298          (insert
 299           (format "    { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + %d) },\n"
 300                   (* (+ 4 4 16 4 4 32)
 301                      (+ (* n n) nopt n 1))))
 302          (insert "    { SCM_BOOL_F, SCM_PACK (0) },\n")
 303          (setq nreq (1- nreq))))
 304      (insert "\n")))
 305
 306  (defun generate-objcode-cells (n)
 307    "Generate objcode cells for up to N arguments"
 308    (interactive "p")
 309    (let ((i 0))
 310      (while (<= i n)
 311        (generate-objcode-cells-helper i)
 312        (setq i (1+ i)))))
 313 */
 314
 315 #define STATIC_OBJCODE_TAG                                      \
 316   SCM_PACK (SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0))
 317
 318 static const struct
 319 {
 320   scm_t_uint64 dummy; /* alignment */
 321   scm_t_cell cells[121 * 2]; /* 11*11 double cells */
 322 } objcode_cells = {
 323   0,
 324   /* C-u 1 0 M-x generate-objcode-cells RET */
 325   {
 326     /* 0 arguments */
 327     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
 328     { SCM_BOOL_F, SCM_PACK (0) },
 329
 330
 331     /* 1 arguments */
 332     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
 333     { SCM_BOOL_F, SCM_PACK (0) },
 334     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
 335     { SCM_BOOL_F, SCM_PACK (0) },
 336
 337     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
 338     { SCM_BOOL_F, SCM_PACK (0) },
 339
 340     /* 2 arguments */
 341     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
 342     { SCM_BOOL_F, SCM_PACK (0) },
 343     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
 344     { SCM_BOOL_F, SCM_PACK (0) },
 345     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
 346     { SCM_BOOL_F, SCM_PACK (0) },
 347
 348     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
 349     { SCM_BOOL_F, SCM_PACK (0) },
 350     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
 351     { SCM_BOOL_F, SCM_PACK (0) },
 352
 353     /* 3 arguments */
 354     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
 355     { SCM_BOOL_F, SCM_PACK (0) },
 356     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
 357     { SCM_BOOL_F, SCM_PACK (0) },
 358     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
 359     { SCM_BOOL_F, SCM_PACK (0) },
 360     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
 361     { SCM_BOOL_F, SCM_PACK (0) },
 362
 363     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
 364     { SCM_BOOL_F, SCM_PACK (0) },
 365     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
 366     { SCM_BOOL_F, SCM_PACK (0) },
 367     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
 368     { SCM_BOOL_F, SCM_PACK (0) },
 369
 370     /* 4 arguments */
 371     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
 372     { SCM_BOOL_F, SCM_PACK (0) },
 373     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
 374     { SCM_BOOL_F, SCM_PACK (0) },
 375     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
 376     { SCM_BOOL_F, SCM_PACK (0) },
 377     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
 378     { SCM_BOOL_F, SCM_PACK (0) },
 379     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
 380     { SCM_BOOL_F, SCM_PACK (0) },
 381
 382     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
 383     { SCM_BOOL_F, SCM_PACK (0) },
 384     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
 385     { SCM_BOOL_F, SCM_PACK (0) },
 386     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
 387     { SCM_BOOL_F, SCM_PACK (0) },
 388     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
 389     { SCM_BOOL_F, SCM_PACK (0) },
 390
 391     /* 5 arguments */
 392     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
 393     { SCM_BOOL_F, SCM_PACK (0) },
 394     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
 395     { SCM_BOOL_F, SCM_PACK (0) },
 396     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
 397     { SCM_BOOL_F, SCM_PACK (0) },
 398     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
 399     { SCM_BOOL_F, SCM_PACK (0) },
 400     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
 401     { SCM_BOOL_F, SCM_PACK (0) },
 402     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
 403     { SCM_BOOL_F, SCM_PACK (0) },
 404
 405     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
 406     { SCM_BOOL_F, SCM_PACK (0) },
 407     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
 408     { SCM_BOOL_F, SCM_PACK (0) },
 409     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
 410     { SCM_BOOL_F, SCM_PACK (0) },
 411     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
 412     { SCM_BOOL_F, SCM_PACK (0) },
 413     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
 414     { SCM_BOOL_F, SCM_PACK (0) },
 415
 416     /* 6 arguments */
 417     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
 418     { SCM_BOOL_F, SCM_PACK (0) },
 419     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
 420     { SCM_BOOL_F, SCM_PACK (0) },
 421     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
 422     { SCM_BOOL_F, SCM_PACK (0) },
 423     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
 424     { SCM_BOOL_F, SCM_PACK (0) },
 425     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
 426     { SCM_BOOL_F, SCM_PACK (0) },
 427     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
 428     { SCM_BOOL_F, SCM_PACK (0) },
 429     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
 430     { SCM_BOOL_F, SCM_PACK (0) },
 431
 432     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
 433     { SCM_BOOL_F, SCM_PACK (0) },
 434     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
 435     { SCM_BOOL_F, SCM_PACK (0) },
 436     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
 437     { SCM_BOOL_F, SCM_PACK (0) },
 438     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
 439     { SCM_BOOL_F, SCM_PACK (0) },
 440     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
 441     { SCM_BOOL_F, SCM_PACK (0) },
 442     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
 443     { SCM_BOOL_F, SCM_PACK (0) },
 444
 445     /* 7 arguments */
 446     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
 447     { SCM_BOOL_F, SCM_PACK (0) },
 448     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
 449     { SCM_BOOL_F, SCM_PACK (0) },
 450     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
 451     { SCM_BOOL_F, SCM_PACK (0) },
 452     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
 453     { SCM_BOOL_F, SCM_PACK (0) },
 454     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
 455     { SCM_BOOL_F, SCM_PACK (0) },
 456     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
 457     { SCM_BOOL_F, SCM_PACK (0) },
 458     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
 459     { SCM_BOOL_F, SCM_PACK (0) },
 460     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
 461     { SCM_BOOL_F, SCM_PACK (0) },
 462
 463     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
 464     { SCM_BOOL_F, SCM_PACK (0) },
 465     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
 466     { SCM_BOOL_F, SCM_PACK (0) },
 467     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
 468     { SCM_BOOL_F, SCM_PACK (0) },
 469     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
 470     { SCM_BOOL_F, SCM_PACK (0) },
 471     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
 472     { SCM_BOOL_F, SCM_PACK (0) },
 473     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
 474     { SCM_BOOL_F, SCM_PACK (0) },
 475     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
 476     { SCM_BOOL_F, SCM_PACK (0) },
 477
 478     /* 8 arguments */
 479     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
 480     { SCM_BOOL_F, SCM_PACK (0) },
 481     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
 482     { SCM_BOOL_F, SCM_PACK (0) },
 483     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
 484     { SCM_BOOL_F, SCM_PACK (0) },
 485     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
 486     { SCM_BOOL_F, SCM_PACK (0) },
 487     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
 488     { SCM_BOOL_F, SCM_PACK (0) },
 489     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
 490     { SCM_BOOL_F, SCM_PACK (0) },
 491     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
 492     { SCM_BOOL_F, SCM_PACK (0) },
 493     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
 494     { SCM_BOOL_F, SCM_PACK (0) },
 495     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
 496     { SCM_BOOL_F, SCM_PACK (0) },
 497
 498     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
 499     { SCM_BOOL_F, SCM_PACK (0) },
 500     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
 501     { SCM_BOOL_F, SCM_PACK (0) },
 502     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
 503     { SCM_BOOL_F, SCM_PACK (0) },
 504     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
 505     { SCM_BOOL_F, SCM_PACK (0) },
 506     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
 507     { SCM_BOOL_F, SCM_PACK (0) },
 508     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
 509     { SCM_BOOL_F, SCM_PACK (0) },
 510     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
 511     { SCM_BOOL_F, SCM_PACK (0) },
 512     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
 513     { SCM_BOOL_F, SCM_PACK (0) },
 514
 515     /* 9 arguments */
 516     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
 517     { SCM_BOOL_F, SCM_PACK (0) },
 518     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
 519     { SCM_BOOL_F, SCM_PACK (0) },
 520     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
 521     { SCM_BOOL_F, SCM_PACK (0) },
 522     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
 523     { SCM_BOOL_F, SCM_PACK (0) },
 524     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
 525     { SCM_BOOL_F, SCM_PACK (0) },
 526     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
 527     { SCM_BOOL_F, SCM_PACK (0) },
 528     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
 529     { SCM_BOOL_F, SCM_PACK (0) },
 530     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
 531     { SCM_BOOL_F, SCM_PACK (0) },
 532     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
 533     { SCM_BOOL_F, SCM_PACK (0) },
 534     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
 535     { SCM_BOOL_F, SCM_PACK (0) },
 536
 537     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
 538     { SCM_BOOL_F, SCM_PACK (0) },
 539     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
 540     { SCM_BOOL_F, SCM_PACK (0) },
 541     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
 542     { SCM_BOOL_F, SCM_PACK (0) },
 543     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
 544     { SCM_BOOL_F, SCM_PACK (0) },
 545     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
 546     { SCM_BOOL_F, SCM_PACK (0) },
 547     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
 548     { SCM_BOOL_F, SCM_PACK (0) },
 549     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
 550     { SCM_BOOL_F, SCM_PACK (0) },
 551     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
 552     { SCM_BOOL_F, SCM_PACK (0) },
 553     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
 554     { SCM_BOOL_F, SCM_PACK (0) },
 555
 556     /* 10 arguments */
 557     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
 558     { SCM_BOOL_F, SCM_PACK (0) },
 559     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
 560     { SCM_BOOL_F, SCM_PACK (0) },
 561     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
 562     { SCM_BOOL_F, SCM_PACK (0) },
 563     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
 564     { SCM_BOOL_F, SCM_PACK (0) },
 565     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
 566     { SCM_BOOL_F, SCM_PACK (0) },
 567     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
 568     { SCM_BOOL_F, SCM_PACK (0) },
 569     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
 570     { SCM_BOOL_F, SCM_PACK (0) },
 571     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
 572     { SCM_BOOL_F, SCM_PACK (0) },
 573     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
 574     { SCM_BOOL_F, SCM_PACK (0) },
 575     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
 576     { SCM_BOOL_F, SCM_PACK (0) },
 577     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
 578     { SCM_BOOL_F, SCM_PACK (0) },
 579
 580     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
 581     { SCM_BOOL_F, SCM_PACK (0) },
 582     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
 583     { SCM_BOOL_F, SCM_PACK (0) },
 584     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
 585     { SCM_BOOL_F, SCM_PACK (0) },
 586     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
 587     { SCM_BOOL_F, SCM_PACK (0) },
 588     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
 589     { SCM_BOOL_F, SCM_PACK (0) },
 590     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
 591     { SCM_BOOL_F, SCM_PACK (0) },
 592     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
 593     { SCM_BOOL_F, SCM_PACK (0) },
 594     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
 595     { SCM_BOOL_F, SCM_PACK (0) },
 596     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
 597     { SCM_BOOL_F, SCM_PACK (0) },
 598     { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
 599     { SCM_BOOL_F, SCM_PACK (0) }
 600   }
 601 };
 602
 603 /*
 604  (defun generate-objcode (n)
 605    "Generate objcode for N arguments"
 606    (interactive "p")
 607    (insert (format "  /\* %d arguments *\/\n" n))
 608    (let ((i (* n n)))
 609      (while (< i (* (1+ n) (1+ n)))
 610        (insert (format "  SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
 611        (setq i (1+ i)))
 612      (insert "\n")))
 613
 614  (defun generate-objcodes (n)
 615    "Generate objcodes for up to N arguments"
 616    (interactive "p")
 617    (let ((i 0))
 618      (while (<= i n)
 619        (generate-objcode i)
 620        (setq i (1+ i)))))
 621 */
 622 static const SCM scm_subr_objcode_trampolines[121] = {
 623   /* C-u 1 0 M-x generate-objcodes RET */
 624   /* 0 arguments */
 625   SCM_PACK (objcode_cells.cells+0),
 626
 627   /* 1 arguments */
 628   SCM_PACK (objcode_cells.cells+2),
 629   SCM_PACK (objcode_cells.cells+4),
 630   SCM_PACK (objcode_cells.cells+6),
 631
 632   /* 2 arguments */
 633   SCM_PACK (objcode_cells.cells+8),
 634   SCM_PACK (objcode_cells.cells+10),
 635   SCM_PACK (objcode_cells.cells+12),
 636   SCM_PACK (objcode_cells.cells+14),
 637   SCM_PACK (objcode_cells.cells+16),
 638
 639   /* 3 arguments */
 640   SCM_PACK (objcode_cells.cells+18),
 641   SCM_PACK (objcode_cells.cells+20),
 642   SCM_PACK (objcode_cells.cells+22),
 643   SCM_PACK (objcode_cells.cells+24),
 644   SCM_PACK (objcode_cells.cells+26),
 645   SCM_PACK (objcode_cells.cells+28),
 646   SCM_PACK (objcode_cells.cells+30),
 647
 648   /* 4 arguments */
 649   SCM_PACK (objcode_cells.cells+32),
 650   SCM_PACK (objcode_cells.cells+34),
 651   SCM_PACK (objcode_cells.cells+36),
 652   SCM_PACK (objcode_cells.cells+38),
 653   SCM_PACK (objcode_cells.cells+40),
 654   SCM_PACK (objcode_cells.cells+42),
 655   SCM_PACK (objcode_cells.cells+44),
 656   SCM_PACK (objcode_cells.cells+46),
 657   SCM_PACK (objcode_cells.cells+48),
 658
 659   /* 5 arguments */
 660   SCM_PACK (objcode_cells.cells+50),
 661   SCM_PACK (objcode_cells.cells+52),
 662   SCM_PACK (objcode_cells.cells+54),
 663   SCM_PACK (objcode_cells.cells+56),
 664   SCM_PACK (objcode_cells.cells+58),
 665   SCM_PACK (objcode_cells.cells+60),
 666   SCM_PACK (objcode_cells.cells+62),
 667   SCM_PACK (objcode_cells.cells+64),
 668   SCM_PACK (objcode_cells.cells+66),
 669   SCM_PACK (objcode_cells.cells+68),
 670   SCM_PACK (objcode_cells.cells+70),
 671
 672   /* 6 arguments */
 673   SCM_PACK (objcode_cells.cells+72),
 674   SCM_PACK (objcode_cells.cells+74),
 675   SCM_PACK (objcode_cells.cells+76),
 676   SCM_PACK (objcode_cells.cells+78),
 677   SCM_PACK (objcode_cells.cells+80),
 678   SCM_PACK (objcode_cells.cells+82),
 679   SCM_PACK (objcode_cells.cells+84),
 680   SCM_PACK (objcode_cells.cells+86),
 681   SCM_PACK (objcode_cells.cells+88),
 682   SCM_PACK (objcode_cells.cells+90),
 683   SCM_PACK (objcode_cells.cells+92),
 684   SCM_PACK (objcode_cells.cells+94),
 685   SCM_PACK (objcode_cells.cells+96),
 686
 687   /* 7 arguments */
 688   SCM_PACK (objcode_cells.cells+98),
 689   SCM_PACK (objcode_cells.cells+100),
 690   SCM_PACK (objcode_cells.cells+102),
 691   SCM_PACK (objcode_cells.cells+104),
 692   SCM_PACK (objcode_cells.cells+106),
 693   SCM_PACK (objcode_cells.cells+108),
 694   SCM_PACK (objcode_cells.cells+110),
 695   SCM_PACK (objcode_cells.cells+112),
 696   SCM_PACK (objcode_cells.cells+114),
 697   SCM_PACK (objcode_cells.cells+116),
 698   SCM_PACK (objcode_cells.cells+118),
 699   SCM_PACK (objcode_cells.cells+120),
 700   SCM_PACK (objcode_cells.cells+122),
 701   SCM_PACK (objcode_cells.cells+124),
 702   SCM_PACK (objcode_cells.cells+126),
 703
 704   /* 8 arguments */
 705   SCM_PACK (objcode_cells.cells+128),
 706   SCM_PACK (objcode_cells.cells+130),
 707   SCM_PACK (objcode_cells.cells+132),
 708   SCM_PACK (objcode_cells.cells+134),
 709   SCM_PACK (objcode_cells.cells+136),
 710   SCM_PACK (objcode_cells.cells+138),
 711   SCM_PACK (objcode_cells.cells+140),
 712   SCM_PACK (objcode_cells.cells+142),
 713   SCM_PACK (objcode_cells.cells+144),
 714   SCM_PACK (objcode_cells.cells+146),
 715   SCM_PACK (objcode_cells.cells+148),
 716   SCM_PACK (objcode_cells.cells+150),
 717   SCM_PACK (objcode_cells.cells+152),
 718   SCM_PACK (objcode_cells.cells+154),
 719   SCM_PACK (objcode_cells.cells+156),
 720   SCM_PACK (objcode_cells.cells+158),
 721   SCM_PACK (objcode_cells.cells+160),
 722
 723   /* 9 arguments */
 724   SCM_PACK (objcode_cells.cells+162),
 725   SCM_PACK (objcode_cells.cells+164),
 726   SCM_PACK (objcode_cells.cells+166),
 727   SCM_PACK (objcode_cells.cells+168),
 728   SCM_PACK (objcode_cells.cells+170),
 729   SCM_PACK (objcode_cells.cells+172),
 730   SCM_PACK (objcode_cells.cells+174),
 731   SCM_PACK (objcode_cells.cells+176),
 732   SCM_PACK (objcode_cells.cells+178),
 733   SCM_PACK (objcode_cells.cells+180),
 734   SCM_PACK (objcode_cells.cells+182),
 735   SCM_PACK (objcode_cells.cells+184),
 736   SCM_PACK (objcode_cells.cells+186),
 737   SCM_PACK (objcode_cells.cells+188),
 738   SCM_PACK (objcode_cells.cells+190),
 739   SCM_PACK (objcode_cells.cells+192),
 740   SCM_PACK (objcode_cells.cells+194),
 741   SCM_PACK (objcode_cells.cells+196),
 742   SCM_PACK (objcode_cells.cells+198),
 743
 744   /* 10 arguments */
 745   SCM_PACK (objcode_cells.cells+200),
 746   SCM_PACK (objcode_cells.cells+202),
 747   SCM_PACK (objcode_cells.cells+204),
 748   SCM_PACK (objcode_cells.cells+206),
 749   SCM_PACK (objcode_cells.cells+208),
 750   SCM_PACK (objcode_cells.cells+210),
 751   SCM_PACK (objcode_cells.cells+212),
 752   SCM_PACK (objcode_cells.cells+214),
 753   SCM_PACK (objcode_cells.cells+216),
 754   SCM_PACK (objcode_cells.cells+218),
 755   SCM_PACK (objcode_cells.cells+220),
 756   SCM_PACK (objcode_cells.cells+222),
 757   SCM_PACK (objcode_cells.cells+224),
 758   SCM_PACK (objcode_cells.cells+226),
 759   SCM_PACK (objcode_cells.cells+228),
 760   SCM_PACK (objcode_cells.cells+230),
 761   SCM_PACK (objcode_cells.cells+232),
 762   SCM_PACK (objcode_cells.cells+234),
 763   SCM_PACK (objcode_cells.cells+236),
 764   SCM_PACK (objcode_cells.cells+238),
 765   SCM_PACK (objcode_cells.cells+240)
 766 };
 767
 768 /* (nargs * nargs) + nopt + rest * (nargs + 1) */
 769 #define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest)                     \
 770   scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
 771                                + nopt + rest * (nreq + nopt + rest + 1)]
 772
 773 SCM
 774 scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
 775                              unsigned int rest)
 776 {
 777   if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
 778     scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
 779
 780   return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
 781 }
 782
 783 static SCM
 784 create_gsubr (int define, const char *name,
 785               unsigned int nreq, unsigned int nopt, unsigned int rest,
 786               SCM (*fcn) (), SCM *generic_loc)
 787 {
 788   SCM ret;
 789   SCM sname;
 790   SCM table;
 791   scm_t_bits flags;
 792
 793   /* make objtable */
 794   sname = scm_from_locale_symbol (name);
 795   table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
 796   SCM_SIMPLE_VECTOR_SET (table, 0, scm_from_pointer (fcn, NULL));
 797   SCM_SIMPLE_VECTOR_SET (table, 1, sname);
 798   if (generic_loc)
 799     SCM_SIMPLE_VECTOR_SET (table, 2,
 800                            scm_from_pointer (generic_loc, NULL));
 801
 802   /* make program */
 803   ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
 804                           table, SCM_BOOL_F);
 805
 806   /* set flags */
 807   flags = SCM_F_PROGRAM_IS_PRIMITIVE;
 808   flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
 809   SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
 810
 811   /* define, if needed */
 812   if (define)
 813     scm_define (sname, ret);
 814
 815   /* et voila. */
 816   return ret;
 817 }
 818
 819 SCM
 820 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 821 {
 822   return create_gsubr (0, name, req, opt, rst, fcn, NULL);
 823 }
 824
 825 SCM
 826 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 827 {
 828   return create_gsubr (1, name, req, opt, rst, fcn, NULL);
 829 }
 830
 831 SCM
 832 scm_c_make_gsubr_with_generic (const char *name,
 833                                int req,
 834                                int opt,
 835                                int rst,
 836                                SCM (*fcn)(),
 837                                SCM *gf)
 838 {
 839   return create_gsubr (0, name, req, opt, rst, fcn, gf);
 840 }
 841
 842 SCM
 843 scm_c_define_gsubr_with_generic (const char *name,
 844                                  int req,
 845                                  int opt,
 846                                  int rst,
 847                                  SCM (*fcn)(),
 848                                  SCM *gf)
 849 {
 850   return create_gsubr (1, name, req, opt, rst, fcn, gf);
 851 }
 852
 853
 854 #ifdef GSUBR_TEST
 855 /* A silly example, taking 2 required args, 1 optional, and
 856    a scm_list of rest args
 857    */
 858 SCM
 859 gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
 860 {
 861   scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
 862   scm_display(req1, scm_cur_outp);
 863   scm_puts ("\n req2: ", scm_cur_outp);
 864   scm_display(req2, scm_cur_outp);
 865   scm_puts ("\n opt: ", scm_cur_outp);
 866   scm_display(opt, scm_cur_outp);
 867   scm_puts ("\n rest: ", scm_cur_outp);
 868   scm_display(rst, scm_cur_outp);
 869   scm_newline(scm_cur_outp);
 870   return SCM_UNSPECIFIED;
 871 }
 872 #endif
 873
 874
 875 void
 876 scm_init_gsubr()
 877 {
 878 #ifdef GSUBR_TEST
 879   scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
 880 #endif
 881
 882 #include "libguile/gsubr.x"
 883 }
 884
 885 /*
 886   Local Variables:
 887   c-file-style: "gnu"
 888   End:
 889 */