1 /* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "procprop.h" /* scm_sym_name */
31 static SCM write_program
= SCM_BOOL_F
;
33 SCM_DEFINE (scm_make_rtl_program
, "make-rtl-program", 1, 2, 0,
34 (SCM bytevector
, SCM byte_offset
, SCM free_variables
),
36 #define FUNC_NAME s_scm_make_rtl_program
41 if (!scm_is_bytevector (bytevector
))
42 scm_wrong_type_arg (FUNC_NAME
, 1, bytevector
);
43 if (SCM_UNBNDP (byte_offset
))
47 offset
= scm_to_uint32 (byte_offset
);
48 if (offset
> SCM_BYTEVECTOR_LENGTH (bytevector
))
49 SCM_OUT_OF_RANGE (2, byte_offset
);
52 code
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bytevector
) + offset
;
53 if (((scm_t_uintptr
) code
) % 4)
54 SCM_OUT_OF_RANGE (2, byte_offset
);
56 if (SCM_UNBNDP (free_variables
) || scm_is_false (free_variables
))
57 return scm_cell (scm_tc7_rtl_program
, (scm_t_bits
) code
);
63 SCM_DEFINE (scm_rtl_program_code
, "rtl-program-code", 1, 0, 0,
66 #define FUNC_NAME s_scm_rtl_program_code
68 SCM_VALIDATE_RTL_PROGRAM (1, program
);
70 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_RTL_PROGRAM_CODE (program
));
75 scm_i_rtl_program_name (SCM program
)
77 static SCM rtl_program_name
= SCM_BOOL_F
;
79 if (SCM_PRIMITIVE_P (program
))
80 return SCM_SUBR_NAME (program
);
82 if (scm_is_false (rtl_program_name
) && scm_module_system_booted_p
)
84 scm_c_private_variable ("system vm program", "rtl-program-name");
86 return scm_call_1 (scm_variable_ref (rtl_program_name
), program
);
90 scm_i_rtl_program_documentation (SCM program
)
92 static SCM rtl_program_documentation
= SCM_BOOL_F
;
94 if (SCM_PRIMITIVE_P (program
))
97 if (scm_is_false (rtl_program_documentation
) && scm_module_system_booted_p
)
98 rtl_program_documentation
=
99 scm_c_private_variable ("system vm program",
100 "rtl-program-documentation");
102 return scm_call_1 (scm_variable_ref (rtl_program_documentation
), program
);
106 scm_i_rtl_program_properties (SCM program
)
108 static SCM rtl_program_properties
= SCM_BOOL_F
;
110 if (SCM_PRIMITIVE_P (program
))
112 SCM name
= scm_i_rtl_program_name (program
);
113 if (scm_is_false (name
))
115 return scm_acons (scm_sym_name
, name
, SCM_EOL
);
118 if (scm_is_false (rtl_program_properties
) && scm_module_system_booted_p
)
119 rtl_program_properties
=
120 scm_c_private_variable ("system vm program", "rtl-program-properties");
122 return scm_call_1 (scm_variable_ref (rtl_program_properties
), program
);
126 scm_i_program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
128 static int print_error
= 0;
130 if (scm_is_false (write_program
) && scm_module_system_booted_p
)
131 write_program
= scm_c_private_variable ("system vm program",
134 if (SCM_PROGRAM_IS_CONTINUATION (program
))
137 scm_puts_unlocked ("#<continuation ", port
);
138 scm_uintprint (SCM_UNPACK (program
), 16, port
);
139 scm_putc_unlocked ('>', port
);
141 else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program
))
144 scm_puts_unlocked ("#<partial-continuation ", port
);
145 scm_uintprint (SCM_UNPACK (program
), 16, port
);
146 scm_putc_unlocked ('>', port
);
148 else if (scm_is_false (write_program
) || print_error
)
150 scm_puts_unlocked ("#<rtl-program ", port
);
151 scm_uintprint (SCM_UNPACK (program
), 16, port
);
152 scm_putc_unlocked (' ', port
);
153 scm_uintprint ((scm_t_uintptr
) SCM_RTL_PROGRAM_CODE (program
), 16, port
);
154 scm_putc_unlocked ('>', port
);
159 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
169 SCM_DEFINE (scm_rtl_program_p
, "rtl-program?", 1, 0, 0,
172 #define FUNC_NAME s_scm_rtl_program_p
174 return scm_from_bool (SCM_RTL_PROGRAM_P (obj
));
178 SCM_DEFINE (scm_primitive_p
, "primitive?", 1, 0, 0,
181 #define FUNC_NAME s_scm_primitive_p
183 return scm_from_bool (SCM_PRIMITIVE_P (obj
));
187 SCM_DEFINE (scm_primitive_call_ip
, "primitive-call-ip", 1, 0, 0,
190 #define FUNC_NAME s_scm_primitive_p
192 SCM_MAKE_VALIDATE (1, prim
, PRIMITIVE_P
);
194 return scm_from_uintptr_t (scm_i_primitive_call_ip (prim
));
199 scm_find_source_for_addr (SCM ip
)
201 static SCM source_for_addr
= SCM_BOOL_F
;
203 if (scm_is_false (source_for_addr
)) {
204 if (!scm_module_system_booted_p
)
208 scm_c_private_variable ("system vm program", "source-for-addr");
211 return scm_call_1 (scm_variable_ref (source_for_addr
), ip
);
215 scm_program_source (SCM program
, SCM ip
, SCM sources
)
217 static SCM program_source
= SCM_BOOL_F
;
219 if (scm_is_false (program_source
)) {
220 if (!scm_module_system_booted_p
)
224 scm_c_private_variable ("system vm program", "program-source");
227 if (SCM_UNBNDP (sources
))
228 return scm_call_2 (scm_variable_ref (program_source
), program
, ip
);
230 return scm_call_3 (scm_variable_ref (program_source
), program
, ip
, sources
);
233 SCM_DEFINE (scm_program_num_free_variables
, "program-num-free-variables", 1, 0, 0,
236 #define FUNC_NAME s_scm_program_num_free_variables
238 SCM_VALIDATE_RTL_PROGRAM (1, program
);
240 return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
));
244 SCM_DEFINE (scm_program_free_variable_ref
, "program-free-variable-ref", 2, 0, 0,
245 (SCM program
, SCM i
),
247 #define FUNC_NAME s_scm_program_free_variable_ref
251 SCM_VALIDATE_RTL_PROGRAM (1, program
);
252 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
253 if (idx
>= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
))
254 SCM_OUT_OF_RANGE (2, i
);
255 return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program
, idx
);
259 SCM_DEFINE (scm_program_free_variable_set_x
, "program-free-variable-set!", 3, 0, 0,
260 (SCM program
, SCM i
, SCM x
),
262 #define FUNC_NAME s_scm_program_free_variable_set_x
266 SCM_VALIDATE_RTL_PROGRAM (1, program
);
267 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
268 if (idx
>= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
))
269 SCM_OUT_OF_RANGE (2, i
);
270 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program
, idx
, x
);
271 return SCM_UNSPECIFIED
;
276 scm_i_program_arity (SCM program
, int *req
, int *opt
, int *rest
)
278 static SCM rtl_program_minimum_arity
= SCM_BOOL_F
;
281 if (SCM_PRIMITIVE_P (program
))
282 return scm_i_primitive_arity (program
, req
, opt
, rest
);
284 if (SCM_PROGRAM_IS_FOREIGN (program
))
285 return scm_i_foreign_arity (program
, req
, opt
, rest
);
287 if (SCM_PROGRAM_IS_CONTINUATION (program
)
288 || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program
))
295 if (scm_is_false (rtl_program_minimum_arity
) && scm_module_system_booted_p
)
296 rtl_program_minimum_arity
=
297 scm_c_private_variable ("system vm program",
298 "rtl-program-minimum-arity");
300 l
= scm_call_1 (scm_variable_ref (rtl_program_minimum_arity
), program
);
301 if (scm_is_false (l
))
304 *req
= scm_to_int (scm_car (l
));
305 *opt
= scm_to_int (scm_cadr (l
));
306 *rest
= scm_is_true (scm_caddr (l
));
314 scm_bootstrap_programs (void)
316 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
318 (scm_t_extension_init_func
)scm_init_programs
, NULL
);
322 scm_init_programs (void)
324 #ifndef SCM_MAGIC_SNARFER
325 #include "libguile/programs.x"