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 static SCM write_program
= SCM_BOOL_F
;
36 SCM_DEFINE (scm_make_program
, "make-program", 1, 2, 0,
37 (SCM objcode
, SCM objtable
, SCM free_variables
),
39 #define FUNC_NAME s_scm_make_program
41 SCM_VALIDATE_OBJCODE (1, objcode
);
42 if (SCM_UNLIKELY (SCM_UNBNDP (objtable
)))
43 objtable
= SCM_BOOL_F
;
44 else if (scm_is_true (objtable
))
45 SCM_VALIDATE_VECTOR (2, objtable
);
46 if (SCM_UNLIKELY (SCM_UNBNDP (free_variables
)))
47 free_variables
= SCM_BOOL_F
;
48 else if (free_variables
!= SCM_BOOL_F
)
49 SCM_VALIDATE_VECTOR (3, free_variables
);
51 return scm_double_cell (scm_tc7_program
, (scm_t_bits
)objcode
,
52 (scm_t_bits
)objtable
, (scm_t_bits
)free_variables
);
57 scm_i_program_print (SCM program
, SCM port
, scm_print_state
*pstate
)
59 static int print_error
= 0;
61 if (SCM_FALSEP (write_program
) && scm_module_system_booted_p
)
62 write_program
= scm_module_local_variable
63 (scm_c_resolve_module ("system vm program"),
64 scm_from_locale_symbol ("write-program"));
66 if (SCM_FALSEP (write_program
) || print_error
)
68 scm_puts ("#<program ", port
);
69 scm_uintprint (SCM_CELL_WORD_1 (program
), 16, port
);
75 scm_call_2 (SCM_VARIABLE_REF (write_program
), program
, port
);
85 SCM_DEFINE (scm_program_p
, "program?", 1, 0, 0,
88 #define FUNC_NAME s_scm_program_p
90 return SCM_BOOL (SCM_PROGRAM_P (obj
));
94 SCM_DEFINE (scm_program_base
, "program-base", 1, 0, 0,
97 #define FUNC_NAME s_scm_program_base
99 SCM_VALIDATE_PROGRAM (1, program
);
101 return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program
)->base
);
105 SCM_DEFINE (scm_program_arity
, "program-arity", 1, 0, 0,
108 #define FUNC_NAME s_scm_program_arity
110 struct scm_objcode
*p
;
112 SCM_VALIDATE_PROGRAM (1, program
);
114 p
= SCM_PROGRAM_DATA (program
);
115 return scm_list_3 (SCM_I_MAKINUM (p
->nargs
),
116 SCM_I_MAKINUM (p
->nrest
),
117 SCM_I_MAKINUM (p
->nlocs
));
121 SCM_DEFINE (scm_program_objects
, "program-objects", 1, 0, 0,
124 #define FUNC_NAME s_scm_program_objects
126 SCM_VALIDATE_PROGRAM (1, program
);
127 return SCM_PROGRAM_OBJTABLE (program
);
131 SCM_DEFINE (scm_program_module
, "program-module", 1, 0, 0,
134 #define FUNC_NAME s_scm_program_module
137 SCM_VALIDATE_PROGRAM (1, program
);
138 objs
= SCM_PROGRAM_OBJTABLE (program
);
139 return scm_is_true (objs
) ? scm_c_vector_ref (objs
, 0) : SCM_BOOL_F
;
143 SCM_DEFINE (scm_program_meta
, "program-meta", 1, 0, 0,
146 #define FUNC_NAME s_scm_program_meta
150 SCM_VALIDATE_PROGRAM (1, program
);
152 metaobj
= scm_objcode_meta (SCM_PROGRAM_OBJCODE (program
));
153 if (scm_is_true (metaobj
))
154 return scm_make_program (metaobj
, SCM_BOOL_F
, SCM_BOOL_F
);
160 SCM_DEFINE (scm_program_bindings
, "program-bindings", 1, 0, 0,
163 #define FUNC_NAME s_scm_program_bindings
167 SCM_VALIDATE_PROGRAM (1, program
);
169 meta
= scm_program_meta (program
);
170 if (scm_is_false (meta
))
173 return scm_car (scm_call_0 (meta
));
177 SCM_DEFINE (scm_program_sources
, "program-sources", 1, 0, 0,
180 #define FUNC_NAME s_scm_program_sources
182 SCM meta
, sources
, ret
, filename
;
184 SCM_VALIDATE_PROGRAM (1, program
);
186 meta
= scm_program_meta (program
);
187 if (scm_is_false (meta
))
190 filename
= SCM_BOOL_F
;
192 for (sources
= scm_cadr (scm_call_0 (meta
)); !scm_is_null (sources
);
193 sources
= scm_cdr (sources
))
195 SCM x
= scm_car (sources
);
198 if (scm_is_number (scm_car (x
)))
200 SCM addr
= scm_car (x
);
201 ret
= scm_acons (addr
, scm_cons (filename
, scm_cdr (x
)),
204 else if (scm_is_eq (scm_car (x
), scm_sym_filename
))
205 filename
= scm_cdr (x
);
208 return scm_reverse_x (ret
, SCM_UNDEFINED
);
212 SCM_DEFINE (scm_program_properties
, "program-properties", 1, 0, 0,
215 #define FUNC_NAME s_scm_program_properties
219 SCM_VALIDATE_PROGRAM (1, program
);
221 meta
= scm_program_meta (program
);
222 if (scm_is_false (meta
))
225 return scm_cddr (scm_call_0 (meta
));
229 SCM_DEFINE (scm_program_name
, "program-name", 1, 0, 0,
232 #define FUNC_NAME s_scm_program_name
234 SCM_VALIDATE_PROGRAM (1, program
);
235 return scm_assq_ref (scm_program_properties (program
), scm_sym_name
);
239 SCM_DEFINE (scm_program_source
, "program-source", 2, 0, 0,
240 (SCM program
, SCM ip
),
242 #define FUNC_NAME s_scm_program_source
244 SCM_VALIDATE_PROGRAM (1, program
);
245 return scm_c_program_source (program
, scm_to_size_t (ip
));
250 scm_c_program_source (SCM program
, size_t ip
)
252 SCM sources
, source
= SCM_BOOL_F
;
254 for (sources
= scm_program_sources (program
);
255 !scm_is_null (sources
)
256 && scm_to_size_t (scm_caar (sources
)) <= ip
;
257 sources
= scm_cdr (sources
))
258 source
= scm_car (sources
);
260 return source
; /* (addr . (filename . (line . column))) */
263 SCM_DEFINE (scm_program_free_variables
, "program-free-variables", 1, 0, 0,
266 #define FUNC_NAME s_scm_program_free_variables
268 SCM_VALIDATE_PROGRAM (1, program
);
269 return SCM_PROGRAM_FREE_VARIABLES (program
);
273 SCM_DEFINE (scm_program_objcode
, "program-objcode", 1, 0, 0,
275 "Return a @var{program}'s object code.")
276 #define FUNC_NAME s_scm_program_objcode
278 SCM_VALIDATE_PROGRAM (1, program
);
280 return SCM_PROGRAM_OBJCODE (program
);
287 scm_bootstrap_programs (void)
289 scm_c_register_extension ("libguile", "scm_init_programs",
290 (scm_t_extension_init_func
)scm_init_programs
, NULL
);
294 scm_init_programs (void)
298 #ifndef SCM_MAGIC_SNARFER
299 #include "libguile/programs.x"