From 27337b6373954e1a975d97d0bf06b5c03d65b64d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Oct 2013 10:03:26 +0200 Subject: [PATCH] Subrs are RTL programs * libguile/gsubr.c: Define RTL stubs instead of stack VM stubs. (SUBR_STUB_CODE, get_subr_stub_code): Adapt to return a uint32_t* pointer instead of a SCM value. (create_subr): Create RTL procedures instead of stack VM procedures. For RTL procedures, the function pointer, name, and generic address pointer go inline to the procedure, as free variables. (scm_i_primitive_arity, scm_i_primitive_call_ip): New helpers. (scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic) (scm_c_define_gsubr_with_generic): Adapt to create_gsubr being renamed to create_subr. Remove gsubr test code. * libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): Only RTL programs can be primitives now. (SCM_SUBRF, SCM_SUBR_NAME, SCM_SUBR_GENERIC): These fields are now in the RTL free variables, not the object table. * libguile/programs.c (scm_i_rtl_program_name): (scm_i_rtl_program_documentation): (scm_i_rtl_program_properties): (scm_i_rtl_program_minimum_arity): Implement these appropriately for primitives, which lack debugging information. (scm_primitive_p, scm_primitive_call_ip): New helpers. * libguile/snarf.h: Remove static allocation for subrs. Since there is nothing to allocate besides the program itself, which needs runtime relocation, static allocation is not a win. * system/vm/program.scm: Fix up various arity-related things for primitives, which don't use ELF arity info. * test-suite/tests/eval.test ("stack involving a primitive"): Add an XFAIL until we get just one VM. --- libguile/gsubr.c | 1233 ++++++++++------------------------ libguile/gsubr.h | 23 +- libguile/programs.c | 37 + libguile/programs.h | 3 + libguile/snarf.h | 41 +- module/system/vm/program.scm | 38 +- test-suite/tests/eval.test | 6 +- 7 files changed, 430 insertions(+), 951 deletions(-) rewrite libguile/gsubr.c (84%) diff --git a/libguile/gsubr.c b/libguile/gsubr.c dissimilarity index 84% index 84846cf35..4e061e340 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_utf8_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_unlocked ("gsubr-2-1-l:\n req1: ", scm_cur_outp); - scm_display(req1, scm_cur_outp); - scm_puts_unlocked ("\n req2: ", scm_cur_outp); - scm_display(req2, scm_cur_outp); - scm_puts_unlocked ("\n opt: ", scm_cur_outp); - scm_display(opt, scm_cur_outp); - scm_puts_unlocked ("\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_RTL_24 (scm_rtl_op_assert_nargs_ee, nreq + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \ + 0, \ + 0 + +#define B(nopt) \ + SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \ + 0 + +#define C() \ + SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \ + 0, \ + 0 + +#define AB(nreq, nopt) \ + SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_le, nreq + nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, nreq + nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0) + +#define AC(nreq) \ + SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \ + 0 + +#define BC(nopt) \ + SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_subr_call, 0), \ + 0, \ + 0 + +#define ABC(nreq, nopt) \ + SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, nreq + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_bind_rest, nreq + nopt + 1), \ + SCM_PACK_RTL_24 (scm_rtl_op_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); + + ret = scm_words (scm_tc7_rtl_program | (nfree << 16), nfree + 2); + 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); + SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest)); + SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL)); + SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname); + if (generic_loc) + SCM_RTL_PROGRAM_FREE_VARIABLE_SET (ret, 2, + scm_from_pointer (generic_loc, NULL)); + + if (define) + scm_define (sname, ret); + + return ret; +} + +/* Given an RTL primitive, determine its minimum arity. This is + possible because each RTL primitive 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_RTL_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; +} + +int +scm_i_primitive_call_ip (SCM subr) +{ + const scm_t_uint32 *code = SCM_RTL_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 code[3] ? 12 : code[2] ? 8 : 4; +} + +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: +*/ diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 5adffa4fe..6bdfe6baf 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -4,7 +4,7 @@ #define SCM_GSUBR_H /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009, - * 2010, 2011 Free Software Foundation, Inc. + * 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 @@ -30,36 +30,33 @@ -SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq, - unsigned int nopt, - unsigned int rest); - - /* Subrs */ /* Max number of args to the C procedure backing a gsubr */ #define SCM_GSUBR_MAX 10 -#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x)) +#define SCM_PRIMITIVE_P(x) (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x)) -#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)) +#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_RTL_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x)) #define SCM_SUBRF(x) \ - ((SCM (*) (void)) \ - SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0))) + ((SCM (*) (void)) \ + SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 0))) -#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1)) +#define SCM_SUBR_NAME(x) (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 1)) #define SCM_SUBR_GENERIC(x) \ - ((SCM *) \ - SCM_POINTER_VALUE (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 2))) + ((SCM *) SCM_POINTER_VALUE (SCM_RTL_PROGRAM_FREE_VARIABLE_REF (x, 2))) #define SCM_SET_SUBR_GENERIC(x, g) \ (*SCM_SUBR_GENERIC (x) = (g)) +SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); +SCM_INTERNAL int scm_i_primitive_call_ip (SCM subr); + SCM_API SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn); SCM_API SCM scm_c_make_gsubr_with_generic (const char *name, diff --git a/libguile/programs.c b/libguile/programs.c index 5039d2a2b..c10dede10 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -116,6 +116,9 @@ scm_i_rtl_program_name (SCM program) { static SCM rtl_program_name = SCM_BOOL_F; + if (SCM_PRIMITIVE_P (program)) + return SCM_SUBR_NAME (program); + if (scm_is_false (rtl_program_name) && scm_module_system_booted_p) rtl_program_name = scm_c_private_variable ("system vm program", "rtl-program-name"); @@ -128,6 +131,9 @@ scm_i_rtl_program_documentation (SCM program) { static SCM rtl_program_documentation = SCM_BOOL_F; + if (SCM_PRIMITIVE_P (program)) + return SCM_BOOL_F; + if (scm_is_false (rtl_program_documentation) && scm_module_system_booted_p) rtl_program_documentation = scm_c_private_variable ("system vm program", @@ -141,6 +147,14 @@ scm_i_rtl_program_properties (SCM program) { static SCM rtl_program_properties = SCM_BOOL_F; + if (SCM_PRIMITIVE_P (program)) + { + SCM name = scm_i_rtl_program_name (program); + if (scm_is_false (name)) + return SCM_EOL; + return scm_acons (scm_sym_name, name, SCM_EOL); + } + if (scm_is_false (rtl_program_properties) && scm_module_system_booted_p) rtl_program_properties = scm_c_private_variable ("system vm program", "rtl-program-properties"); @@ -219,6 +233,26 @@ SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_primitive_p +{ + return scm_from_bool (SCM_PRIMITIVE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, + (SCM prim), + "") +#define FUNC_NAME s_scm_primitive_p +{ + SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); + + return scm_from_int (scm_i_primitive_call_ip (prim)); +} +#undef FUNC_NAME + SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, (SCM program), "") @@ -487,6 +521,9 @@ scm_i_rtl_program_minimum_arity (SCM program, int *req, int *opt, int *rest) static SCM rtl_program_minimum_arity = SCM_BOOL_F; SCM l; + if (SCM_PRIMITIVE_P (program)) + return scm_i_primitive_arity (program, req, opt, rest); + if (scm_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p) rtl_program_minimum_arity = scm_c_private_variable ("system vm program", diff --git a/libguile/programs.h b/libguile/programs.h index 275570cd1..1ecc35d9a 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -44,6 +44,9 @@ SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM free SCM_INTERNAL SCM scm_rtl_program_p (SCM obj); SCM_INTERNAL SCM scm_rtl_program_code (SCM program); +SCM_INTERNAL SCM scm_primitive_p (SCM obj); +SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim); + SCM_INTERNAL SCM scm_i_rtl_program_name (SCM program); SCM_INTERNAL SCM scm_i_rtl_program_documentation (SCM program); SCM_INTERNAL SCM scm_i_rtl_program_properties (SCM program); diff --git a/libguile/snarf.h b/libguile/snarf.h index 3931570f4..7843ac8da 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -4,7 +4,7 @@ #define SCM_SNARF_H /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. + * 2004, 2006, 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 @@ -96,48 +96,9 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \ )\ 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( \ - static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \ - SCM_API SCM FNAME ARGLIST; \ - SCM_IMMUTABLE_POINTER (scm_i_paste (FNAME, __subr_foreign), \ - (scm_t_bits) &FNAME); /* the subr */ \ - 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)[1] = scm_i_paste (FNAME, __subr_foreign); \ - /* Initialize the procedure name (an interned symbol). */ \ - scm_i_paste (FNAME, __raw_objtable)[2] = 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_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \ -) \ -SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) - -#else /* !SCM_SUPPORT_STATIC_ALLOCATION */ - /* Always use the generic subr case. */ #define SCM_DEFINE SCM_DEFINE_GSUBR -#endif /* !SCM_SUPPORT_STATIC_ALLOCATION */ - #define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 86db41180..4466504de 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -198,7 +198,8 @@ ;; returns list of list of bindings ;; (list-ref ret N) == bindings bound to the Nth local slot (define (program-bindings-by-index prog) - (cond ((program-bindings prog) => collapse-locals) + (cond ((rtl-program? prog) '()) + ((program-bindings prog) => collapse-locals) (else '()))) (define (program-bindings-for-ip prog ip) @@ -291,14 +292,29 @@ ;; the name "program-arguments" is taken by features.c... (define* (program-arguments-alist prog #:optional ip) "Returns the signature of the given procedure in the form of an association list." - (if (rtl-program? prog) + (cond + ((primitive? prog) + (match (procedure-minimum-arity prog) + (#f #f) + ((nreq nopt rest?) + (let ((start (primitive-call-ip prog))) + ;; Assume that there is only one IP for the call. + (and (or (not ip) (= start ip)) + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ())))))))) + ((rtl-program? prog) + (let ((pc (and ip (+ (rtl-program-code prog) ip)))) (or-map (lambda (arity) - (and #t + (and (or (not pc) + (and (<= (arity-low-pc arity) pc) + (< pc (arity-high-pc arity)))) (arity-arguments-alist arity))) - (or (find-program-arities (rtl-program-code prog)) '())) - (let ((arity (program-arity prog ip))) - (and arity - (arity->arguments-alist prog arity))))) + (or (find-program-arities (rtl-program-code prog)) '())))) + (else + (let ((arity (program-arity prog ip))) + (and arity + (arity->arguments-alist prog arity)))))) (define* (program-lambda-list prog #:optional ip) "Returns the signature of the given procedure in the form of an argument list." @@ -325,6 +341,14 @@ (define (program-arguments-alists prog) (cond + ((primitive? prog) + (match (procedure-minimum-arity prog) + (#f '()) + ((nreq nopt rest?) + (list + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ()))))))) ((rtl-program? prog) (map arity-arguments-alist (or (find-program-arities (rtl-program-code prog)) '()))) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 24afe2da0..a0221b81b 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 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 @@ -349,7 +349,9 @@ (define tag (make-prompt-tag "foo")) (with-test-prefix "stacks" - (pass-if "stack involving a primitive" + ;; FIXME: Until we get one VM, a call to an RTL primitive from the + ;; stack VM will result in the primitive being on the stack twice. + (expect-fail "stack involving a primitive" ;; The primitive involving the error must appear exactly once on the ;; stack. (let* ((stack (make-tagged-trimmed-stack tag '(#t))) -- 2.20.1