1 /* Copyright (C) 2001, 2009 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 "vm-bootstrap.h"
26 #include "instructions.h"
29 #include "procprop.h" // scm_sym_name
30 #include "srcprop.h" // scm_sym_filename
34 scm_t_bits scm_tc16_program
;
36 static SCM write_program
= SCM_BOOL_F
;
38 SCM_DEFINE (scm_make_program
, "make-program", 1, 2, 0,
39 (SCM objcode
, SCM objtable
, SCM free_vars
),
41 #define FUNC_NAME s_scm_make_program
43 SCM_VALIDATE_OBJCODE (1, objcode
);
44 if (SCM_UNLIKELY (SCM_UNBNDP (objtable
)))
45 objtable
= SCM_BOOL_F
;
46 else if (scm_is_true (objtable
))
47 SCM_VALIDATE_VECTOR (2, objtable
);
48 if (SCM_UNLIKELY (SCM_UNBNDP (free_vars
)))
49 free_vars
= SCM_BOOL_F
;
50 else if (free_vars
!= SCM_BOOL_F
)
51 SCM_VALIDATE_VECTOR (3, free_vars
);
53 SCM_RETURN_NEWSMOB3 (scm_tc16_program
, objcode
, objtable
, free_vars
);
58 program_mark (SCM obj
)
60 if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj
)))
61 scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj
));
62 if (scm_is_true (SCM_PROGRAM_FREE_VARS (obj
)))
63 scm_gc_mark (SCM_PROGRAM_FREE_VARS (obj
));
64 return SCM_PROGRAM_OBJCODE (obj
);
68 program_apply (SCM program
, SCM args
)
70 return scm_vm_apply (scm_the_vm (), program
, args
);
74 program_apply_0 (SCM program
)
76 return scm_c_vm_run (scm_the_vm (), program
, NULL
, 0);
80 program_apply_1 (SCM program
, SCM a
)
82 return scm_c_vm_run (scm_the_vm (), program
, &a
, 1);
86 program_apply_2 (SCM program
, SCM a
, SCM b
)
91 return scm_c_vm_run (scm_the_vm (), program
, args
, 2);
95 program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
97 static int print_error
= 0;
99 if (SCM_FALSEP (write_program
) && scm_module_system_booted_p
)
100 write_program
= scm_module_local_variable
101 (scm_c_resolve_module ("system vm program"),
102 scm_from_locale_symbol ("write-program"));
104 if (SCM_FALSEP (write_program
) || print_error
)
105 return scm_smob_print (program
, port
, pstate
);
108 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
118 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
121 #define FUNC_NAME s_scm_program_p
123 return SCM_BOOL (SCM_PROGRAM_P (obj
));
127 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
130 #define FUNC_NAME s_scm_program_base
132 SCM_VALIDATE_PROGRAM (1, program
);
134 return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program
)->base
);
138 SCM_DEFINE (scm_program_arity
, "program-arity", 1, 0, 0,
141 #define FUNC_NAME s_scm_program_arity
143 struct scm_objcode
*p
;
145 SCM_VALIDATE_PROGRAM (1, program
);
147 p
= SCM_PROGRAM_DATA (program
);
148 return scm_list_3 (SCM_I_MAKINUM (p
->nargs
),
149 SCM_I_MAKINUM (p
->nrest
),
150 SCM_I_MAKINUM (p
->nlocs
));
154 SCM_DEFINE (scm_program_objects
, "program-objects", 1, 0, 0,
157 #define FUNC_NAME s_scm_program_objects
159 SCM_VALIDATE_PROGRAM (1, program
);
160 return SCM_PROGRAM_OBJTABLE (program
);
164 SCM_DEFINE (scm_program_module
, "program-module", 1, 0, 0,
167 #define FUNC_NAME s_scm_program_module
170 SCM_VALIDATE_PROGRAM (1, program
);
171 objs
= SCM_PROGRAM_OBJTABLE (program
);
172 return scm_is_true (objs
) ? scm_c_vector_ref (objs
, 0) : SCM_BOOL_F
;
176 SCM_DEFINE (scm_program_meta
, "program-meta", 1, 0, 0,
179 #define FUNC_NAME s_scm_program_meta
183 SCM_VALIDATE_PROGRAM (1, program
);
185 metaobj
= scm_objcode_meta (SCM_PROGRAM_OBJCODE (program
));
186 if (scm_is_true (metaobj
))
187 return scm_make_program (metaobj
, SCM_BOOL_F
, SCM_BOOL_F
);
193 SCM_DEFINE (scm_program_bindings
, "program-bindings", 1, 0, 0,
196 #define FUNC_NAME s_scm_program_bindings
200 SCM_VALIDATE_PROGRAM (1, program
);
202 meta
= scm_program_meta (program
);
203 if (scm_is_false (meta
))
206 return scm_car (scm_call_0 (meta
));
210 SCM_DEFINE (scm_program_sources
, "program-sources", 1, 0, 0,
213 #define FUNC_NAME s_scm_program_sources
215 SCM meta
, sources
, ret
, filename
;
217 SCM_VALIDATE_PROGRAM (1, program
);
219 meta
= scm_program_meta (program
);
220 if (scm_is_false (meta
))
223 filename
= SCM_BOOL_F
;
225 for (sources
= scm_cadr (scm_call_0 (meta
)); !scm_is_null (sources
);
226 sources
= scm_cdr (sources
))
228 SCM x
= scm_car (sources
);
231 if (scm_is_number (scm_car (x
)))
233 SCM addr
= scm_car (x
);
234 ret
= scm_acons (addr
, scm_cons (filename
, scm_cdr (x
)),
237 else if (scm_is_eq (scm_car (x
), scm_sym_filename
))
238 filename
= scm_cdr (x
);
241 return scm_reverse_x (ret
, SCM_UNDEFINED
);
245 SCM_DEFINE (scm_program_properties
, "program-properties", 1, 0, 0,
248 #define FUNC_NAME s_scm_program_properties
252 SCM_VALIDATE_PROGRAM (1, program
);
254 meta
= scm_program_meta (program
);
255 if (scm_is_false (meta
))
258 return scm_cddr (scm_call_0 (meta
));
262 SCM_DEFINE (scm_program_name
, "program-name", 1, 0, 0,
265 #define FUNC_NAME s_scm_program_name
267 SCM_VALIDATE_PROGRAM (1, program
);
268 return scm_assq_ref (scm_program_properties (program
), scm_sym_name
);
272 SCM_DEFINE (scm_program_source
, "program-source", 2, 0, 0,
273 (SCM program
, SCM ip
),
275 #define FUNC_NAME s_scm_program_source
277 SCM_VALIDATE_PROGRAM (1, program
);
278 return scm_c_program_source (program
, scm_to_size_t (ip
));
283 scm_c_program_source (SCM program
, size_t ip
)
285 SCM sources
, source
= SCM_BOOL_F
;
287 for (sources
= scm_program_sources (program
);
288 !scm_is_null (sources
)
289 && scm_to_size_t (scm_caar (sources
)) <= ip
;
290 sources
= scm_cdr (sources
))
291 source
= scm_car (sources
);
293 return source
; /* (addr . (filename . (line . column))) */
296 SCM_DEFINE (scm_program_free_vars
, "program-free-vars", 1, 0, 0,
299 #define FUNC_NAME s_scm_program_free_vars
301 SCM_VALIDATE_PROGRAM (1, program
);
302 return SCM_PROGRAM_FREE_VARS (program
);
306 SCM_DEFINE (scm_program_objcode
, "program-objcode", 1, 0, 0,
308 "Return a @var{program}'s object code.")
309 #define FUNC_NAME s_scm_program_objcode
311 SCM_VALIDATE_PROGRAM (1, program
);
313 return SCM_PROGRAM_OBJCODE (program
);
320 scm_bootstrap_programs (void)
322 scm_tc16_program
= scm_make_smob_type ("program", 0);
323 scm_set_smob_mark (scm_tc16_program
, program_mark
);
324 scm_set_smob_apply (scm_tc16_program
, program_apply
, 0, 0, 1);
325 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_0
= program_apply_0
;
326 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_1
= program_apply_1
;
327 scm_smobs
[SCM_TC2SMOBNUM (scm_tc16_program
)].apply_2
= program_apply_2
;
328 scm_set_smob_print (scm_tc16_program
, program_print
);
329 scm_c_register_extension ("libguile", "scm_init_programs",
330 (scm_t_extension_init_func
)scm_init_programs
, NULL
);
334 scm_init_programs (void)
338 #ifndef SCM_MAGIC_SNARFER
339 #include "libguile/programs.x"