diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-09-02 00:07:27 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-09-02 01:37:37 +0200 |
commit | 5f236208d0d864546e59afa0f5a11c9b3ba14b10 (patch) | |
tree | eed5d9203a2633c8efb85c1b36425eab87574299 /libguile/programs.c | |
parent | f0eb5ae6c173aed35965b0561897fda1d8ff0db1 (diff) | |
parent | d7e7a02a6251c8ed4f76933d9d30baeee3f599c0 (diff) | |
download | guile-5f236208d0d864546e59afa0f5a11c9b3ba14b10.tar.gz |
Merge branch 'boehm-demers-weiser-gc' into bdw-gc-static-alloc
Conflicts:
acinclude.m4
libguile/strings.c
Diffstat (limited to 'libguile/programs.c')
-rw-r--r-- | libguile/programs.c | 307 |
1 files changed, 307 insertions, 0 deletions
diff --git a/libguile/programs.c b/libguile/programs.c new file mode 100644 index 000000000..b2bf80674 --- /dev/null +++ b/libguile/programs.c @@ -0,0 +1,307 @@ +/* Copyright (C) 2001, 2009 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "_scm.h" +#include "vm-bootstrap.h" +#include "instructions.h" +#include "modules.h" +#include "programs.h" +#include "procprop.h" // scm_sym_name +#include "srcprop.h" // scm_sym_filename +#include "vm.h" + + +static SCM write_program = SCM_BOOL_F; + +SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, + (SCM objcode, SCM objtable, SCM free_variables), + "") +#define FUNC_NAME s_scm_make_program +{ + SCM_VALIDATE_OBJCODE (1, objcode); + if (SCM_UNLIKELY (SCM_UNBNDP (objtable))) + objtable = SCM_BOOL_F; + else if (scm_is_true (objtable)) + SCM_VALIDATE_VECTOR (2, objtable); + if (SCM_UNLIKELY (SCM_UNBNDP (free_variables))) + free_variables = SCM_BOOL_F; + else if (free_variables != SCM_BOOL_F) + SCM_VALIDATE_VECTOR (3, free_variables); + + return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode, + (scm_t_bits)objtable, (scm_t_bits)free_variables); +} +#undef FUNC_NAME + +void +scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) +{ + static int print_error = 0; + + if (SCM_FALSEP (write_program) && scm_module_system_booted_p) + write_program = scm_module_local_variable + (scm_c_resolve_module ("system vm program"), + scm_from_locale_symbol ("write-program")); + + if (SCM_FALSEP (write_program) || print_error) + { + scm_puts ("#<program ", port); + scm_uintprint (SCM_CELL_WORD_1 (program), 16, port); + scm_putc ('>', port); + } + else + { + print_error = 1; + scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); + print_error = 0; + } +} + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_program_p +{ + return SCM_BOOL (SCM_PROGRAM_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_base +{ + SCM_VALIDATE_PROGRAM (1, program); + + return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_arity +{ + struct scm_objcode *p; + + SCM_VALIDATE_PROGRAM (1, program); + + p = SCM_PROGRAM_DATA (program); + return scm_list_3 (SCM_I_MAKINUM (p->nargs), + SCM_I_MAKINUM (p->nrest), + SCM_I_MAKINUM (p->nlocs)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_objects +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_OBJTABLE (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_module +{ + SCM objs; + SCM_VALIDATE_PROGRAM (1, program); + objs = SCM_PROGRAM_OBJTABLE (program); + return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_meta +{ + SCM metaobj; + + SCM_VALIDATE_PROGRAM (1, program); + + metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); + if (scm_is_true (metaobj)) + return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_bindings +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_BOOL_F; + + return scm_car (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_sources +{ + SCM meta, sources, ret, filename; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_EOL; + + filename = SCM_BOOL_F; + ret = SCM_EOL; + for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources); + sources = scm_cdr (sources)) + { + SCM x = scm_car (sources); + if (scm_is_pair (x)) + { + if (scm_is_number (scm_car (x))) + { + SCM addr = scm_car (x); + ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)), + ret); + } + else if (scm_is_eq (scm_car (x), scm_sym_filename)) + filename = scm_cdr (x); + } + } + return scm_reverse_x (ret, SCM_UNDEFINED); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_properties +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_EOL; + + return scm_cddr (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_name +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_assq_ref (scm_program_properties (program), scm_sym_name); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0, + (SCM program, SCM ip), + "") +#define FUNC_NAME s_scm_program_source +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_c_program_source (program, scm_to_size_t (ip)); +} +#undef FUNC_NAME + +extern SCM +scm_c_program_source (SCM program, size_t ip) +{ + SCM sources, source = SCM_BOOL_F; + + for (sources = scm_program_sources (program); + !scm_is_null (sources) + && scm_to_size_t (scm_caar (sources)) <= ip; + sources = scm_cdr (sources)) + source = scm_car (sources); + + return source; /* (addr . (filename . (line . column))) */ +} + +SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_free_variables +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_FREE_VARIABLES (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, + (SCM program), + "Return a @var{program}'s object code.") +#define FUNC_NAME s_scm_program_objcode +{ + SCM_VALIDATE_PROGRAM (1, program); + + return SCM_PROGRAM_OBJCODE (program); +} +#undef FUNC_NAME + + + +void +scm_bootstrap_programs (void) +{ + scm_c_register_extension ("libguile", "scm_init_programs", + (scm_t_extension_init_func)scm_init_programs, NULL); +} + +void +scm_init_programs (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/programs.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ |