mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-08 21:20:19 +02:00
Code Activity

Make programs.h private

Browse source 
This header file turns out to only have internal details.  Users that
need introspection can use Scheme.

* libguile/programs.h (SCM_PROGRAM_P, SCM_PROGRAM_CODE)
(SCM_PROGRAM_FREE_VARIABLES, SCM_PROGRAM_FREE_VARIABLE_REF)
(SCM_PROGRAM_FREE_VARIABLE_SET, SCM_PROGRAM_NUM_FREE_VARIABLES)
(SCM_VALIDATE_PROGRAM, SCM_F_PROGRAM_IS_BOOT, SCM_F_PROGRAM_IS_PRIMITIVE)
(SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC, SCM_F_PROGRAM_IS_CONTINUATION)
(SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION, SCM_F_PROGRAM_IS_FOREIGN)
(SCM_PROGRAM_IS_BOOT, SCM_PROGRAM_IS_PRIMITIVE)
(SCM_PROGRAM_IS_PRIMITIVE_GENERIC, SCM_PROGRAM_IS_CONTINUATION)
(SCM_PROGRAM_IS_PARTIAL_CONTINUATION, SCM_PROGRAM_IS_FOREIGN): Remove
these macros, as we are making this whole API private.
(struct scm_program, scm_is_program, scm_to_program, scm_from_program)
(scm_program_flags, scm_program_is_boot, scm_program_is_primitive)
(scm_program_is_primitive_generic, scm_program_is_continuation)
(scm_program_is_partial_continuation, scm_program_is_foreign)
(scm_program_code, scm_program_free_variable_count)
(scm_program_free_variable_ref, scm_program_free_variable_set_x)
(scm_i_make_program): New inline functions.
* libguile/Makefile.am (noinst_HEADERS): Add programs.h; no longer
installed.  It was never directly included from libguile.h.
* libguile/continuations.c:
* libguile/continuations.h:
* libguile/control.c:
* libguile/foreign.c:
* libguile/frames.c:
* libguile/frames.h:
* libguile/goops.c:
* libguile/gsubr.c:
* libguile/gsubr.h:
* libguile/intrinsics.h:
* libguile/procprop.c:
* libguile/procs.c:
* libguile/programs.c:
* libguile/stacks.c:
* libguile/vm-engine.c:
* libguile/vm.c:
* libguile/vm.h: Adapt all users.
This commit is contained in:
Andy Wingo 2025-05-30 12:40:52 +02:00
parent 93e5a2454a
commit 464ec999de
19 changed files with 290 additions and 144 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/Makefile.am
View file

@ -530,6 +530,7 @@ noinst_HEADERS = custom-ports.h \
gc-internal.h \ gc-internal.h \
posix-w32.h \ posix-w32.h \
private-options.h \ private-options.h \
programs.h \
ports-internal.h \ ports-internal.h \
syntax.h \ syntax.h \
trace.h \ trace.h \
@ -658,7 +659,6 @@ modinclude_HEADERS = \
print.h \ print.h \
procprop.h \ procprop.h \
procs.h \ procs.h \
programs.h \
promises.h \ promises.h \
pthread-threads.h \ pthread-threads.h \
r6rs-ports.h \ r6rs-ports.h \

17
libguile/continuations.c
View file

@ -46,6 +46,7 @@
#include "numbers.h" #include "numbers.h"
#include "pairs.h" #include "pairs.h"
#include "ports.h" #include "ports.h"
#include "programs.h"
#include "smob.h" #include "smob.h"
#include "stackchk.h" #include "stackchk.h"
#include "stacks.h" #include "stacks.h"
@ -99,15 +100,18 @@ struct goto_continuation_code goto_continuation_code = {
static SCM static SCM
make_continuation_trampoline (SCM contregs) make_continuation_trampoline (SCM contregs)
{ {
SCM ret;
scm_t_bits nfree = 1; scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION; scm_t_bits flags = SCM_F_PROGRAM_IS_CONTINUATION;
scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); struct scm_program *ret =
SCM_SET_CELL_WORD_1 (ret, goto_continuation_code.code); scm_gc_malloc (sizeof (struct scm_program) + nfree * sizeof(SCM),
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, contregs); "foreign procedure");
ret->tag_flags_and_free_variable_count = tag;
ret->code = goto_continuation_code.code;
ret->free_variables[0] = contregs;
return ret; return scm_from_program (ret);
} }
@ -218,7 +222,8 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame)
SCM contregs; SCM contregs;
scm_t_contregs *cont; scm_t_contregs *cont;
contregs = SCM_PROGRAM_FREE_VARIABLE_REF (continuation, 0); struct scm_program *program = scm_to_program (continuation);
contregs = scm_program_free_variable_ref (program, 0);
cont = SCM_CONTREGS (contregs); cont = SCM_CONTREGS (contregs);
if (cont->vm_cont) if (cont->vm_cont)

4
libguile/continuations.h
View file

@ -28,14 +28,10 @@
#include "libguile/setjump-win.h" #include "libguile/setjump-win.h"
#endif #endif
#include "libguile/programs.h"
#include "libguile/throw.h" #include "libguile/throw.h"
#define SCM_CONTINUATIONP(x) \
(SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_CONTINUATION (x))
/* a continuation SCM is a non-immediate pointing to a heap cell with: /* a continuation SCM is a non-immediate pointing to a heap cell with:
word 0: bits 0-15: smob type tag: scm_tc16_continuation. word 0: bits 0-15: smob type tag: scm_tc16_continuation.
bits 16-31: unused. bits 16-31: unused.

15
libguile/control.c
View file

@ -1,4 +1,4 @@
/* Copyright 2010-2013,2018 /* Copyright 2010-2013,2018,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -95,13 +95,16 @@ scm_i_make_composable_continuation (SCM vmcont)
{ {
scm_t_bits nfree = 1; scm_t_bits nfree = 1;
scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION; scm_t_bits flags = SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
SCM ret; scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); struct scm_program *ret =
SCM_SET_CELL_WORD_1 (ret, compose_continuation_code.code); scm_gc_malloc (sizeof (struct scm_program) + nfree * sizeof(SCM),
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, vmcont); "foreign procedure");
ret->tag_flags_and_free_variable_count = tag;
ret->code = compose_continuation_code.code;
ret->free_variables[0] = vmcont;
return ret; return scm_from_program (ret);
} }
SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0, SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0,

16
libguile/foreign.c
View file

@ -49,6 +49,7 @@
#include "numbers.h" #include "numbers.h"
#include "pairs.h" #include "pairs.h"
#include "ports.h" #include "ports.h"
#include "programs.h"
#include "stacks.h" #include "stacks.h"
#include "symbols.h" #include "symbols.h"
#include "threads.h" #include "threads.h"
@ -943,18 +944,21 @@ static SCM
cif_to_procedure (SCM cif, SCM func_ptr, int with_errno) cif_to_procedure (SCM cif, SCM func_ptr, int with_errno)
{ {
ffi_cif *c_cif; ffi_cif *c_cif;
SCM ret;
scm_t_bits nfree = 2; scm_t_bits nfree = 2;
scm_t_bits flags = SCM_F_PROGRAM_IS_FOREIGN; scm_t_bits flags = SCM_F_PROGRAM_IS_FOREIGN;
scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif);
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); struct scm_program *ret =
SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno)); scm_gc_malloc (sizeof (struct scm_program) + nfree * sizeof(SCM),
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif); "foreign procedure");
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr); ret->tag_flags_and_free_variable_count = tag;
ret->code = get_foreign_stub_code (c_cif->nargs, with_errno);
ret->free_variables[0] = cif;
ret->free_variables[1] = func_ptr;
return ret; return scm_from_program (ret);
} }
/* Set *LOC to the foreign representation of X with TYPE. */ /* Set *LOC to the foreign representation of X with TYPE. */

1
libguile/frames.c
View file

@ -33,6 +33,7 @@
#include "numbers.h" #include "numbers.h"
#include "pairs.h" #include "pairs.h"
#include "ports.h" #include "ports.h"
#include "programs.h"
#include "symbols.h" #include "symbols.h"
#include "threads.h" #include "threads.h"
#include "variable.h" #include "variable.h"

1
libguile/frames.h
View file

@ -23,7 +23,6 @@
#include <string.h> #include <string.h>
#include <libguile/gc.h> #include <libguile/gc.h>
#include "programs.h"
/* Stack frames /* Stack frames

12
libguile/goops.c
View file

@ -282,8 +282,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_fraction; return class_fraction;
} }
case scm_tc7_program: case scm_tc7_program:
if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) if (scm_program_is_primitive_generic (scm_to_program (x))
&& SCM_UNPACK (*SCM_SUBR_GENERIC (x))) && SCM_UNPACK (*scm_subr_generic (x)))
return class_primitive_generic; return class_primitive_generic;
else else
return class_procedure; return class_procedure;
@ -578,7 +578,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
{ {
SCM subr = SCM_CAR (subrs); SCM subr = SCM_CAR (subrs);
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME); SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARGn, FUNC_NAME);
SCM_SET_SUBR_GENERIC (subr, scm_set_subr_generic (subr,
scm_make (scm_list_3 (class_generic, scm_make (scm_list_3 (class_generic,
k_name, k_name,
SCM_SUBR_NAME (subr)))); SCM_SUBR_NAME (subr))));
@ -595,7 +595,7 @@ SCM_DEFINE (scm_set_primitive_generic_x, "set-primitive-generic!", 2, 0, 0,
{ {
SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME); SCM_ASSERT (SCM_PRIMITIVE_GENERIC_P (subr), subr, SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME); SCM_ASSERT (SCM_GENERICP (generic), generic, SCM_ARG2, FUNC_NAME);
SCM_SET_SUBR_GENERIC (subr, generic); scm_set_subr_generic (subr, generic);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -607,9 +607,9 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
{ {
if (SCM_PRIMITIVE_GENERIC_P (subr)) if (SCM_PRIMITIVE_GENERIC_P (subr))
{ {
if (!SCM_UNPACK (*SCM_SUBR_GENERIC (subr))) if (!SCM_UNPACK (*scm_subr_generic (subr)))
scm_enable_primitive_generic_x (scm_list_1 (subr)); scm_enable_primitive_generic_x (scm_list_1 (subr));
return *SCM_SUBR_GENERIC (subr); return *scm_subr_generic (subr);
} }
SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
} }

57
libguile/gsubr.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2001,2006,2008-2011,2013,2015,2018-2019 /* Copyright 1995-2001,2006,2008-2011,2013,2015,2018-2019,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -336,7 +336,7 @@ create_subr (int define, const char *name,
unsigned int nreq, unsigned int nopt, unsigned int rest, unsigned int nreq, unsigned int nopt, unsigned int rest,
void *fcn, SCM *generic_loc) void *fcn, SCM *generic_loc)
{ {
SCM ret, sname; SCM sname;
uint32_t idx; uint32_t idx;
scm_t_bits flags; scm_t_bits flags;
scm_t_bits nfree = generic_loc ? 1 : 0; scm_t_bits nfree = generic_loc ? 1 : 0;
@ -347,17 +347,50 @@ create_subr (int define, const char *name,
flags = SCM_F_PROGRAM_IS_PRIMITIVE; flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0; flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); scm_t_bits tag = scm_tc7_program | (nfree << 16) | flags;
SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (idx, nreq, nopt, rest));
struct scm_program *ret =
scm_gc_malloc (sizeof (struct scm_program) + nfree * sizeof(SCM),
"foreign procedure");
ret->tag_flags_and_free_variable_count = tag;
ret->code = get_subr_stub_code (idx, nreq, nopt, rest);
record_subr_name (idx, sname); record_subr_name (idx, sname);
if (generic_loc) if (generic_loc)
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_program_free_variable_set_x (ret, 0,
scm_from_pointer (generic_loc, NULL)); scm_from_pointer (generic_loc, NULL));
if (define) if (define)
scm_define (sname, ret); scm_define (sname, scm_from_program (ret));
return ret; return scm_from_program (ret);
}
int
scm_is_primitive (SCM x)
{
return scm_is_program (x) && scm_program_is_primitive (scm_to_program (x));
}
int
scm_is_primitive_generic (SCM x)
{
return scm_is_program (x) &&
scm_program_is_primitive_generic (scm_to_program (x));
}
SCM*
scm_subr_generic (SCM subr)
{
if (!scm_is_primitive_generic (subr))
abort ();
struct scm_program *p = scm_to_program (subr);
return (SCM*) SCM_POINTER_VALUE (scm_program_free_variable_ref (p, 0));
}
void
scm_set_subr_generic (SCM subr, SCM g)
{
*scm_subr_generic (subr) = g;
} }
int int
@ -429,9 +462,9 @@ primitive_subr_idx (const uint32_t *code)
} }
uintptr_t uintptr_t
scm_i_primitive_call_ip (SCM subr) scm_i_primitive_call_ip (struct scm_program *subr)
{ {
return primitive_call_ip (SCM_PROGRAM_CODE (subr)); return primitive_call_ip (scm_program_code (subr));
} }
SCM SCM
@ -454,14 +487,14 @@ scm_subr_function_by_index (uint32_t idx)
scm_t_subr scm_t_subr
scm_subr_function (SCM subr) scm_subr_function (SCM subr)
{ {
uint32_t idx = primitive_subr_idx (SCM_PROGRAM_CODE (subr)); uint32_t idx = primitive_subr_idx (scm_program_code (scm_to_program (subr)));
return scm_subr_function_by_index (idx); return scm_subr_function_by_index (idx);
} }
SCM SCM
scm_subr_name (SCM subr) scm_subr_name (SCM subr)
{ {
return scm_i_primitive_name (SCM_PROGRAM_CODE (subr)); return scm_i_primitive_name (scm_program_code (scm_to_program (subr)));
} }
SCM SCM

22
libguile/gsubr.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_GSUBR_H #ifndef SCM_GSUBR_H
#define SCM_GSUBR_H #define SCM_GSUBR_H
/* Copyright 1995-1996,1998,2000-2001,2006,2008,2009-2011,2013,2015,2018 /* Copyright 1995-1996,1998,2000-2001,2006,2008,2009-2011,2013,2015,2018,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -34,31 +34,31 @@
/* Max number of args to the C procedure backing a gsubr */ /* Max number of args to the C procedure backing a gsubr */
#define SCM_GSUBR_MAX 10 #define SCM_GSUBR_MAX 10
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x)) #define SCM_PRIMITIVE_P(x) (scm_is_primitive (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (scm_is_primitive_generic (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) scm_subr_function (x) #define SCM_SUBRF(x) scm_subr_function (x)
#define SCM_SUBR_NAME(x) scm_subr_name (x) #define SCM_SUBR_NAME(x) scm_subr_name (x)
#define SCM_SUBR_GENERIC(x) \
((SCM *) SCM_POINTER_VALUE (SCM_PROGRAM_FREE_VARIABLE_REF (x, 0)))
#define SCM_SET_SUBR_GENERIC(x, g) \
(*SCM_SUBR_GENERIC (x) = (g))
struct scm_program;
SCM_INTERNAL uint32_t * SCM_INTERNAL uint32_t *
scm_i_alloc_primitive_code_with_instrumentation (size_t uint32_count, scm_i_alloc_primitive_code_with_instrumentation (size_t uint32_count,
uint32_t **write_ptr); uint32_t **write_ptr);
SCM_INTERNAL int scm_i_primitive_code_p (const uint32_t *code); SCM_INTERNAL int scm_i_primitive_code_p (const uint32_t *code);
SCM_INTERNAL uintptr_t scm_i_primitive_call_ip (SCM subr); SCM_INTERNAL uintptr_t scm_i_primitive_call_ip (struct scm_program *subr);
SCM_INTERNAL SCM scm_i_primitive_name (const uint32_t *code); SCM_INTERNAL SCM scm_i_primitive_name (const uint32_t *code);
SCM_INTERNAL int scm_is_primitive (SCM x);
SCM_INTERNAL int scm_is_primitive_generic (SCM x);
SCM_API scm_t_subr scm_subr_function (SCM subr); SCM_API scm_t_subr scm_subr_function (SCM subr);
SCM_INTERNAL scm_t_subr scm_subr_function_by_index (uint32_t subr_idx); SCM_INTERNAL scm_t_subr scm_subr_function_by_index (uint32_t subr_idx);
SCM_API SCM scm_subr_name (SCM subr); SCM_API SCM scm_subr_name (SCM subr);
SCM_INTERNAL SCM* scm_subr_generic (SCM x);
SCM_INTERNAL void scm_set_subr_generic (SCM x, SCM g);
SCM_INTERNAL SCM scm_apply_subr (union scm_vm_stack_element *sp, SCM_INTERNAL SCM scm_apply_subr (union scm_vm_stack_element *sp,
uint32_t subr_idx, ptrdiff_t nargs); uint32_t subr_idx, ptrdiff_t nargs);

2
libguile/intrinsics.h
View file

@ -92,7 +92,7 @@ typedef void (*scm_t_thread_u8_scm_sp_vra_mra_intrinsic) (scm_thread*,
const union scm_vm_stack_element*, const union scm_vm_stack_element*,
uint32_t*, uint8_t*); uint32_t*, uint8_t*);
typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*); typedef void (*scm_t_thread_mra_intrinsic) (scm_thread*, uint8_t*);
typedef uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*); typedef const uint32_t* (*scm_t_vra_from_thread_intrinsic) (scm_thread*);
typedef uint8_t* (*scm_t_mra_from_thread_scm_intrinsic) (scm_thread*, SCM); typedef uint8_t* (*scm_t_mra_from_thread_scm_intrinsic) (scm_thread*, SCM);
typedef uint8_t* (*scm_t_mra_from_thread_mra_intrinsic) (scm_thread*, uint8_t*); typedef uint8_t* (*scm_t_mra_from_thread_mra_intrinsic) (scm_thread*, uint8_t*);
typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*); typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);

8
libguile/procprop.c
View file

@ -67,7 +67,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
return 1; return 1;
} }
while (!SCM_PROGRAM_P (proc)) while (!scm_is_program (proc))
{ {
if (SCM_STRUCTP (proc)) if (SCM_STRUCTP (proc))
{ {
@ -153,7 +153,7 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props))) if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props)))
return scm_cdr (user_props); return scm_cdr (user_props);
if (SCM_PROGRAM_P (proc)) if (scm_is_program (proc))
ret = scm_i_program_properties (proc); ret = scm_i_program_properties (proc);
else else
ret = SCM_EOL; ret = SCM_EOL;
@ -265,7 +265,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
return SCM_BOOL_F; return SCM_BOOL_F;
} }
if (SCM_PROGRAM_P (proc)) if (scm_is_program (proc))
return scm_i_program_name (proc); return scm_i_program_name (proc);
else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) else if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc)); return scm_procedure_name (SCM_STRUCT_PROCEDURE (proc));
@ -302,7 +302,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
return SCM_BOOL_F; return SCM_BOOL_F;
} }
if (SCM_PROGRAM_P (proc)) if (scm_is_program (proc))
return scm_i_program_documentation (proc); return scm_i_program_documentation (proc);
else else
return SCM_BOOL_F; return SCM_BOOL_F;

4
libguile/procs.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018,2020 /* Copyright 1995-1997,1999-2001,2006,2008-2013,2017-2018,2020,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -49,7 +49,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a procedure.") "Return @code{#t} if @var{obj} is a procedure.")
#define FUNC_NAME s_scm_procedure_p #define FUNC_NAME s_scm_procedure_p
{ {
return scm_from_bool (SCM_PROGRAM_P (obj) return scm_from_bool (scm_is_program (obj)
|| (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj)) || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
|| (SCM_HAS_TYP7 (obj, scm_tc7_smob) || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
&& SCM_SMOB_APPLICABLE_P (obj))); && SCM_SMOB_APPLICABLE_P (obj)));

39
libguile/programs.c
View file

@ -40,6 +40,13 @@
#include "programs.h" #include "programs.h"
#define SCM_PROGRAM_P(x) (scm_is_program (x))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
static SCM write_program = SCM_BOOL_F; static SCM write_program = SCM_BOOL_F;
@ -49,8 +56,9 @@ SCM_DEFINE_STATIC (program_code, "program-code", 1, 0, 0,
#define FUNC_NAME s_program_code #define FUNC_NAME s_program_code
{ {
SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_PROGRAM (1, program);
struct scm_program *p = scm_to_program (program);
return scm_from_uintptr_t ((uintptr_t) SCM_PROGRAM_CODE (program)); return scm_from_uintptr_t ((uintptr_t) scm_program_code (p));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -60,7 +68,7 @@ scm_i_program_name (SCM program)
static SCM program_name = SCM_BOOL_F; static SCM program_name = SCM_BOOL_F;
if (SCM_PRIMITIVE_P (program)) if (SCM_PRIMITIVE_P (program))
return scm_i_primitive_name (SCM_PROGRAM_CODE (program)); return scm_i_primitive_name (scm_to_program (program)->code);
if (scm_is_false (program_name) && scm_module_system_booted_p) if (scm_is_false (program_name) && scm_module_system_booted_p)
program_name = program_name =
@ -113,14 +121,15 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
write_program = scm_c_private_variable ("system vm program", write_program = scm_c_private_variable ("system vm program",
"write-program"); "write-program");
if (SCM_PROGRAM_IS_CONTINUATION (program)) struct scm_program *p = scm_to_program (program);
if (scm_program_is_continuation (p))
{ {
/* twingliness */ /* twingliness */
scm_puts ("#<continuation ", port); scm_puts ("#<continuation ", port);
scm_uintprint (SCM_UNPACK (program), 16, port); scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
} }
else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) else if (scm_program_is_partial_continuation (p))
{ {
/* twingliness */ /* twingliness */
scm_puts ("#<partial-continuation ", port); scm_puts ("#<partial-continuation ", port);
@ -132,7 +141,7 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
scm_puts ("#<program ", port); scm_puts ("#<program ", port);
scm_uintprint (SCM_UNPACK (program), 16, port); scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc (' ', port); scm_putc (' ', port);
scm_uintprint ((uintptr_t) SCM_PROGRAM_CODE (program), 16, port); scm_uintprint ((uintptr_t) p->code, 16, port);
scm_putc ('>', port); scm_putc ('>', port);
} }
else else
@ -153,7 +162,7 @@ SCM_DEFINE_STATIC (program_p, "program?", 1, 0, 0,
"") "")
#define FUNC_NAME s_program_p #define FUNC_NAME s_program_p
{ {
return scm_from_bool (SCM_PROGRAM_P (obj)); return scm_from_bool (scm_is_program (obj));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -177,7 +186,7 @@ SCM_DEFINE_STATIC (primitive_call_ip, "primitive-call-ip", 1, 0, 0,
SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P);
ip = scm_i_primitive_call_ip (prim); ip = scm_i_primitive_call_ip (scm_to_program (prim));
return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F; return ip ? scm_from_uintptr_t (ip) : SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -230,8 +239,9 @@ SCM_DEFINE_STATIC (program_num_free_variables, "program-num-free-variables",
#define FUNC_NAME s_program_num_free_variables #define FUNC_NAME s_program_num_free_variables
{ {
SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_PROGRAM (1, program);
struct scm_program *p = scm_to_program (program);
return scm_from_ulong (SCM_PROGRAM_NUM_FREE_VARIABLES (program)); return scm_from_ulong (scm_program_free_variable_count (p));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -244,9 +254,10 @@ SCM_DEFINE_STATIC (program_free_variable_ref, "program-free-variable-ref",
SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx); SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) struct scm_program *p = scm_to_program (program);
if (idx >= scm_program_free_variable_count (p))
SCM_OUT_OF_RANGE (2, i); SCM_OUT_OF_RANGE (2, i);
return SCM_PROGRAM_FREE_VARIABLE_REF (program, idx); return scm_program_free_variable_ref (p, idx);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -259,9 +270,11 @@ SCM_DEFINE_STATIC (program_free_variable_set_x, "program-free-variable-set!",
SCM_VALIDATE_PROGRAM (1, program); SCM_VALIDATE_PROGRAM (1, program);
SCM_VALIDATE_ULONG_COPY (2, i, idx); SCM_VALIDATE_ULONG_COPY (2, i, idx);
if (idx >= SCM_PROGRAM_NUM_FREE_VARIABLES (program)) struct scm_program *p = scm_to_program (program);
if (idx >= scm_program_free_variable_count (p))
SCM_OUT_OF_RANGE (2, i); SCM_OUT_OF_RANGE (2, i);
SCM_PROGRAM_FREE_VARIABLE_SET (program, idx, x);
scm_program_free_variable_set_x (p, idx, x);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -270,7 +283,7 @@ SCM_DEFINE_STATIC (program_free_variable_set_x, "program-free-variable-set!",
static int static int
try_parse_arity (SCM program, int *req, int *opt, int *rest) try_parse_arity (SCM program, int *req, int *opt, int *rest)
{ {
uint32_t *code = SCM_PROGRAM_CODE (program); const uint32_t *code = scm_program_code (scm_to_program (program));
uint32_t slots, min; uint32_t slots, min;
if ((code[0] & 0xff) == scm_op_instrument_entry) if ((code[0] & 0xff) == scm_op_instrument_entry)

128
libguile/programs.h
View file

@ -26,41 +26,111 @@
* Programs * Programs
*/ */
#define SCM_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_program)) struct scm_program
#define SCM_PROGRAM_CODE(x) ((uint32_t *) SCM_CELL_WORD_1 (x))
#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
#define SCM_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_PROGRAM_FREE_VARIABLES (x)[i])
#define SCM_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_PROGRAM_FREE_VARIABLES (x)[i]=(v))
#define SCM_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE 0x200
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x400
#define SCM_F_PROGRAM_IS_CONTINUATION 0x800
#define SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION 0x1000
#define SCM_F_PROGRAM_IS_FOREIGN 0x2000
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
#define SCM_PROGRAM_IS_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_CONTINUATION)
#define SCM_PROGRAM_IS_PARTIAL_CONTINUATION(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION)
#define SCM_PROGRAM_IS_FOREIGN(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_FOREIGN)
#ifdef BUILDING_LIBGUILE
static inline SCM
scm_i_make_program (const uint32_t *code)
{ {
return scm_cell (scm_tc7_program, (scm_t_bits)code); scm_t_bits tag_flags_and_free_variable_count;
} const uint32_t *code;
SCM free_variables[];
};
static inline int static inline int
scm_is_program (SCM x) scm_is_program (SCM x)
{ {
return SCM_PROGRAM_P (x); return SCM_HAS_TYP7 (x, scm_tc7_program);
}
static inline struct scm_program*
scm_to_program (SCM x)
{
if (!scm_is_program (x))
abort ();
return (struct scm_program*) SCM_UNPACK_POINTER (x);
}
static inline SCM
scm_from_program (struct scm_program *program)
{
return SCM_PACK_POINTER (program);
}
enum scm_program_flags
{
SCM_F_PROGRAM_IS_BOOT = 0x100,
SCM_F_PROGRAM_IS_PRIMITIVE = 0x200,
SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC = 0x400,
SCM_F_PROGRAM_IS_CONTINUATION = 0x800,
SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION = 0x1000,
SCM_F_PROGRAM_IS_FOREIGN = 0x2000
};
static inline scm_t_bits
scm_program_flags (struct scm_program *program)
{
return program->tag_flags_and_free_variable_count & 0xff00;
}
static inline int
scm_program_is_boot (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_BOOT;
}
static inline int
scm_program_is_primitive (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_PRIMITIVE;
}
static inline int
scm_program_is_primitive_generic (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC;
}
static inline int
scm_program_is_continuation (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_CONTINUATION;
}
static inline int
scm_program_is_partial_continuation (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_PARTIAL_CONTINUATION;
}
static inline int
scm_program_is_foreign (struct scm_program *program)
{
return scm_program_flags (program) & SCM_F_PROGRAM_IS_FOREIGN;
}
static inline const uint32_t*
scm_program_code (struct scm_program *program)
{
return program->code;
}
static inline size_t
scm_program_free_variable_count (struct scm_program *program)
{
return program->tag_flags_and_free_variable_count >> 16;
}
static inline SCM
scm_program_free_variable_ref (struct scm_program *program, size_t idx)
{
return program->free_variables[idx];
}
static inline void
scm_program_free_variable_set_x (struct scm_program *program, size_t idx, SCM v)
{
program->free_variables[idx] = v;
}
static inline SCM
scm_i_make_program (const uint32_t *code)
{
struct scm_program *ret =
scm_gc_malloc_pointerless (sizeof (struct scm_program), "program");
ret->tag_flags_and_free_variable_count = scm_tc7_program;
ret->code = code;
return scm_from_program (ret);
} }
#endif
SCM_INTERNAL SCM scm_i_program_name (SCM program); SCM_INTERNAL SCM scm_i_program_name (SCM program);
SCM_INTERNAL SCM scm_i_program_documentation (SCM program); SCM_INTERNAL SCM scm_i_program_documentation (SCM program);

59
libguile/stacks.c
View file

@ -39,6 +39,7 @@
#include "pairs.h" #include "pairs.h"
#include "private-options.h" #include "private-options.h"
#include "procprop.h" #include "procprop.h"
#include "programs.h"
#include "strings.h" #include "strings.h"
#include "struct.h" #include "struct.h"
#include "symbols.h" #include "symbols.h"
@ -337,26 +338,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
kind = scm_vm_frame_kind (f); kind = scm_vm_frame_kind (f);
scm_frame_init_from_vm_frame (&frame, f); scm_frame_init_from_vm_frame (&frame, f);
} }
else if (SCM_CONTINUATIONP (obj)) else if (scm_is_program (obj))
/* FIXME: Narrowing to prompt tags should narrow with respect to the prompts
that were in place when the continuation was captured. */
{ {
kind = SCM_VM_FRAME_KIND_CONT; struct scm_program *program = scm_to_program (obj);
if (!scm_i_continuation_to_frame (obj, &frame)) if (scm_program_is_continuation (program))
return SCM_BOOL_F; /* FIXME: Narrowing to prompt tags should narrow with respect to
} the prompts that were in place when the continuation was
else if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (obj)) captured. */
{ {
kind = SCM_VM_FRAME_KIND_CONT; kind = SCM_VM_FRAME_KIND_CONT;
if (!scm_i_vm_cont_to_frame (SCM_PROGRAM_FREE_VARIABLE_REF (obj, 0), if (!scm_i_continuation_to_frame (obj, &frame))
&frame)) return SCM_BOOL_F;
return SCM_BOOL_F; }
else if (scm_program_is_partial_continuation (program))
{
kind = SCM_VM_FRAME_KIND_CONT;
if (!scm_i_vm_cont_to_frame (scm_program_free_variable_ref (program, 0),
&frame))
return SCM_BOOL_F;
}
else
{
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
/* not reached */
}
} }
else else
{ {
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
/* not reached */ /* not reached */
} }
/* Skip initial boot frame, if any. This is possible if the frame /* Skip initial boot frame, if any. This is possible if the frame
originates from a captured continuation. */ originates from a captured continuation. */
@ -416,17 +428,20 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
SCM stacks = scm_fluid_ref (scm_sys_stacks); SCM stacks = scm_fluid_ref (scm_sys_stacks);
return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F; return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F;
} }
else if (SCM_CONTINUATIONP (stack)) else if (scm_is_program (stack))
/* FIXME: implement me */
return SCM_BOOL_F;
else if (SCM_PROGRAM_P (stack) && SCM_PROGRAM_IS_PARTIAL_CONTINUATION (stack))
/* FIXME: implement me */
return SCM_BOOL_F;
else
{ {
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack); struct scm_program *p = scm_to_program (stack);
/* not reached */ if (scm_program_is_continuation (p))
/* FIXME: implement me */
return SCM_BOOL_F;
else if (scm_program_is_partial_continuation (p))
/* FIXME: implement me */
return SCM_BOOL_F;
/* Fall through. */
} }
SCM_WRONG_TYPE_ARG (SCM_ARG1, stack);
/* not reached */
} }
#undef FUNC_NAME #undef FUNC_NAME

22
libguile/vm-engine.c
View file

@ -454,7 +454,8 @@ VM_NAME (scm_thread *thread)
VP->fp = new_fp; VP->fp = new_fp;
RESET_FRAME (nlocals); RESET_FRAME (nlocals);
ip = CALL_INTRINSIC (get_callee_vcode, (thread)); /* FIXME: Don't strip const qualifier. */
ip = (uint32_t *) CALL_INTRINSIC (get_callee_vcode, (thread));
CACHE_SP (); CACHE_SP ();
NEXT (0); NEXT (0);
@ -502,7 +503,8 @@ VM_NAME (scm_thread *thread)
*/ */
VM_DEFINE_OP (5, tail_call, "tail-call", OP1 (X32)) VM_DEFINE_OP (5, tail_call, "tail-call", OP1 (X32))
{ {
ip = CALL_INTRINSIC (get_callee_vcode, (thread)); /* FIXME: Don't strip const qualifier. */
ip = (uint32_t *) CALL_INTRINSIC (get_callee_vcode, (thread));
CACHE_SP (); CACHE_SP ();
NEXT (0); NEXT (0);
} }
@ -996,13 +998,14 @@ VM_NAME (scm_thread *thread)
VM_DEFINE_OP (29, foreign_call, "foreign-call", OP1 (X8_C12_C12)) VM_DEFINE_OP (29, foreign_call, "foreign-call", OP1 (X8_C12_C12))
{ {
uint16_t cif_idx, ptr_idx; uint16_t cif_idx, ptr_idx;
SCM closure, cif, pointer; struct scm_program *closure;
SCM cif, pointer;
UNPACK_12_12 (op, cif_idx, ptr_idx); UNPACK_12_12 (op, cif_idx, ptr_idx);
closure = FP_REF (0); closure = scm_to_program (FP_REF (0));
cif = SCM_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx); cif = scm_program_free_variable_ref (closure, cif_idx);
pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx); pointer = scm_program_free_variable_ref (closure, ptr_idx);
SYNC_IP (); SYNC_IP ();
CALL_INTRINSIC (foreign_call, (thread, cif, pointer)); CALL_INTRINSIC (foreign_call, (thread, cif, pointer));
@ -1026,8 +1029,8 @@ VM_NAME (scm_thread *thread)
UNPACK_24 (op, contregs_idx); UNPACK_24 (op, contregs_idx);
contregs = struct scm_program *closure = scm_to_program (FP_REF (0));
SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), contregs_idx); contregs = scm_program_free_variable_ref (closure, contregs_idx);
SYNC_IP (); SYNC_IP ();
CALL_INTRINSIC (reinstate_continuation_x, (thread, contregs)); CALL_INTRINSIC (reinstate_continuation_x, (thread, contregs));
@ -1051,7 +1054,8 @@ VM_NAME (scm_thread *thread)
uint8_t *mcode; uint8_t *mcode;
UNPACK_24 (op, cont_idx); UNPACK_24 (op, cont_idx);
vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), cont_idx); struct scm_program *closure = scm_to_program (FP_REF (0));
vmcont = scm_program_free_variable_ref (closure, cont_idx);
SYNC_IP (); SYNC_IP ();
mcode = CALL_INTRINSIC (compose_continuation, (thread, vmcont)); mcode = CALL_INTRINSIC (compose_continuation, (thread, vmcont));

24
libguile/vm.c
View file

@ -485,9 +485,12 @@ define_vm_builtins (void)
{ \ { \
size_t sz = sizeof (builtin##_code); \ size_t sz = sizeof (builtin##_code); \
vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \ vm_builtin_##builtin##_code = instrumented_code (builtin##_code, sz); \
vm_builtin_##builtin = \ struct scm_program *p = \
scm_cell (scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE, \ scm_gc_malloc_pointerless (sizeof (struct scm_program), "builtin"); \
(scm_t_bits)vm_builtin_##builtin##_code); \ scm_t_bits tag = scm_tc7_program | SCM_F_PROGRAM_IS_PRIMITIVE; \
p->tag_flags_and_free_variable_count = tag; \
p->code = vm_builtin_##builtin##_code; \
vm_builtin_##builtin = scm_from_program (p); \
} }
FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN); FOR_EACH_VM_BUILTIN (DEFINE_BUILTIN);
#undef INDEX_TO_NAME #undef INDEX_TO_NAME
@ -1453,23 +1456,23 @@ abort_to_prompt (scm_thread *thread, uint8_t *saved_mra)
return mra; return mra;
} }
static uint32_t * static const uint32_t *
get_callee_vcode (scm_thread *thread) get_callee_vcode (scm_thread *thread)
{ {
struct scm_vm *vp = &thread->vm; struct scm_vm *vp = &thread->vm;
SCM proc = SCM_FRAME_LOCAL (vp->fp, 0); SCM proc = SCM_FRAME_LOCAL (vp->fp, 0);
if (SCM_LIKELY (SCM_PROGRAM_P (proc))) if (SCM_LIKELY (scm_is_program (proc)))
return SCM_PROGRAM_CODE (proc); return scm_program_code (scm_to_program (proc));
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
{ {
proc = SCM_STRUCT_PROCEDURE (proc); proc = SCM_STRUCT_PROCEDURE (proc);
SCM_FRAME_LOCAL (vp->fp, 0) = proc; SCM_FRAME_LOCAL (vp->fp, 0) = proc;
if (SCM_PROGRAM_P (proc)) if (scm_is_program (proc))
return SCM_PROGRAM_CODE (proc); return scm_program_code (scm_to_program (proc));
} }
if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc))
@ -1486,7 +1489,7 @@ get_callee_vcode (scm_thread *thread)
proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline; proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline;
SCM_FRAME_LOCAL (vp->fp, 0) = proc; SCM_FRAME_LOCAL (vp->fp, 0) = proc;
return SCM_PROGRAM_CODE (proc); return scm_program_code (scm_to_program (proc));
} }
vp->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp); vp->ip = SCM_FRAME_VIRTUAL_RETURN_ADDRESS (vp->fp);
@ -1567,7 +1570,8 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs)
#endif #endif
} }
else else
vp->ip = get_callee_vcode (thread); /* FIXME: Don't strip const qualifier. */
vp->ip = (uint32_t *) get_callee_vcode (thread);
ret = vm_engines[vp->engine](thread); ret = vm_engines[vp->engine](thread);
thread->vm.registers = prev_registers; thread->vm.registers = prev_registers;

1
libguile/vm.h
View file

@ -28,7 +28,6 @@
#include <libguile/gc.h> #include <libguile/gc.h>
#include <libguile/frames.h> #include <libguile/frames.h>
#include <libguile/programs.h>
#define SCM_VM_REGULAR_ENGINE 0 #define SCM_VM_REGULAR_ENGINE 0
#define SCM_VM_DEBUG_ENGINE 1 #define SCM_VM_DEBUG_ENGINE 1