X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f9654187b1ff0e20dfcb66da963eae62f4d03be1..74870c0d2f2cfb2a15ab732c0cc0378bbf268682:/libguile/gsubr.c?ds=inline diff --git a/libguile/gsubr.c b/libguile/gsubr.c dissimilarity index 85% index b6f261faf..49edd3c5c 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,889 +1,344 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011 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 -#endif - -#include -#include - -#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_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)) - -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: -*/ +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010, 2011, 2013 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 +#endif + +#include +#include + +#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. + */ + + + +/* 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. +*/ + +/* A: req; B: opt; C: rest */ +#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 + + +/* + (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 scm_t_uint32 subr_stub_code[] = { + /* 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 + +/* (nargs * nargs) + nopt + rest * (nargs + 1) */ +#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; +} + +/* Given a program that is a primitive, determine its minimum arity. + This is possible because each primitive's code is 4 32-bit words + long, and they are laid out contiguously in an ordered pattern. */ +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); + + /* A stub is 4 32-bit words long, or 16 bytes. The call will be one + instruction, in either the fourth, third, or second word. Return a + byte offset from the entry. */ + return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); +} + +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" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/