summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-08-21 18:39:30 -0700
committerAndy Wingo <wingo@pobox.com>2008-08-21 18:39:30 -0700
commit83495480e8e401d99158222f61d5c96fd2480e24 (patch)
treecdc006fdec9fda0909563b9daacf207e31265afa /libguile
parentbe52b55a3213c8f683d1007a542771daa3f9a06b (diff)
downloadguile-83495480e8e401d99158222f61d5c96fd2480e24.tar.gz
merge guile-vm into libguile itself
* ice-9/boot-9.scm: Only define load-compiled as #f if it's not already defined, which won't normally be the case. * libguile/guile-vm.c: Removed, there's no more guile-vm binary. * libguile/frames.c: (with change frame? -> heap-frame?) * libguile/frames.h: * libguile/instructions.c: * libguile/instructions.h: * libguile/objcodes.c: * libguile/objcodes.h: * libguile/programs.c: * libguile/programs.h: * libguile/vm-bootstrap.h: (was bootstrap.h) * libguile/vm-engine.c: (was vm_engine.c) * libguile/vm-engine.h: (was vm_engine.h) * libguile/vm-expand.h: (was vm_expand.h) * libguile/vm-i-loader.c: (was vm_loader.c) * libguile/vm-i-scheme.c: (was vm_scheme.c) * libguile/vm-i-system.c: (was vm_system.c) * libguile/vm.c: * libguile/vm.h: These files moved here from src/, as guile-vm is now a part of libguile. * libguile/init.c: Bootstrap the VM. Yay! * libguile/Makefile.am: The necessary chicanery here. * module/system/vm/Makefile.am: * module/system/vm/bootstrap.scm: * module/system/vm/frame.scm: * module/system/vm/instruction.scm: * module/system/vm/objcode.scm: * module/system/vm/program.scm: * module/system/vm/vm.scm: * pre-inst-guile-env.in: Add builddirs to the load path; add module/ to the path in the empty-$GUILE_LOAD_PATH case as well. * src/Makefile.am: Moved out everything except guilec and guile-disasm, which probably should be moved to the scripts directory? * testsuite/Makefile.am: Update to find guile-vm in the right place. * module/system/vm/Makefile.am: * module/system/vm/bootstrap.scm: Removed bootstrap.scm, scm_init_guile handles the bootstrapping for us. * module/system/vm/frame.scm: * module/system/vm/instruction.scm: * module/system/vm/objcode.scm: * module/system/vm/program.scm: * module/system/vm/vm.scm: Call the init functions in libguile; should fix at some point to avoid the dlopen?
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am19
-rw-r--r--libguile/frames.c197
-rw-r--r--libguile/frames.h125
-rw-r--r--libguile/init.c3
-rw-r--r--libguile/instructions.c181
-rw-r--r--libguile/instructions.h99
-rw-r--r--libguile/objcodes.c301
-rw-r--r--libguile/objcodes.h78
-rw-r--r--libguile/programs.c258
-rw-r--r--libguile/programs.h93
-rw-r--r--libguile/vm-bootstrap.h53
-rw-r--r--libguile/vm-engine.c206
-rw-r--r--libguile/vm-engine.h487
-rw-r--r--libguile/vm-expand.h103
-rw-r--r--libguile/vm-i-loader.c229
-rw-r--r--libguile/vm-i-scheme.c283
-rw-r--r--libguile/vm-i-system.c672
-rw-r--r--libguile/vm.c680
-rw-r--r--libguile/vm.h117
19 files changed, 4183 insertions, 1 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 74ed806dd..0f91cbc97 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -115,6 +115,9 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
ramap.c unif.c
+# vm-related sources
+libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
+
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \
$(libguile_la_CFLAGS)
@@ -139,6 +142,9 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
strports.x struct.x symbols.x threads.x throw.x values.x \
variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
+# vm-related snarfs
+DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
+
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
@@ -162,9 +168,14 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+
+.c.i:
+ grep '^VM_DEFINE' $< > $@
+
BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
version.h scmconfig.h \
- $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+ $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
EXTRA_libguile_la_SOURCES = _scm.h \
inet_aton.c memmove.c putenv.c strerror.c \
@@ -192,6 +203,9 @@ noinst_HEADERS = convert.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
private-gc.h private-options.h
+# vm instructions
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+
libguile_la_DEPENDENCIES = @LIBLOBJS@
libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
@@ -219,6 +233,9 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
pthread-threads.h null-threads.h throw.h unif.h values.h \
variable.h vectors.h vports.h weaks.h
+modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h \
+ programs.h vm.h vm-engine.h vm-expand.h
+
nodist_modinclude_HEADERS = version.h scmconfig.h
bin_SCRIPTS = guile-snarf
diff --git a/libguile/frames.c b/libguile/frames.c
new file mode 100644
index 000000000..c4f2f275d
--- /dev/null
+++ b/libguile/frames.c
@@ -0,0 +1,197 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+
+
+scm_t_bits scm_tc16_heap_frame;
+
+SCM
+scm_c_make_heap_frame (SCM *fp)
+{
+ SCM frame;
+ SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ size_t size = sizeof (SCM) * (upper - lower + 1);
+ SCM *p = scm_gc_malloc (size, "frame");
+
+ SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
+ p[0] = frame; /* self link */
+ memcpy (p + 1, lower, size - sizeof (SCM));
+
+ return frame;
+}
+
+static SCM
+heap_frame_mark (SCM obj)
+{
+ SCM *sp;
+ SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+ SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
+
+ for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++)
+ if (SCM_NIMP (*sp))
+ scm_gc_mark (*sp);
+
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+heap_frame_free (SCM obj)
+{
+ SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+ SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+ SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+ size_t size = sizeof (SCM) * (upper - lower + 1);
+
+ scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
+
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_heap_frame_p, "heap-frame?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_heap_frame_p
+{
+ return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_program
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
+ (SCM frame, SCM index),
+ "")
+#define FUNC_NAME s_scm_frame_local_ref
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+ return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+ SCM_I_INUM (index));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
+ (SCM frame, SCM index, SCM val),
+ "")
+#define FUNC_NAME s_scm_frame_local_set_x
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+ SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+ SCM_I_INUM (index)) = val;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_return_address
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long)
+ (SCM_FRAME_RETURN_ADDRESS
+ (SCM_HEAP_FRAME_POINTER (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_dynamic_link
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+ (SCM frame),
+ "")
+#define FUNC_NAME s_scm_frame_external_link
+{
+ SCM_VALIDATE_HEAP_FRAME (1, frame);
+ return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+
+void
+scm_bootstrap_frames (void)
+{
+ scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
+ scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
+ scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
+}
+
+void
+scm_init_frames (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "frames.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/frames.h b/libguile/frames.h
new file mode 100644
index 000000000..53fc4e858
--- /dev/null
+++ b/libguile/frames.h
@@ -0,0 +1,125 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_FRAMES_H_
+#define _SCM_FRAMES_H_
+
+#include <libguile.h>
+#include "programs.h"
+
+
+/*
+ * VM frames
+ */
+
+/* VM Frame Layout
+ ---------------
+
+ | | <- fp + bp->nargs + bp->nlocs + 4
+ +------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
+ | Return address |
+ | Dynamic link |
+ | Heap link |
+ | External link | <- fp + bp->nargs + bp->nlocs
+ | Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
+ | Local variable 0 | <- fp + bp->nargs
+ | Argument 1 |
+ | Argument 0 | <- fp
+ | Program | <- fp - 1
+ +------------------+ = SCM_FRAME_LOWER_ADDRESS (fp)
+ | |
+
+ As can be inferred from this drawing, it is assumed that
+ `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
+ assumed to be as long as SCM objects. */
+
+#define SCM_FRAME_DATA_ADDRESS(fp) \
+ (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
+
+#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
+
+#define SCM_FRAME_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
+#define SCM_FRAME_DYNAMIC_LINK(fp) \
+ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
+ ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
+#define SCM_FRAME_HEAP_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[1])
+#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
+#define SCM_FRAME_VARIABLE(fp,i) fp[i]
+#define SCM_FRAME_PROGRAM(fp) fp[-1]
+
+
+/*
+ * Heap frames
+ */
+
+extern scm_t_bits scm_tc16_heap_frame;
+
+#define SCM_HEAP_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
+#define SCM_HEAP_FRAME_DATA(f) ((SCM *) SCM_SMOB_DATA (f))
+#define SCM_HEAP_FRAME_SELF(f) (SCM_HEAP_FRAME_DATA (f) + 0)
+#define SCM_HEAP_FRAME_POINTER(f) (SCM_HEAP_FRAME_DATA (f) + 2)
+#define SCM_VALIDATE_HEAP_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
+
+extern SCM scm_heap_frame_p (SCM obj);
+extern SCM scm_frame_program (SCM frame);
+extern SCM scm_frame_local_ref (SCM frame, SCM index);
+extern SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+extern SCM scm_frame_return_address (SCM frame);
+extern SCM scm_frame_dynamic_link (SCM frame);
+extern SCM scm_frame_external_link (SCM frame);
+
+extern SCM scm_c_make_heap_frame (SCM *fp);
+extern void scm_bootstrap_frames (void);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/init.c b/libguile/init.c
index 25cff62a5..cdd756894 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -118,6 +118,7 @@
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
+#include "libguile/vm-bootstrap.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
@@ -572,6 +573,8 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_rw ();
scm_init_extensions ();
+ scm_bootstrap_vm ();
+
atexit (cleanup_for_exit);
scm_load_startup_files ();
}
diff --git a/libguile/instructions.c b/libguile/instructions.c
new file mode 100644
index 000000000..89b6c774b
--- /dev/null
+++ b/libguile/instructions.c
@@ -0,0 +1,181 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+
+struct scm_instruction scm_instruction_table[] = {
+#define VM_INSTRUCTION_TO_TABLE 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_TABLE
+ {scm_op_last}
+};
+
+/* C interface */
+
+struct scm_instruction *
+scm_lookup_instruction (SCM name)
+{
+ struct scm_instruction *ip;
+ char *symbol;
+
+ if (SCM_SYMBOLP (name))
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ {
+ symbol = scm_to_locale_string (scm_symbol_to_string (name));
+ if ((symbol) && (strcmp (ip->name, symbol) == 0))
+ {
+ free (symbol);
+ return ip;
+ }
+
+ if (symbol)
+ free (symbol);
+ }
+
+ return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_instruction_list
+{
+ SCM list = SCM_EOL;
+ struct scm_instruction *ip;
+ for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+ list = scm_cons (scm_from_locale_symbol (ip->name), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_instruction_p
+{
+ return SCM_BOOL (SCM_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_length
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pops
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_pushes
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+ (SCM inst),
+ "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_I_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
+ (SCM op),
+ "")
+#define FUNC_NAME s_scm_opcode_to_instruction
+{
+ int i;
+ SCM_MAKE_VALIDATE (1, op, I_INUMP);
+ i = SCM_I_INUM (op);
+ SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
+ return scm_from_locale_symbol (scm_instruction_table[i].name);
+}
+#undef FUNC_NAME
+
+void
+scm_bootstrap_instructions (void)
+{
+}
+
+void
+scm_init_instructions (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "instructions.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/instructions.h b/libguile/instructions.h
new file mode 100644
index 000000000..1a965daf9
--- /dev/null
+++ b/libguile/instructions.h
@@ -0,0 +1,99 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_INSTRUCTIONS_H_
+#define _SCM_INSTRUCTIONS_H_
+
+#include <libguile.h>
+
+enum scm_opcode {
+#define VM_INSTRUCTION_TO_OPCODE 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_OPCODE
+ scm_op_last
+};
+
+struct scm_instruction {
+ enum scm_opcode opcode; /* opcode */
+ const char *name; /* instruction name */
+ signed char len; /* Instruction length. This may be -1 for
+ the loader (see the `VM_LOADER'
+ macro). */
+ signed char npop; /* The number of values popped. This may be
+ -1 for insns like `call' which can take
+ any number of arguments. */
+ char npush; /* the number of values pushed */
+};
+
+#define SCM_INSTRUCTION_P(x) (scm_lookup_instruction (x))
+#define SCM_INSTRUCTION_OPCODE(i) (scm_lookup_instruction (i)->opcode)
+#define SCM_INSTRUCTION_NAME(i) (scm_lookup_instruction (i)->name)
+#define SCM_INSTRUCTION_LENGTH(i) (scm_lookup_instruction (i)->len)
+#define SCM_INSTRUCTION_POPS(i) (scm_lookup_instruction (i)->npop)
+#define SCM_INSTRUCTION_PUSHES(i) (scm_lookup_instruction (i)->npush)
+#define SCM_VALIDATE_INSTRUCTION(p,x) SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
+
+#define SCM_INSTRUCTION(i) (&scm_instruction_table[i])
+
+extern struct scm_instruction scm_instruction_table[];
+extern struct scm_instruction *scm_lookup_instruction (SCM name);
+
+extern SCM scm_instruction_list (void);
+extern SCM scm_instruction_p (SCM obj);
+extern SCM scm_instruction_length (SCM inst);
+extern SCM scm_instruction_pops (SCM inst);
+extern SCM scm_instruction_pushes (SCM inst);
+extern SCM scm_instruction_to_opcode (SCM inst);
+extern SCM scm_opcode_to_instruction (SCM op);
+
+extern void scm_bootstrap_instructions (void);
+extern void scm_init_instructions (void);
+
+#endif /* _SCM_INSTRUCTIONS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
new file mode 100644
index 000000000..6891e8a6a
--- /dev/null
+++ b/libguile/objcodes.c
@@ -0,0 +1,301 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "vm-bootstrap.h"
+#include "programs.h"
+#include "objcodes.h"
+
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode (size_t size)
+#define FUNC_NAME "make_objcode"
+{
+ struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
+ "objcode");
+ p->size = size;
+ p->base = scm_gc_malloc (size, "objcode-base");
+ p->fd = -1;
+ SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+ int ret;
+ char *addr;
+ struct stat st;
+ struct scm_objcode *p;
+
+ ret = fstat (fd, &st);
+ if (ret < 0)
+ SCM_SYSERROR;
+
+ if (st.st_size <= strlen (OBJCODE_COOKIE))
+ scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+ SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
+
+ addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+ if (addr == MAP_FAILED)
+ SCM_SYSERROR;
+
+ if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+ SCM_SYSERROR;
+
+ p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
+ p->size = st.st_size;
+ p->base = addr;
+ p->fd = fd;
+ SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static scm_sizet
+objcode_free (SCM obj)
+#define FUNC_NAME "objcode_free"
+{
+ size_t size = sizeof (struct scm_objcode);
+ struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
+
+ if (p->fd >= 0)
+ {
+ int rv;
+ rv = munmap (p->base, p->size);
+ if (rv < 0) SCM_SYSERROR;
+ rv = close (p->fd);
+ if (rv < 0) SCM_SYSERROR;
+ }
+ else
+ scm_gc_free (p->base, p->size, "objcode-base");
+
+ scm_gc_free (p, size, "objcode");
+
+ return 0;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Scheme interface
+ */
+
+#if 0
+SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0,
+ (SCM car, SCM cdr),
+ "This is a stupid test to see how cells work. (Ludo)")
+{
+ static SCM room[512];
+ static SCM *where = &room[0];
+ SCM the_pair;
+ size_t incr;
+
+ if ((scm_t_bits)where & 6)
+ {
+ /* Align the cell pointer so that Guile considers it as a
+ non-immediate object (see tags.h). */
+ incr = (scm_t_bits)where & 6;
+ incr = (~incr) & 7;
+ where += incr;
+ }
+
+ printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where);
+ where[0] = car;
+ where[1] = cdr;
+
+ the_pair = PTR2SCM (where);
+ /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
+ "mark bitmap" at the end of a supposed cell segment which doesn't
+ exist. */
+
+ return (the_pair);
+}
+#endif
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_objcode_p
+{
+ return SCM_BOOL (SCM_OBJCODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
+ (SCM bytecode, SCM nlocs, SCM nexts),
+ "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+ size_t size;
+ ssize_t increment;
+ scm_t_array_handle handle;
+ char *base;
+ const scm_t_uint8 *c_bytecode;
+ SCM objcode;
+
+ if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+ scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+ SCM_VALIDATE_NUMBER (2, nlocs);
+ SCM_VALIDATE_NUMBER (3, nexts);
+
+ c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ assert (increment == 1);
+
+ /* Account for the 10 byte-long header. */
+ size += 10;
+ objcode = make_objcode (size);
+ base = SCM_OBJCODE_BASE (objcode);
+
+ memcpy (base, OBJCODE_COOKIE, 8);
+ base[8] = scm_to_uint8 (nlocs);
+ base[9] = scm_to_uint8 (nexts);
+
+ memcpy (base + 10, c_bytecode, size - 10);
+
+ scm_array_handle_release (&handle);
+
+ return objcode;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
+ (SCM file),
+ "")
+#define FUNC_NAME s_scm_load_objcode
+{
+ int fd;
+ char *c_file;
+
+ SCM_VALIDATE_STRING (1, file);
+
+ c_file = scm_to_locale_string (file);
+ fd = open (c_file, O_RDONLY);
+ free (c_file);
+ if (fd < 0) SCM_SYSERROR;
+
+ return make_objcode_by_mmap (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_u8vector
+{
+ scm_t_uint8 *u8vector;
+ size_t size;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ size = SCM_OBJCODE_SIZE (objcode);
+ /* FIXME: Is `gc_malloc' ok here? */
+ u8vector = scm_gc_malloc (size, "objcode-u8vector");
+ memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+
+ return scm_take_u8vector (u8vector, size);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
+ (SCM objcode),
+ "")
+#define FUNC_NAME s_scm_objcode_to_program
+{
+ SCM prog;
+ size_t size;
+ char *base;
+ struct scm_program *p;
+
+ SCM_VALIDATE_OBJCODE (1, objcode);
+
+ base = SCM_OBJCODE_BASE (objcode);
+ size = SCM_OBJCODE_SIZE (objcode);
+ prog = scm_c_make_program (base + 10, size - 10, objcode);
+ p = SCM_PROGRAM_DATA (prog);
+ p->nlocs = base[8];
+ p->nexts = base[9];
+ return prog;
+}
+#undef FUNC_NAME
+
+
+void
+scm_bootstrap_objcodes (void)
+{
+ scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+ scm_set_smob_free (scm_tc16_objcode, objcode_free);
+}
+
+void
+scm_init_objcodes (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "objcodes.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
new file mode 100644
index 000000000..2cedefa98
--- /dev/null
+++ b/libguile/objcodes.h
@@ -0,0 +1,78 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+
+struct scm_objcode {
+ size_t size; /* objcode size */
+ char *base; /* objcode base address */
+ int fd; /* file descriptor when mmap'ed */
+};
+
+extern scm_t_bits scm_tc16_objcode;
+
+#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
+#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
+
+#define SCM_OBJCODE_SIZE(x) (SCM_OBJCODE_DATA (x)->size)
+#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
+#define SCM_OBJCODE_FD(x) (SCM_OBJCODE_DATA (x)->fd)
+
+extern SCM scm_load_objcode (SCM file);
+extern SCM scm_objcode_to_program (SCM objcode);
+extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_bytecode_to_objcode (SCM bytecode, SCM nlocs, SCM nexts);
+extern SCM scm_objcode_to_u8vector (SCM objcode);
+
+extern void scm_bootstrap_objcodes (void);
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/programs.c b/libguile/programs.c
new file mode 100644
index 000000000..436e2b863
--- /dev/null
+++ b/libguile/programs.c
@@ -0,0 +1,258 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+#include "programs.h"
+#include "vm.h"
+
+
+scm_t_bits scm_tc16_program;
+
+static SCM zero_vector;
+
+SCM
+scm_c_make_program (void *addr, size_t size, SCM holder)
+#define FUNC_NAME "scm_c_make_program"
+{
+ struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
+ "program");
+ p->size = size;
+ p->nargs = 0;
+ p->nrest = 0;
+ p->nlocs = 0;
+ p->nexts = 0;
+ p->meta = SCM_BOOL_F;
+ p->objs = zero_vector;
+ p->external = SCM_EOL;
+ p->holder = holder;
+
+ /* If nobody holds bytecode's address, then allocate a new memory */
+ if (SCM_FALSEP (holder))
+ {
+ p->base = scm_gc_malloc (size, "program-base");
+ memcpy (p->base, addr, size);
+ }
+ else
+ p->base = addr;
+
+ SCM_RETURN_NEWSMOB (scm_tc16_program, p);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_closure (SCM program, SCM external)
+{
+ SCM prog = scm_c_make_program (0, 0, program);
+ *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
+ SCM_PROGRAM_DATA (prog)->external = external;
+ return prog;
+}
+
+static SCM
+program_mark (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_gc_mark (p->meta);
+ scm_gc_mark (p->objs);
+ scm_gc_mark (p->external);
+ return p->holder;
+}
+
+static scm_sizet
+program_free (SCM obj)
+{
+ struct scm_program *p = SCM_PROGRAM_DATA (obj);
+ scm_sizet size = (sizeof (struct scm_program));
+
+ if (SCM_FALSEP (p->holder))
+ scm_gc_free (p->base, p->size, "program-base");
+
+ scm_gc_free (p, size, "program");
+
+ return 0;
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+ return scm_vm_apply (scm_the_vm (), program, args);
+}
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_program_p
+{
+ return SCM_BOOL (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
+ (SCM program),
+ "")
+#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_program *p;
+
+ 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));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_meta
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->meta;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_objects
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->objs;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+ (SCM program),
+ "")
+#define FUNC_NAME s_scm_program_external
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_DATA (program)->external;
+}
+#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_VALIDATE_PROGRAM (1, program);
+ SCM_VALIDATE_LIST (2, external);
+ SCM_PROGRAM_DATA (program)->external = external;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
+ (SCM program),
+ "Return a u8vector containing @var{program}'s bytecode.")
+#define FUNC_NAME s_scm_program_bytecode
+{
+ size_t size;
+ scm_t_uint8 *c_bytecode;
+
+ SCM_VALIDATE_PROGRAM (1, program);
+
+ size = SCM_PROGRAM_DATA (program)->size;
+ c_bytecode = malloc (size);
+ if (!c_bytecode)
+ return SCM_BOOL_F;
+
+ memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size);
+
+ return scm_take_u8vector (c_bytecode, size);
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_bootstrap_programs (void)
+{
+ zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
+
+ scm_tc16_program = scm_make_smob_type ("program", 0);
+ scm_set_smob_mark (scm_tc16_program, program_mark);
+ scm_set_smob_free (scm_tc16_program, program_free);
+ scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+}
+
+void
+scm_init_programs (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "programs.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/programs.h b/libguile/programs.h
new file mode 100644
index 000000000..04f2d459d
--- /dev/null
+++ b/libguile/programs.h
@@ -0,0 +1,93 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_PROGRAMS_H_
+#define _SCM_PROGRAMS_H_
+
+#include <libguile.h>
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+struct scm_program {
+ size_t size; /* the size of the program */
+ unsigned char nargs; /* the number of arguments */
+ unsigned char nrest; /* the number of rest argument (0 or 1) */
+ unsigned char nlocs; /* the number of local variables */
+ unsigned char nexts; /* the number of external variables */
+ scm_byte_t *base; /* program base address */
+ SCM meta; /* meta data */
+ SCM objs; /* constant objects */
+ SCM external; /* external environment */
+ SCM holder; /* the owner of bytecode */
+};
+
+extern scm_t_bits scm_tc16_program;
+
+#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_DATA(x) ((struct scm_program *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
+extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
+extern SCM scm_c_make_closure (SCM program, SCM external);
+
+extern SCM scm_program_p (SCM obj);
+extern SCM scm_program_base (SCM program);
+extern SCM scm_program_arity (SCM program);
+extern SCM scm_program_meta (SCM program);
+extern SCM scm_program_objects (SCM program);
+extern SCM scm_program_external (SCM program);
+extern SCM scm_program_external_set_x (SCM program, SCM external);
+extern SCM scm_program_bytecode (SCM program);
+
+extern void scm_bootstrap_programs (void);
+extern void scm_init_programs (void);
+
+#endif /* _SCM_PROGRAMS_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
new file mode 100644
index 000000000..beecf0fc2
--- /dev/null
+++ b/libguile/vm-bootstrap.h
@@ -0,0 +1,53 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_VM_BOOTSTRAP_H_
+#define _SCM_VM_BOOTSTRAP_H_
+
+extern void scm_bootstrap_vm (void);
+
+#endif /* _SCM_VM_BOOTSTRAP_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
new file mode 100644
index 000000000..def7e807b
--- /dev/null
+++ b/libguile/vm-engine.c
@@ -0,0 +1,206 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+/* This file is included in vm.c twice */
+
+#include "vm-engine.h"
+
+
+static SCM
+vm_run (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "vm-engine"
+{
+ /* VM registers */
+ register scm_byte_t *ip IP_REG; /* instruction pointer */
+ register SCM *sp SP_REG; /* stack pointer */
+ register SCM *fp FP_REG; /* frame pointer */
+
+ /* Cache variables */
+ struct scm_vm *vp = SCM_VM_DATA (vm); /* VM data pointer */
+ struct scm_program *bp = NULL; /* program base pointer */
+ SCM external = SCM_EOL; /* external environment */
+ SCM *objects = NULL; /* constant objects */
+ scm_t_array_handle objects_handle; /* handle of the OBJECTS array */
+ size_t object_count; /* length of OBJECTS */
+ SCM *stack_base = vp->stack_base; /* stack base address */
+ SCM *stack_limit = vp->stack_limit; /* stack limit address */
+
+ /* Internal variables */
+ int nargs = 0;
+ long start_time = scm_c_get_internal_run_time ();
+ // SCM dynwinds = SCM_EOL;
+ SCM err_msg;
+ SCM err_args;
+#if VM_USE_HOOKS
+ SCM hook_args = SCM_LIST1 (vm);
+#endif
+ struct vm_unwind_data wind_data;
+
+ /* dynwind ended in the halt instruction */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ wind_data.vp = vp;
+ wind_data.sp = vp->sp;
+ wind_data.fp = vp->fp;
+ wind_data.this_frame = vp->this_frame;
+ scm_dynwind_unwind_handler (vm_reset_stack, &wind_data, 0);
+
+
+#ifdef HAVE_LABELS_AS_VALUES
+ /* Jump table */
+ static void *jump_table[] = {
+#define VM_INSTRUCTION_TO_LABEL 1
+#include "vm-expand.h"
+#include "vm-i-system.i"
+#include "vm-i-scheme.i"
+#include "vm-i-loader.i"
+#undef VM_INSTRUCTION_TO_LABEL
+ };
+#endif
+
+ /* Initialization */
+ {
+ SCM prog = program;
+
+ /* Boot program */
+ scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
+ bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
+ program = scm_c_make_program (bytes, 3, SCM_BOOL_F);
+
+ /* Initial frame */
+ CACHE_REGISTER ();
+ CACHE_PROGRAM ();
+ PUSH (program);
+ NEW_FRAME ();
+
+ /* Initial arguments */
+ PUSH (prog);
+ for (; !SCM_NULLP (args); args = SCM_CDR (args))
+ PUSH (SCM_CAR (args));
+ }
+
+ /* Let's go! */
+ BOOT_HOOK ();
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start:
+ switch (*ip++) {
+#endif
+
+#include "vm-expand.h"
+#include "vm-i-system.c"
+#include "vm-i-scheme.c"
+#include "vm-i-loader.c"
+
+#ifndef HAVE_LABELS_AS_VALUES
+ }
+#endif
+
+ /* Errors */
+ {
+ vm_error_unbound:
+ err_msg = scm_from_locale_string ("VM: Unbound variable: ~A");
+ goto vm_error;
+
+ vm_error_wrong_type_arg:
+ err_msg = scm_from_locale_string ("VM: Wrong type argument");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_wrong_num_args:
+ err_msg = scm_from_locale_string ("VM: Wrong number of arguments");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_wrong_type_apply:
+ err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+ "[IP offset: ~a]");
+ err_args = SCM_LIST2 (program,
+ SCM_I_MAKINUM (ip - bp->base));
+ goto vm_error;
+
+ vm_error_stack_overflow:
+ err_msg = scm_from_locale_string ("VM: Stack overflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+ vm_error_stack_underflow:
+ err_msg = scm_from_locale_string ("VM: Stack underflow");
+ err_args = SCM_EOL;
+ goto vm_error;
+
+#if VM_CHECK_IP
+ vm_error_invalid_address:
+ err_msg = scm_from_locale_string ("VM: Invalid program address");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+#if VM_CHECK_EXTERNAL
+ vm_error_external:
+ err_msg = scm_from_locale_string ("VM: Invalid external access");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+#if VM_CHECK_OBJECT
+ vm_error_object:
+ err_msg = scm_from_locale_string ("VM: Invalid object table access");
+ err_args = SCM_EOL;
+ goto vm_error;
+#endif
+
+ vm_error:
+ SYNC_ALL ();
+ if (objects)
+ scm_array_handle_release (&objects_handle);
+
+ scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
+ }
+
+ abort (); /* never reached */
+}
+#undef FUNC_NAME
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
new file mode 100644
index 000000000..2026e3cdf
--- /dev/null
+++ b/libguile/vm-engine.h
@@ -0,0 +1,487 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+/* This file is included in vm_engine.c */
+
+/*
+ * Options
+ */
+
+#define VM_USE_HOOKS 1 /* Various hooks */
+#define VM_USE_CLOCK 1 /* Bogoclock */
+#define VM_CHECK_EXTERNAL 1 /* Check external link */
+#define VM_CHECK_OBJECT 1 /* Check object table */
+
+
+/*
+ * Registers
+ */
+
+/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
+
+ Some compilers underestimate the use of the local variables representing
+ the abstract machine registers, and don't put them in hardware registers,
+ which slows down the interpreter considerably.
+ For GCC, I have hand-assigned hardware registers for several architectures.
+*/
+
+#ifdef __GNUC__
+#ifdef __mips__
+#define IP_REG asm("$16")
+#define SP_REG asm("$17")
+#define FP_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define IP_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define FP_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define IP_REG asm("r9")
+#define SP_REG asm("r10")
+#define FP_REG asm("r11")
+#else
+#define IP_REG asm("$9")
+#define SP_REG asm("$10")
+#define FP_REG asm("$11")
+#endif
+#endif
+#ifdef __i386__
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
+#endif
+
+#ifndef IP_REG
+#define IP_REG
+#endif
+#ifndef SP_REG
+#define SP_REG
+#endif
+#ifndef FP_REG
+#define FP_REG
+#endif
+
+
+/*
+ * Cache/Sync
+ */
+
+#define CACHE_REGISTER() \
+{ \
+ ip = vp->ip; \
+ sp = vp->sp; \
+ fp = vp->fp; \
+}
+
+#define SYNC_REGISTER() \
+{ \
+ vp->ip = ip; \
+ vp->sp = sp; \
+ vp->fp = fp; \
+}
+
+#ifdef IP_PARANOIA
+#define CHECK_IP() \
+ do { if (ip < bp->base || ip - bp->base > bp->size) abort (); } while (0)
+#else
+#define CHECK_IP()
+#endif
+
+/* Get a local copy of the program's "object table" (i.e. the vector of
+ external bindings that are referenced by the program), initialized by
+ `load-program'. */
+/* XXX: We could instead use the "simple vector macros", thus not having to
+ call `scm_vector_writable_elements ()' and the likes. */
+#define CACHE_PROGRAM() \
+{ \
+ ssize_t _vincr; \
+ \
+ if (bp != SCM_PROGRAM_DATA (program)) { \
+ bp = SCM_PROGRAM_DATA (program); \
+ /* Was: objects = SCM_VELTS (bp->objs); */ \
+ \
+ if (objects) \
+ scm_array_handle_release (&objects_handle); \
+ \
+ objects = scm_vector_writable_elements (bp->objs, &objects_handle, \
+ &object_count, &_vincr); \
+ } \
+}
+
+#define SYNC_BEFORE_GC() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+#define SYNC_ALL() \
+{ \
+ SYNC_REGISTER (); \
+}
+
+
+/*
+ * Error check
+ */
+
+#undef CHECK_EXTERNAL
+#if VM_CHECK_EXTERNAL
+#define CHECK_EXTERNAL(e) \
+ do { if (!SCM_CONSP (e)) goto vm_error_external; } while (0)
+#else
+#define CHECK_EXTERNAL(e)
+#endif
+
+/* Accesses to a program's object table. */
+#if VM_CHECK_OBJECT
+#define CHECK_OBJECT(_num) \
+ do { if ((_num) >= object_count) goto vm_error_object; } while (0)
+#else
+#define CHECK_OBJECT(_num)
+#endif
+
+
+/*
+ * Hooks
+ */
+
+#undef RUN_HOOK
+#if VM_USE_HOOKS
+#define RUN_HOOK(h) \
+{ \
+ if (!SCM_FALSEP (vp->hooks[h])) \
+ { \
+ SYNC_REGISTER (); \
+ vm_heapify_frames (vm); \
+ scm_c_run_hook (vp->hooks[h], hook_args); \
+ CACHE_REGISTER (); \
+ } \
+}
+#else
+#define RUN_HOOK(h)
+#endif
+
+#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK)
+#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK)
+#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK)
+#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK)
+#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK)
+#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK)
+#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK)
+
+
+/*
+ * Stack operation
+ */
+
+#define CHECK_OVERFLOW() \
+ if (sp > stack_limit) \
+ goto vm_error_stack_overflow
+
+#define CHECK_UNDERFLOW() \
+ if (sp < stack_base) \
+ goto vm_error_stack_underflow;
+
+#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
+#define DROP() do { sp--; CHECK_UNDERFLOW (); } while (0)
+#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); } while (0)
+#define POP(x) do { x = *sp; DROP (); } while (0)
+
+/* A fast CONS. This has to be fast since its used, for instance, by
+ POP_LIST when fetching a function's argument list. Note: `scm_cell' is an
+ inlined function in Guile 1.7. Unfortunately, it calls
+ `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
+ heap. XXX */
+#define CONS(x,y,z) \
+{ \
+ SYNC_BEFORE_GC (); \
+ x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \
+}
+
+/* Pop the N objects on top of the stack and push a list that contains
+ them. */
+#define POP_LIST(n) \
+do \
+{ \
+ int i; \
+ SCM l = SCM_EOL; \
+ sp -= n; \
+ for (i = n; i; i--) \
+ CONS (l, sp[i], l); \
+ PUSH (l); \
+} while (0)
+
+
+/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
+ allocate cells on the stack. This is a significant improvement for
+ programs which call a lot of procedures, since the procedure call
+ mechanism uses POP_LIST which normally uses `scm_cons'.
+
+ What it does is that it creates a list whose cells are allocated on the
+ VM's stack instead of being allocated on the heap via `scm_cell'. This is
+ much faster. However, if the callee does something like:
+
+ (lambda (. args)
+ (set! the-args args))
+
+ then terrible things may happen since the list of arguments may be
+ overwritten later on. */
+
+
+/* Awful hack that aligns PTR so that it can be considered as a non-immediate
+ value by Guile. */
+#define ALIGN_AS_NON_IMMEDIATE(_ptr) \
+{ \
+ if ((scm_t_bits)(_ptr) & 6) \
+ { \
+ size_t _incr; \
+ \
+ _incr = (scm_t_bits)(_ptr) & 6; \
+ _incr = (~_incr) & 7; \
+ (_ptr) += _incr; \
+ } \
+}
+
+#define POP_LIST_ON_STACK(n) \
+do \
+{ \
+ int i; \
+ if (n == 0) \
+ { \
+ sp -= n; \
+ PUSH (SCM_EOL); \
+ } \
+ else \
+ { \
+ SCM *list_head, *list; \
+ \
+ list_head = sp + 1; \
+ ALIGN_AS_NON_IMMEDIATE (list_head); \
+ list = list_head; \
+ \
+ sp -= n; \
+ for (i = 1; i <= n; i++) \
+ { \
+ /* The cell's car and cdr. */ \
+ *(list) = sp[i]; \
+ *(list + 1) = PTR2SCM (list + 2); \
+ list += 2; \
+ } \
+ \
+ /* The last pair's cdr is '(). */ \
+ list--; \
+ *list = SCM_EOL; \
+ /* Push the SCM object that points */ \
+ /* to the first cell. */ \
+ PUSH (PTR2SCM (list_head)); \
+ } \
+} \
+while (0)
+
+/* end of the experiment */
+
+
+#define POP_LIST_MARK() \
+do { \
+ SCM o; \
+ SCM l = SCM_EOL; \
+ POP (o); \
+ while (!SCM_UNBNDP (o)) \
+ { \
+ CONS (l, o, l); \
+ POP (o); \
+ } \
+ PUSH (l); \
+} while (0)
+
+
+/*
+ * Instruction operation
+ */
+
+#define FETCH() (*ip++)
+#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
+
+#undef CLOCK
+#if VM_USE_CLOCK
+#define CLOCK(n) vp->clock += n
+#else
+#define CLOCK(n)
+#endif
+
+#undef NEXT_JUMP
+#ifdef HAVE_LABELS_AS_VALUES
+#define NEXT_JUMP() goto *jump_table[FETCH ()]
+#else
+#define NEXT_JUMP() goto vm_start
+#endif
+
+#define NEXT \
+{ \
+ CLOCK (1); \
+ NEXT_HOOK (); \
+ NEXT_JUMP (); \
+}
+
+
+/*
+ * Stack frame
+ */
+
+#define INIT_ARGS() \
+{ \
+ if (bp->nrest) \
+ { \
+ int n = nargs - (bp->nargs - 1); \
+ if (n < 0) \
+ goto vm_error_wrong_num_args; \
+ POP_LIST (n); \
+ } \
+ else \
+ { \
+ if (nargs != bp->nargs) \
+ goto vm_error_wrong_num_args; \
+ } \
+}
+
+/* See frames.h for the layout of stack frames */
+
+#define NEW_FRAME() \
+{ \
+ int i; \
+ SCM ra = SCM_PACK (ip); \
+ SCM dl = SCM_PACK (fp); \
+ SCM *p = sp + 1; \
+ SCM *q = p + bp->nlocs; \
+ \
+ /* New pointers */ \
+ ip = bp->base; \
+ fp = p - bp->nargs; \
+ sp = q + 3; \
+ CHECK_OVERFLOW (); \
+ \
+ /* Init local variables */ \
+ for (; p < q; p++) \
+ *p = SCM_UNDEFINED; \
+ \
+ /* Create external variables */ \
+ external = bp->external; \
+ for (i = 0; i < bp->nexts; i++) \
+ CONS (external, SCM_UNDEFINED, external); \
+ \
+ /* Set frame data */ \
+ p[3] = ra; \
+ p[2] = dl; \
+ p[1] = SCM_BOOL_F; \
+ p[0] = external; \
+ stack_base = p + 3; \
+}
+
+#define FREE_FRAME() \
+{ \
+ SCM *last_sp = sp; \
+ SCM *last_fp = fp; \
+ SCM *p = fp + bp->nargs + bp->nlocs; \
+ \
+ /* Restore pointers */ \
+ ip = SCM_FRAME_BYTE_CAST (p[3]); \
+ fp = SCM_FRAME_STACK_CAST (p[2]); \
+ \
+ if (!SCM_FALSEP (p[1])) \
+ { \
+ /* Unlink the heap stack */ \
+ vp->this_frame = p[1]; \
+ } \
+ else \
+ { \
+ /* Move stack items */ \
+ p += 4; \
+ sp = SCM_FRAME_LOWER_ADDRESS (last_fp); \
+ while (p <= last_sp) \
+ *sp++ = *p++; \
+ sp--; \
+ } \
+ stack_base = fp ? \
+ SCM_FRAME_UPPER_ADDRESS (fp) - 1 \
+ : vp->stack_base; \
+}
+
+#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
+
+
+/*
+ * Function support
+ */
+
+#define ARGS1(a1) SCM a1 = sp[0];
+#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--;
+#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
+
+#define RETURN(x) do { *sp = x; NEXT; } while (0)
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
new file mode 100644
index 000000000..cccb56b9f
--- /dev/null
+++ b/libguile/vm-expand.h
@@ -0,0 +1,103 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef VM_LABEL
+#define VM_LABEL(tag) l_##tag
+#define VM_OPCODE(tag) scm_op_##tag
+
+#ifdef HAVE_LABELS_AS_VALUES
+#define VM_TAG(tag) VM_LABEL(tag):
+#define VM_ADDR(tag) &&VM_LABEL(tag)
+#else /* not HAVE_LABELS_AS_VALUES */
+#define VM_TAG(tag) case VM_OPCODE(tag):
+#define VM_ADDR(tag) NULL
+#endif /* not HAVE_LABELS_AS_VALUES */
+#endif /* VM_LABEL */
+
+#undef VM_DEFINE_INSTRUCTION
+#undef VM_DEFINE_FUNCTION
+#undef VM_DEFINE_LOADER
+#ifdef VM_INSTRUCTION_TO_TABLE
+/*
+ * These will go to scm_instruction_table in vm.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
+ {VM_OPCODE (tag), name, len, npop, npush},
+#define VM_DEFINE_FUNCTION(tag,name,nargs) \
+ {VM_OPCODE (tag), name, 0, nargs, 1},
+#define VM_DEFINE_LOADER(tag,name) \
+ {VM_OPCODE (tag), name, -1, 0, 1},
+
+#else
+#ifdef VM_INSTRUCTION_TO_LABEL
+/*
+ * These will go to jump_table in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_ADDR (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_ADDR (tag),
+#define VM_DEFINE_LOADER(tag,name) VM_ADDR (tag),
+
+#else
+#ifdef VM_INSTRUCTION_TO_OPCODE
+/*
+ * These will go to scm_opcode in vm.h
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_OPCODE (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_OPCODE (tag),
+#define VM_DEFINE_LOADER(tag,name) VM_OPCODE (tag),
+
+#else /* Otherwise */
+/*
+ * These are directly included in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) VM_TAG (tag)
+#define VM_DEFINE_FUNCTION(tag,name,nargs) VM_TAG (tag)
+#define VM_DEFINE_LOADER(tag,name) VM_TAG (tag)
+
+#endif /* VM_INSTRUCTION_TO_OPCODE */
+#endif /* VM_INSTRUCTION_TO_LABEL */
+#endif /* VM_INSTRUCTION_TO_TABLE */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
new file mode 100644
index 000000000..db0ee9b57
--- /dev/null
+++ b/libguile/vm-i-loader.c
@@ -0,0 +1,229 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+/* This file is included in vm_engine.c */
+
+VM_DEFINE_LOADER (load_integer, "load-integer")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ if (len <= 4)
+ {
+ long val = 0;
+ while (len-- > 0)
+ val = (val << 8) + FETCH ();
+ SYNC_REGISTER ();
+ PUSH (scm_from_ulong (val));
+ NEXT;
+ }
+ else
+ SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (load_number, "load-number")
+{
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
+ SCM_UNDEFINED /* radix = 10 */));
+ /* Was: scm_istring2number (ip, len, 10)); */
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_string, "load-string")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_stringn ((char *)ip, len));
+ /* Was: scm_makfromstr (ip, len, 0) */
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_symbol, "load-symbol")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_symboln ((char *)ip, len));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_keyword, "load-keyword")
+{
+ size_t len;
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ PUSH (scm_from_locale_keywordn ((char *)ip, len));
+ ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (load_program, "load-program")
+{
+ size_t len;
+ SCM prog, x;
+ struct scm_program *p;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ prog = scm_c_make_program (ip, len, program);
+ p = SCM_PROGRAM_DATA (prog);
+ ip += len;
+
+ POP (x);
+
+ /* init meta data */
+ if (SCM_CONSP (x))
+ {
+ p->meta = x;
+ POP (x);
+ }
+
+ /* init object table */
+ if (scm_is_vector (x))
+ {
+#if 0
+ if (scm_is_simple_vector (x))
+ printf ("is_simple_vector!\n");
+ else
+ printf ("NOT is_simple_vector\n");
+#endif
+ p->objs = x;
+ POP (x);
+ }
+
+ /* init parameters */
+ /* NOTE: format defined in system/vm/assemble.scm */
+ if (SCM_I_INUMP (x))
+ {
+ int i = SCM_I_INUM (x);
+ if (-128 <= i && i <= 127)
+ {
+ /* 8-bit representation */
+ p->nargs = (i >> 6) & 0x03; /* 7-6 bits */
+ p->nrest = (i >> 5) & 0x01; /* 5 bit */
+ p->nlocs = (i >> 2) & 0x07; /* 4-2 bits */
+ p->nexts = i & 0x03; /* 1-0 bits */
+ }
+ else
+ {
+ /* 16-bit representation */
+ p->nargs = (i >> 12) & 0x07; /* 15-12 bits */
+ p->nrest = (i >> 11) & 0x01; /* 11 bit */
+ p->nlocs = (i >> 4) & 0x7f; /* 10-04 bits */
+ p->nexts = i & 0x0f; /* 03-00 bits */
+ }
+ }
+ else
+ {
+ /* Other cases */
+ /* x is #f, and already popped off */
+ p->nargs = SCM_I_INUM (sp[-3]);
+ p->nrest = SCM_I_INUM (sp[-2]);
+ p->nlocs = SCM_I_INUM (sp[-1]);
+ p->nexts = SCM_I_INUM (sp[0]);
+ sp -= 4;
+ }
+
+ PUSH (prog);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
+{
+ SCM sym;
+ POP (sym);
+ SYNC_REGISTER ();
+ PUSH (scm_lookup (sym)); /* might longjmp */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
+{
+ SCM modname, sym;
+ POP (sym);
+ POP (modname);
+ SYNC_REGISTER ();
+ PUSH (scm_cons (modname, sym));
+ NEXT;
+}
+
+VM_DEFINE_LOADER (define, "define")
+{
+ SCM sym;
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ sym = scm_from_locale_symboln ((char *)ip, len);
+ ip += len;
+
+ SYNC_REGISTER ();
+ PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
+ NEXT;
+}
+
+VM_DEFINE_LOADER (late_bind, "late-bind")
+{
+ SCM sym;
+ size_t len;
+
+ FETCH_LENGTH (len);
+ SYNC_REGISTER ();
+ sym = scm_from_locale_symboln ((char *)ip, len);
+ ip += len;
+
+ PUSH (sym);
+ NEXT;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
new file mode 100644
index 000000000..e1c0dbdb3
--- /dev/null
+++ b/libguile/vm-i-scheme.c
@@ -0,0 +1,283 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+/* This file is included in vm_engine.c */
+
+
+/*
+ * Predicates
+ */
+
+VM_DEFINE_FUNCTION (not, "not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_not, "not-not", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (eq, "eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
+{
+ ARGS2 (x, y);
+ RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (nullp, "null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_EQ_P (x, y))
+ RETURN (SCM_BOOL_T);
+ if (SCM_IMP (x) || SCM_IMP (y))
+ RETURN (SCM_BOOL_F);
+ SYNC_REGISTER ();
+ RETURN (scm_eqv_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (equal, "equal?", 2)
+{
+ ARGS2 (x, y);
+ if (SCM_EQ_P (x, y))
+ RETURN (SCM_BOOL_T);
+ if (SCM_IMP (x) || SCM_IMP (y))
+ RETURN (SCM_BOOL_F);
+ SYNC_REGISTER ();
+ RETURN (scm_equal_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (pairp, "pair?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (SCM_CONSP (x)));
+}
+
+VM_DEFINE_FUNCTION (listp, "list?", 1)
+{
+ ARGS1 (x);
+ RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+}
+
+
+/*
+ * Basic data
+ */
+
+VM_DEFINE_FUNCTION (cons, "cons", 2)
+{
+ ARGS2 (x, y);
+ CONS (x, x, y);
+ RETURN (x);
+}
+
+VM_DEFINE_FUNCTION (car, "car", 1)
+{
+ ARGS1 (x);
+ SCM_VALIDATE_CONS (1, x);
+ RETURN (SCM_CAR (x));
+}
+
+VM_DEFINE_FUNCTION (cdr, "cdr", 1)
+{
+ ARGS1 (x);
+ SCM_VALIDATE_CONS (1, x);
+ RETURN (SCM_CDR (x));
+}
+
+VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
+{
+ ARGS2 (x, y);
+ SCM_VALIDATE_CONS (1, x);
+ SCM_SETCAR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
+{
+ ARGS2 (x, y);
+ SCM_VALIDATE_CONS (1, x);
+ SCM_SETCDR (x, y);
+ RETURN (SCM_UNSPECIFIED);
+}
+
+
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel) \
+{ \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \
+ SYNC_REGISTER (); \
+ RETURN (srel (x, y)); \
+}
+
+VM_DEFINE_FUNCTION (ee, "ee?", 2)
+{
+ REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (lt, "lt?", 2)
+{
+ REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (le, "le?", 2)
+{
+ REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (gt, "gt?", 2)
+{
+ REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (ge, "ge?", 2)
+{
+ REL (>=, scm_geq_p);
+}
+
+
+/*
+ * Numeric functions
+ */
+
+#undef FUNC1
+#define FUNC1(CEXP,SEXP) \
+{ \
+ ARGS1 (x); \
+ if (SCM_I_INUMP (x)) \
+ { \
+ int n = CEXP; \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_I_MAKINUM (n)); \
+ } \
+ SYNC_REGISTER (); \
+ RETURN (SEXP); \
+}
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC) \
+{ \
+ ARGS2 (x, y); \
+ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
+ { \
+ int n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y); \
+ if (SCM_FIXABLE (n)) \
+ RETURN (SCM_I_MAKINUM (n)); \
+ } \
+ SYNC_REGISTER (); \
+ RETURN (SFUNC (x, y)); \
+}
+
+VM_DEFINE_FUNCTION (add, "add", 2)
+{
+ FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (sub, "sub", 2)
+{
+ FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (mul, "mul", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (div, "div", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (quo, "quo", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (rem, "rem", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (mod, "mod", 2)
+{
+ ARGS2 (x, y);
+ SYNC_REGISTER ();
+ RETURN (scm_modulo (x, y));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
new file mode 100644
index 000000000..353b3b8a2
--- /dev/null
+++ b/libguile/vm-i-system.c
@@ -0,0 +1,672 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+/* This file is included in vm_engine.c */
+
+
+/*
+ * Basic operations
+ */
+
+/* This must be the first instruction! */
+VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
+{
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
+{
+ SCM ret;
+ vp->time += scm_c_get_internal_run_time () - start_time;
+ HALT_HOOK ();
+ POP (ret);
+ FREE_FRAME ();
+ SYNC_ALL ();
+ vp->ip = NULL;
+ scm_dynwind_end ();
+ return ret;
+}
+
+VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
+{
+ BREAK_HOOK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
+{
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+{
+ PUSH (SCM_UNDEFINED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
+{
+ SCM x = *sp;
+ PUSH (x);
+ NEXT;
+}
+
+
+/*
+ * Object creation
+ */
+
+VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
+{
+ PUSH (SCM_UNSPECIFIED);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_T);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
+{
+ PUSH (SCM_BOOL_F);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
+{
+ PUSH (SCM_EOL);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
+{
+ PUSH (SCM_INUM0);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
+{
+ PUSH (SCM_I_MAKINUM (1));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
+{
+ PUSH (SCM_MAKE_CHAR (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ unsigned len = ((h << 8) + l);
+ POP_LIST (len);
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+{
+ POP_LIST_MARK ();
+ *sp = scm_vector (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+{
+ SCM l;
+ POP (l);
+ for (; !SCM_NULLP (l); l = SCM_CDR (l))
+ PUSH (SCM_CAR (l));
+ NEXT;
+}
+
+
+/*
+ * Variable access
+ */
+
+#define OBJECT_REF(i) objects[i]
+#define OBJECT_SET(i,o) objects[i] = o
+
+#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i)
+#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o
+
+/* For the variable operations, we _must_ obviously avoid function calls to
+ `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
+ nothing more than the corresponding macros. */
+#define VARIABLE_REF(v) SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
+
+/* ref */
+
+VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
+{
+ register unsigned objnum = FETCH ();
+ CHECK_OBJECT (objnum);
+ PUSH (OBJECT_REF (objnum));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
+{
+ PUSH (LOCAL_REF (FETCH ()));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
+{
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
+ PUSH (SCM_CAR (e));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
+{
+ SCM x = *sp;
+
+ if (!VARIABLE_BOUNDP (x))
+ {
+ err_args = SCM_LIST1 (x);
+ /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
+ goto vm_error_unbound;
+ }
+ else
+ {
+ SCM o = VARIABLE_REF (x);
+ *sp = o;
+ }
+
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
+{
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
+ CHECK_OBJECT (objnum);
+ pair_or_var = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (pair_or_var))
+ {
+ SYNC_REGISTER ();
+ /* either one of these calls might longjmp */
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
+ if (!VARIABLE_BOUNDP (pair_or_var))
+ {
+ err_args = SCM_LIST1 (pair_or_var);
+ goto vm_error_unbound;
+ }
+ }
+
+ PUSH (VARIABLE_REF (pair_or_var));
+ NEXT;
+}
+
+/* set */
+
+VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
+{
+ LOCAL_SET (FETCH (), *sp);
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
+{
+ unsigned int i;
+ SCM e = external;
+ for (i = FETCH (); i; i--)
+ {
+ CHECK_EXTERNAL(e);
+ e = SCM_CDR (e);
+ }
+ CHECK_EXTERNAL(e);
+ SCM_SETCAR (e, *sp);
+ DROP ();
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
+{
+ VARIABLE_SET (sp[0], sp[-1]);
+ sp -= 2;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
+{
+ unsigned objnum = FETCH ();
+ SCM pair_or_var;
+ CHECK_OBJECT (objnum);
+ pair_or_var = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (pair_or_var))
+ {
+ SYNC_BEFORE_GC ();
+ SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+ /* module_lookup might longjmp */
+ pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+ OBJECT_SET (objnum, pair_or_var);
+ }
+
+ VARIABLE_SET (pair_or_var, *sp);
+ DROP ();
+ NEXT;
+}
+
+
+/*
+ * branch and jump
+ */
+
+#define BR(p) \
+{ \
+ int h = FETCH (); \
+ int l = FETCH (); \
+ signed short offset = (h << 8) + l; \
+ if (p) \
+ ip += offset; \
+ DROP (); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+{
+ int h = FETCH ();
+ int l = FETCH ();
+ ip += (signed short) (h << 8) + l;
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
+{
+ BR (!SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
+{
+ BR (SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
+{
+ BR (SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+{
+ BR (!SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
+{
+ BR (SCM_NULLP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
+{
+ BR (!SCM_NULLP (*sp));
+}
+
+
+/*
+ * Subprogram call
+ */
+
+VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
+{
+ SYNC_BEFORE_GC ();
+ *sp = scm_c_make_closure (*sp, external);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
+{
+ SCM x;
+ nargs = FETCH ();
+
+ vm_call:
+ x = sp[-nargs];
+
+ /*
+ * Subprogram call
+ */
+ if (SCM_PROGRAM_P (x))
+ {
+ program = x;
+ vm_call_program:
+ CACHE_PROGRAM ();
+ INIT_ARGS ();
+ NEW_FRAME ();
+ ENTER_HOOK ();
+ APPLY_HOOK ();
+ NEXT;
+ }
+#ifdef ENABLE_TRAMPOLINE
+ /* Seems to slow down the fibo test, dunno why */
+ /*
+ * Subr call
+ */
+ switch (nargs)
+ {
+ case 0:
+ {
+ scm_t_trampoline_0 call = scm_trampoline_0 (x);
+ if (call)
+ {
+ SYNC_ALL ();
+ *sp = call (x);
+ NEXT;
+ }
+ break;
+ }
+ case 1:
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (x);
+ if (call)
+ {
+ SCM arg1;
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1);
+ NEXT;
+ }
+ break;
+ }
+ case 2:
+ {
+ scm_t_trampoline_2 call = scm_trampoline_2 (x);
+ if (call)
+ {
+ SCM arg1, arg2;
+ POP (arg2);
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1, arg2);
+ NEXT;
+ }
+ break;
+ }
+ }
+#endif
+ /*
+ * Other interpreted or compiled call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (x)))
+ {
+ /* At this point, the stack contains the procedure and each one of its
+ arguments. */
+ SCM args;
+ POP_LIST (nargs);
+ POP (args);
+ SYNC_REGISTER ();
+ *sp = scm_apply (x, args, SCM_EOL);
+ NEXT;
+ }
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (x))
+ {
+ program = x;
+ vm_call_cc:
+ /* Check the number of arguments */
+ if (nargs != 1)
+ scm_wrong_num_args (program);
+
+ /* Reinstate the continuation */
+ EXIT_HOOK ();
+ reinstate_vm_cont (vp, program);
+ CACHE_REGISTER ();
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ NEXT;
+ }
+
+ program = x;
+ goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
+{
+ register SCM x;
+ nargs = FETCH ();
+ x = sp[-nargs];
+
+ SCM_TICK; /* allow interrupt here */
+
+ /*
+ * Tail recursive call
+ */
+ if (SCM_EQ_P (x, program))
+ {
+ int i;
+
+ /* Move arguments */
+ INIT_ARGS ();
+ sp -= bp->nargs - 1;
+ for (i = 0; i < bp->nargs; i++)
+ LOCAL_SET (i, sp[i]);
+
+ /* Drop the first argument and the program itself. */
+ sp -= 2;
+
+ /* Call itself */
+ ip = bp->base;
+ APPLY_HOOK ();
+ NEXT;
+ }
+ /*
+ * Proper tail call
+ */
+ if (SCM_PROGRAM_P (x))
+ {
+ EXIT_HOOK ();
+ FREE_FRAME ();
+ program = x;
+ goto vm_call_program;
+ }
+#ifdef ENABLE_TRAMPOLINE
+ /* This seems to actually slow down the fibo test -- dunno why */
+ /*
+ * Subr call
+ */
+ switch (nargs)
+ {
+ case 0:
+ {
+ scm_t_trampoline_0 call = scm_trampoline_0 (x);
+ if (call)
+ {
+ SYNC_ALL ();
+ *sp = call (x);
+ goto vm_return;
+ }
+ break;
+ }
+ case 1:
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (x);
+ if (call)
+ {
+ SCM arg1;
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1);
+ goto vm_return;
+ }
+ break;
+ }
+ case 2:
+ {
+ scm_t_trampoline_2 call = scm_trampoline_2 (x);
+ if (call)
+ {
+ SCM arg1, arg2;
+ POP (arg2);
+ POP (arg1);
+ SYNC_ALL ();
+ *sp = call (x, arg1, arg2);
+ goto vm_return;
+ }
+ break;
+ }
+ }
+#endif
+
+ /*
+ * Other interpreted or compiled call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (x)))
+ {
+ SCM args;
+ POP_LIST (nargs);
+ POP (args);
+ SYNC_REGISTER ();
+ *sp = scm_apply (x, args, SCM_EOL);
+ goto vm_return;
+ }
+
+ program = x;
+
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (program))
+ goto vm_call_cc;
+
+ goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
+{
+ int len;
+ SCM ls;
+ POP (ls);
+
+ nargs = FETCH ();
+ if (nargs < 2)
+ goto vm_error_wrong_num_args;
+
+ len = scm_ilength (ls);
+ if (len < 0)
+ goto vm_error_wrong_type_arg;
+
+ for (; !SCM_NULLP (ls); ls = SCM_CDR (ls))
+ PUSH (SCM_CAR (ls));
+
+ nargs += len - 2;
+ goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
+{
+ SYNC_BEFORE_GC ();
+ PUSH (capture_vm_cont (vp));
+ POP (program);
+ nargs = 1;
+ goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
+{
+ vm_return:
+ EXIT_HOOK ();
+ RETURN_HOOK ();
+ FREE_FRAME ();
+
+ /* Restore the last program */
+ program = SCM_FRAME_PROGRAM (fp);
+ CACHE_PROGRAM ();
+ CACHE_EXTERNAL ();
+ CHECK_IP ();
+ NEXT;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm.c b/libguile/vm.c
new file mode 100644
index 000000000..5ec7d9291
--- /dev/null
+++ b/libguile/vm.c
@@ -0,0 +1,680 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
+#include "vm.h"
+
+/* I sometimes use this for debugging. */
+#define vm_puts(OBJ) \
+{ \
+ scm_display (OBJ, scm_current_error_port ()); \
+ scm_newline (scm_current_error_port ()); \
+}
+
+
+/*
+ * VM Continuation
+ */
+
+scm_t_bits scm_tc16_vm_cont;
+
+
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_VP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+
+static SCM
+capture_vm_cont (struct scm_vm *vp)
+{
+ struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = vp->stack_limit - vp->sp;
+ p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+ "capture_vm_cont");
+ p->stack_limit = p->stack_base + p->stack_size - 2;
+ p->ip = vp->ip;
+ p->sp = (SCM *) (vp->stack_limit - vp->sp);
+ p->fp = (SCM *) (vp->stack_limit - vp->fp);
+ memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
+ SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+}
+
+static void
+reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+{
+ struct scm_vm *p = SCM_VM_CONT_VP (cont);
+ if (vp->stack_size < p->stack_size)
+ {
+ /* puts ("FIXME: Need to expand"); */
+ abort ();
+ }
+ vp->ip = p->ip;
+ vp->sp = vp->stack_limit - (int) p->sp;
+ vp->fp = vp->stack_limit - (int) p->fp;
+ memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+struct vm_unwind_data
+{
+ struct scm_vm *vp;
+ SCM *sp;
+ SCM *fp;
+ SCM this_frame;
+};
+
+static void
+vm_reset_stack (void *data)
+{
+ struct vm_unwind_data *w = data;
+
+ w->vp->sp = w->sp;
+ w->vp->fp = w->fp;
+ w->vp->this_frame = w->this_frame;
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+ SCM *p;
+ struct scm_vm *vp = SCM_VM_CONT_VP (obj);
+ for (p = vp->stack_base; p <= vp->stack_limit; p++)
+ if (SCM_NIMP (*p))
+ scm_gc_mark (*p);
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+vm_cont_free (SCM obj)
+{
+ struct scm_vm *p = SCM_VM_CONT_VP (obj);
+
+ scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
+ scm_gc_free (p, sizeof (struct scm_vm), "vm");
+
+ return 0;
+}
+
+
+/*
+ * VM Internal functions
+ */
+
+SCM_SYMBOL (sym_vm_run, "vm-run");
+SCM_SYMBOL (sym_vm_error, "vm-error");
+
+static scm_byte_t *
+vm_fetch_length (scm_byte_t *ip, size_t *lenp)
+{
+ /* NOTE: format defined in system/vm/conv.scm */
+ *lenp = *ip++;
+ if (*lenp < 254)
+ return ip;
+ else if (*lenp == 254)
+ {
+ int b1 = *ip++;
+ int b2 = *ip++;
+ *lenp = (b1 << 8) + b2;
+ }
+ else
+ {
+ int b1 = *ip++;
+ int b2 = *ip++;
+ int b3 = *ip++;
+ int b4 = *ip++;
+ *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
+ }
+ return ip;
+}
+
+static SCM
+vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
+{
+ SCM frame;
+ SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
+#if 0
+ SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
+#endif
+ SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
+
+ if (!dl)
+ {
+ /* The top frame */
+ frame = scm_c_make_heap_frame (fp);
+ fp = SCM_HEAP_FRAME_POINTER (frame);
+ SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
+ }
+ else
+ {
+ /* Child frames */
+ SCM link = SCM_FRAME_HEAP_LINK (dl);
+ if (!SCM_FALSEP (link))
+ link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
+ else
+ link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
+ frame = scm_c_make_heap_frame (fp);
+ fp = SCM_HEAP_FRAME_POINTER (frame);
+ SCM_FRAME_HEAP_LINK (fp) = link;
+ SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
+ }
+
+ /* Apparently the intention here is to be able to have a frame on the heap,
+ but data on the stack, so that you can push as much as you want on the
+ stack; but I think that it's currently causing borkage with nonlocal exits
+ and the unwind handler, which reinstates the sp and fp, but it's no longer
+ pointing at a valid stack frame. So disable for now, we'll get back to
+ this later. */
+#if 0
+ /* Move stack data */
+ for (; src <= sp; src++, dest++)
+ *dest = *src;
+ *destp = dest;
+#endif
+
+ return frame;
+}
+
+static SCM
+vm_heapify_frames (SCM vm)
+{
+ struct scm_vm *vp = SCM_VM_DATA (vm);
+ if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
+ {
+ SCM *dest;
+ vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+ vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
+ vp->sp = dest - 1;
+ }
+ return vp->this_frame;
+}
+
+
+/*
+ * VM
+ */
+
+#define VM_DEFAULT_STACK_SIZE (16 * 1024)
+
+#define VM_REGULAR_ENGINE 0
+#define VM_DEBUG_ENGINE 1
+
+#if 0
+#define VM_NAME vm_regular_engine
+#define VM_ENGINE VM_REGULAR_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+#endif
+
+#define VM_NAME vm_debug_engine
+#define VM_ENGINE VM_DEBUG_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+
+scm_t_bits scm_tc16_vm;
+
+static SCM the_vm;
+
+static SCM
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+ int i;
+ struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
+ vp->stack_size = VM_DEFAULT_STACK_SIZE;
+ vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM),
+ "stack-base");
+ vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+ vp->ip = NULL;
+ vp->sp = vp->stack_base - 1;
+ vp->fp = NULL;
+ vp->time = 0;
+ vp->clock = 0;
+ vp->options = SCM_EOL;
+ vp->this_frame = SCM_BOOL_F;
+ vp->last_frame = SCM_BOOL_F;
+ vp->last_ip = NULL;
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ vp->hooks[i] = SCM_BOOL_F;
+ SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+}
+#undef FUNC_NAME
+
+static SCM
+vm_mark (SCM obj)
+{
+ int i;
+ struct scm_vm *vp = SCM_VM_DATA (obj);
+
+ /* mark the stack conservatively */
+ scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
+ sizeof (SCM) * (vp->sp - vp->stack_base + 1));
+
+ /* mark other objects */
+ for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+ scm_gc_mark (vp->hooks[i]);
+ scm_gc_mark (vp->this_frame);
+ scm_gc_mark (vp->last_frame);
+ return vp->options;
+}
+
+static scm_sizet
+vm_free (SCM obj)
+{
+ struct scm_vm *vp = SCM_VM_DATA (obj);
+
+ scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
+ "stack-base");
+ scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+ return 0;
+}
+
+SCM_SYMBOL (sym_debug, "debug");
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return vm_run (vm, program, args);
+}
+#undef FUNC_NAME
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_vm_version
+{
+ return scm_from_locale_string (PACKAGE_VERSION);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_the_vm
+{
+ return the_vm;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
+ (SCM obj),
+ "")
+#define FUNC_NAME s_scm_vm_p
+{
+ return SCM_BOOL (SCM_VM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_make_vm,
+{
+ return make_vm ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_ip
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_sp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fp
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+#define VM_DEFINE_HOOK(n) \
+{ \
+ struct scm_vm *vp; \
+ SCM_VALIDATE_VM (1, vm); \
+ vp = SCM_VM_DATA (vm); \
+ if (SCM_FALSEP (vp->hooks[n])) \
+ vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \
+ return vp->hooks[n]; \
+}
+
+SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_boot_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_halt_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_next_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_break_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_enter_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_apply_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_exit_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_return_hook
+{
+ VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
+ (SCM vm, SCM key),
+ "")
+#define FUNC_NAME s_scm_vm_option
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
+ (SCM vm, SCM key, SCM val),
+ "")
+#define FUNC_NAME s_scm_set_vm_option_x
+{
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VM_DATA (vm)->options
+ = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_stats
+{
+ SCM stats;
+
+ SCM_VALIDATE_VM (1, vm);
+
+ stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
+ scm_vector_set_x (stats, SCM_I_MAKINUM (0),
+ scm_from_ulong (SCM_VM_DATA (vm)->time));
+ scm_vector_set_x (stats, SCM_I_MAKINUM (1),
+ scm_from_ulong (SCM_VM_DATA (vm)->clock));
+
+ return stats;
+}
+#undef FUNC_NAME
+
+#define VM_CHECK_RUNNING(vm) \
+ if (!SCM_VM_DATA (vm)->ip) \
+ SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
+
+SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_this_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->this_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_last_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->last_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_ip, "vm:last-ip", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_last_ip
+{
+ SCM_VALIDATE_VM (1, vm);
+ return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->last_ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_save_stack, "vm-save-stack", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_save_stack
+{
+ struct scm_vm *vp;
+ SCM *dest;
+ SCM_VALIDATE_VM (1, vm);
+ vp = SCM_VM_DATA (vm);
+
+ if (vp->fp)
+ {
+ vp->last_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+ vp->last_ip = vp->ip;
+ }
+ else
+ {
+ vp->last_frame = SCM_BOOL_F;
+ }
+
+
+ return vp->last_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_code
+{
+ int i;
+ SCM list;
+ scm_byte_t *ip;
+ struct scm_instruction *p;
+
+ SCM_VALIDATE_VM (1, vm);
+ VM_CHECK_RUNNING (vm);
+
+ ip = SCM_VM_DATA (vm)->ip;
+ p = SCM_INSTRUCTION (*ip);
+
+ list = SCM_LIST1 (scm_str2symbol (p->name));
+ for (i = 1; i <= p->len; i++)
+ list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
+ (SCM vm),
+ "")
+#define FUNC_NAME s_scm_vm_fetch_stack
+{
+ SCM *sp;
+ SCM ls = SCM_EOL;
+ struct scm_vm *vp;
+
+ SCM_VALIDATE_VM (1, vm);
+ VM_CHECK_RUNNING (vm);
+
+ vp = SCM_VM_DATA (vm);
+ for (sp = vp->stack_base; sp <= vp->sp; sp++)
+ ls = scm_cons (*sp, ls);
+ return ls;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Initialize
+ */
+
+SCM scm_load_compiled_with_vm (SCM file)
+{
+ SCM program = scm_objcode_to_program (scm_load_objcode (file));
+
+ return vm_run (the_vm, program, SCM_EOL);
+}
+
+void
+scm_bootstrap_vm (void)
+{
+ static int strappage = 0;
+
+ if (strappage)
+ return;
+
+ scm_bootstrap_frames ();
+ scm_bootstrap_instructions ();
+ scm_bootstrap_objcodes ();
+ scm_bootstrap_programs ();
+
+ scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
+ scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
+ scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
+
+ scm_tc16_vm = scm_make_smob_type ("vm", 0);
+ scm_set_smob_mark (scm_tc16_vm, vm_mark);
+ scm_set_smob_free (scm_tc16_vm, vm_free);
+ scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
+
+ the_vm = scm_permanent_object (make_vm ());
+
+ scm_c_define ("load-compiled",
+ scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+ scm_load_compiled_with_vm));
+
+ strappage = 1;
+}
+
+void
+scm_init_vm (void)
+{
+ scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "vm.x"
+#endif
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/vm.h b/libguile/vm.h
new file mode 100644
index 000000000..af4c81588
--- /dev/null
+++ b/libguile/vm.h
@@ -0,0 +1,117 @@
+/* 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.
+ *
+ * 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 exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * 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. */
+
+#ifndef _SCM_VM_H_
+#define _SCM_VM_H_
+
+#include <libguile.h>
+
+#define SCM_VM_BOOT_HOOK 0
+#define SCM_VM_HALT_HOOK 1
+#define SCM_VM_NEXT_HOOK 2
+#define SCM_VM_BREAK_HOOK 3
+#define SCM_VM_ENTER_HOOK 4
+#define SCM_VM_APPLY_HOOK 5
+#define SCM_VM_EXIT_HOOK 6
+#define SCM_VM_RETURN_HOOK 7
+#define SCM_VM_NUM_HOOKS 8
+
+struct scm_vm {
+ scm_byte_t *ip; /* instruction pointer */
+ SCM *sp; /* stack pointer */
+ SCM *fp; /* frame pointer */
+ size_t stack_size; /* stack size */
+ SCM *stack_base; /* stack base address */
+ SCM *stack_limit; /* stack limit address */
+ SCM this_frame; /* currrent frame */
+ SCM last_frame; /* last frame */
+ scm_byte_t *last_ip; /* ip when exception occured */
+ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */
+ SCM options; /* options */
+ unsigned long time; /* time spent */
+ unsigned long clock; /* bogos clock */
+};
+
+#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
+
+extern SCM scm_the_vm ();
+extern SCM scm_make_vm (void);
+extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+extern SCM scm_vm_option_ref (SCM vm, SCM key);
+extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+extern SCM scm_vm_version (void);
+extern SCM scm_the_vm (void);
+extern SCM scm_vm_p (SCM obj);
+extern SCM scm_vm_ip (SCM vm);
+extern SCM scm_vm_sp (SCM vm);
+extern SCM scm_vm_fp (SCM vm);
+extern SCM scm_vm_boot_hook (SCM vm);
+extern SCM scm_vm_halt_hook (SCM vm);
+extern SCM scm_vm_next_hook (SCM vm);
+extern SCM scm_vm_break_hook (SCM vm);
+extern SCM scm_vm_enter_hook (SCM vm);
+extern SCM scm_vm_apply_hook (SCM vm);
+extern SCM scm_vm_exit_hook (SCM vm);
+extern SCM scm_vm_return_hook (SCM vm);
+extern SCM scm_vm_option (SCM vm, SCM key);
+extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+extern SCM scm_vm_stats (SCM vm);
+extern SCM scm_vm_this_frame (SCM vm);
+extern SCM scm_vm_last_frame (SCM vm);
+extern SCM scm_vm_last_ip (SCM vm);
+extern SCM scm_vm_save_stack (SCM vm);
+extern SCM scm_vm_fetch_code (SCM vm);
+extern SCM scm_vm_fetch_stack (SCM vm);
+
+extern SCM scm_load_compiled_with_vm (SCM file);
+
+extern void scm_init_vm (void);
+
+#endif /* _SCM_VM_H_ */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/