summaryrefslogtreecommitdiff
path: root/libguile/programs.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/programs.c')
-rw-r--r--libguile/programs.c166
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;