diff options
Diffstat (limited to 'libguile/programs.c')
-rw-r--r-- | libguile/programs.c | 367 |
1 files changed, 111 insertions, 256 deletions
diff --git a/libguile/programs.c b/libguile/programs.c index d2b2e755b..fae95d0ab 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2001, 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 License @@ -22,52 +22,74 @@ #include <string.h> #include "_scm.h" -#include "instructions.h" #include "modules.h" #include "programs.h" #include "procprop.h" /* scm_sym_name */ -#include "srcprop.h" /* scm_sym_filename */ #include "vm.h" static SCM write_program = SCM_BOOL_F; -SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, - (SCM objcode, SCM objtable, SCM free_variables), - "") -#define FUNC_NAME s_scm_make_program +SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_code { - SCM_VALIDATE_OBJCODE (1, objcode); - if (SCM_UNLIKELY (SCM_UNBNDP (objtable))) - objtable = SCM_BOOL_F; - else if (scm_is_true (objtable)) - SCM_VALIDATE_VECTOR (2, objtable); + SCM_VALIDATE_PROGRAM (1, program); - if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables)) - { - SCM ret = scm_words (scm_tc7_program, 3); - SCM_SET_CELL_OBJECT_1 (ret, objcode); - SCM_SET_CELL_OBJECT_2 (ret, objtable); - return ret; - } - else + return scm_from_uintptr_t ((scm_t_uintptr) 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_SUBR_NAME (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)) { - size_t i, len; - SCM ret; - SCM_VALIDATE_VECTOR (3, free_variables); - len = scm_c_vector_length (free_variables); - if (SCM_UNLIKELY (len >> 16)) - SCM_OUT_OF_RANGE (3, free_variables); - ret = scm_words (scm_tc7_program | (len<<16), 3 + len); - SCM_SET_CELL_OBJECT_1 (ret, objcode); - SCM_SET_CELL_OBJECT_2 (ret, objtable); - for (i = 0; i < len; i++) - SCM_SET_CELL_OBJECT (ret, 3+i, - SCM_SIMPLE_VECTOR_REF (free_variables, i)); - return ret; + 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); } -#undef FUNC_NAME void scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) @@ -75,29 +97,30 @@ 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_module_local_variable - (scm_c_resolve_module ("system vm program"), - scm_from_latin1_symbol ("write-program")); + write_program = scm_c_private_variable ("system vm program", + "write-program"); if (SCM_PROGRAM_IS_CONTINUATION (program)) { /* twingliness */ - scm_puts ("#<continuation ", port); + scm_puts_unlocked ("#<continuation ", port); scm_uintprint (SCM_UNPACK (program), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) { /* twingliness */ - scm_puts ("#<partial-continuation ", port); + scm_puts_unlocked ("#<partial-continuation ", port); scm_uintprint (SCM_UNPACK (program), 16, port); - scm_putc ('>', port); + scm_putc_unlocked ('>', port); } else if (scm_is_false (write_program) || print_error) { - scm_puts ("#<program ", port); + scm_puts_unlocked ("#<program ", port); scm_uintprint (SCM_UNPACK (program), 16, port); - scm_putc ('>', port); + scm_putc_unlocked (' ', port); + scm_uintprint ((scm_t_uintptr) SCM_PROGRAM_CODE (program), 16, port); + scm_putc_unlocked ('>', port); } else { @@ -121,185 +144,49 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_base -{ - const struct scm_objcode *c_objcode; - - SCM_VALIDATE_PROGRAM (1, program); - - c_objcode = SCM_PROGRAM_DATA (program); - return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_objects -{ - SCM_VALIDATE_PROGRAM (1, program); - return SCM_PROGRAM_OBJTABLE (program); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_module -{ - SCM objs, mod; - SCM_VALIDATE_PROGRAM (1, program); - objs = SCM_PROGRAM_OBJTABLE (program); - /* If a program is the result of compiling GLIL to assembly, then if - it has an objtable, the first entry will be a module. But some - programs are hand-coded trampolines, like boot programs and - primitives and the like. So if a program happens to have a - non-module in the first slot of the objtable, assume that it is - such a trampoline, and just return #f for the module. */ - mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F; - return SCM_MODULEP (mod) ? mod : SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_meta -{ - SCM metaobj; - - SCM_VALIDATE_PROGRAM (1, program); - - metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); - if (scm_is_true (metaobj)) - return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program), - SCM_BOOL_F); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, - (SCM program), - "") -#define FUNC_NAME s_scm_program_bindings -{ - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_BOOL_F; - - return scm_car (scm_call_0 (meta)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0, - (SCM program), +SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0, + (SCM obj), "") -#define FUNC_NAME s_scm_program_sources +#define FUNC_NAME s_scm_primitive_p { - SCM meta, sources, ret, filename; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_EOL; - - filename = SCM_BOOL_F; - ret = SCM_EOL; - for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources); - sources = scm_cdr (sources)) - { - SCM x = scm_car (sources); - if (scm_is_pair (x)) - { - if (scm_is_number (scm_car (x))) - { - SCM addr = scm_car (x); - ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)), - ret); - } - else if (scm_is_eq (scm_car (x), scm_sym_filename)) - filename = scm_cdr (x); - } - } - return scm_reverse_x (ret, SCM_UNDEFINED); + return scm_from_bool (SCM_PRIMITIVE_P (obj)); } #undef FUNC_NAME -SCM_DEFINE (scm_program_arities, "program-arities", 1, 0, 0, - (SCM program), +SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, + (SCM prim), "") -#define FUNC_NAME s_scm_program_arities +#define FUNC_NAME s_scm_primitive_p { - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); - - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_BOOL_F; + SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); - return scm_caddr (scm_call_0 (meta)); + return scm_from_uintptr_t (scm_i_primitive_call_ip (prim)); } #undef FUNC_NAME SCM -scm_i_program_properties (SCM program) -#define FUNC_NAME "%program-properties" +scm_find_source_for_addr (SCM ip) { - SCM meta; - - SCM_VALIDATE_PROGRAM (1, program); + static SCM source_for_addr = SCM_BOOL_F; - meta = scm_program_meta (program); - if (scm_is_false (meta)) - return SCM_EOL; - - return scm_cdddr (scm_call_0 (meta)); -} -#undef FUNC_NAME + if (scm_is_false (source_for_addr)) { + if (!scm_module_system_booted_p) + return SCM_BOOL_F; -static SCM -program_source (SCM program, size_t ip, SCM sources) -{ - SCM source = SCM_BOOL_F; + source_for_addr = + scm_c_private_variable ("system vm program", "source-for-addr"); + } - while (!scm_is_null (sources) - && scm_to_size_t (scm_caar (sources)) <= ip) - { - source = scm_car (sources); - sources = scm_cdr (sources); - } - - return source; /* (addr . (filename . (line . column))) */ + return scm_call_1 (scm_variable_ref (source_for_addr), ip); } -SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0, - (SCM program, SCM ip, SCM sources), - "") -#define FUNC_NAME s_scm_program_source -{ - SCM_VALIDATE_PROGRAM (1, program); - if (SCM_UNBNDP (sources)) - sources = scm_program_sources (program); - return program_source (program, scm_to_size_t (ip), sources); -} -#undef FUNC_NAME - 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 @@ -310,6 +197,7 @@ SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0, #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)) @@ -324,6 +212,7 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, #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)) @@ -333,71 +222,37 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, - (SCM program), - "Return a @var{program}'s object code.") -#define FUNC_NAME s_scm_program_objcode +int +scm_i_program_arity (SCM program, int *req, int *opt, int *rest) { - SCM_VALIDATE_PROGRAM (1, program); + static SCM program_minimum_arity = SCM_BOOL_F; + SCM l; - return SCM_PROGRAM_OBJCODE (program); -} -#undef FUNC_NAME + if (SCM_PRIMITIVE_P (program)) + return scm_i_primitive_arity (program, req, opt, rest); -/* procedure-minimum-arity support. */ -static void -parse_arity (SCM arity, int *req, int *opt, int *rest) -{ - SCM x = scm_cddr (arity); - - if (scm_is_pair (x)) + if (SCM_PROGRAM_IS_FOREIGN (program)) + return scm_i_foreign_arity (program, req, opt, rest); + + if (SCM_PROGRAM_IS_CONTINUATION (program) + || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) { - *req = scm_to_int (scm_car (x)); - x = scm_cdr (x); - if (scm_is_pair (x)) - { - *opt = scm_to_int (scm_car (x)); - x = scm_cdr (x); - if (scm_is_pair (x)) - *rest = scm_is_true (scm_car (x)); - else - *rest = 0; - } - else - *opt = *rest = 0; + *req = *opt = 0; + *rest = 1; + return 1; } - else - *req = *opt = *rest = 0; -} - -int -scm_i_program_arity (SCM program, int *req, int *opt, int *rest) -{ - SCM arities; - - arities = scm_program_arities (program); - if (!scm_is_pair (arities)) + + 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; - parse_arity (scm_car (arities), req, opt, rest); - arities = scm_cdr (arities); - - for (; scm_is_pair (arities); arities = scm_cdr (arities)) - { - int thisreq, thisopt, thisrest; - - parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest); - - if (thisreq < *req - || (thisreq == *req - && ((thisrest && (!*rest || thisopt > *opt)) - || (!thisrest && !*rest && thisopt > *opt)))) - { - *req = thisreq; - *opt = thisopt; - *rest = thisrest; - } - } + *req = scm_to_int (scm_car (l)); + *opt = scm_to_int (scm_cadr (l)); + *rest = scm_is_true (scm_caddr (l)); return 1; } |