123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393 |
- /* Copyright 2001,2009-2014,2017-2019
- Free Software Foundation, Inc.
- This file is part of Guile.
- Guile 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.
- Guile 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 Guile. If not, see
- <https://www.gnu.org/licenses/>. */
- #if HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include <string.h>
- #include "alist.h"
- #include "boolean.h"
- #include "eval.h"
- #include "extensions.h"
- #include "gsubr.h"
- #include "instructions.h"
- #include "modules.h"
- #include "numbers.h"
- #include "pairs.h"
- #include "ports.h"
- #include "procprop.h" /* scm_sym_name */
- #include "variable.h"
- #include "version.h"
- #include "vm.h"
- #include "programs.h"
- static SCM write_program = SCM_BOOL_F;
- SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
- (SCM program),
- "")
- #define FUNC_NAME s_scm_program_code
- {
- SCM_VALIDATE_PROGRAM (1, program);
- return scm_from_uintptr_t ((uintptr_t) SCM_PROGRAM_CODE (program));
- }
- #undef FUNC_NAME
- SCM
- scm_i_program_name (SCM program)
- {
- static SCM program_name = SCM_BOOL_F;
- if (SCM_PRIMITIVE_P (program))
- return scm_i_primitive_name (SCM_PROGRAM_CODE (program));
- if (scm_is_false (program_name) && scm_module_system_booted_p)
- program_name =
- scm_c_private_variable ("system vm program", "program-name");
- return scm_call_1 (scm_variable_ref (program_name), program);
- }
- SCM
- scm_i_program_documentation (SCM program)
- {
- static SCM program_documentation = SCM_BOOL_F;
- if (SCM_PRIMITIVE_P (program))
- return SCM_BOOL_F;
- if (scm_is_false (program_documentation) && scm_module_system_booted_p)
- program_documentation =
- scm_c_private_variable ("system vm program", "program-documentation");
- return scm_call_1 (scm_variable_ref (program_documentation), program);
- }
- SCM
- scm_i_program_properties (SCM program)
- {
- static SCM program_properties = SCM_BOOL_F;
- if (SCM_PRIMITIVE_P (program))
- {
- SCM name = scm_i_program_name (program);
- if (scm_is_false (name))
- return SCM_EOL;
- return scm_acons (scm_sym_name, name, SCM_EOL);
- }
- if (scm_is_false (program_properties) && scm_module_system_booted_p)
- program_properties =
- scm_c_private_variable ("system vm program", "program-properties");
- return scm_call_1 (scm_variable_ref (program_properties), program);
- }
- void
- scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
- {
- static int print_error = 0;
- if (scm_is_false (write_program) && scm_module_system_booted_p)
- write_program = scm_c_private_variable ("system vm program",
- "write-program");
-
- if (SCM_PROGRAM_IS_CONTINUATION (program))
- {
- /* twingliness */
- scm_puts ("#<continuation ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
- }
- else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
- {
- /* twingliness */
- scm_puts ("#<partial-continuation ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc ('>', port);
- }
- else if (scm_is_false (write_program) || print_error)
- {
- scm_puts ("#<program ", port);
- scm_uintprint (SCM_UNPACK (program), 16, port);
- scm_putc (' ', port);
- scm_uintprint ((uintptr_t) SCM_PROGRAM_CODE (program), 16, port);
- scm_putc ('>', port);
- }
- else
- {
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- }
- }
- /*
- * Scheme interface
- */
- SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
- (SCM obj),
- "")
- #define FUNC_NAME s_scm_program_p
- {
- return scm_from_bool (SCM_PROGRAM_P (obj));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
- (SCM code),
- "")
- #define FUNC_NAME s_scm_primitive_code_p
- {
- const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
- return scm_from_bool (scm_i_primitive_code_p (ptr));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
- (SCM prim),
- "")
- #define FUNC_NAME s_scm_primitive_call_ip
- {
- uintptr_t ip;
- SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
- ip = scm_i_primitive_call_ip (prim);
- return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_primitive_code_name, "primitive-code-name", 1, 0, 0,
- (SCM code),
- "")
- #define FUNC_NAME s_scm_primitive_code_name
- {
- const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
- if (scm_i_primitive_code_p (ptr))
- return scm_i_primitive_name (ptr);
- return SCM_BOOL_F;
- }
- #undef FUNC_NAME
- SCM
- scm_find_source_for_addr (SCM ip)
- {
- static SCM source_for_addr = SCM_BOOL_F;
- if (scm_is_false (source_for_addr)) {
- if (!scm_module_system_booted_p)
- return SCM_BOOL_F;
- source_for_addr =
- scm_c_private_variable ("system vm program", "source-for-addr");
- }
- return scm_call_1 (scm_variable_ref (source_for_addr), ip);
- }
- SCM
- scm_program_address_range (SCM program)
- {
- static SCM program_address_range = SCM_BOOL_F;
- if (scm_is_false (program_address_range) && scm_module_system_booted_p)
- program_address_range =
- scm_c_private_variable ("system vm program", "program-address-range");
- return scm_call_1 (scm_variable_ref (program_address_range), program);
- }
- SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
- (SCM program),
- "")
- #define FUNC_NAME s_scm_program_num_free_variables
- {
- SCM_VALIDATE_PROGRAM (1, program);
- return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
- (SCM program, SCM i),
- "")
- #define FUNC_NAME s_scm_program_free_variable_ref
- {
- unsigned long idx;
- SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
- SCM_OUT_OF_RANGE (2, i);
- return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
- (SCM program, SCM i, SCM x),
- "")
- #define FUNC_NAME s_scm_program_free_variable_set_x
- {
- unsigned long idx;
- SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_ULONG_COPY (2, i, idx);
- if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
- SCM_OUT_OF_RANGE (2, i);
- SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
- return SCM_UNSPECIFIED;
- }
- #undef FUNC_NAME
- /* It's hacky, but it manages to cover all of the non-keyword cases. */
- static int
- try_parse_arity (SCM program, int *req, int *opt, int *rest)
- {
- uint32_t *code = SCM_PROGRAM_CODE (program);
- uint32_t slots, min;
- if ((code[0] & 0xff) == scm_op_instrument_entry)
- code += 2;
- switch (code[0] & 0xff) {
- case scm_op_assert_nargs_ee:
- slots = code[0] >> 8;
- *req = slots - 1;
- *opt = 0;
- *rest = 0;
- return 1;
- case scm_op_assert_nargs_ee_locals:
- slots = (code[0] >> 8) & 0xfff;
- *req = slots - 1;
- *opt = 0;
- *rest = 0;
- return 1;
- case scm_op_assert_nargs_le:
- slots = code[0] >> 8;
- *req = 0;
- *opt = slots - 1;
- *rest = 0;
- return 1;
- case scm_op_bind_optionals:
- slots = code[0] >> 8;
- *req = 0;
- *opt = slots - 1;
- *rest = ((code[1] & 0xff) == scm_op_bind_rest);
- return 1;
- case scm_op_bind_rest:
- slots = code[0] >> 8;
- *req = 0;
- *opt = slots - 1;
- *rest = 1;
- return 1;
- case scm_op_assert_nargs_ge:
- min = code[0] >> 8;
- switch (code[1] & 0xff) {
- case scm_op_assert_nargs_le:
- slots = code[1] >> 8;
- *req = min - 1;
- *opt = slots - 1 - *req;
- *rest = 0;
- return 1;
- case scm_op_bind_optionals:
- slots = code[1] >> 8;
- *req = min - 1;
- *opt = slots - 1 - *req;
- *rest = ((code[2] & 0xff) == scm_op_bind_rest);
- return 1;
- case scm_op_bind_rest:
- slots = code[1] >> 8;
- *req = min - 1;
- *opt = slots - min;
- *rest = 1;
- return 1;
- case scm_op_shuffle_down:
- case scm_op_abort:
- *req = min - 1;
- *opt = 0;
- *rest = 1;
- return 1;
- default:
- return 0;
- }
- case scm_op_continuation_call:
- case scm_op_compose_continuation:
- case scm_op_shuffle_down:
- *req = 0;
- *opt = 0;
- *rest = 1;
- return 1;
- default:
- return 0;
- }
- }
- int
- scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
- {
- static SCM program_minimum_arity = SCM_BOOL_F;
- SCM l;
- if (try_parse_arity (program, req, opt, rest))
- return 1;
- if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p)
- program_minimum_arity =
- scm_c_private_variable ("system vm program", "program-minimum-arity");
- l = scm_call_1 (scm_variable_ref (program_minimum_arity), program);
- if (scm_is_false (l))
- return 0;
- *req = scm_to_int (scm_car (l));
- *opt = scm_to_int (scm_cadr (l));
- *rest = scm_is_true (scm_caddr (l));
- return 1;
- }
- void
- scm_bootstrap_programs (void)
- {
- scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
- "scm_init_programs",
- (scm_t_extension_init_func)scm_init_programs, NULL);
- }
- void
- scm_init_programs (void)
- {
- #ifndef SCM_MAGIC_SNARFER
- #include "programs.x"
- #endif
- }
|