1 /* Copyright (C) 2001 Free Software Foundation, Inc.
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
47 #include "vm-bootstrap.h"
48 #include "instructions.h"
51 #include "procprop.h" // scm_sym_name
52 #include "srcprop.h" // scm_sym_filename
56 scm_t_bits scm_tc16_program
;
58 static SCM write_program
= SCM_BOOL_F
;
60 SCM_DEFINE (scm_make_program
, "make-program", 1, 2, 0,
61 (SCM objcode
, SCM objtable
, SCM external
),
63 #define FUNC_NAME s_scm_make_program
65 SCM_VALIDATE_OBJCODE (1, objcode
);
66 if (SCM_UNLIKELY (SCM_UNBNDP (objtable
)))
67 objtable
= SCM_BOOL_F
;
68 else if (scm_is_true (objtable
))
69 SCM_VALIDATE_VECTOR (2, objtable
);
70 if (SCM_UNLIKELY (SCM_UNBNDP (external
)))
73 /* FIXME: currently this test is quite expensive (can be 2-3% of total
74 execution time in programs that make many closures). We could remove it,
75 yes, but we'd get much better gains if we used some other method, like
76 just capturing the variables that we need instead of all heap-allocated
77 variables. Dunno. Keeping the check for now, as it's a user-callable
78 function, and inlining the op in the vm's make-closure operation. */
79 SCM_VALIDATE_LIST (3, external
);
81 SCM_RETURN_NEWSMOB3 (scm_tc16_program
, objcode
, objtable
, external
);
86 program_mark (SCM obj
)
88 if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj
)))
89 scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj
));
90 if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj
)))
91 scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj
));
92 return SCM_PROGRAM_OBJCODE (obj
);
96 program_apply (SCM program
, SCM args
)
98 return scm_vm_apply (scm_the_vm (), program
, args
);
102 program_apply_0 (SCM program
)
104 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
108 program_apply_1 (SCM program
, SCM a
)
110 return scm_c_vm_run (scm_the_vm (), program
, &a
, 1);
114 program_apply_2 (SCM program
, SCM a
, SCM b
)
119 return scm_c_vm_run (scm_the_vm (), program
, args
, 2);
123 program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
125 static int print_error
= 0;
127 if (SCM_FALSEP (write_program
) && scm_module_system_booted_p
)
128 write_program
= scm_module_local_variable
129 (scm_c_resolve_module ("system vm program"),
130 scm_from_locale_symbol ("write-program"));
132 if (SCM_FALSEP (write_program
) || print_error
)
133 return scm_smob_print (program
, port
, pstate
);
136 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
146 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
149 #define FUNC_NAME s_scm_program_p
151 return SCM_BOOL (SCM_PROGRAM_P (obj
));
155 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
158 #define FUNC_NAME s_scm_program_base
160 SCM_VALIDATE_PROGRAM (1, program
);
162 return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program
)->base
);
166 SCM_DEFINE (scm_program_arity
, "program-arity", 1, 0, 0,
169 #define FUNC_NAME s_scm_program_arity
171 struct scm_objcode
*p
;
173 SCM_VALIDATE_PROGRAM (1, program
);
175 p
= SCM_PROGRAM_DATA (program
);
176 return SCM_LIST4 (SCM_I_MAKINUM (p
->nargs
),
177 SCM_I_MAKINUM (p
->nrest
),
178 SCM_I_MAKINUM (p
->nlocs
),
179 SCM_I_MAKINUM (p
->nexts
));
183 SCM_DEFINE (scm_program_objects
, "program-objects", 1, 0, 0,
186 #define FUNC_NAME s_scm_program_objects
188 SCM_VALIDATE_PROGRAM (1, program
);
189 return SCM_PROGRAM_OBJTABLE (program
);
193 SCM_DEFINE (scm_program_module
, "program-module", 1, 0, 0,
196 #define FUNC_NAME s_scm_program_module
199 SCM_VALIDATE_PROGRAM (1, program
);
200 objs
= SCM_PROGRAM_OBJTABLE (program
);
201 return scm_is_true (objs
) ? scm_c_vector_ref (objs
, 0) : SCM_BOOL_F
;
205 SCM_DEFINE (scm_program_meta
, "program-meta", 1, 0, 0,
208 #define FUNC_NAME s_scm_program_meta
212 SCM_VALIDATE_PROGRAM (1, program
);
214 metaobj
= scm_objcode_meta (SCM_PROGRAM_OBJCODE (program
));
215 if (scm_is_true (metaobj
))
216 return scm_make_program (metaobj
, SCM_BOOL_F
, SCM_EOL
);
222 SCM_DEFINE (scm_program_bindings
, "program-bindings", 1, 0, 0,
225 #define FUNC_NAME s_scm_program_bindings
229 SCM_VALIDATE_PROGRAM (1, program
);
231 meta
= scm_program_meta (program
);
232 if (scm_is_false (meta
))
235 return scm_car (scm_call_0 (meta
));
239 SCM_DEFINE (scm_program_sources
, "program-sources", 1, 0, 0,
242 #define FUNC_NAME s_scm_program_sources
244 SCM meta
, sources
, ret
, filename
;
246 SCM_VALIDATE_PROGRAM (1, program
);
248 meta
= scm_program_meta (program
);
249 if (scm_is_false (meta
))
252 filename
= SCM_BOOL_F
;
254 for (sources
= scm_cadr (scm_call_0 (meta
)); !scm_is_null (sources
);
255 sources
= scm_cdr (sources
))
257 SCM x
= scm_car (sources
);
260 if (scm_is_number (scm_car (x
)))
262 SCM addr
= scm_car (x
);
263 ret
= scm_acons (addr
, scm_cons (filename
, scm_cdr (x
)),
266 else if (scm_is_eq (scm_car (x
), scm_sym_filename
))
267 filename
= scm_cdr (x
);
270 return scm_reverse_x (ret
, SCM_UNDEFINED
);
274 SCM_DEFINE (scm_program_properties
, "program-properties", 1, 0, 0,
277 #define FUNC_NAME s_scm_program_properties
281 SCM_VALIDATE_PROGRAM (1, program
);
283 meta
= scm_program_meta (program
);
284 if (scm_is_false (meta
))
287 return scm_cddr (scm_call_0 (meta
));
291 SCM_DEFINE (scm_program_name
, "program-name", 1, 0, 0,
294 #define FUNC_NAME s_scm_program_name
296 SCM_VALIDATE_PROGRAM (1, program
);
297 return scm_assq_ref (scm_program_properties (program
), scm_sym_name
);
301 SCM_DEFINE (scm_program_source
, "program-source", 2, 0, 0,
302 (SCM program
, SCM ip
),
304 #define FUNC_NAME s_scm_program_source
306 SCM_VALIDATE_PROGRAM (1, program
);
307 return scm_c_program_source (program
, scm_to_size_t (ip
));
312 scm_c_program_source (SCM program
, size_t ip
)
314 SCM sources
, source
= SCM_BOOL_F
;
316 for (sources
= scm_program_sources (program
);
317 !scm_is_null (sources
)
318 && scm_to_size_t (scm_caar (sources
)) <= ip
;
319 sources
= scm_cdr (sources
))
320 source
= scm_car (sources
);
322 return source
; /* (addr . (filename . (line . column))) */
325 SCM_DEFINE (scm_program_external
, "program-external", 1, 0, 0,
328 #define FUNC_NAME s_scm_program_external
330 SCM_VALIDATE_PROGRAM (1, program
);
331 return SCM_PROGRAM_EXTERNALS (program
);
335 SCM_DEFINE (scm_program_external_set_x
, "program-external-set!", 2, 0, 0,
336 (SCM program
, SCM external
),
337 "Modify the list of closure variables of @var{program} (for "
338 "debugging purposes).")
339 #define FUNC_NAME s_scm_program_external_set_x
341 SCM_VALIDATE_PROGRAM (1, program
);
342 SCM_VALIDATE_LIST (2, external
);
343 SCM_PROGRAM_EXTERNALS (program
) = external
;
344 return SCM_UNSPECIFIED
;
348 SCM_DEFINE (scm_program_objcode
, "program-objcode", 1, 0, 0,
350 "Return a @var{program}'s object code.")
351 #define FUNC_NAME s_scm_program_objcode
353 SCM_VALIDATE_PROGRAM (1, program
);
355 return SCM_PROGRAM_OBJCODE (program
);
362 scm_bootstrap_programs (void)
364 scm_tc16_program
= scm_make_smob_type ("program", 0);
365 scm_set_smob_mark (scm_tc16_program
, program_mark
);
366 scm_set_smob_apply (scm_tc16_program
, program_apply
, 0, 0, 1);
367 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_0
= program_apply_0
;
368 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_1
= program_apply_1
;
369 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_2
= program_apply_2
;
370 scm_set_smob_print (scm_tc16_program
, program_print
);
374 scm_init_programs (void)
378 #ifndef SCM_MAGIC_SNARFER
379 #include "programs.x"