summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/goops.c5
-rw-r--r--libguile/gsubr.c793
-rw-r--r--libguile/gsubr.h34
-rw-r--r--libguile/objcodes.h1
-rw-r--r--libguile/procprop.c3
-rw-r--r--libguile/snarf.h77
7 files changed, 852 insertions, 63 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h
index c3aa8ff85..f80ec8366 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -79,6 +79,8 @@
#include "libguile/boolean.h" /* Everyone wonders about the truth. */
#include "libguile/threads.h" /* You are not alone. */
#include "libguile/snarf.h" /* Everyone snarfs. */
+#include "libguile/foreign.h" /* Snarfing needs the foreign data structures. */
+#include "libguile/programs.h" /* ... and program.h. */
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"
diff --git a/libguile/goops.c b/libguile/goops.c
index ca850fa8c..97129851b 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -254,7 +254,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
else
return scm_class_procedure;
case scm_tc7_program:
- return scm_class_procedure;
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ return scm_class_primitive_generic;
+ else
+ return scm_class_procedure;
case scm_tc7_smob:
{
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 70be51b91..becbe88d2 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* 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
@@ -27,11 +27,12 @@
#include <stdarg.h>
#include "libguile/_scm.h"
-#include "libguile/procprop.h"
-#include "libguile/root.h"
-
#include "libguile/gsubr.h"
-#include "libguile/deprecation.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"
@@ -43,38 +44,780 @@
/* #define GSUBR_TEST */
-SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
+
+
+/* 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 req, unsigned int opt, unsigned int rst,
+ unsigned int nreq, unsigned int nopt, unsigned int rest,
SCM (*fcn) (), SCM *generic_loc)
{
- SCM subr;
+ SCM ret;
SCM sname;
- SCM *meta_info;
- unsigned type;
+ SCM table;
+ scm_t_bits flags;
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
-
- meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
+ /* make objtable */
sname = scm_from_locale_symbol (name);
- meta_info[0] = sname;
- meta_info[1] = SCM_EOL; /* properties */
+ table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (table, 0,
+ scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
+ &fcn, 0, NULL));
+ SCM_SIMPLE_VECTOR_SET (table, 1, sname);
+ if (generic_loc)
+ SCM_SIMPLE_VECTOR_SET (table, 2,
+ scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
+ &generic_loc, 0, NULL));
+
+ /* make program */
+ ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
+ table, SCM_BOOL_F);
- subr = scm_double_cell ((scm_t_bits) scm_tc7_gsubr | (type << 8U),
- (scm_t_bits) fcn,
- (scm_t_bits) generic_loc,
- (scm_t_bits) meta_info);
+ /* set flags */
+ 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, subr);
+ scm_define (sname, ret);
- return subr;
+ /* et voila. */
+ return ret;
}
SCM
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 74a08a242..0f9d2acd9 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -3,7 +3,7 @@
#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* 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
@@ -28,28 +28,24 @@
-/* Subrs
- */
-
-#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr)
-#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PRIMITIVE_P (x) && SCM_SUBR_GENERIC (x))
-#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
-#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
-#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
-#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
-#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
-#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
-#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g))
+SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
+ unsigned int nopt,
+ unsigned int rest);
-/* Return the most suitable subr type for a subr with REQ required arguments,
- OPT optional arguments, and REST (0 or 1) arguments. This has to be in
- sync with `create_gsubr ()'. */
-#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
- (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
+/* Subrs
+ */
-
+#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr)
+#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
+
+#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void*)))
+#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_GENERIC(x) \
+ (SCM_FOREIGN_OBJECT_REF (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2), SCM*))
+#define SCM_SET_SUBR_GENERIC(x, g) \
+ (*SCM_SUBR_GENERIC (x) = (g))
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 498c606ba..2bff9aae2 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -38,6 +38,7 @@ struct scm_objcode
#define SCM_F_OBJCODE_IS_MMAP (1<<0)
#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_STATIC (1<<3)
#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_objcode)
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 7cfd2e64f..24d65dce7 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -40,6 +40,7 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM props;
static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
diff --git a/libguile/snarf.h b/libguile/snarf.h
index a00f5b7bc..5b5a19bff 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -99,22 +99,37 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
/* Static subr allocation. */
+/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
-SCM_SNARF_HERE( \
+SCM_SNARF_HERE( \
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_SUBR (scm_i_paste (FNAME, __subr), \
- scm_i_paste (FNAME, __name), \
- REQ, OPT, VAR, &FNAME); \
+ static const scm_t_bits scm_i_paste (FNAME, __subr_ptr) = \
+ (scm_t_bits) &FNAME; /* the subr */ \
+ SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
+ scm_i_paste (FNAME, __subr_ptr)); \
+ SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
+ /* FIXME: directly be the foreign */ \
+ SCM_BOOL_F); \
+ /* FIXME: be immutable. grr */ \
+ SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
+ SCM_BOOL_F, \
+ SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
+ SCM_BOOL_F); \
SCM FNAME ARGLIST \
) \
SCM_SNARF_INIT( \
+ /* Initialize the foreign. */ \
+ scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME, __subr_foreign); \
/* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+ scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
+ /* Initialize the objcode trampoline. */ \
+ SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
+ scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
\
/* Define the subr. */ \
- scm_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr)); \
+ scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
) \
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
@@ -297,6 +312,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+#define SCM_IMMUTABLE_CELL(c_name, car, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
+ c_name ## _raw_scell = \
+ { \
+ SCM_PACK (car), \
+ SCM_PACK (cdr) \
+ }; \
+ static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell)
+
#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
c_name ## _raw_cell [2] = \
@@ -306,6 +330,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
}; \
static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \
+ c_name ## _raw_cell [2] = \
+ { \
+ { SCM_PACK (car), SCM_PACK (cbr) }, \
+ { SCM_PACK (ccr), SCM_PACK (cdr) } \
+ }; \
+ static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+
#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \
static SCM_UNUSED const \
struct \
@@ -330,17 +363,27 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_SUBR(c_name, name, req, opt, rest, fcn) \
- static SCM_UNUSED SCM scm_i_paste (c_name, _meta_info)[2] = \
- { \
- SCM_BOOL_F, /* The name, initialized at run-time. */ \
- SCM_EOL /* The procedure properties. */ \
- }; \
- SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
- SCM_SUBR_ARITY_TO_TYPE (req, opt, rest), \
- (scm_t_bits) fcn, \
- (scm_t_bits) 0 /* no generic */, \
- (scm_t_bits) & scm_i_paste (c_name, _meta_info));
+#define SCM_IMMUTABLE_FOREIGN(c_name, loc) \
+ SCM_IMMUTABLE_CELL (c_name, \
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \
+ &loc)
+
+/* for primitive-generics, add a foreign to the end */
+#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
+ static SCM_ALIGNED (8) SCM c_name[4] = \
+ { \
+ SCM_PACK (scm_tc7_vector | (2 << 8)), \
+ SCM_PACK (0), \
+ foreign, \
+ SCM_BOOL_F, /* the name */ \
+ }; \
+
+#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
+ SCM_STATIC_DOUBLE_CELL (c_name, \
+ scm_tc7_program, \
+ (scm_t_bits) objcode, \
+ (scm_t_bits) objtable, \
+ (scm_t_bits) freevars)
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
View Lorry Controller Status