-/* Copyright (C) 2001, 2009 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
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
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);
+ if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
+ {
+ SCM ret = scm_words (scm_tc7_program, 3);
+ SCM_SET_CELL_OBJECT_1 (ret, objcode);
+ SCM_SET_CELL_OBJECT_2 (ret, objtable);
+ return ret;
+ }
+ else
+ {
+ size_t i, len;
+ SCM ret;
+ SCM_VALIDATE_VECTOR (3, free_variables);
+ len = scm_c_vector_length (free_variables);
+ if (SCM_UNLIKELY (len >> 16))
+ SCM_OUT_OF_RANGE (3, free_variables);
+ ret = scm_words (scm_tc7_program | (len<<16), 3 + len);
+ SCM_SET_CELL_OBJECT_1 (ret, objcode);
+ SCM_SET_CELL_OBJECT_2 (ret, objtable);
+ for (i = 0; i < len; i++)
+ SCM_SET_CELL_OBJECT (ret, 3+i,
+ SCM_SIMPLE_VECTOR_REF (free_variables, i));
+ return ret;
+ }
}
#undef FUNC_NAME
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_is_false (write_program) || print_error)
+ if (SCM_PROGRAM_IS_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts ("#<continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ {
+ /* twingliness */
+ scm_puts ("#<partial-continuation ", port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else if (scm_is_false (write_program) || print_error)
{
scm_puts ("#<program ", port);
- scm_uintprint (SCM_CELL_WORD_1 (program), 16, port);
+ scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
else
"")
#define FUNC_NAME s_scm_program_base
{
+ const struct scm_objcode *c_objcode;
+
SCM_VALIDATE_PROGRAM (1, program);
- return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
+ c_objcode = SCM_PROGRAM_DATA (program);
+ 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
metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
if (scm_is_true (metaobj))
- return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
+ return scm_make_program (metaobj, SCM_PROGRAM_OBJTABLE (program),
+ SCM_BOOL_F);
else
return SCM_BOOL_F;
}
}
#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_DEFINE (scm_program_num_free_variables, "program-num-free-variables", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_num_free_variables
{
- SCM sources, source = SCM_BOOL_F;
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
+}
+#undef FUNC_NAME
- 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_variable_ref, "program-free-variable-ref", 2, 0, 0,
+ (SCM program, SCM i),
+ "")
+#define FUNC_NAME s_scm_program_free_variable_ref
+{
+ unsigned long idx;
+ SCM_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx);
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
- (SCM program),
+SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, 0,
+ (SCM program, SCM i, SCM x),
"")
-#define FUNC_NAME s_scm_program_free_variables
+#define FUNC_NAME s_scm_program_free_variable_set_x
{
+ unsigned long idx;
SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_FREE_VARIABLES (program);
+ SCM_VALIDATE_ULONG_COPY (2, i, idx);
+ if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program))
+ SCM_OUT_OF_RANGE (2, i);
+ SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
+ return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
}
#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_init_programs",
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "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
HCoop / bpt / guile.git / blobdiff