summaryrefslogtreecommitdiff
path: root/libguile/programs.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/programs.c')
-rw-r--r--libguile/programs.c111
1 files changed, 78 insertions, 33 deletions
diff --git a/libguile/programs.c b/libguile/programs.c
index 237d282ec..81495a5b1 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,33 +1,45 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2017 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
- */
+/* Copyright 2001,2009-2014,2017-2019
+ Free Software Foundation, Inc.
+
+ This file is part of Guile.
+
+ Guile 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.
+
+ Guile 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 Guile. If not, see
+ <https://www.gnu.org/licenses/>. */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
-#include "_scm.h"
+
+#include "alist.h"
+#include "boolean.h"
+#include "eval.h"
+#include "extensions.h"
+#include "gsubr.h"
#include "instructions.h"
#include "modules.h"
-#include "programs.h"
+#include "numbers.h"
+#include "pairs.h"
+#include "ports.h"
#include "procprop.h" /* scm_sym_name */
+#include "variable.h"
+#include "version.h"
#include "vm.h"
+#include "programs.h"
+
static SCM write_program = SCM_BOOL_F;
@@ -38,7 +50,7 @@ SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
{
SCM_VALIDATE_PROGRAM (1, program);
- return scm_from_uintptr_t ((scm_t_uintptr) SCM_PROGRAM_CODE (program));
+ return scm_from_uintptr_t ((uintptr_t) SCM_PROGRAM_CODE (program));
}
#undef FUNC_NAME
@@ -48,7 +60,7 @@ scm_i_program_name (SCM program)
static SCM program_name = SCM_BOOL_F;
if (SCM_PRIMITIVE_P (program))
- return SCM_SUBR_NAME (program);
+ return scm_i_primitive_name (SCM_PROGRAM_CODE (program));
if (scm_is_false (program_name) && scm_module_system_booted_p)
program_name =
@@ -120,7 +132,7 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
scm_puts ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc (' ', port);
- scm_uintprint ((scm_t_uintptr) SCM_PROGRAM_CODE (program), 16, port);
+ scm_uintprint ((uintptr_t) SCM_PROGRAM_CODE (program), 16, port);
scm_putc ('>', port);
}
else
@@ -150,7 +162,7 @@ SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0,
"")
#define FUNC_NAME s_scm_primitive_code_p
{
- const scm_t_uint32 * ptr = (const scm_t_uint32 *) scm_to_uintptr_t (code);
+ const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
return scm_from_bool (scm_i_primitive_code_p (ptr));
}
@@ -161,9 +173,26 @@ SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0,
"")
#define FUNC_NAME s_scm_primitive_call_ip
{
+ uintptr_t ip;
+
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
- return scm_from_uintptr_t (scm_i_primitive_call_ip (prim));
+ ip = scm_i_primitive_call_ip (prim);
+ return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_code_name, "primitive-code-name", 1, 0, 0,
+ (SCM code),
+ "")
+#define FUNC_NAME s_scm_primitive_code_name
+{
+ const uint32_t * ptr = (const uint32_t *) scm_to_uintptr_t (code);
+
+ if (scm_i_primitive_code_p (ptr))
+ return scm_i_primitive_name (ptr);
+
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -241,8 +270,11 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0,
static int
try_parse_arity (SCM program, int *req, int *opt, int *rest)
{
- scm_t_uint32 *code = SCM_PROGRAM_CODE (program);
- scm_t_uint32 slots, min;
+ uint32_t *code = SCM_PROGRAM_CODE (program);
+ uint32_t slots, min;
+
+ if ((code[0] & 0xff) == scm_op_instrument_entry)
+ code += 2;
switch (code[0] & 0xff) {
case scm_op_assert_nargs_ee:
@@ -263,6 +295,12 @@ try_parse_arity (SCM program, int *req, int *opt, int *rest)
*opt = slots - 1;
*rest = 0;
return 1;
+ case scm_op_bind_optionals:
+ slots = code[0] >> 8;
+ *req = 0;
+ *opt = slots - 1;
+ *rest = ((code[1] & 0xff) == scm_op_bind_rest);
+ return 1;
case scm_op_bind_rest:
slots = code[0] >> 8;
*req = 0;
@@ -278,17 +316,30 @@ try_parse_arity (SCM program, int *req, int *opt, int *rest)
*opt = slots - 1 - *req;
*rest = 0;
return 1;
+ case scm_op_bind_optionals:
+ slots = code[1] >> 8;
+ *req = min - 1;
+ *opt = slots - 1 - *req;
+ *rest = ((code[2] & 0xff) == scm_op_bind_rest);
+ return 1;
case scm_op_bind_rest:
slots = code[1] >> 8;
*req = min - 1;
*opt = slots - min;
*rest = 1;
return 1;
+ case scm_op_shuffle_down:
+ case scm_op_abort:
+ *req = min - 1;
+ *opt = 0;
+ *rest = 1;
+ return 1;
default:
return 0;
}
case scm_op_continuation_call:
case scm_op_compose_continuation:
+ case scm_op_shuffle_down:
*req = 0;
*opt = 0;
*rest = 1;
@@ -336,12 +387,6 @@ void
scm_init_programs (void)
{
#ifndef SCM_MAGIC_SNARFER
-#include "libguile/programs.x"
+#include "programs.x"
#endif
}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/