123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384 |
- #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/srfi-4.h"
- #include "libguile/programs.h"
- #include "libguile/private-options.h"
- #define A(nreq) \
- SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0, \
- 0
- #define B(nopt) \
- SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), \
- SCM_PACK_OP_24 (alloc_frame, nopt + 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0
- #define C() \
- SCM_PACK_OP_24 (bind_rest, 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0, \
- 0
- #define AB(nreq, nopt) \
- SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
- SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), \
- SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1), \
- SCM_PACK_OP_24 (subr_call, 0)
- #define AC(nreq) \
- SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
- SCM_PACK_OP_24 (bind_rest, nreq + 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0
- #define BC(nopt) \
- SCM_PACK_OP_24 (bind_rest, nopt + 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0, \
- 0
- #define ABC(nreq, nopt) \
- SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \
- SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1), \
- SCM_PACK_OP_24 (subr_call, 0), \
- 0
- static const scm_t_uint32 subr_stub_code[] = {
-
-
- A(0),
-
- A(1), B(1),
- C(),
-
- A(2), AB(1,1), B(2),
- AC(1), BC(1),
-
- A(3), AB(2,1), AB(1,2), B(3),
- AC(2), ABC(1,1), BC(2),
-
- A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
- AC(3), ABC(2,1), ABC(1,2), BC(3),
-
- 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),
-
- 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),
-
- 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),
-
- 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),
-
- 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),
-
- 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
- #define SUBR_STUB_CODE(nreq,nopt,rest) \
- &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \
- + nopt + rest * (nreq + nopt + rest + 1)) * 4]
- static const scm_t_uint32*
- get_subr_stub_code (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 SUBR_STUB_CODE (nreq, nopt, rest);
- }
- static SCM
- create_subr (int define, const char *name,
- unsigned int nreq, unsigned int nopt, unsigned int rest,
- SCM (*fcn) (), SCM *generic_loc)
- {
- SCM ret, sname;
- scm_t_bits flags;
- scm_t_bits nfree = generic_loc ? 3 : 2;
- sname = scm_from_utf8_symbol (name);
- flags = SCM_F_PROGRAM_IS_PRIMITIVE;
- flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
- ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
- SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
- if (generic_loc)
- SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
- scm_from_pointer (generic_loc, NULL));
- if (define)
- scm_define (sname, ret);
- return ret;
- }
- int
- scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest)
- {
- const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim);
- unsigned idx, nargs, base, next;
- if (code < subr_stub_code)
- return 0;
- if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32)))
- return 0;
- idx = (code - subr_stub_code) / 4;
- nargs = -1;
- next = 0;
- do
- {
- base = next;
- nargs++;
- next = (nargs + 1) * (nargs + 1);
- }
- while (idx >= next);
- *rest = (next - idx) < (idx - base);
- *req = *rest ? (next - 1) - idx : (base + nargs) - idx;
- *opt = *rest ? idx - (next - nargs) : idx - base;
- return 1;
- }
- scm_t_uintptr
- scm_i_primitive_call_ip (SCM subr)
- {
- const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr);
-
- return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1));
- }
- SCM
- scm_apply_subr (union scm_vm_stack_element *sp, scm_t_ptrdiff nslots)
- {
- SCM (*subr)() = SCM_SUBRF (sp[nslots - 1].as_scm);
- #define ARG(i) (sp[i].as_scm)
- switch (nslots - 1)
- {
- case 0:
- return subr ();
- case 1:
- return subr (ARG (0));
- case 2:
- return subr (ARG (1), ARG (0));
- case 3:
- return subr (ARG (2), ARG (1), ARG (0));
- case 4:
- return subr (ARG (3), ARG (2), ARG (1), ARG (0));
- case 5:
- return subr (ARG (4), ARG (3), ARG (2), ARG (1), ARG (0));
- case 6:
- return subr (ARG (5), ARG (4), ARG (3), ARG (2), ARG (1),
- ARG (0));
- case 7:
- return subr (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2),
- ARG (1), ARG (0));
- case 8:
- return subr (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3),
- ARG (2), ARG (1), ARG (0));
- case 9:
- return subr (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4),
- ARG (3), ARG (2), ARG (1), ARG (0));
- case 10:
- return subr (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5),
- ARG (4), ARG (3), ARG (2), ARG (1), ARG (0));
- default:
- abort ();
- }
- #undef ARG
- }
- SCM
- scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
- {
- return create_subr (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_subr (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_subr (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_subr (1, name, req, opt, rst, fcn, gf);
- }
- void
- scm_init_gsubr()
- {
- #include "libguile/gsubr.x"
- }
|