-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * 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 exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * 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.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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 "vm-bootstrap.h"
+#include "_scm.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
-#include "procprop.h" // scm_sym_name
-#include "srcprop.h" // scm_sym_filename
+#include "procprop.h" /* scm_sym_name */
+#include "srcprop.h" /* scm_sym_filename */
#include "vm.h"
\f
-scm_t_bits scm_tc16_program;
-
static SCM write_program = SCM_BOOL_F;
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
- (SCM objcode, SCM objtable, SCM external),
+ (SCM objcode, SCM objtable, SCM free_variables),
"")
#define FUNC_NAME s_scm_make_program
{
objtable = SCM_BOOL_F;
else if (scm_is_true (objtable))
SCM_VALIDATE_VECTOR (2, objtable);
- if (SCM_UNLIKELY (SCM_UNBNDP (external)))
- external = SCM_EOL;
+
+ 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
- /* FIXME: currently this test is quite expensive (can be 2-3% of total
- execution time in programs that make many closures). We could remove it,
- yes, but we'd get much better gains if we used some other method, like
- just capturing the variables that we need instead of all heap-allocated
- variables. Dunno. Keeping the check for now, as it's a user-callable
- function, and inlining the op in the vm's make-closure operation. */
- SCM_VALIDATE_LIST (3, external);
-
- SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
+ {
+ 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
-static SCM
-program_mark (SCM obj)
-{
- if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
- scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
- if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
- scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
- return SCM_PROGRAM_OBJCODE (obj);
-}
-
-static SCM
-program_apply (SCM program, SCM args)
-{
- return scm_vm_apply (scm_the_vm (), program, args);
-}
-
-static SCM
-program_apply_0 (SCM program)
-{
- return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
-}
-
-static SCM
-program_apply_1 (SCM program, SCM a)
-{
- return scm_c_vm_run (scm_the_vm (), program, &a, 1);
-}
-
-static SCM
-program_apply_2 (SCM program, SCM a, SCM b)
-{
- SCM args[2];
- args[0] = a;
- args[1] = b;
- return scm_c_vm_run (scm_the_vm (), program, args, 2);
-}
-
-static int
-program_print (SCM program, SCM port, scm_print_state *pstate)
+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)
+ 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_FALSEP (write_program) || print_error)
- return scm_smob_print (program, port, pstate);
-
- print_error = 1;
- scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
- print_error = 0;
- return 1;
+ 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_UNPACK (program), 16, port);
+ scm_putc ('>', port);
+ }
+ else
+ {
+ print_error = 1;
+ scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
+ print_error = 0;
+ }
}
\f
"")
#define FUNC_NAME s_scm_program_p
{
- return SCM_BOOL (SCM_PROGRAM_P (obj));
+ return scm_from_bool (SCM_PROGRAM_P (obj));
}
#undef FUNC_NAME
"")
#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;
+ const struct scm_objcode *c_objcode;
SCM_VALIDATE_PROGRAM (1, program);
- p = SCM_PROGRAM_DATA (program);
- return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs),
- SCM_I_MAKINUM (p->nexts));
+ 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_EOL);
+ 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_DEFINE (scm_program_arities, "program-arities", 1, 0, 0,
(SCM program),
"")
-#define FUNC_NAME s_scm_program_properties
+#define FUNC_NAME s_scm_program_arities
{
SCM meta;
meta = scm_program_meta (program);
if (scm_is_false (meta))
- return SCM_EOL;
-
- return scm_cddr (scm_call_0 (meta));
+ return SCM_BOOL_F;
+
+ return scm_caddr (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
+scm_i_program_properties (SCM program)
+#define FUNC_NAME "%program-properties"
{
+ SCM meta;
+
SCM_VALIDATE_PROGRAM (1, program);
- return scm_assq_ref (scm_program_properties (program), scm_sym_name);
+
+ meta = scm_program_meta (program);
+ if (scm_is_false (meta))
+ return SCM_EOL;
+
+ return scm_cdddr (scm_call_0 (meta));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
- (SCM program, SCM ip),
+static SCM
+program_source (SCM program, size_t ip, SCM sources)
+{
+ 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))) */
+}
+
+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;
-
- 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_VALIDATE_PROGRAM (1, program);
+ return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program));
}
+#undef FUNC_NAME
-SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
- (SCM program),
+SCM_DEFINE (scm_program_free_variable_ref, "program-free-variable-ref", 2, 0, 0,
+ (SCM program, SCM i),
"")
-#define FUNC_NAME s_scm_program_external
+#define FUNC_NAME s_scm_program_free_variable_ref
{
+ unsigned long idx;
SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_EXTERNALS (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_external_set_x, "program-external-set!", 2, 0, 0,
- (SCM program, SCM external),
- "Modify the list of closure variables of @var{program} (for "
- "debugging purposes).")
-#define FUNC_NAME s_scm_program_external_set_x
+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_variable_set_x
{
+ unsigned long idx;
SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_LIST (2, external);
- SCM_PROGRAM_EXTERNALS (program) = external;
+ 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
+/* procedure-minimum-arity support. */
+static void
+parse_arity (SCM arity, int *req, int *opt, int *rest)
+{
+ SCM x = scm_cddr (arity);
+
+ if (scm_is_pair (x))
+ {
+ *req = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ {
+ *opt = scm_to_int (scm_car (x));
+ x = scm_cdr (x);
+ if (scm_is_pair (x))
+ *rest = scm_is_true (scm_car (x));
+ else
+ *rest = 0;
+ }
+ else
+ *opt = *rest = 0;
+ }
+ 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;
+}
\f
+
void
scm_bootstrap_programs (void)
{
- scm_tc16_program = scm_make_smob_type ("program", 0);
- scm_set_smob_mark (scm_tc16_program, program_mark);
- scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
- scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
- scm_set_smob_print (scm_tc16_program, program_print);
+ 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 "programs.x"
+#include "libguile/programs.x"
#endif
}
HCoop / bpt / guile.git / blobdiff