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
25 #include "instructions.h"
28 #include "procprop.h" /* scm_sym_name */
29 #include "srcprop.h" /* scm_sym_filename */
33 static SCM write_program
= SCM_BOOL_F
;
35 SCM_DEFINE (scm_make_program
, "make-program", 1, 2, 0,
36 (SCM objcode
, SCM objtable
, SCM free_variables
),
38 #define FUNC_NAME s_scm_make_program
40 SCM_VALIDATE_OBJCODE (1, objcode
);
41 if (SCM_UNLIKELY (SCM_UNBNDP (objtable
)))
42 objtable
= SCM_BOOL_F
;
43 else if (scm_is_true (objtable
))
44 SCM_VALIDATE_VECTOR (2, objtable
);
46 if (SCM_UNBNDP (free_variables
) || scm_is_false (free_variables
))
48 SCM ret
= scm_words (scm_tc7_program
, 3);
49 SCM_SET_CELL_OBJECT_1 (ret
, objcode
);
50 SCM_SET_CELL_OBJECT_2 (ret
, objtable
);
57 SCM_VALIDATE_VECTOR (3, free_variables
);
58 len
= scm_c_vector_length (free_variables
);
59 if (SCM_UNLIKELY (len
>> 16))
60 SCM_OUT_OF_RANGE (3, free_variables
);
61 ret
= scm_words (scm_tc7_program
| (len
<<16), 3 + len
);
62 SCM_SET_CELL_OBJECT_1 (ret
, objcode
);
63 SCM_SET_CELL_OBJECT_2 (ret
, objtable
);
64 for (i
= 0; i
< len
; i
++)
65 SCM_SET_CELL_OBJECT (ret
, 3+i
,
66 SCM_SIMPLE_VECTOR_REF (free_variables
, i
));
72 SCM_DEFINE (scm_make_rtl_program
, "make-rtl-program", 1, 2, 0,
73 (SCM bytevector
, SCM byte_offset
, SCM free_variables
),
75 #define FUNC_NAME s_scm_make_rtl_program
80 if (!scm_is_bytevector (bytevector
))
81 scm_wrong_type_arg (FUNC_NAME
, 1, bytevector
);
82 if (SCM_UNBNDP (byte_offset
))
86 offset
= scm_to_uint32 (byte_offset
);
87 if (offset
> SCM_BYTEVECTOR_LENGTH (bytevector
))
88 SCM_OUT_OF_RANGE (2, byte_offset
);
91 code
= (scm_t_uint8
*) SCM_BYTEVECTOR_CONTENTS (bytevector
) + offset
;
92 if (((scm_t_uintptr
) code
) % 4)
93 SCM_OUT_OF_RANGE (2, byte_offset
);
95 if (SCM_UNBNDP (free_variables
) || scm_is_false (free_variables
))
96 return scm_cell (scm_tc7_rtl_program
, (scm_t_bits
) code
);
102 SCM_DEFINE (scm_rtl_program_code
, "rtl-program-code", 1, 0, 0,
105 #define FUNC_NAME s_scm_rtl_program_code
107 SCM_VALIDATE_RTL_PROGRAM (1, program
);
109 return scm_from_uintptr_t ((scm_t_uintptr
) SCM_RTL_PROGRAM_CODE (program
));
114 scm_i_rtl_program_name (SCM program
)
116 static SCM rtl_program_name
= SCM_BOOL_F
;
118 if (SCM_PRIMITIVE_P (program
))
119 return SCM_SUBR_NAME (program
);
121 if (scm_is_false (rtl_program_name
) && scm_module_system_booted_p
)
123 scm_c_private_variable ("system vm program", "rtl-program-name");
125 return scm_call_1 (scm_variable_ref (rtl_program_name
), program
);
129 scm_i_rtl_program_documentation (SCM program
)
131 static SCM rtl_program_documentation
= SCM_BOOL_F
;
133 if (SCM_PRIMITIVE_P (program
))
136 if (scm_is_false (rtl_program_documentation
) && scm_module_system_booted_p
)
137 rtl_program_documentation
=
138 scm_c_private_variable ("system vm program",
139 "rtl-program-documentation");
141 return scm_call_1 (scm_variable_ref (rtl_program_documentation
), program
);
145 scm_i_rtl_program_properties (SCM program
)
147 static SCM rtl_program_properties
= SCM_BOOL_F
;
149 if (SCM_PRIMITIVE_P (program
))
151 SCM name
= scm_i_rtl_program_name (program
);
152 if (scm_is_false (name
))
154 return scm_acons (scm_sym_name
, name
, SCM_EOL
);
157 if (scm_is_false (rtl_program_properties
) && scm_module_system_booted_p
)
158 rtl_program_properties
=
159 scm_c_private_variable ("system vm program", "rtl-program-properties");
161 return scm_call_1 (scm_variable_ref (rtl_program_properties
), program
);
165 scm_i_program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
167 static int print_error
= 0;
169 if (scm_is_false (write_program
) && scm_module_system_booted_p
)
170 write_program
= scm_c_private_variable ("system vm program",
173 if (SCM_PROGRAM_IS_CONTINUATION (program
))
176 scm_puts_unlocked ("#<continuation ", port
);
177 scm_uintprint (SCM_UNPACK (program
), 16, port
);
178 scm_putc_unlocked ('>', port
);
180 else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program
))
183 scm_puts_unlocked ("#<partial-continuation ", port
);
184 scm_uintprint (SCM_UNPACK (program
), 16, port
);
185 scm_putc_unlocked ('>', port
);
187 else if (scm_is_false (write_program
) || print_error
)
189 if (SCM_RTL_PROGRAM_P (program
))
191 scm_puts_unlocked ("#<rtl-program ", port
);
192 scm_uintprint (SCM_UNPACK (program
), 16, port
);
193 scm_putc_unlocked (' ', port
);
194 scm_uintprint ((scm_t_uintptr
) SCM_RTL_PROGRAM_CODE (program
), 16, port
);
195 scm_putc_unlocked ('>', port
);
199 scm_puts_unlocked ("#<program ", port
);
200 scm_uintprint (SCM_UNPACK (program
), 16, port
);
201 scm_putc_unlocked ('>', port
);
207 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
217 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
220 #define FUNC_NAME s_scm_program_p
222 return scm_from_bool (SCM_PROGRAM_P (obj
));
226 SCM_DEFINE (scm_rtl_program_p
, "rtl-program?", 1, 0, 0,
229 #define FUNC_NAME s_scm_rtl_program_p
231 return scm_from_bool (SCM_RTL_PROGRAM_P (obj
));
235 SCM_DEFINE (scm_primitive_p
, "primitive?", 1, 0, 0,
238 #define FUNC_NAME s_scm_primitive_p
240 return scm_from_bool (SCM_PRIMITIVE_P (obj
));
244 SCM_DEFINE (scm_primitive_call_ip
, "primitive-call-ip", 1, 0, 0,
247 #define FUNC_NAME s_scm_primitive_p
249 SCM_MAKE_VALIDATE (1, prim
, PRIMITIVE_P
);
251 return scm_from_int (scm_i_primitive_call_ip (prim
));
255 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
258 #define FUNC_NAME s_scm_program_base
260 const struct scm_objcode
*c_objcode
;
262 SCM_VALIDATE_PROGRAM (1, program
);
264 c_objcode
= SCM_PROGRAM_DATA (program
);
265 return scm_from_unsigned_integer ((scm_t_bits
) SCM_C_OBJCODE_BASE (c_objcode
));
269 SCM_DEFINE (scm_program_objects
, "program-objects", 1, 0, 0,
272 #define FUNC_NAME s_scm_program_objects
274 SCM_VALIDATE_PROGRAM (1, program
);
275 return SCM_PROGRAM_OBJTABLE (program
);
279 SCM_DEFINE (scm_program_module
, "program-module", 1, 0, 0,
282 #define FUNC_NAME s_scm_program_module
285 SCM_VALIDATE_PROGRAM (1, program
);
286 objs
= SCM_PROGRAM_OBJTABLE (program
);
287 /* If a program is the result of compiling GLIL to assembly, then if
288 it has an objtable, the first entry will be a module. But some
289 programs are hand-coded trampolines, like boot programs and
290 primitives and the like. So if a program happens to have a
291 non-module in the first slot of the objtable, assume that it is
292 such a trampoline, and just return #f for the module. */
293 mod
= scm_is_true (objs
) ? scm_c_vector_ref (objs
, 0) : SCM_BOOL_F
;
294 return SCM_MODULEP (mod
) ? mod
: SCM_BOOL_F
;
298 SCM_DEFINE (scm_program_meta
, "program-meta", 1, 0, 0,
301 #define FUNC_NAME s_scm_program_meta
305 SCM_VALIDATE_PROGRAM (1, program
);
307 metaobj
= scm_objcode_meta (SCM_PROGRAM_OBJCODE (program
));
308 if (scm_is_true (metaobj
))
309 return scm_make_program (metaobj
, SCM_PROGRAM_OBJTABLE (program
),
316 SCM_DEFINE (scm_program_bindings
, "program-bindings", 1, 0, 0,
319 #define FUNC_NAME s_scm_program_bindings
323 SCM_VALIDATE_PROGRAM (1, program
);
325 meta
= scm_program_meta (program
);
326 if (scm_is_false (meta
))
329 return scm_car (scm_call_0 (meta
));
333 SCM_DEFINE (scm_program_sources
, "%program-sources", 1, 0, 0,
336 #define FUNC_NAME s_scm_program_sources
338 SCM meta
, sources
, ret
, filename
;
340 SCM_VALIDATE_PROGRAM (1, program
);
342 meta
= scm_program_meta (program
);
343 if (scm_is_false (meta
))
346 filename
= SCM_BOOL_F
;
348 for (sources
= scm_cadr (scm_call_0 (meta
)); !scm_is_null (sources
);
349 sources
= scm_cdr (sources
))
351 SCM x
= scm_car (sources
);
354 if (scm_is_number (scm_car (x
)))
356 SCM addr
= scm_car (x
);
357 ret
= scm_acons (addr
, scm_cons (filename
, scm_cdr (x
)),
360 else if (scm_is_eq (scm_car (x
), scm_sym_filename
))
361 filename
= scm_cdr (x
);
364 return scm_reverse_x (ret
, SCM_UNDEFINED
);
368 SCM_DEFINE (scm_program_arities
, "program-arities", 1, 0, 0,
371 #define FUNC_NAME s_scm_program_arities
375 SCM_VALIDATE_PROGRAM (1, program
);
377 meta
= scm_program_meta (program
);
378 if (scm_is_false (meta
))
381 return scm_caddr (scm_call_0 (meta
));
386 scm_i_program_properties (SCM program
)
387 #define FUNC_NAME "%program-properties"
391 SCM_VALIDATE_PROGRAM (1, program
);
393 meta
= scm_program_meta (program
);
394 if (scm_is_false (meta
))
397 return scm_cdddr (scm_call_0 (meta
));
402 scm_find_source_for_addr (SCM ip
)
404 static SCM source_for_addr
= SCM_BOOL_F
;
406 if (scm_is_false (source_for_addr
)) {
407 if (!scm_module_system_booted_p
)
411 scm_c_private_variable ("system vm program", "source-for-addr");
414 return scm_call_1 (scm_variable_ref (source_for_addr
), ip
);
418 scm_program_source (SCM program
, SCM ip
, SCM sources
)
420 static SCM program_source
= SCM_BOOL_F
;
422 if (scm_is_false (program_source
)) {
423 if (!scm_module_system_booted_p
)
427 scm_c_private_variable ("system vm program", "program-source");
430 if (SCM_UNBNDP (sources
))
431 return scm_call_2 (scm_variable_ref (program_source
), program
, ip
);
433 return scm_call_3 (scm_variable_ref (program_source
), program
, ip
, sources
);
436 SCM_DEFINE (scm_program_num_free_variables
, "program-num-free-variables", 1, 0, 0,
439 #define FUNC_NAME s_scm_program_num_free_variables
441 if (SCM_RTL_PROGRAM_P (program
)) {
442 return scm_from_ulong (SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
));
445 SCM_VALIDATE_PROGRAM (1, program
);
446 return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program
));
450 SCM_DEFINE (scm_program_free_variable_ref
, "program-free-variable-ref", 2, 0, 0,
451 (SCM program
, SCM i
),
453 #define FUNC_NAME s_scm_program_free_variable_ref
457 if (SCM_RTL_PROGRAM_P (program
)) {
458 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
459 if (idx
>= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
))
460 SCM_OUT_OF_RANGE (2, i
);
461 return SCM_RTL_PROGRAM_FREE_VARIABLE_REF (program
, idx
);
464 SCM_VALIDATE_PROGRAM (1, program
);
465 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
466 if (idx
>= SCM_PROGRAM_NUM_FREE_VARIABLES (program
))
467 SCM_OUT_OF_RANGE (2, i
);
468 return SCM_PROGRAM_FREE_VARIABLE_REF (program
, idx
);
472 SCM_DEFINE (scm_program_free_variable_set_x
, "program-free-variable-set!", 3, 0, 0,
473 (SCM program
, SCM i
, SCM x
),
475 #define FUNC_NAME s_scm_program_free_variable_set_x
479 if (SCM_RTL_PROGRAM_P (program
)) {
480 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
481 if (idx
>= SCM_RTL_PROGRAM_NUM_FREE_VARIABLES (program
))
482 SCM_OUT_OF_RANGE (2, i
);
483 SCM_RTL_PROGRAM_FREE_VARIABLE_SET (program
, idx
, x
);
484 return SCM_UNSPECIFIED
;
487 SCM_VALIDATE_PROGRAM (1, program
);
488 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
489 if (idx
>= SCM_PROGRAM_NUM_FREE_VARIABLES (program
))
490 SCM_OUT_OF_RANGE (2, i
);
491 SCM_PROGRAM_FREE_VARIABLE_SET (program
, idx
, x
);
492 return SCM_UNSPECIFIED
;
496 SCM_DEFINE (scm_program_objcode
, "program-objcode", 1, 0, 0,
498 "Return a @var{program}'s object code.")
499 #define FUNC_NAME s_scm_program_objcode
501 SCM_VALIDATE_PROGRAM (1, program
);
503 return SCM_PROGRAM_OBJCODE (program
);
507 /* procedure-minimum-arity support. */
509 parse_arity (SCM arity
, int *req
, int *opt
, int *rest
)
511 SCM x
= scm_cddr (arity
);
515 *req
= scm_to_int (scm_car (x
));
519 *opt
= scm_to_int (scm_car (x
));
522 *rest
= scm_is_true (scm_car (x
));
530 *req
= *opt
= *rest
= 0;
534 scm_i_rtl_program_minimum_arity (SCM program
, int *req
, int *opt
, int *rest
)
536 static SCM rtl_program_minimum_arity
= SCM_BOOL_F
;
539 if (SCM_PRIMITIVE_P (program
))
540 return scm_i_primitive_arity (program
, req
, opt
, rest
);
542 if (SCM_PROGRAM_IS_FOREIGN (program
))
543 return scm_i_foreign_arity (program
, req
, opt
, rest
);
545 if (SCM_PROGRAM_IS_CONTINUATION (program
)
546 || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program
))
553 if (scm_is_false (rtl_program_minimum_arity
) && scm_module_system_booted_p
)
554 rtl_program_minimum_arity
=
555 scm_c_private_variable ("system vm program",
556 "rtl-program-minimum-arity");
558 l
= scm_call_1 (scm_variable_ref (rtl_program_minimum_arity
), program
);
559 if (scm_is_false (l
))
562 *req
= scm_to_int (scm_car (l
));
563 *opt
= scm_to_int (scm_cadr (l
));
564 *rest
= scm_is_true (scm_caddr (l
));
570 scm_i_program_arity (SCM program
, int *req
, int *opt
, int *rest
)
574 if (SCM_RTL_PROGRAM_P (program
))
575 return scm_i_rtl_program_minimum_arity (program
, req
, opt
, rest
);
577 arities
= scm_program_arities (program
);
578 if (!scm_is_pair (arities
))
581 parse_arity (scm_car (arities
), req
, opt
, rest
);
582 arities
= scm_cdr (arities
);
584 for (; scm_is_pair (arities
); arities
= scm_cdr (arities
))
586 int thisreq
, thisopt
, thisrest
;
588 parse_arity (scm_car (arities
), &thisreq
, &thisopt
, &thisrest
);
592 && ((thisrest
&& (!*rest
|| thisopt
> *opt
))
593 || (!thisrest
&& !*rest
&& thisopt
> *opt
))))
607 scm_bootstrap_programs (void)
609 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
611 (scm_t_extension_init_func
)scm_init_programs
, NULL
);
615 scm_init_programs (void)
617 #ifndef SCM_MAGIC_SNARFER
618 #include "libguile/programs.x"