1 /* Copyright (C) 2001, 2009, 2010 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
));
73 scm_i_program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
75 static int print_error
= 0;
77 if (scm_is_false (write_program
) && scm_module_system_booted_p
)
78 write_program
= scm_module_local_variable
79 (scm_c_resolve_module ("system vm program"),
80 scm_from_locale_symbol ("write-program"));
82 if (SCM_PROGRAM_IS_CONTINUATION (program
))
85 scm_puts ("#<continuation ", port
);
86 scm_uintprint (SCM_UNPACK (program
), 16, port
);
89 else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program
))
92 scm_puts ("#<partial-continuation ", port
);
93 scm_uintprint (SCM_UNPACK (program
), 16, port
);
96 else if (scm_is_false (write_program
) || print_error
)
98 scm_puts ("#<program ", port
);
99 scm_uintprint (SCM_UNPACK (program
), 16, port
);
100 scm_putc ('>', port
);
105 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
115 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
118 #define FUNC_NAME s_scm_program_p
120 return scm_from_bool (SCM_PROGRAM_P (obj
));
124 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
127 #define FUNC_NAME s_scm_program_base
129 const struct scm_objcode
*c_objcode
;
131 SCM_VALIDATE_PROGRAM (1, program
);
133 c_objcode
= SCM_PROGRAM_DATA (program
);
134 return scm_from_ulong ((unsigned long) SCM_C_OBJCODE_BASE (c_objcode
));
138 SCM_DEFINE (scm_program_objects
, "program-objects", 1, 0, 0,
141 #define FUNC_NAME s_scm_program_objects
143 SCM_VALIDATE_PROGRAM (1, program
);
144 return SCM_PROGRAM_OBJTABLE (program
);
148 SCM_DEFINE (scm_program_module
, "program-module", 1, 0, 0,
151 #define FUNC_NAME s_scm_program_module
154 SCM_VALIDATE_PROGRAM (1, program
);
155 objs
= SCM_PROGRAM_OBJTABLE (program
);
156 return scm_is_true (objs
) ? scm_c_vector_ref (objs
, 0) : SCM_BOOL_F
;
160 SCM_DEFINE (scm_program_meta
, "program-meta", 1, 0, 0,
163 #define FUNC_NAME s_scm_program_meta
167 SCM_VALIDATE_PROGRAM (1, program
);
169 metaobj
= scm_objcode_meta (SCM_PROGRAM_OBJCODE (program
));
170 if (scm_is_true (metaobj
))
171 return scm_make_program (metaobj
, SCM_PROGRAM_OBJTABLE (program
),
178 SCM_DEFINE (scm_program_bindings
, "program-bindings", 1, 0, 0,
181 #define FUNC_NAME s_scm_program_bindings
185 SCM_VALIDATE_PROGRAM (1, program
);
187 meta
= scm_program_meta (program
);
188 if (scm_is_false (meta
))
191 return scm_car (scm_call_0 (meta
));
195 SCM_DEFINE (scm_program_sources
, "program-sources", 1, 0, 0,
198 #define FUNC_NAME s_scm_program_sources
200 SCM meta
, sources
, ret
, filename
;
202 SCM_VALIDATE_PROGRAM (1, program
);
204 meta
= scm_program_meta (program
);
205 if (scm_is_false (meta
))
208 filename
= SCM_BOOL_F
;
210 for (sources
= scm_cadr (scm_call_0 (meta
)); !scm_is_null (sources
);
211 sources
= scm_cdr (sources
))
213 SCM x
= scm_car (sources
);
216 if (scm_is_number (scm_car (x
)))
218 SCM addr
= scm_car (x
);
219 ret
= scm_acons (addr
, scm_cons (filename
, scm_cdr (x
)),
222 else if (scm_is_eq (scm_car (x
), scm_sym_filename
))
223 filename
= scm_cdr (x
);
226 return scm_reverse_x (ret
, SCM_UNDEFINED
);
230 SCM_DEFINE (scm_program_arities
, "program-arities", 1, 0, 0,
233 #define FUNC_NAME s_scm_program_arities
237 SCM_VALIDATE_PROGRAM (1, program
);
239 meta
= scm_program_meta (program
);
240 if (scm_is_false (meta
))
243 return scm_caddr (scm_call_0 (meta
));
248 scm_i_program_properties (SCM program
)
249 #define FUNC_NAME "%program-properties"
253 SCM_VALIDATE_PROGRAM (1, program
);
255 meta
= scm_program_meta (program
);
256 if (scm_is_false (meta
))
259 return scm_cdddr (scm_call_0 (meta
));
263 SCM_DEFINE (scm_program_source
, "program-source", 2, 0, 0,
264 (SCM program
, SCM ip
),
266 #define FUNC_NAME s_scm_program_source
268 SCM_VALIDATE_PROGRAM (1, program
);
269 return scm_c_program_source (program
, scm_to_size_t (ip
));
274 scm_c_program_source (SCM program
, size_t ip
)
276 SCM sources
, source
= SCM_BOOL_F
;
278 for (sources
= scm_program_sources (program
);
279 !scm_is_null (sources
)
280 && scm_to_size_t (scm_caar (sources
)) <= ip
;
281 sources
= scm_cdr (sources
))
282 source
= scm_car (sources
);
284 return source
; /* (addr . (filename . (line . column))) */
287 SCM_DEFINE (scm_program_num_free_variables
, "program-num-free-variables", 1, 0, 0,
290 #define FUNC_NAME s_scm_program_num_free_variables
292 SCM_VALIDATE_PROGRAM (1, program
);
293 return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program
));
297 SCM_DEFINE (scm_program_free_variable_ref
, "program-free-variable-ref", 2, 0, 0,
298 (SCM program
, SCM i
),
300 #define FUNC_NAME s_scm_program_free_variable_ref
303 SCM_VALIDATE_PROGRAM (1, program
);
304 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
305 if (idx
>= SCM_PROGRAM_NUM_FREE_VARIABLES (program
))
306 SCM_OUT_OF_RANGE (2, i
);
307 return SCM_PROGRAM_FREE_VARIABLE_REF (program
, idx
);
311 SCM_DEFINE (scm_program_free_variable_set_x
, "program-free-variable-set!", 3, 0, 0,
312 (SCM program
, SCM i
, SCM x
),
314 #define FUNC_NAME s_scm_program_free_variable_set_x
317 SCM_VALIDATE_PROGRAM (1, program
);
318 SCM_VALIDATE_ULONG_COPY (2, i
, idx
);
319 if (idx
>= SCM_PROGRAM_NUM_FREE_VARIABLES (program
))
320 SCM_OUT_OF_RANGE (2, i
);
321 SCM_PROGRAM_FREE_VARIABLE_SET (program
, idx
, x
);
322 return SCM_UNSPECIFIED
;
326 SCM_DEFINE (scm_program_objcode
, "program-objcode", 1, 0, 0,
328 "Return a @var{program}'s object code.")
329 #define FUNC_NAME s_scm_program_objcode
331 SCM_VALIDATE_PROGRAM (1, program
);
333 return SCM_PROGRAM_OBJCODE (program
);
337 /* procedure-minimum-arity support. */
339 parse_arity (SCM arity
, int *req
, int *opt
, int *rest
)
341 SCM x
= scm_cddr (arity
);
345 *req
= scm_to_int (scm_car (x
));
349 *opt
= scm_to_int (scm_car (x
));
352 *rest
= scm_is_true (scm_car (x
));
360 *req
= *opt
= *rest
= 0;
364 scm_i_program_arity (SCM program
, int *req
, int *opt
, int *rest
)
368 arities
= scm_program_arities (program
);
369 if (!scm_is_pair (arities
))
372 parse_arity (scm_car (arities
), req
, opt
, rest
);
373 arities
= scm_cdr (arities
);
375 for (; scm_is_pair (arities
); arities
= scm_cdr (arities
))
377 int thisreq
, thisopt
, thisrest
;
379 parse_arity (scm_car (arities
), &thisreq
, &thisopt
, &thisrest
);
383 && ((thisrest
&& (!*rest
|| thisopt
> *opt
))
384 || (!thisrest
&& !*rest
&& thisopt
> *opt
))))
398 scm_bootstrap_programs (void)
400 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
402 (scm_t_extension_init_func
)scm_init_programs
, NULL
);
406 scm_init_programs (void)
408 #ifndef SCM_MAGIC_SNARFER
409 #include "libguile/programs.x"