diff options
Diffstat (limited to 'libguile/programs.c')
-rw-r--r-- | libguile/programs.c | 166 |
1 files changed, 155 insertions, 11 deletions
diff --git a/libguile/programs.c b/libguile/programs.c index b84f84bd3..9b3e74834 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011 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 @@ -69,35 +69,124 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2, 0, + (SCM bytevector, SCM byte_offset, SCM free_variables), + "") +#define FUNC_NAME s_scm_make_rtl_program +{ + scm_t_uint8 *code; + scm_t_uint32 offset; + + if (!scm_is_bytevector (bytevector)) + scm_wrong_type_arg (FUNC_NAME, 1, bytevector); + if (SCM_UNBNDP (byte_offset)) + offset = 0; + else + { + offset = scm_to_uint32 (byte_offset); + if (offset > SCM_BYTEVECTOR_LENGTH (bytevector)) + SCM_OUT_OF_RANGE (2, byte_offset); + } + + code = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bytevector) + offset; + if (((scm_t_uintptr) code) % 4) + SCM_OUT_OF_RANGE (2, byte_offset); + + if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables)) + return scm_cell (scm_tc7_rtl_program, (scm_t_bits) code); + else + abort (); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_rtl_program_code +{ + SCM_VALIDATE_RTL_PROGRAM (1, program); + + /* FIXME: we need scm_from_uintptr (). */ + return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program)); +} +#undef FUNC_NAME + +SCM +scm_i_rtl_program_name (SCM program) +{ + static SCM rtl_program_name = SCM_BOOL_F; + + 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"); + + return scm_call_1 (scm_variable_ref (rtl_program_name), program); +} + +SCM +scm_i_rtl_program_documentation (SCM program) +{ + static SCM rtl_program_documentation = 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", + "rtl-program-documentation"); + + return scm_call_1 (scm_variable_ref (rtl_program_documentation), program); +} + +SCM +scm_i_rtl_program_properties (SCM program) +{ + static SCM rtl_program_properties = SCM_BOOL_F; + + 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"); + + return scm_call_1 (scm_variable_ref (rtl_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_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_uintprint (SCM_UNPACK (program), 16, port); - scm_putc ('>', port); + if (SCM_RTL_PROGRAM_P (program)) + { + scm_puts_unlocked ("#<rtl-program ", port); + scm_uintprint (SCM_UNPACK (program), 16, port); + scm_putc_unlocked (' ', port); + scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port); + scm_putc_unlocked ('>', port); + } + else + { + scm_puts_unlocked ("#<program ", port); + scm_uintprint (SCM_UNPACK (program), 16, port); + scm_putc_unlocked ('>', port); + } } else { @@ -121,6 +210,15 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_rtl_program_p +{ + return scm_from_bool (SCM_RTL_PROGRAM_P (obj)); +} +#undef FUNC_NAME + SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, (SCM program), "") @@ -305,6 +403,10 @@ SCM_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, "") #define FUNC_NAME s_scm_program_num_free_variables { + if (SCM_RTL_PROGRAM_P (program)) { + return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)); + } + SCM_VALIDATE_PROGRAM (1, program); return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program)); } @@ -316,6 +418,14 @@ 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; + + if (SCM_RTL_PROGRAM_P (program)) { + SCM_VALIDATE_ULONG_COPY (2, i, idx); + if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) + SCM_OUT_OF_RANGE (2, i); + return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program, idx); + } + SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_ULONG_COPY (2, i, idx); if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) @@ -330,6 +440,15 @@ 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; + + if (SCM_RTL_PROGRAM_P (program)) { + SCM_VALIDATE_ULONG_COPY (2, i, idx); + if (idx >= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program)) + SCM_OUT_OF_RANGE (2, i); + SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program, idx, x); + return SCM_UNSPECIFIED; + } + SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_ULONG_COPY (2, i, idx); if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) @@ -376,11 +495,36 @@ parse_arity (SCM arity, int *req, int *opt, int *rest) *req = *opt = *rest = 0; } +static int +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_is_false (rtl_program_minimum_arity) && scm_module_system_booted_p) + rtl_program_minimum_arity = + scm_c_private_variable ("system vm program", + "rtl-program-minimum-arity"); + + l = scm_call_1 (scm_variable_ref (rtl_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; +} + int scm_i_program_arity (SCM program, int *req, int *opt, int *rest) { SCM arities; + if (SCM_RTL_PROGRAM_P (program)) + return scm_i_rtl_program_minimum_arity (program, req, opt, rest); + arities = scm_program_arities (program); if (!scm_is_pair (arities)) return 0; |