-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2013 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
if (scm_is_false (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"));
+ scm_from_latin1_symbol ("write-program"));
if (SCM_PROGRAM_IS_CONTINUATION (program))
{
SCM_VALIDATE_PROGRAM (1, program);
c_objcode = SCM_PROGRAM_DATA (program);
- return scm_from_ulong ((unsigned long) SCM_C_OBJCODE_BASE (c_objcode));
+ return scm_from_unsigned_integer ((scm_t_bits) SCM_C_OBJCODE_BASE (c_objcode));
}
#undef FUNC_NAME
"")
#define FUNC_NAME s_scm_program_module
{
- SCM objs;
+ SCM objs, mod;
SCM_VALIDATE_PROGRAM (1, program);
objs = SCM_PROGRAM_OBJTABLE (program);
- return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
+ /* If a program is the result of compiling GLIL to assembly, then if
+ it has an objtable, the first entry will be a module. But some
+ programs are hand-coded trampolines, like boot programs and
+ primitives and the like. So if a program happens to have a
+ non-module in the first slot of the objtable, assume that it is
+ such a trampoline, and just return #f for the module. */
+ mod = scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
+ return SCM_MODULEP (mod) ? mod : SCM_BOOL_F;
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_properties
+SCM
+scm_i_program_properties (SCM program)
+#define FUNC_NAME "%program-properties"
{
SCM meta;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
- (SCM program),
- "")
-#define FUNC_NAME s_scm_program_name
+static SCM
+program_source (SCM program, size_t ip, SCM sources)
{
- SCM_VALIDATE_PROGRAM (1, program);
- return scm_assq_ref (scm_program_properties (program), scm_sym_name);
+ SCM source = SCM_BOOL_F;
+
+ while (!scm_is_null (sources)
+ && scm_to_size_t (scm_caar (sources)) <= ip)
+ {
+ source = scm_car (sources);
+ sources = scm_cdr (sources);
+ }
+
+ return source; /* (addr . (filename . (line . column))) */
}
-#undef FUNC_NAME
-SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
- (SCM program, SCM ip),
+SCM_DEFINE (scm_program_source, "program-source", 2, 1, 0,
+ (SCM program, SCM ip, SCM sources),
"")
#define FUNC_NAME s_scm_program_source
{
SCM_VALIDATE_PROGRAM (1, program);
- return scm_c_program_source (program, scm_to_size_t (ip));
+ if (SCM_UNBNDP (sources))
+ sources = scm_program_sources (program);
+ return program_source (program, scm_to_size_t (ip), sources);
}
#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_num_free_variables, "program-num-free-variables", 1, 0, 0,
(SCM program),
"")
}
#undef FUNC_NAME
-/* This one is a shim to pre-case-lambda internal interfaces. Avoid it if you
- can -- use program-arguments or the like. */
-static SCM sym_arglist;
-int
-scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+/* procedure-minimum-arity support. */
+static void
+parse_arity (SCM arity, int *req, int *opt, int *rest)
{
- SCM arities, x;
+ SCM x = scm_cddr (arity);
- arities = scm_program_arities (program);
- if (!scm_is_pair (arities))
- return 0;
- /* take the last arglist, it will be least specific */
- while (scm_is_pair (scm_cdr (arities)))
- arities = scm_cdr (arities);
- x = scm_cddar (arities);
if (scm_is_pair (x))
{
*req = scm_to_int (scm_car (x));
}
else
*req = *opt = *rest = 0;
-
+}
+
+int
+scm_i_program_arity (SCM program, int *req, int *opt, int *rest)
+{
+ SCM arities;
+
+ arities = scm_program_arities (program);
+ if (!scm_is_pair (arities))
+ return 0;
+
+ parse_arity (scm_car (arities), req, opt, rest);
+ arities = scm_cdr (arities);
+
+ for (; scm_is_pair (arities); arities = scm_cdr (arities))
+ {
+ int thisreq, thisopt, thisrest;
+
+ parse_arity (scm_car (arities), &thisreq, &thisopt, &thisrest);
+
+ if (thisreq < *req
+ || (thisreq == *req
+ && ((thisrest && (!*rest || thisopt > *opt))
+ || (!thisrest && !*rest && thisopt > *opt))))
+ {
+ *req = thisreq;
+ *opt = thisopt;
+ *rest = thisrest;
+ }
+ }
+
return 1;
}
void
scm_bootstrap_programs (void)
{
- /* arglist can't be snarfed, because snarfage is only loaded when (system vm
- program) is loaded. perhaps static-alloc will fix this. */
- sym_arglist = scm_from_locale_symbol ("arglist");
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_programs",
(scm_t_extension_init_func)scm_init_programs, NULL);