--- /dev/null
+Keisuke Nishida <kxn30@po.cwru.edu>
--- /dev/null
+2000-08-20 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Version 0.2 is released.
+
+2000-08-12 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Version 0.1 is released.
+
+2000-07-29 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Version 0.0 is released.
+
--- /dev/null
+SUBDIRS = src vm doc test
+
+EXTRA_DIST = acconfig.h
+
+MAINTAINERCLEANFILES = COPYING INSTALL config.guess config.sub ltconfig \
+ ltmain.sh Makefile.in aclocal.m4 config.h.in stamp-h.in \
+ configure missing mkinstalldirs install-sh texinfo.tex
--- /dev/null
+Guile VM is motivated by QScheme.
--- /dev/null
+/* Define if compiler supports gcc's "labels as values" (aka computed goto)
+ * feature (which is used to speed up instruction dispatch in the interpreter).
+ */
+#undef HAVE_LABELS_AS_VALUES
--- /dev/null
+dnl check for gcc's "labels as values" feature
+AC_DEFUN(AC_C_LABELS_AS_VALUES,
+[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values,
+[AC_TRY_COMPILE([
+int foo(int);
+int foo(i)
+int i; {
+static void *label[] = { &&l1, &&l2 };
+goto *label[i];
+l1: return 1;
+l2: return 2;
+}
+],
+[int i;],
+ac_cv_labels_as_values=yes,
+ac_cv_labels_as_values=no)])
+if test "$ac_cv_labels_as_values" = yes; then
+AC_DEFINE(HAVE_LABELS_AS_VALUES)
+fi
+])
--- /dev/null
+#!/bin/sh
+
+aclocal
+autoheader
+automake -a
+autoconf
--- /dev/null
+AC_INIT(src/guile-vm.c)
+AM_INIT_AUTOMAKE(guile-vm, 0.2)
+AM_CONFIG_HEADER(src/config.h)
+
+GUILE_FLAGS
+if test "`guile -c '(display (string>=? (version) "1.4.1"))'`" != "#t"; then
+ AC_MSG_ERROR([Your Guile is too old. You need guile-1.4.1 or later.])
+fi
+
+AC_PROG_CC
+AC_PROG_LN_S
+AM_PROG_LIBTOOL
+AC_C_LABELS_AS_VALUES
+
+AC_OUTPUT(Makefile src/Makefile vm/Makefile doc/Makefile test/Makefile)
--- /dev/null
+EXTRA_DIST = vm-spec.txt
+MAINTAINERCLEANFILES = Makefile.in
--- /dev/null
+From: Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+Subject: Re: After GOOPS integration: Computation with native types!
+To: Keisuke Nishida <kxn30@po.cwru.edu>
+Cc: djurfeldt@nada.kth.se, guile@sourceware.cygnus.com
+Cc: djurfeldt@nada.kth.se
+Date: 17 Aug 2000 03:01:13 +0200
+
+Keisuke Nishida <kxn30@po.cwru.edu> writes:
+
+> Do I need to include some special feature in my VM? Hmm, but maybe
+> I shouldn't do that now...
+
+Probably not, so I probably shouldn't answer, but... :)
+
+You'll need to include some extremely efficient mechanism to do
+multi-method dispatch. The SCM_IM_DISPATCH form, with its
+implementation at line 2250 in eval.c, is the current basis for
+efficient dispatch in GOOPS.
+
+I think we should develop a new instruction for the VM which
+corresponds to the SCM_IM_DISPATCH form.
+
+This form serves both the purpose to map argument types to the correct
+code, and as a cache of compiled methods.
+
+Notice that I talk about cmethods below, not methods. In GOOPS, the
+GF has a set of methods, but each method has a "code-table" mapping
+argument types to code compiled for those particular concrete types.
+(So, in essence, GOOPS methods abstractly do a deeper level of type
+dispatch.)
+
+The SCM_IM_DISPATCH form has two shapes, depending on whether we use
+sequential search (few cmethods) or hashed lookup (many cmethods).
+
+Shape 1:
+
+ (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
+
+Shape 2:
+
+ (#@dispatch args N-SPECIALIZED HASHSET MASK
+ #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
+ GF)
+
+`args' is (I hope!) a now historic obscure optimization.
+
+N-SPECIALIZED is the maximum number of arguments t do type checking
+on. This is used early termination of argument checking where the
+already checked arguments are enough to pick out the cmethod.
+
+The vector is the cache proper.
+
+During sequential search the argument types are simply checked against
+each entry.
+
+The method for hashed dispatch is described in:
+
+http://www.parc.xerox.com/csl/groups/sda/publications/papers/Kiczales-Andreas-PCL
+
+In this method, each class has a hash code. Dispatch means summing
+the hash codes for all arguments (up til N-SPECIALIZED) and using the
+sum to pick a location in the cache. The cache is sequentially
+searched for an argument type match from that point.
+
+Kiczales introduced a clever method to maximize the probability of a
+direct cache hit. We actually have 8 separate sets of hash codes for
+all types. The hash set to use is selected specifically per GF and is
+optimized to give fastest average hit.
+
+
+What we could try to do as soon as the VM is complete enough is to
+represent the cmethods as chunks of byte code. In the current GOOPS
+code, the compilation step (which is currently empty) is situated in
+`compile-cmethod' in guile-oops/compile.scm. [Apologies for the
+terrible code. That particular part was written at Arlanda airport
+after a sleepless night (packing luggage, not coding), on my way to
+visit Marius (who, BTW, didn't take GOOPS seriously. ;-)]
+
--- /dev/null
+Guile VM Specification -*- outline -*-
+======================
+Updated: $Date: 2000/08/22 15:54:19 $
+
+* Introduction
+
+A Guile VM has a set of registers and its own stack memory. Guile may
+have more than one VM's. Each VM may execute at most one program at a
+time. Guile VM is a CISC system so designed as to execute Scheme and
+other languages efficiently.
+
+** Registers
+
+ pc - Program counter ;; ip (instruction poiner) is better?
+ sp - Stack pointer
+ bp - Base pointer
+ ac - Accumulator
+
+** Engine
+
+A VM may have one of three engines: reckless, regular, or debugging.
+Reckless engine is fastest but dangerous. Regular engine is normally
+fail-safe and reasonably fast. Debugging engine is safest and
+functional but very slow.
+
+** Memory
+
+Stack is the only memory that each VM owns. The other memory is shared
+memory that is shared among every VM and other part of Guile.
+
+** Program
+
+A VM program consists of a bytecode that is executed and an environment
+in which execution is done. Each program is allocated in the shared
+memory and may be executed by any VM. A program may call other programs
+within a VM.
+
+** Instruction
+
+Guile VM has dozens of system instructions and (possibly) hundreds of
+functional instructions. Some Scheme procedures such as cons and car
+are implemented as VM's builtin functions, which are very efficient.
+Other procedures defined outside of the VM are also considered as VM's
+functional features, since they do not change the state of VM.
+Procedures defined within the VM are called subprograms.
+
+Most instructions deal with the accumulator (ac). The VM stores all
+results from functions in ac, instead of pushing them into the stack.
+I'm not sure whether this is a good thing or not.
+
+* Variable Management
+
+A program may have access to local variables, external variables, and
+top-level variables.
+
+** Local/external variables
+
+A stack is logically divided into several blocks during execution. A
+"block" is such a unit that maintains local variables and dynamic chain.
+A "frame" is an upper level unit that maintains subprogram calls.
+
+ Stack
+ dynamic | | | |
+ chain +==========+ - =
+ | |local vars| | |
+ `-|block data| | block |
+ /|frame data| | |
+ | +----------+ - |
+ | |local vars| | | frame
+ `-|block data| | |
+ /+----------+ - |
+ | |local vars| | |
+ `-|block data| | |
+ /+==========+ - =
+ | |local vars| | |
+ `-|block data| | |
+ /|frame data| | |
+ | +----------+ - |
+ | | | | |
+
+The first block of each frame may look like this:
+
+ Address Data
+ ------- ----
+ xxx0028 Local variable 2
+ xxx0024 Local variable 1
+ bp ->xxx0020 Local variable 0
+ xxx001c Local link (block data)
+ xxx0018 External link (block data)
+ xxx0014 Stack pointer (block data)
+ xxx0010 Return address (frame data)
+ xxx000c Parent program (frame data)
+
+The base pointer (bp) always points to the lowest address of local
+variables of the recent block. Local variables are referred as "bp[n]".
+The local link field has a pointer to the dynamic parent of the block.
+The parent's variables are referred as "bp[-1][n]", and grandparent's
+are "bp[-1][-1][n]". Thus, any local variable is represented by its
+depth and offset from the current bp.
+
+A variable may be "external", which is allocated in the shared memory.
+The external link field of a block has a pointer to such a variable set,
+which I call "fragment" (what should I call?). A fragment has a set of
+variables and its own chain.
+
+ local external
+ chain| | chain
+ | +-----+ .--------, |
+ `-|block|--+->|fragment|-'
+ /+-----+ | `--------'\,
+ `-|block|--' |
+ /+-----+ .--------, |
+ `-|block|---->|fragment|-'
+ +-----+ `--------'
+ | |
+
+An external variable is referred as "bp[-2]->variables[n]" or
+"bp[-2]->link->...->variables[n]". This is also represented by a pair
+of depth and offset. At any point of execution, the value of bp
+determines the current local link and external link, and thus the
+current environment of a program.
+
+Other data fields are described later.
+
+** Top-level variables
+
+Guile VM uses the same top-level variables as the regular Guile. A
+program may have direct access to vcells. Currently this is done by
+calling scm_intern0, but a program is possible to have any top-level
+environment defined by the current module.
+
+*** Scheme and VM variable
+
+Let's think about the following Scheme code as an example:
+
+ (define (foo a)
+ (lambda (b) (list foo a b)))
+
+In the lambda expression, "foo" is a top-level variable, "a" is an
+external variable, and "b" is a local variable.
+
+When a VM executes foo, it allocates a block for "a". Since "a" may be
+externally referred from the closure, the VM creates a fragment with a
+copy of "a" in it. When the VM evaluates the lambda expression, it
+creates a subprogram (closure), associating the fragment with the
+subprogram as its external environment. When the closure is executed,
+its environment will look like this:
+
+ block Top-level: foo
+ +-------------+
+ |local var: b | fragment
+ +-------------+ .-----------,
+ |external link|---->|variable: a|
+ +-------------+ `-----------'
+
+The fragment remains as long as the closure exists.
+
+** Addressing mode
+
+Guile VM has five addressing modes:
+
+ o Real address
+ o Local position
+ o External position
+ o Top-level location
+ o Immediate object
+
+Real address points to the address in the real program and is only used
+with the program counter (pc).
+
+Local position and external position are represented as a pair of depth
+and offset from bp, as described above. These are base relative
+addresses, and the real address may vary during execution.
+
+Top-level location is represented as a Guile's vcell. This location is
+determined at loading time, so the use of this address is efficient.
+
+Immediate object is not an address but gives an instruction an Scheme
+object directly.
+
+[ We'll also need dynamic scope addressing to support Emacs Lisp? ]
+
+*** At a Glance
+
+Guile VM has a set of instructions for each instruction family. `%load'
+is, for example, a family to load an object from memory and set the
+accumulator (ac). There are four basic `%load' instructions:
+
+ %loadl - Local addressing
+ %loade - External addressing
+ %loadt - Top-level addressing
+ %loadi - Immediate addressing
+
+A possible program code may look like this:
+
+ %loadl (0 . 1) ; ac = local[0][1]
+ %loade (2 . 3) ; ac = external[2][3]
+ %loadt (foo . #<undefined>) ; ac = #<undefined>
+ %loadi "hello" ; ac = "hello"
+
+One instruction that uses real addressing is `%jump', which changes the
+value of the program counter:
+
+ %jump 0x80234ab8 ; pc = 0x80234ab8
+
+* Program Execution
+
+Overall procedure:
+
+ 1. A source program is compiled into a bytecode.
+
+ 2. A bytecode is given an environment and becomes a program.
+
+ 3. A VM starts execution, creating a frame for it.
+
+ 4. Whenever a program calls a subprogram, a new frame is created for it.
+
+ 5. When a program finishes execution, it returns a value, and the VM
+ continues execution of the parent program.
+
+ 6. When all programs terminated, the VM returns the final value and stops.
+
+** Environment
+
+Local variable:
+
+ (let ((a 1) (b 2) (c 3)) (+ a b c)) ->
+
+ %pushi 1 ; a
+ %pushi 2 ; b
+ %pushi 3 ; c
+ %bind 3 ; create local bindings
+ %pushl (0 . 0) ; local variable a
+ %pushl (0 . 1) ; local variable b
+ %pushl (0 . 2) ; local variable c
+ add 3 ; ac = a + b + c
+ %unbind ; remove local bindings
+
+External variable:
+
+ (define foo (let ((n 0)) (lambda () n)))
+
+ %pushi 0 ; n
+ %bind 1 ; create local bindings
+ %export [0] ; make it an external variable
+ %make-program #<bytecode xxx> ; create a program in this environment
+ %unbind ; remove local bindings
+ %savet (foo . #<undefined>) ; save the program in foo
+
+ (foo) ->
+
+ %loadt (foo . #<program xxx>) ; program has an external link
+ %call 0 ; change the current external link
+ %loade (0 . 0) ; external variable n
+ %return ; recover the external link
+
+Top-level variable:
+
+ foo ->
+
+ %loadt (foo . #<program xxx>) ; top-level variable foo
+
+** Flow control
+
+ (if #t 1 0) ->
+
+ %loadi #t
+ %br-if-not L1
+ %loadi 1
+ %jump L2
+ L1: %loadi 0
+ L2:
+
+** Function call
+
+Builtin function:
+
+ (1+ 2) ->
+
+ %loadi 2 ; ac = 2
+ 1+ ; one argument
+
+ (+ 1 2) ->
+
+ %pushi 1 ; 1 -> stack
+ %loadi 2 ; ac = 2
+ add2 ; two argument
+
+ (+ 1 2 3) ->
+
+ %pushi 1 ; 1 -> stack
+ %pushi 2 ; 2 -> stack
+ %pushi 3 ; 3 -> stack
+ add 3 ; many argument
+
+External function:
+
+ (version) ->
+
+ %func0 (version . #<primitive-procedure version>) ; no argument
+
+ (display "hello") ->
+
+ %loadi "hello"
+ %func1 (display . #<primitive-procedure display>) ; one argument
+
+ (open-file "file" "w") ->
+
+ %pushi "file"
+ %loadi "w"
+ %func2 (open-file . #<primitive-procedure open-file>) ; two arguments
+
+ (equal 1 2 3)
+
+ %pushi 1
+ %pushi 2
+ %pushi 3
+ %loadi 3 ; the number of arguments
+ %func (equal . #<primitive-procedure equal>) ; many arguments
+
+** Subprogram call
+
+ (define (plus a b) (+ a b))
+ (plus 1 2) ->
+
+ %pushi 1 ; argument 1
+ %pushi 2 ; argument 2
+ %loadt (plus . #<program xxx>) ; load the program
+ %call 2 ; call it with two arguments
+ %pushl (0 . 0) ; argument 1
+ %loadl (0 . 1) ; argument 2
+ add2 ; ac = 1 + 2
+ %return ; result is 3
+
+* Instruction Set
+
+The Guile VM instruction set is roughly divided two groups: system
+instructions and functional instructions. System instructions control
+the execution of programs, while functional instructions provide many
+useful calculations. By convention, system instructions begin with a
+letter `%'.
+
+** Environment control instructions
+
+- %alloc
+- %bind
+- %export
+- %unbind
+
+** Subprogram control instructions
+
+- %make-program
+- %call
+- %return
+
+** Data control instructinos
+
+- %push
+- %pushi
+- %pushl, %pushl:0:0, %pushl:0:1, %pushl:0:2, %pushl:0:3
+- %pushe, %pushe:0:0, %pushe:0:1, %pushe:0:2, %pushe:0:3
+- %pusht
+
+- %loadi
+- %loadl, %loadl:0:0, %loadl:0:1, %loadl:0:2, %loadl:0:3
+- %loade, %loade:0:0, %loade:0:1, %loade:0:2, %loade:0:3
+- %loadt
+
+- %savei
+- %savel, %savel:0:0, %savel:0:1, %savel:0:2, %savel:0:3
+- %savee, %savee:0:0, %savee:0:1, %savee:0:2, %savee:0:3
+- %savet
+
+** Flow control instructions
+
+- %br-if
+- %br-if-not
+- %jump
+
+** Function call instructions
+
+- %func, %func0, %func1, %func2
+
+** Scheme buitin functions
+
+- cons
+- car
+- cdr
+
+** Mathematical buitin functions
+
+- 1+
+- 1-
+- add, add2
+- sub, sub2, minus
+- mul2
+- div2
+- lt2
+- gt2
+- le2
+- ge2
+- num-eq2
--- /dev/null
+bin_PROGRAMS = guile-vm
+guile_vm_SOURCES = guile-vm.c
+guile_vm_LDADD = libguilevm.la
+guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
+
+bin_SCRIPTS = guile-compile
+
+lib_LTLIBRARIES = libguilevm.la
+libguilevm_la_SOURCES = vm.c
+libguilevm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
+noinst_HEADERS = vm.h vm_engine.h vm-snarf.h
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_number.c \
+ test.scm guile-compile.in
+BUILT_SOURCES = vm_system.vi vm_scheme.vi vm_number.vi \
+ vm_system.op vm_scheme.op vm_number.op vm.x
+
+CFLAGS = -g -O2 -Wall
+INCLUDES = $(GUILE_CFLAGS)
+CLEANFILES = $(bin_SCRIPTS)
+DISTCLEANFILES = $(BUILT_SOURCES)
+MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in
+
+SNARF = guile-snarf
+SUFFIXES = .x .vi .op
+.c.x:
+ $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+ || { rm $@; false; }
+
+.c.vi:
+ $(SNARF) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+ || { rm $@; false; }
+
+.c.op:
+ $(SNARF) -DSCM_SNARF_OPCODE $(DEFS) $(INCLUDES) $(CPPFLAGS) \
+ $(CFLAGS) $< > $@ || { rm $@; false; }
+
+$(BUILT_SOURCES): config.h vm-snarf.h
+
+guile-compile: guile-compile.in
+ sed -e 's!\@bindir\@!$(bindir)!' -e 's!\@PACKAGE\@!$(PACKAGE)!' \
+ $< > $@
+
+test: all
+ $(bin_PROGRAMS) -s test.scm
+
+debug-test: all
+ $(bin_PROGRAMS) -s test.scm debug
--- /dev/null
+#!@bindir@/@PACKAGE@ -s
+!#
+
+(use-modules (vm compile))
+
+(for-each compile-file (cdr (command-line)))
--- /dev/null
+/* Copyright (C) 2000 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. */
+
+#include <libguile.h>
+
+extern void scm_init_vm_vm_module ();
+
+static void
+inner_main (void *closure, int argc, char **argv)
+{
+ scm_init_vm_vm_module ();
+ scm_shell (argc, argv);
+}
+
+int
+main (int argc, char **argv)
+{
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* never reached */
+}
--- /dev/null
+
+(set! %load-path (cons ".." %load-path))
+(use-modules (vm vm))
+(use-modules (vm shell))
+(use-modules (vm compile))
+(use-modules (ice-9 syncase))
+
+(define *verbose-output* (if (null? (cdr (command-line))) #f #t))
+
+(define test-list
+ '((1 1)
+ ((1- 1) 0)
+ ((+ (+ 1) (- 2)) -1)
+ ((+ (+ 1 2) (- 1 2) (* 1 2) (/ 1 2)) 4.5)
+ ((* (- 1 2 3) (+ 1.2 3.4) (/ 1 2 4)) -2.3)
+ ((let ((a 1)) a) 1)
+ ((let ((a 1) (b 2)) b) 2)
+ ((let* ((a 1) (a 2)) a) 2)
+ ((let ((a 1)) (let ((b 2)) a)) 1)
+ ((let ((a 1) (b 2) (c 3))
+ ((lambda (d e f)
+ ((lambda (g h i)
+ ((lambda () (list a b d f h i))))
+ 7 8 9))
+ 4 5 6))
+ (1 2 4 6 8 9))
+ ((do ((i 3 (1- i)) (n 0 (+ n i))) ((< i 0) n)) 6)
+ ((let () (define (foo a) a) (foo 1)) 1)
+ ((begin (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
+ (fib 3)) 2)
+ ((begin (define (loop i l) (if (< i l) (loop (+ 1 i) l) l))
+ (loop 0 3)) 3)
+; ((call-with-current-continuation (lambda (c) (c 1) 2)) 1)
+ ((map 1+ '(1 2 3)) (2 3 4))
+ ))
+
+(define (test vm form answer)
+ (format #t "Testing ~S = ~S ..." form answer)
+ (let ((result (vm-run vm (compile form))))
+ (if (equal? result answer)
+ (display "OK\n")
+ (format #t "failed: ~S\n" result))))
+
+(define (debug-test vm form answer)
+ (format #t "Testing ~S = ~S ...\n" form answer)
+ (let ((result (begin
+ (vm-set-option! vm 'verbose *verbose-output*)
+ (vm-trace vm form))))
+ (if (equal? result answer)
+ (display "OK\n")
+ (format #t "failed: ~S\n" result))))
+
+(let ((vm (make-vm)))
+ (display "=== Testing the debug engine ===\n")
+ (vm-set-option! vm 'debug #t)
+ (for-each (lambda (q) (apply debug-test vm q)) test-list)
+ (display "\n=== Testing the fast engine ===\n")
+ (vm-set-option! vm 'debug #f)
+ (for-each (lambda (q) (apply test vm q)) test-list)
+ (display "done\n"))
--- /dev/null
+/* Copyright (C) 2000 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_SNARF_H
+#define VM_SNARF_H
+
+#include "config.h"
+
+#define VM_LABEL(TAG) l_##TAG##
+#define VM_OPCODE(TAG) 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 */
+
+#ifndef SCM_MAGIC_SNARFER
+
+/*
+ * These are directly included in vm_engine.c
+ */
+#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) VM_TAG(TAG)
+#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) VM_TAG(TAG)
+
+#else /* SCM_MAGIC_SNARFER */
+#ifndef SCM_SNARF_OPCODE
+
+/*
+ * These will go to *.vi
+ */
+#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) \
+ SCM_SNARF_INIT_START {VM_OPCODE(TAG), TYPE, NAME, VM_ADDR(TAG), SCM_BOOL_F, NULL, 0, 0},
+#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) \
+ SCM_SNARF_INIT_START {VM_OPCODE(TAG), INST_NONE, NAME, VM_ADDR(TAG), SCM_BOOL_F, SNAME, NARGS, RESTP},
+
+#else /* SCM_SNARF_OPCODE */
+
+/*
+ * These will go to *.op
+ */
+#define SCM_DEFINE_INSTRUCTION(TAG,NAME,TYPE) SCM_SNARF_INIT_START VM_OPCODE(TAG),
+#define SCM_DEFINE_VM_FUNCTION(TAG,SNAME,NAME,NARGS,RESTP) SCM_SNARF_INIT_START VM_OPCODE(TAG),
+
+#endif /* SCM_SNARF_OPCODE */
+#endif /* SCM_MAGIC_SNARFER */
+
+#endif /* not VM_SNARF_H */
--- /dev/null
+/* Copyright (C) 2000 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. */
+
+#define SCM_DEBUG_TYPING_STRICTNESS 0
+#include "config.h"
+#include "vm.h"
+
+/* default stack size in the number of SCM */
+#define VM_DEFAULT_STACK_SIZE (1 * 1024) /* = 128KB */
+#define VM_MAXIMUM_STACK_SIZE (1024 * 1024) /* = 4MB */
+
+/* I sometimes use this for debugging. */
+#define vm_puts(OBJ) \
+{ \
+ scm_display (OBJ, scm_def_errp); \
+ scm_newline (scm_def_errp); \
+}
+
+\f
+/*
+ * Instruction
+ */
+
+#define INSTRUCTION_HASH_SIZE op_last
+#define INSTRUCTION_HASH(ADDR) (((int) (ADDR) >> 1) % INSTRUCTION_HASH_SIZE)
+
+/* These variables are defined in VM engines when they are first called. */
+static struct scm_instruction *scm_regular_instruction_table = 0;
+static struct scm_instruction *scm_debug_instruction_table = 0;
+
+/* Hash table for finding instructions from addresses */
+static struct inst_hash {
+ void *addr;
+ struct scm_instruction *inst;
+ struct inst_hash *next;
+} *scm_instruction_hash_table[INSTRUCTION_HASH_SIZE];
+
+static long scm_instruction_tag;
+
+static SCM
+make_instruction (struct scm_instruction *instp)
+{
+ SCM_RETURN_NEWSMOB (scm_instruction_tag, instp);
+}
+
+static int
+print_instruction (SCM obj, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<instruction ", port);
+ scm_puts (SCM_INSTRUCTION_DATA (obj)->name, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static void
+init_instruction_type ()
+{
+ scm_instruction_tag = scm_make_smob_type ("instruction", 0);
+ scm_set_smob_print (scm_instruction_tag, print_instruction);
+}
+
+/* C interface */
+
+static struct scm_instruction *
+find_instruction_by_name (const char *name)
+{
+ struct scm_instruction *p;
+ for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
+ if (strcmp (name, p->name) == 0)
+ return p;
+ return 0;
+}
+
+static struct scm_instruction *
+find_instruction_by_code (SCM code)
+{
+ struct inst_hash *p;
+ void *addr = SCM_CODE_TO_ADDR (code);
+ for (p = scm_instruction_hash_table[INSTRUCTION_HASH (addr)]; p; p = p->next)
+ if (p->addr == addr)
+ return p->inst;
+ return 0;
+}
+
+#ifdef HAVE_LABELS_AS_VALUES
+static void *
+instruction_code_to_debug_addr (SCM code)
+{
+ struct scm_instruction *p = find_instruction_by_code (code);
+ return scm_debug_instruction_table[p->opcode].addr;
+}
+#endif
+
+/* Scheme interface */
+
+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_system_instruction_p, "system-instruction?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_system_instruction_p
+{
+ return SCM_BOOL (SCM_SYSTEM_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_functional_instruction_p, "functional-instruction?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_functional_instruction_p
+{
+ return SCM_BOOL (SCM_FUNCTIONAL_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_name_p, "instruction-name?", 1, 0, 0,
+ (SCM name),
+"")
+#define FUNC_NAME s_scm_instruction_name_p
+{
+ SCM_VALIDATE_SYMBOL (1, name);
+ return SCM_BOOL (find_instruction_by_name (SCM_CHARS (name)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_to_instruction, "symbol->instruction", 1, 0, 0,
+ (SCM name),
+"")
+#define FUNC_NAME s_scm_symbol_to_instruction
+{
+ struct scm_instruction *p;
+ SCM_VALIDATE_SYMBOL (1, name);
+
+ p = find_instruction_by_name (SCM_CHARS (name));
+ if (!p)
+ SCM_MISC_ERROR ("No such instruction: ~S", SCM_LIST1 (name));
+
+ return p->obj;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+ (),
+"")
+#define FUNC_NAME s_scm_instruction_list
+{
+ SCM list = SCM_EOL;
+ struct scm_instruction *p;
+ for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
+ list = scm_cons (p->obj, list);
+ return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_opcode, "instruction-opcode", 1, 0, 0,
+ (SCM inst),
+"")
+#define FUNC_NAME s_scm_instruction_opcode
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->opcode);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_name, "instruction-name", 1, 0, 0,
+ (SCM inst),
+"")
+#define FUNC_NAME s_scm_instruction_name
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->name));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_type, "instruction-type", 1, 0, 0,
+ (SCM inst),
+"")
+#define FUNC_NAME s_scm_instruction_type
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ return SCM_MAKINUM (SCM_INSTRUCTION_DATA (inst)->type);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_scheme_name, "instruction-scheme-name", 1, 0, 0,
+ (SCM inst),
+"")
+#define FUNC_NAME s_scm_instruction_scheme_name
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
+ return SCM_CAR (scm_intern0 (SCM_INSTRUCTION_DATA (inst)->sname));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_arity, "instruction-arity", 1, 0, 0,
+ (SCM inst),
+"")
+#define FUNC_NAME s_scm_instruction_arity
+{
+ SCM_VALIDATE_INSTRUCTION (1, inst);
+ if (SCM_FUNCTIONAL_INSTRUCTION_P (inst))
+ {
+ struct scm_instruction *p = SCM_INSTRUCTION_DATA (inst);
+ return SCM_LIST2 (SCM_MAKINUM (p->nargs), SCM_BOOL (p->restp));
+ }
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Bytecode
+ */
+
+static long scm_bytecode_tag;
+
+static SCM
+make_bytecode (int size)
+{
+ struct scm_bytecode *p
+ = scm_must_malloc (sizeof (*p) + (size * sizeof (SCM)), "make_bytecode");
+ p->size = size;
+ SCM_RETURN_NEWSMOB (scm_bytecode_tag, p);
+}
+
+static SCM
+mark_bytecode (SCM bytecode)
+{
+ int i;
+ struct scm_instruction *p;
+
+ int size = SCM_BYTECODE_SIZE (bytecode);
+ SCM *base = SCM_BYTECODE_BASE (bytecode);
+
+ for (i = 0; i < size; i++)
+ {
+ p = find_instruction_by_code (base[i]);
+ switch (p->type)
+ {
+ case INST_NONE:
+ break;
+ case INST_SCM:
+ case INST_TOP:
+ case INST_EXT:
+ case INST_CODE:
+ scm_gc_mark (base[++i]);
+ break;
+ case INST_INUM: /* a fixed integer; we don't need to mark it */
+ case INST_ADDR: /* real memory address; we shouldn't mark it! */
+ i++;
+ }
+ }
+ return SCM_BOOL_F;
+}
+
+static int
+print_bytecode (SCM obj, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<bytecode 0x", port);
+ scm_intprint ((long) SCM_BYTECODE_BASE (obj), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static scm_sizet
+free_bytecode (SCM bytecode)
+{
+ int size = (sizeof (struct scm_bytecode)
+ + (SCM_BYTECODE_SIZE (bytecode) * sizeof (SCM)));
+ if (SCM_BYTECODE_EXTS (bytecode))
+ {
+ size += (SCM_BYTECODE_EXTS (bytecode)[0] + 1) * sizeof (int);
+ scm_must_free (SCM_BYTECODE_EXTS (bytecode));
+ }
+ scm_must_free (SCM_BYTECODE_DATA (bytecode));
+ return size;
+}
+
+static void
+init_bytecode_type ()
+{
+ scm_bytecode_tag = scm_make_smob_type ("bytecode", 0);
+ scm_set_smob_mark (scm_bytecode_tag, mark_bytecode);
+ scm_set_smob_print (scm_bytecode_tag, print_bytecode);
+ scm_set_smob_free (scm_bytecode_tag, free_bytecode);
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_bytecode_p, "bytecode?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_bytecode_p
+{
+ return SCM_BOOL (SCM_BYTECODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_bytecode, "make-bytecode", 1, 0, 0,
+ (SCM code),
+"")
+#define FUNC_NAME s_scm_make_bytecode
+{
+ int i, size, len, offset;
+ SCM header, body, nreqs, restp, nvars, nexts, exts, bytecode;
+ SCM *old, *new, *address;
+
+ /* Type check */
+ SCM_VALIDATE_VECTOR (1, code);
+ SCM_ASSERT_RANGE (1, code, SCM_LENGTH (code) == 2);
+ header = SCM_VELTS (code)[0];
+ body = SCM_VELTS (code)[1];
+ SCM_VALIDATE_VECTOR (1, header);
+ SCM_VALIDATE_VECTOR (2, body);
+ SCM_ASSERT_RANGE (1, header, SCM_LENGTH (header) == 5);
+ nreqs = SCM_VELTS (header)[0];
+ restp = SCM_VELTS (header)[1];
+ nvars = SCM_VELTS (header)[2];
+ nexts = SCM_VELTS (header)[3];
+ exts = SCM_VELTS (header)[4];
+ SCM_VALIDATE_INUM (1, nreqs);
+ SCM_VALIDATE_BOOL (2, restp);
+ SCM_VALIDATE_INUM (3, nvars);
+ SCM_VALIDATE_INUM (4, nexts);
+ SCM_VALIDATE_VECTOR (5, exts);
+
+ /* Create a new bytecode */
+ size = SCM_LENGTH (body);
+ old = SCM_VELTS (body);
+ bytecode = make_bytecode (size);
+ new = SCM_BYTECODE_BASE (bytecode);
+
+ /* Initialize the header */
+ SCM_BYTECODE_NREQS (bytecode) = SCM_INUM (nreqs);
+ SCM_BYTECODE_RESTP (bytecode) = SCM_FALSEP (restp) ? 0 : 1;
+ SCM_BYTECODE_NVARS (bytecode) = SCM_INUM (nvars);
+ SCM_BYTECODE_NEXTS (bytecode) = SCM_INUM (nexts);
+ len = SCM_LENGTH (exts);
+ if (len == 0)
+ {
+ SCM_BYTECODE_EXTS (bytecode) = NULL;
+ }
+ else
+ {
+ SCM_BYTECODE_EXTS (bytecode) =
+ scm_must_malloc ((len + 1) * sizeof (int), FUNC_NAME);
+ SCM_BYTECODE_EXTS (bytecode)[0] = len;
+ for (i = 0; i < len; i++)
+ SCM_BYTECODE_EXTS (bytecode)[i + 1] = SCM_INUM (SCM_VELTS (exts)[i]);
+ }
+
+ /* Initialize the body */
+ for (i = 0; i < size; i++)
+ {
+ struct scm_instruction *p;
+
+ /* Process instruction */
+ if (!SCM_SYMBOLP (old[i])
+ || !(p = find_instruction_by_name (SCM_CHARS (old[i]))))
+ SCM_MISC_ERROR ("Invalid instruction: ~S", SCM_LIST1 (old[i]));
+ new[i] = SCM_ADDR_TO_CODE (p->addr);
+
+ /* Process arguments */
+ if (p->type == INST_NONE)
+ continue;
+ if (++i >= size)
+ SCM_MISC_ERROR ("Unexpected end of code", SCM_EOL);
+ switch (p->type)
+ {
+ case INST_NONE:
+ /* never come here */
+ case INST_INUM:
+ SCM_VALIDATE_INUM (1, old[i]);
+ /* fall through */
+ case INST_SCM:
+ /* just copy */
+ new[i] = old[i];
+ break;
+ case INST_TOP:
+ /* top-level variable */
+ SCM_VALIDATE_SYMBOL (1, old[i]);
+ new[i] = scm_intern0 (SCM_CHARS (old[i]));
+ break;
+ case INST_EXT:
+ /* just copy for now */
+ SCM_VALIDATE_CONS (1, old[i]);
+ SCM_VALIDATE_INUM (1, SCM_CAR (old[i]));
+ SCM_VALIDATE_INUM (1, SCM_CDR (old[i]));
+ new[i] = old[i];
+ break;
+ case INST_CODE:
+ /* another bytecode */
+ new[i] = scm_make_bytecode (old[i]);
+ break;
+ case INST_ADDR:
+ /* real address */
+ SCM_VALIDATE_INUM (1, old[i]);
+ /* Without the following intermediate variables, type conversion
+ fails on my machine. Casting doesn't work well, why? */
+ offset = SCM_INUM (old[i]);
+ address = new + offset;
+ new[i] = SCM_VM_MAKE_ADDRESS (address);
+ break;
+ }
+ }
+ return bytecode;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_decode, "bytecode-decode", 1, 0, 0,
+ (SCM bytecode),
+"")
+#define FUNC_NAME s_scm_bytecode_decode
+{
+ int i, size, offset;
+ SCM code, *old, *new;
+
+ SCM_VALIDATE_BYTECODE (1, bytecode);
+
+ size = SCM_BYTECODE_SIZE (bytecode);
+ old = SCM_BYTECODE_BASE (bytecode);
+ code = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
+ new = SCM_VELTS (code);
+
+ for (i = 0; i < size; i++)
+ {
+ struct scm_instruction *p;
+
+ /* Process instruction */
+ p = find_instruction_by_code (old[i]);
+ if (!p)
+ {
+ broken:
+ SCM_MISC_ERROR ("Broken bytecode", SCM_EOL);
+ }
+ new[i] = scm_instruction_name (p->obj);
+
+ /* Process arguments */
+ if (p->type == INST_NONE)
+ continue;
+ if (++i >= size)
+ goto broken;
+ switch (p->type)
+ {
+ case INST_NONE:
+ /* never come here */
+ case INST_INUM:
+ case INST_SCM:
+ case INST_EXT:
+ /* just copy */
+ new[i] = old[i];
+ break;
+ case INST_TOP:
+ /* top-level variable */
+ new[i] = SCM_CAR (old[i]);
+ break;
+ case INST_CODE:
+ /* another bytecode */
+ new[i] = scm_bytecode_decode (old[i]);
+ break;
+ case INST_ADDR:
+ /* program address */
+ offset = SCM_VM_ADDRESS (old[i]) - old;
+ new[i] = SCM_MAKINUM (offset);
+ break;
+ }
+ }
+ return code;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * Program
+ */
+
+static long scm_program_tag;
+
+static SCM
+make_program (SCM bytecode, SCM parent)
+{
+ SCM env = SCM_PROGRAM_P (parent) ? SCM_PROGRAM_ENV (parent) : SCM_BOOL_F;
+ int nexts = SCM_BYTECODE_NEXTS (bytecode);
+
+ if (nexts)
+ {
+ SCM tmp = SCM_VM_MAKE_EXTERNAL (nexts);
+ SCM_VM_EXTERNAL_LINK (tmp) = env;
+ env = tmp;
+ }
+
+ SCM_RETURN_NEWSMOB2 (scm_program_tag,
+ SCM_UNPACK (bytecode),
+ SCM_UNPACK (env));
+}
+
+static SCM
+mark_program (SCM program)
+{
+ scm_gc_mark (SCM_PROGRAM_CODE (program));
+ return SCM_PROGRAM_ENV (program);
+}
+
+static SCM scm_program_name (SCM program);
+
+static int
+print_program (SCM obj, SCM port, scm_print_state *pstate)
+{
+ SCM name = scm_program_name (obj);
+ scm_puts ("#<program ", port);
+ if (SCM_FALSEP (name))
+ {
+ scm_puts ("0x", port);
+ scm_intprint ((long) SCM_PROGRAM_BASE (obj), 16, port);
+ }
+ else
+ {
+ scm_display (name, port);
+ }
+ scm_putc ('>', port);
+ return 1;
+}
+
+static void
+init_program_type ()
+{
+ scm_program_tag = scm_make_smob_type ("program", 0);
+ scm_set_smob_mark (scm_program_tag, mark_program);
+ scm_set_smob_print (scm_program_tag, print_program);
+}
+
+/* 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_make_program, "make-program", 2, 0, 0,
+ (SCM bytecode, SCM parent),
+"")
+#define FUNC_NAME s_scm_make_program
+{
+ SCM_VALIDATE_BYTECODE (1, bytecode);
+ return make_program (bytecode, parent);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
+ (SCM program),
+"")
+#define FUNC_NAME s_scm_program_name
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return scm_object_property (program, scm_sym_name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_code, "program-code", 1, 0, 0,
+ (SCM program),
+"")
+#define FUNC_NAME s_scm_program_code
+{
+ SCM_VALIDATE_PROGRAM (1, program);
+ return SCM_PROGRAM_CODE (program);
+}
+#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_VM_MAKE_ADDRESS (SCM_PROGRAM_BASE (program));
+}
+#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_ENV (program);
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * VM Frame
+ */
+
+static long scm_vm_frame_tag;
+
+/* This is used for debugging */
+struct scm_vm_frame {
+ int size;
+ SCM program;
+ SCM variables;
+ SCM dynamic_link;
+ SCM stack_pointer;
+ SCM return_address;
+};
+
+#define SCM_VM_FRAME_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_frame_tag, OBJ)
+#define SCM_VM_FRAME_DATA(FR) ((struct scm_vm_frame *) SCM_SMOB_DATA (FR))
+#define SCM_VALIDATE_VM_FRAME(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_FRAME_P)
+
+static SCM
+make_vm_frame (SCM *fp)
+{
+ int i;
+ int size = SCM_INUM (SCM_VM_FRAME_SIZE (fp));
+ struct scm_vm_frame *p = scm_must_malloc (sizeof (*p), "make_vm_frame");
+ p->program = SCM_VM_FRAME_PROGRAM (fp);
+ p->dynamic_link = SCM_VM_FRAME_DYNAMIC_LINK (fp);
+ p->stack_pointer = SCM_VM_FRAME_STACK_POINTER (fp);
+ p->return_address = SCM_VM_FRAME_RETURN_ADDRESS (fp);
+
+ if (!SCM_FALSEP (p->dynamic_link))
+ p->dynamic_link = make_vm_frame (SCM_VM_ADDRESS (p->dynamic_link));
+
+ size += SCM_PROGRAM_NREQS (p->program) + SCM_PROGRAM_RESTP (p->program);
+ p->variables = scm_make_vector (SCM_MAKINUM (size), SCM_BOOL_F);
+ for (i = 0; i < size; i++)
+ SCM_VELTS (p->variables)[i] = SCM_VM_FRAME_VARIABLE (fp, i);
+
+ SCM_RETURN_NEWSMOB (scm_vm_frame_tag, p);
+}
+
+static SCM
+mark_vm_frame (SCM frame)
+{
+ struct scm_vm_frame *p = SCM_VM_FRAME_DATA (frame);
+ scm_gc_mark (p->program);
+ scm_gc_mark (p->dynamic_link);
+ return p->variables;
+}
+
+static void
+init_vm_frame_type ()
+{
+ scm_vm_frame_tag = scm_make_smob_type ("vm-frame", 0);
+ scm_set_smob_mark (scm_vm_frame_tag, mark_vm_frame);
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
+ (SCM obj),
+"")
+#define FUNC_NAME s_scm_frame_p
+{
+ return SCM_BOOL (SCM_VM_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_VM_FRAME (1, frame);
+ return SCM_VM_FRAME_DATA (frame)->program;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_variables, "frame-variables", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_variables
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_VM_FRAME_DATA (frame)->variables;
+}
+#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_VM_FRAME (1, frame);
+ return SCM_VM_FRAME_DATA (frame)->dynamic_link;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_stack_pointer, "frame-stack-pointer", 1, 0, 0,
+ (SCM frame),
+"")
+#define FUNC_NAME s_scm_frame_stack_pointer
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return SCM_VM_FRAME_DATA (frame)->stack_pointer;
+}
+#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_VM_FRAME (1, frame);
+ return SCM_VM_FRAME_DATA (frame)->return_address;
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * VM Continuation
+ */
+
+static long scm_vm_cont_tag;
+
+static SCM
+capture_vm_cont (struct scm_vm *vmp)
+{
+ struct scm_vm *p = scm_must_malloc (sizeof (*p), "capture_vm_cont");
+ p->stack_size = vmp->stack_limit - vmp->sp;
+ p->stack_base = scm_must_malloc (p->stack_size * sizeof (SCM),
+ "capture_vm_cont");
+ p->stack_limit = p->stack_base + p->stack_size - 1;
+ p->pc = vmp->pc;
+ p->sp = (SCM *) (vmp->stack_limit - vmp->sp);
+ p->fp = (SCM *) (vmp->stack_limit - vmp->fp);
+ memcpy (p->stack_base, vmp->sp + 1, vmp->stack_size * sizeof (SCM));
+ SCM_RETURN_NEWSMOB (scm_vm_cont_tag, p);
+}
+
+static void
+reinstate_vm_cont (struct scm_vm *vmp, SCM cont)
+{
+ struct scm_vm *p = SCM_VM_CONT_VMP (cont);
+ if (vmp->stack_size < p->stack_size)
+ {
+ puts ("FIXME: Need to expand");
+ abort ();
+ }
+ vmp->pc = p->pc;
+ vmp->sp = vmp->stack_limit - (int) p->sp;
+ vmp->fp = vmp->stack_limit - (int) p->fp;
+ memcpy (vmp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+static SCM
+mark_vm_cont (SCM cont)
+{
+ SCM *p;
+ struct scm_vm *vmp = SCM_VM_CONT_VMP (cont);
+ for (p = vmp->stack_base; p <= vmp->stack_limit; p++)
+ if (SCM_NIMP (*p))
+ scm_gc_mark (*p);
+ return SCM_BOOL_F;
+}
+
+static scm_sizet
+free_vm_cont (SCM cont)
+{
+ struct scm_vm *p = SCM_VM_CONT_VMP (cont);
+ int size = sizeof (struct scm_vm) + p->stack_size * sizeof (SCM);
+ scm_must_free (p->stack_base);
+ scm_must_free (p);
+ return size;
+}
+
+static void
+init_vm_cont_type ()
+{
+ scm_vm_cont_tag = scm_make_smob_type ("vm-cont", 0);
+ scm_set_smob_mark (scm_vm_cont_tag, mark_vm_cont);
+ scm_set_smob_free (scm_vm_cont_tag, free_vm_cont);
+}
+
+\f
+/*
+ * VM
+ */
+
+static long scm_vm_tag;
+
+static SCM
+make_vm (int stack_size)
+{
+ struct scm_vm *vmp = scm_must_malloc (sizeof (struct scm_vm), "make_vm");
+ vmp->stack_size = stack_size;
+ vmp->stack_base = scm_must_malloc (stack_size * sizeof (SCM), "make_vm");
+ vmp->stack_limit = vmp->stack_base + vmp->stack_size - 1;
+ vmp->sp = vmp->stack_limit;
+ vmp->ac = SCM_BOOL_F;
+ vmp->pc = NULL;
+ vmp->fp = NULL;
+ vmp->options = SCM_EOL;
+ vmp->boot_hook = scm_make_hook (SCM_MAKINUM (1));
+ vmp->halt_hook = scm_make_hook (SCM_MAKINUM (1));
+ vmp->next_hook = scm_make_hook (SCM_MAKINUM (1));
+ vmp->call_hook = scm_make_hook (SCM_MAKINUM (1));
+ vmp->apply_hook = scm_make_hook (SCM_MAKINUM (1));
+ vmp->return_hook = scm_make_hook (SCM_MAKINUM (1));
+ SCM_RETURN_NEWSMOB (scm_vm_tag, vmp);
+}
+
+static SCM
+mark_vm (SCM vm)
+{
+ SCM *p;
+ struct scm_vm *vmp = SCM_VM_DATA (vm);
+ for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
+ if (SCM_NIMP (*p))
+ scm_gc_mark (*p);
+
+ scm_gc_mark (vmp->ac);
+ scm_gc_mark (vmp->boot_hook);
+ scm_gc_mark (vmp->halt_hook);
+ scm_gc_mark (vmp->next_hook);
+ scm_gc_mark (vmp->call_hook);
+ scm_gc_mark (vmp->apply_hook);
+ scm_gc_mark (vmp->return_hook);
+ return vmp->options;
+}
+
+static void
+init_vm_type ()
+{
+ scm_vm_tag = scm_make_smob_type ("vm", sizeof (struct scm_vm));
+ scm_set_smob_mark (scm_vm_tag, mark_vm);
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
+ (),
+"")
+#define FUNC_NAME s_scm_vm_version
+{
+ return scm_makfrom0str (VERSION);
+}
+#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,
+ (),
+"")
+#define FUNC_NAME s_scm_make_vm
+{
+ return make_vm (VM_DEFAULT_STACK_SIZE);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_ac, "vm:ac", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_ac
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->ac;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_pc, "vm:pc", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_pc
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->pc);
+}
+#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_VM_MAKE_ADDRESS (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_VM_MAKE_ADDRESS (SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_current_frame, "vm-current-frame", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_current_frame
+{
+ SCM_VALIDATE_VM (1, vm);
+ return make_vm_frame (SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 2, 0, 0,
+ (SCM vm, SCM addr),
+"")
+#define FUNC_NAME s_scm_vm_fetch_code
+{
+ SCM *p, list;
+ struct scm_instruction *inst;
+
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VALIDATE_INUM (2, addr);
+
+ p = SCM_VM_ADDRESS (addr);
+
+ inst = find_instruction_by_code (*p);
+ if (!inst)
+ SCM_MISC_ERROR ("Broken bytecode", SCM_LIST1 (addr));
+
+ list = SCM_LIST1 (scm_instruction_name (inst->obj));
+ if (inst->type != INST_NONE)
+ {
+ if (inst->type == INST_ADDR)
+ {
+ p = SCM_CODE_TO_ADDR (p[1]);
+ SCM_SETCDR (list, SCM_LIST1 (SCM_VM_MAKE_ADDRESS (p)));
+ }
+ else
+ SCM_SETCDR (list, SCM_LIST1 (p[1]));
+ }
+ return list;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_stack_to_list, "vm-stack->list", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_stack_to_list
+{
+ struct scm_vm *vmp;
+ SCM *p, list = SCM_EOL;
+
+ SCM_VALIDATE_VM (1, vm);
+
+ vmp = SCM_VM_DATA (vm);
+ for (p = vmp->sp + 1; p <= vmp->stack_limit; p++)
+ list = scm_cons (*p, list);
+ return list;
+}
+#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);
+ SCM_VALIDATE_SYMBOL (2, key);
+ return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_set_option_x, "vm-set-option!", 3, 0, 0,
+ (SCM vm, SCM key, SCM val),
+"")
+#define FUNC_NAME s_scm_vm_set_option_x
+{
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VALIDATE_SYMBOL (2, key);
+ 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_boot_hook, "vm-boot-hook", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_boot_hook
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (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
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (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
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->next_hook;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_call_hook, "vm-call-hook", 1, 0, 0,
+ (SCM vm),
+"")
+#define FUNC_NAME s_scm_vm_call_hook
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->call_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
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->apply_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
+{
+ SCM_VALIDATE_VM (1, vm);
+ return SCM_VM_DATA (vm)->return_hook;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (sym_debug, "debug");
+
+static SCM scm_regular_vm (SCM vm, SCM program);
+static SCM scm_debug_vm (SCM vm, SCM program);
+
+#define VM_CODE(name) SCM_ADDR_TO_CODE (find_instruction_by_name (name)->addr)
+
+SCM_DEFINE (scm_vm_run, "vm-run", 2, 0, 0,
+ (SCM vm, SCM program),
+"")
+#define FUNC_NAME s_scm_vm_run
+{
+ SCM bootcode;
+ static SCM template[5];
+
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VALIDATE_PROGRAM (2, program);
+
+ if (SCM_EQ_P (template[0], SCM_PACK (0)))
+ {
+ template[0] = VM_CODE ("%loadc");
+ template[1] = SCM_BOOL_F;
+ template[2] = VM_CODE ("%call");
+ template[3] = SCM_MAKINUM (0);
+ template[4] = VM_CODE ("%halt");
+ }
+
+ /* Create a boot program */
+ bootcode = make_bytecode (5);
+ memcpy (SCM_BYTECODE_BASE (bootcode), template, sizeof (SCM) * 5);
+ SCM_BYTECODE_BASE (bootcode)[1] = program;
+ SCM_BYTECODE_SIZE (bootcode) = 5;
+ SCM_BYTECODE_EXTS (bootcode) = NULL;
+ SCM_BYTECODE_NREQS (bootcode) = 0;
+ SCM_BYTECODE_RESTP (bootcode) = 0;
+ SCM_BYTECODE_NVARS (bootcode) = 0;
+ SCM_BYTECODE_NEXTS (bootcode) = 0;
+ program = SCM_MAKE_PROGRAM (bootcode, SCM_BOOL_F);
+
+ if (SCM_FALSEP (scm_vm_option (vm, sym_debug)))
+ return scm_regular_vm (vm, program);
+ else
+ return scm_debug_vm (vm, program);
+}
+#undef FUNC_NAME
+
+\f
+/*
+ * The VM engines
+ */
+
+/* We don't want to snarf the engines */
+#ifndef SCM_MAGIC_SNARFER
+
+/* the regular engine */
+#define VM_ENGINE SCM_VM_REGULAR_ENGINE
+#include "vm_engine.c"
+#undef VM_ENGINE
+
+/* the debug engine */
+#define VM_ENGINE SCM_VM_DEBUG_ENGINE
+#include "vm_engine.c"
+#undef VM_ENGINE
+
+#endif /* not SCM_MAGIC_SNARFER */
+
+\f
+/*
+ * Initialize
+ */
+
+static SCM scm_module_vm;
+
+void
+scm_init_vm ()
+{
+ SCM old_module;
+
+ /* Initialize the module */
+ scm_module_vm = scm_make_module (scm_read_0str ("(vm vm)"));
+ old_module = scm_select_module (scm_module_vm);
+
+ init_instruction_type ();
+ init_bytecode_type ();
+ init_program_type ();
+ init_vm_frame_type ();
+ init_vm_cont_type ();
+ init_vm_type ();
+
+#include "vm.x"
+
+ scm_select_module (old_module);
+
+ /* Initialize instruction tables */
+ {
+ int i;
+ struct scm_instruction *p;
+
+ SCM vm = make_vm (0);
+ scm_regular_vm (vm, SCM_BOOL_F);
+ scm_debug_vm (vm, SCM_BOOL_F);
+
+ /* hash table */
+ for (i = 0; i < INSTRUCTION_HASH_SIZE; i++)
+ scm_instruction_hash_table[i] = NULL;
+
+ for (p = scm_regular_instruction_table; p->opcode != op_last; p++)
+ {
+ int hash;
+ struct inst_hash *data;
+ SCM inst = scm_permanent_object (make_instruction (p));
+ p->obj = inst;
+ if (p->restp) p->type = INST_INUM;
+ hash = INSTRUCTION_HASH (p->addr);
+ data = scm_must_malloc (sizeof (*data), "inst_hash");
+ data->addr = p->addr;
+ data->inst = p;
+ data->next = scm_instruction_hash_table[hash];
+ scm_instruction_hash_table[hash] = data;
+ }
+ }
+}
+
+void
+scm_init_vm_vm_module ()
+{
+ scm_register_module_xxx ("vm vm", (void *) scm_init_vm);
+}
--- /dev/null
+/* Copyright (C) 2000 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_H
+#define VM_H
+
+#include <libguile.h>
+
+\f
+/*
+ * Instruction
+ */
+
+/* Opcode */
+enum scm_opcode {
+#include "vm_system.op"
+#include "vm_scheme.op"
+#include "vm_number.op"
+ op_last
+};
+
+/* Argument type */
+/* Modify `mark_bytecode', `scm_make_bytecode', and `scm_bytecode_decode'! */
+enum scm_inst_type {
+ INST_NONE, /* no argument */
+ INST_INUM, /* fixed integer */
+ INST_SCM, /* scheme object */
+ INST_EXT, /* external offset */
+ INST_TOP, /* top-level variable */
+ INST_CODE, /* program code */
+ INST_ADDR /* program address */
+};
+
+struct scm_instruction {
+ enum scm_opcode opcode; /* opcode */
+ enum scm_inst_type type; /* argument type */
+ char *name; /* instruction name */
+ void *addr; /* instruction address */
+ SCM obj; /* instruction object */
+ /* fields for VM functions */
+ char *sname; /* Scheme procedure name */
+ char nargs; /* the number of arguments */
+ char restp; /* have a rest argument or not */
+};
+
+#define SCM_INSTRUCTION_P(OBJ) SCM_SMOB_PREDICATE (scm_instruction_tag, OBJ)
+#define SCM_INSTRUCTION_DATA(INST) ((struct scm_instruction *) SCM_SMOB_DATA (INST))
+#define SCM_VALIDATE_INSTRUCTION(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, INSTRUCTION_P)
+
+#define SCM_SYSTEM_INSTRUCTION_P(OBJ) \
+ (SCM_INSTRUCTION_P (OBJ) && !SCM_INSTRUCTION_DATA(OBJ)->sname)
+#define SCM_FUNCTIONAL_INSTRUCTION_P(OBJ) \
+ (SCM_INSTRUCTION_P (OBJ) && SCM_INSTRUCTION_DATA(OBJ)->sname)
+
+#define SCM_ADDR_TO_CODE(ADDR) SCM_PACK (ADDR)
+#define SCM_CODE_TO_ADDR(CODE) ((void *) SCM_UNPACK (CODE))
+#define SCM_CODE_TO_DEBUG_ADDR(CODE) instruction_code_to_debug_addr (CODE)
+
+\f
+/*
+ * Bytecode
+ */
+
+struct scm_bytecode {
+ int size; /* the size of the bytecode */
+ char nreqs; /* the number of required arguments */
+ char restp; /* have a rest argument or not */
+ char nvars; /* the number of local variables */
+ char nexts; /* the number of external variables */
+ int *exts; /* externalized arguments */
+ SCM base[0]; /* base address (must be the last!) */
+};
+
+#define SCM_BYTECODE_P(OBJ) SCM_SMOB_PREDICATE (scm_bytecode_tag, OBJ)
+#define SCM_BYTECODE_DATA(BC) ((struct scm_bytecode *) SCM_SMOB_DATA (BC))
+#define SCM_VALIDATE_BYTECODE(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, BYTECODE_P)
+
+#define SCM_BYTECODE_SIZE(BC) SCM_BYTECODE_DATA (BC)->size
+#define SCM_BYTECODE_NREQS(BC) SCM_BYTECODE_DATA (BC)->nreqs
+#define SCM_BYTECODE_RESTP(BC) SCM_BYTECODE_DATA (BC)->restp
+#define SCM_BYTECODE_NVARS(BC) SCM_BYTECODE_DATA (BC)->nvars
+#define SCM_BYTECODE_NEXTS(BC) SCM_BYTECODE_DATA (BC)->nexts
+#define SCM_BYTECODE_EXTS(BC) SCM_BYTECODE_DATA (BC)->exts
+#define SCM_BYTECODE_BASE(BC) SCM_BYTECODE_DATA (BC)->base
+
+extern SCM scm_bytecode_p (SCM obj);
+extern SCM scm_make_bytecode (SCM code);
+extern SCM scm_bytecode_decode (SCM bytecode);
+
+\f
+/*
+ * Program
+ */
+
+#define SCM_MAKE_PROGRAM(CODE,ENV) make_program (CODE, ENV)
+#define SCM_PROGRAM_P(OBJ) SCM_SMOB_PREDICATE (scm_program_tag, OBJ)
+#define SCM_PROGRAM_CODE(PROG) SCM_CELL_OBJECT_1 (PROG)
+#define SCM_PROGRAM_ENV(PROG) SCM_CELL_OBJECT_2 (PROG)
+#define SCM_VALIDATE_PROGRAM(POS,PROG) SCM_MAKE_VALIDATE (POS, PROG, PROGRAM_P)
+
+/* Abbreviations */
+#define SCM_PROGRAM_SIZE(PROG) SCM_BYTECODE_SIZE (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_NREQS(PROG) SCM_BYTECODE_NREQS (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_RESTP(PROG) SCM_BYTECODE_RESTP (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_NVARS(PROG) SCM_BYTECODE_NVARS (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_NEXTS(PROG) SCM_BYTECODE_NEXTS (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_EXTS(PROG) SCM_BYTECODE_EXTS (SCM_PROGRAM_CODE (PROG))
+#define SCM_PROGRAM_BASE(PROG) SCM_BYTECODE_BASE (SCM_PROGRAM_CODE (PROG))
+
+extern SCM scm_program_p (SCM obj);
+extern SCM scm_make_program (SCM bytecode, SCM env);
+extern SCM scm_program_code (SCM program);
+extern SCM scm_program_base (SCM program);
+
+\f
+/*
+ * VM Address
+ */
+
+#define SCM_VM_MAKE_ADDRESS(ADDR) SCM_MAKINUM ((long) (ADDR))
+#define SCM_VM_ADDRESS(OBJ) ((SCM *) SCM_INUM (OBJ))
+
+\f
+/*
+ * VM External
+ */
+
+/* VM external maintains a set of variables outside of the stack.
+ This is used to implement external chain of the environment. */
+
+#define SCM_VM_MAKE_EXTERNAL(SIZE) scm_make_vector (SCM_MAKINUM ((SIZE) + 1), SCM_UNDEFINED)
+#define SCM_VM_EXTERNAL_LINK(EXT) (SCM_VELTS (EXT)[0])
+#define SCM_VM_EXTERNAL_VARIABLE(EXT,N) (SCM_VELTS (EXT)[(N) + 1])
+
+\f
+/*
+ * VM Continuation
+ */
+
+#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_cont_tag, OBJ)
+#define SCM_VM_CONT_VMP(CONT) ((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+
+#define SCM_VM_CAPTURE_CONT(VMP) capture_vm_cont (VMP)
+#define SCM_VM_REINSTATE_CONT(VMP,CONT) reinstate_vm_cont (VMP, CONT)
+
+\f
+/*
+ * VM Frame
+ */
+
+/* VM frame is allocated in the stack */
+/* NOTE: Modify make_vm_frame and VM_NEW_FRAME too! */
+#define SCM_VM_FRAME_DATA_SIZE 5
+#define SCM_VM_FRAME_VARIABLE(FP,N) (FP[N])
+#define SCM_VM_FRAME_SIZE(FP) (FP[-1])
+#define SCM_VM_FRAME_PROGRAM(FP) (FP[-2])
+#define SCM_VM_FRAME_DYNAMIC_LINK(FP) (FP[-3])
+#define SCM_VM_FRAME_STACK_POINTER(FP) (FP[-4])
+#define SCM_VM_FRAME_RETURN_ADDRESS(FP) (FP[-5])
+
+\f
+/*
+ * VM
+ */
+
+/* Modify make_vm, mark_vm, and SYNC, too! */
+struct scm_vm {
+ SCM ac; /* Accumulator */
+ SCM *pc; /* Program counter */
+ SCM *sp; /* Stack pointer */
+ SCM *fp; /* Frame pointer */
+ int stack_size;
+ SCM *stack_base;
+ SCM *stack_limit;
+ SCM options;
+ SCM boot_hook, halt_hook, next_hook;
+ SCM call_hook, apply_hook, return_hook;
+};
+
+#define SCM_VM_P(OBJ) SCM_SMOB_PREDICATE (scm_vm_tag, OBJ)
+#define SCM_VM_DATA(VM) ((struct scm_vm *) SCM_SMOB_DATA (VM))
+#define SCM_VALIDATE_VM(POS,OBJ) SCM_MAKE_VALIDATE (POS, OBJ, VM_P)
+
+/* Engine types */
+#define SCM_VM_REGULAR_ENGINE 0 /* Fail safe and fast enough */
+#define SCM_VM_DEBUG_ENGINE 1 /* Functional but very slow */
+
+#endif /* not VM_H */
--- /dev/null
+/* Copyright (C) 2000 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 two times! */
+
+#include "vm_engine.h"
+
+/* VM names */
+#undef VM_NAME
+#undef VM_TABLE
+#if VM_ENGINE == SCM_VM_REGULAR_ENGINE
+#define VM_NAME scm_regular_vm
+#define VM_TABLE scm_regular_instruction_table
+#else
+#if VM_ENGINE == SCM_VM_DEBUG_ENGINE
+#define VM_NAME scm_debug_vm
+#define VM_TABLE scm_debug_instruction_table
+#endif
+#endif
+
+static SCM
+VM_NAME (SCM vm, SCM program)
+#define FUNC_NAME "vm-engine"
+{
+ /* Copies of VM registers */
+ SCM ac = SCM_PACK (0);
+ SCM *pc = NULL;
+ SCM *sp = NULL;
+ SCM *fp = NULL;
+
+ /* Stack boundaries */
+ SCM *stack_base = NULL;
+ SCM *stack_limit = NULL;
+
+ /* Function arguments */
+ int an = 0;
+ SCM a2 = SCM_PACK (0);
+ SCM a3 = SCM_PACK (0);
+
+ /* Miscellaneous variables */
+ SCM dynwinds = SCM_EOL;
+ struct scm_vm *vmp = NULL;
+
+#if VM_USE_HOOK
+ SCM hook_args = SCM_LIST1 (vm);
+#endif
+
+ /* Initialize the instruction table at the first time.
+ * This code must be here because the following table contains
+ * pointers to the labels defined in this function. */
+ if (!VM_TABLE)
+ {
+ static struct scm_instruction table[] = {
+#include "vm_system.vi"
+#include "vm_scheme.vi"
+#include "vm_number.vi"
+ { op_last }
+ };
+ VM_TABLE = table;
+ return SCM_UNSPECIFIED;
+ }
+
+ SCM_VALIDATE_VM (1, vm);
+ SCM_VALIDATE_PROGRAM (2, program);
+
+ /* Initialize the VM */
+ vmp = SCM_VM_DATA (vm);
+ vmp->pc = SCM_PROGRAM_BASE (program);
+ vmp->sp = vmp->stack_limit;
+ LOAD ();
+
+ /* top frame */
+ VM_NEW_FRAME (fp, program, SCM_BOOL_F,
+ SCM_VM_MAKE_ADDRESS (0),
+ SCM_VM_MAKE_ADDRESS (0));
+
+ /* Let's go! */
+ VM_BOOT_HOOK ();
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start: switch (*pc++) {
+#endif
+
+#include "vm_system.c"
+#include "vm_scheme.c"
+#include "vm_number.c"
+
+#ifndef HAVE_LABELS_AS_VALUES
+ }
+#endif
+
+ abort (); /* never reached */
+}
+#undef FUNC_NAME
--- /dev/null
+/* Copyright (C) 2000 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 Options
+ */
+
+#undef VM_USE_BOOT_HOOK
+#undef VM_USE_HALT_HOOK
+#undef VM_USE_NEXT_HOOK
+#undef VM_USE_CALL_HOOK
+#undef VM_USE_APPLY_HOOK
+#undef VM_USE_RETURN_HOOK
+#undef VM_INIT_LOCAL_VARIABLES
+#undef VM_CHECK_LINK
+#undef VM_CHECK_BINDING
+#undef VM_CHECK_PROGRAM_COUNTER
+
+#if VM_ENGINE == SCM_VM_REGULAR_ENGINE
+#define VM_USE_BOOT_HOOK 0
+#define VM_USE_HALT_HOOK 0
+#define VM_USE_NEXT_HOOK 0
+#define VM_USE_CALL_HOOK 0
+#define VM_USE_APPLY_HOOK 0
+#define VM_USE_RETURN_HOOK 0
+#define VM_INIT_LOCAL_VARIABLES 0
+#define VM_CHECK_LINK 0
+#define VM_CHECK_BINDING 1
+#define VM_CHECK_PROGRAM_COUNTER 0
+#else
+#if VM_ENGINE == SCM_VM_DEBUG_ENGINE
+#define VM_USE_BOOT_HOOK 1
+#define VM_USE_HALT_HOOK 1
+#define VM_USE_NEXT_HOOK 1
+#define VM_USE_CALL_HOOK 1
+#define VM_USE_APPLY_HOOK 1
+#define VM_USE_RETURN_HOOK 1
+#define VM_INIT_LOCAL_VARIABLES 1
+#define VM_CHECK_LINK 1
+#define VM_CHECK_BINDING 1
+#define VM_CHECK_PROGRAM_COUNTER 1
+#endif
+#endif
+
+#undef VM_USE_HOOK
+#if VM_USE_BOOT_HOOK || VM_USE_HALT_HOOK || VM_USE_NEXT_HOOK \
+ || VM_USE_CALL_HOOK || VM_USE_APPLY_HOOK || VM_USE_RETURN_HOOK
+#define VM_USE_HOOK 1
+#else
+#define VM_USE_HOOK 0
+#endif
+
+\f
+/*
+ * Type checking
+ */
+
+#define VM_ASSERT_PROGRAM(OBJ) SCM_VALIDATE_PROGRAM (1, OBJ)
+
+#undef VM_ASSERT_BOUND
+#if VM_CHECK_BINDING
+#define VM_ASSERT_BOUND(CELL) \
+ if (SCM_UNBNDP (SCM_CDR (CELL))) \
+ SCM_MISC_ERROR ("Unbound variable: ~S", SCM_LIST1 (SCM_CAR (CELL)))
+#else
+#define VM_ASSERT_BOUND(CELL)
+#endif
+
+#undef VM_ASSERT_LINK
+#if VM_CHECK_LINK
+#define VM_ASSERT_LINK(OBJ) \
+ if (SCM_FALSEP (OBJ)) \
+ SCM_MISC_ERROR ("VM broken link", SCM_EOL)
+#else
+#define VM_ASSERT_LINK(OBJ)
+#endif
+
+\f
+/*
+ * Hooks
+ */
+
+#undef VM_BOOT_HOOK
+#if VM_USE_BOOT_HOOK
+#define VM_BOOT_HOOK() SYNC (); scm_c_run_hook (vmp->boot_hook, hook_args)
+#else
+#define VM_BOOT_HOOK()
+#endif
+
+#undef VM_HALT_HOOK
+#if VM_USE_HALT_HOOK
+#define VM_HALT_HOOK() SYNC (); scm_c_run_hook (vmp->halt_hook, hook_args)
+#else
+#define VM_HALT_HOOK()
+#endif
+
+#undef VM_NEXT_HOOK
+#if VM_USE_NEXT_HOOK
+#define VM_NEXT_HOOK() SYNC (); scm_c_run_hook (vmp->next_hook, hook_args)
+#else
+#define VM_NEXT_HOOK()
+#endif
+
+#undef VM_CALL_HOOK
+#if VM_USE_CALL_HOOK
+#define VM_CALL_HOOK() SYNC (); scm_c_run_hook (vmp->call_hook, hook_args)
+#else
+#define VM_CALL_HOOK()
+#endif
+
+#undef VM_APPLY_HOOK
+#if VM_USE_APPLY_HOOK
+#define VM_APPLY_HOOK() SYNC (); scm_c_run_hook (vmp->apply_hook, hook_args)
+#else
+#define VM_APPLY_HOOK()
+#endif
+
+#undef VM_RETURN_HOOK
+#if VM_USE_RETURN_HOOK
+#define VM_RETURN_HOOK() SYNC (); scm_c_run_hook (vmp->return_hook, hook_args)
+#else
+#define VM_RETURN_HOOK()
+#endif
+
+\f
+/*
+ * Basic operations
+ */
+
+#define LOAD() \
+{ \
+ ac = vmp->ac; \
+ pc = vmp->pc; \
+ sp = vmp->sp; \
+ fp = vmp->fp; \
+ stack_base = vmp->stack_base; \
+ stack_limit = vmp->stack_limit; \
+}
+
+#define SYNC() \
+{ \
+ vmp->ac = ac; \
+ vmp->pc = pc; \
+ vmp->sp = sp; \
+ vmp->fp = fp; \
+}
+
+#define FETCH() *pc++
+
+#define CONS(X,Y,Z) \
+{ \
+ SCM cell; \
+ SYNC (); \
+ SCM_NEWCELL (cell); \
+ SCM_SET_CELL_OBJECT_0 (cell, Y); \
+ SCM_SET_CELL_OBJECT_1 (cell, Z); \
+ X = cell; \
+}
+
+#define VM_SETUP_ARGS2() an = 2; a2 = ac; POP (ac);
+#define VM_SETUP_ARGS3() an = 3; a3 = ac; POP (a2); POP (ac);
+#define VM_SETUP_ARGS4() an = 4; a4 = ac; POP (a3); POP (a2); POP (ac);
+#define VM_SETUP_ARGSN() an = SCM_INUM (FETCH ());
+
+\f
+/*
+ * Stack operation
+ */
+
+#define PUSH(X) \
+{ \
+ if (sp < stack_base) \
+ SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \
+ *sp-- = (X); \
+}
+
+#define POP(X) \
+{ \
+ if (sp == stack_limit) \
+ SCM_MISC_ERROR ("FIXME: Stack underflow", SCM_EOL); \
+ (X) = *++sp; \
+}
+
+#define POP_LIST(N,L) \
+{ \
+ while (N-- > 0) \
+ { \
+ SCM obj; \
+ POP (obj); \
+ CONS (L, obj, L); \
+ } \
+}
+
+\f
+/*
+ * Frame allocation
+ */
+
+/* an = the number of arguments */
+#define VM_SETUP_ARGS(PROG,NREQS,RESTP) \
+{ \
+ if (RESTP) \
+ /* have a rest argument */ \
+ { \
+ SCM list; \
+ if (an < NREQS) \
+ scm_wrong_num_args (PROG); \
+ \
+ /* Construct the rest argument list */ \
+ an -= NREQS; /* the number of rest arguments */ \
+ list = SCM_EOL; /* list of the rest arguments */ \
+ POP_LIST (an, list); \
+ PUSH (list); \
+ } \
+ else \
+ /* not have a rest argument */ \
+ { \
+ if (an != NREQS) \
+ scm_wrong_num_args (PROG); \
+ } \
+}
+
+#define VM_EXPORT_ARGS(FP,PROG) \
+{ \
+ int *exts = SCM_PROGRAM_EXTS (PROG); \
+ if (exts) \
+ { \
+ int n = exts[0]; \
+ while (n-- > 0) \
+ SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (PROG), n) \
+ = SCM_VM_FRAME_VARIABLE (FP, exts[n + 1]); \
+ } \
+}
+
+#undef VM_FRAME_INIT_VARIABLES
+#if VM_INIT_LOCAL_VARIABLES
+/* This is necessary when creating frame objects for debugging */
+#define VM_FRAME_INIT_VARIABLES(FP,NVARS) \
+{ \
+ int i; \
+ for (i = 0; i < NVARS; i++) \
+ SCM_VM_FRAME_VARIABLE (FP, i) = SCM_UNDEFINED; \
+}
+#else
+#define VM_FRAME_INIT_VARIABLES(FP,NVARS)
+#endif
+
+#define VM_NEW_FRAME(FP,PROG,DL,SP,RA) \
+{ \
+ int nvars = SCM_PROGRAM_NVARS (PROG); /* the number of local vars */ \
+ int nreqs = SCM_PROGRAM_NREQS (PROG); /* the number of required args */ \
+ int restp = SCM_PROGRAM_RESTP (PROG); /* have a rest argument or not */ \
+ \
+ VM_SETUP_ARGS (PROG, nreqs, restp); \
+ if (sp - nvars - SCM_VM_FRAME_DATA_SIZE < stack_base - 1) \
+ SCM_MISC_ERROR ("FIXME: Stack overflow", SCM_EOL); \
+ sp -= nvars + SCM_VM_FRAME_DATA_SIZE; \
+ FP = sp + SCM_VM_FRAME_DATA_SIZE + 1; \
+ SCM_VM_FRAME_SIZE (FP) = SCM_MAKINUM (nvars); \
+ SCM_VM_FRAME_PROGRAM (FP) = PROG; \
+ SCM_VM_FRAME_DYNAMIC_LINK (FP) = DL; \
+ SCM_VM_FRAME_STACK_POINTER (FP) = SP; \
+ SCM_VM_FRAME_RETURN_ADDRESS (FP) = RA; \
+ VM_FRAME_INIT_VARIABLES (FP, nvars); \
+ VM_EXPORT_ARGS (FP, PROG); \
+}
+
+\f
+/*
+ * Goto next
+ */
+
+#undef VM_PROGRAM_COUNTER_CHECK
+#if VM_CHECK_PROGRAM_COUNTER
+#define VM_PROGRAM_COUNTER_CHECK() \
+{ \
+ SCM prog = SCM_VM_FRAME_PROGRAM (fp); \
+ if (pc < SCM_PROGRAM_BASE (prog) \
+ || pc >= (SCM_PROGRAM_BASE (prog) + SCM_PROGRAM_SIZE (prog))) \
+ SCM_MISC_ERROR ("VM accessed invalid program address", SCM_EOL); \
+}
+#else
+#define VM_PROGRAM_COUNTER_CHECK()
+#endif
+
+#undef VM_GOTO_NEXT
+#if HAVE_LABELS_AS_VALUES
+#if VM_ENGINE == SCM_VM_DEBUG_ENGINE
+#define VM_GOTO_NEXT() goto *SCM_CODE_TO_DEBUG_ADDR (FETCH ())
+#else /* not SCM_VM_DEBUG_ENGINE */
+#define VM_GOTO_NEXT() goto *SCM_CODE_TO_ADDR (FETCH ())
+#endif
+#else /* not HAVE_LABELS_AS_VALUES */
+#define VM_GOTO_NEXT() goto vm_start
+#endif
+
+#define NEXT \
+{ \
+ VM_PROGRAM_COUNTER_CHECK (); \
+ VM_NEXT_HOOK (); \
+ VM_GOTO_NEXT (); \
+}
+
+/* Just an abbreviation */
+#define RETURN(X) { ac = (X); NEXT; }
--- /dev/null
+/* Copyright (C) 2000 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 */
+
+#include "vm-snarf.h"
+
+SCM_DEFINE_VM_FUNCTION (zero_p, "zero?", "zero?", 1, 0)
+{
+ if (SCM_INUMP (ac))
+ RETURN (SCM_BOOL (SCM_EQ_P (ac, SCM_INUM0)));
+ RETURN (scm_zero_p (ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (inc, "1+", "inc", 1, 0)
+{
+ if (SCM_INUMP (ac))
+ {
+ int n = SCM_INUM (ac) + 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_sum (ac, SCM_MAKINUM (1)));
+}
+
+SCM_DEFINE_VM_FUNCTION (dec, "1-", "dec", 1, 0)
+{
+ if (SCM_INUMP (ac))
+ {
+ int n = SCM_INUM (ac) - 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_difference (ac, SCM_MAKINUM (1)));
+}
+
+SCM_DEFINE_VM_FUNCTION (add, "+", "add", 0, 1)
+{
+ VM_SETUP_ARGSN ();
+ ac = SCM_MAKINUM (0);
+ while (an-- > 0)
+ {
+ POP (a2);
+ if (SCM_INUMP (ac) && SCM_INUMP (a2))
+ {
+ int n = SCM_INUM (ac) + SCM_INUM (a2);
+ if (SCM_FIXABLE (n))
+ {
+ ac = SCM_MAKINUM (n);
+ continue;
+ }
+ }
+ ac = scm_sum (ac, a2);
+ }
+ NEXT;
+}
+
+SCM_DEFINE_VM_FUNCTION (add2, "+", "add2", 2, 0)
+{
+ VM_SETUP_ARGS2 ();
+ if (SCM_INUMP (ac) && SCM_INUMP (a2))
+ {
+ int n = SCM_INUM (ac) + SCM_INUM (a2);
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_sum (ac, a2));
+}
+
+SCM_DEFINE_VM_FUNCTION (sub, "-", "sub", 1, 1)
+{
+ VM_SETUP_ARGSN ();
+ ac = SCM_MAKINUM (0);
+ while (an-- > 1)
+ {
+ POP (a2);
+ if (SCM_INUMP (ac) && SCM_INUMP (a2))
+ {
+ int n = SCM_INUM (ac) + SCM_INUM (a2);
+ if (SCM_FIXABLE (n))
+ {
+ ac = SCM_MAKINUM (n);
+ continue;
+ }
+ }
+ ac = scm_difference (ac, a2);
+ }
+ POP (a2);
+ if (SCM_INUMP (ac) && SCM_INUMP (a2))
+ {
+ int n = SCM_INUM (a2) - SCM_INUM (ac);
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_difference (a2, ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (sub2, "-", "sub2", 2, 0)
+{
+ VM_SETUP_ARGS2 ();
+ if (SCM_INUMP (ac) && SCM_INUMP (a2))
+ {
+ int n = SCM_INUM (ac) - SCM_INUM (a2);
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_difference (ac, a2));
+}
+
+SCM_DEFINE_VM_FUNCTION (minus, "-", "minus", 1, 0)
+{
+ if (SCM_INUMP (ac))
+ {
+ int n = - SCM_INUM (ac);
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_MAKINUM (n));
+ }
+ RETURN (scm_difference (ac, SCM_UNDEFINED));
+}
+
+#define REL2(CREL,SREL) \
+ VM_SETUP_ARGS2 (); \
+ if (SCM_INUMP (ac) && SCM_INUMP (a2)) \
+ RETURN (SCM_BOOL (SCM_INUM (ac) CREL SCM_INUM (a2))); \
+ RETURN (SREL (ac, a2))
+
+SCM_DEFINE_VM_FUNCTION (lt2, "<", "lt2", 2, 0)
+{
+ REL2 (<, scm_less_p);
+}
+
+SCM_DEFINE_VM_FUNCTION (gt2, ">", "gt2", 2, 0)
+{
+ REL2 (>, scm_gr_p);
+}
+
+SCM_DEFINE_VM_FUNCTION (le2, "<=", "le2", 2, 0)
+{
+ REL2 (<=, scm_leq_p);
+}
+
+SCM_DEFINE_VM_FUNCTION (ge2, ">=", "ge2", 2, 0)
+{
+ REL2 (>=, scm_geq_p);
+}
+
+SCM_DEFINE_VM_FUNCTION (num_eq2, "=", "num-eq2", 2, 0)
+{
+ REL2 (==, scm_num_eq_p);
+}
--- /dev/null
+/* Copyright (C) 2000 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 */
+
+#include "vm-snarf.h"
+
+SCM_DEFINE_VM_FUNCTION (null_p, "null?", "null?", 1, 0)
+{
+ RETURN (SCM_BOOL (SCM_NULLP (ac)));
+}
+
+SCM_DEFINE_VM_FUNCTION (cons, "cons", "cons", 2, 0)
+{
+ VM_SETUP_ARGS2 ();
+ CONS (ac, ac, a2);
+ NEXT;
+}
+
+SCM_DEFINE_VM_FUNCTION (list, "list", "list", 0, 1)
+{
+ VM_SETUP_ARGSN ();
+ ac = SCM_EOL;
+ POP_LIST (an, ac);
+ NEXT;
+}
+
+SCM_DEFINE_VM_FUNCTION (car, "car", "car", 1, 0)
+{
+ SCM_VALIDATE_CONS (0, ac);
+ RETURN (SCM_CAR (ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (cdr, "cdr", "cdr", 1, 0)
+{
+ SCM_VALIDATE_CONS (0, ac);
+ RETURN (SCM_CDR (ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (not, "not", "not", 1, 0)
+{
+ RETURN (SCM_BOOL (SCM_FALSEP (ac)));
+}
+
+SCM_DEFINE_VM_FUNCTION (append, "append", "append", 0, 1)
+{
+ VM_SETUP_ARGSN ();
+ ac = SCM_EOL;
+ POP_LIST (an, ac);
+ RETURN (scm_append (ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (append_x, "append!", "append!", 0, 1)
+{
+ VM_SETUP_ARGSN ();
+ ac = SCM_EOL;
+ POP_LIST (an, ac);
+ RETURN (scm_append_x (ac));
+}
+
+SCM_DEFINE_VM_FUNCTION (catch, "catch", "catch", 3, 0)
+{
+ VM_SETUP_ARGS3 ();
+ dynwinds = SCM_EOL;
+}
+
+SCM_DEFINE_VM_FUNCTION (call_cc, "call-with-current-continuation", "call/cc", 1, 0)
+{
+ SYNC (); /* must sync all registers */
+ PUSH (SCM_VM_CAPTURE_CONT (vmp)); /* argument 1 */
+ an = 1; /* the number of arguments */
+ goto vm_call;
+}
--- /dev/null
+/* Copyright (C) 2000 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 */
+
+#include "vm-snarf.h"
+
+/*
+ * Variable access
+ */
+
+#undef LOCAL_VAR
+#define LOCAL_VAR(OFFSET) SCM_VM_FRAME_VARIABLE (fp, OFFSET)
+
+#undef EXTERNAL_FOCUS
+#define EXTERNAL_FOCUS(DEPTH) \
+{ \
+ int depth = DEPTH; \
+ env = SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)); \
+ while (depth-- > 0) \
+ { \
+ VM_ASSERT_LINK (env); \
+ env = SCM_VM_EXTERNAL_LINK (env); \
+ } \
+}
+
+#undef EXTERNAL_VAR
+#define EXTERNAL_VAR(OFFSET) SCM_VM_EXTERNAL_VARIABLE (env, OFFSET)
+#undef EXTERNAL_VAR0
+#define EXTERNAL_VAR0(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)), OFFSET)
+#define EXTERNAL_VAR1(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp))), OFFSET)
+#define EXTERNAL_VAR2(OFFSET) SCM_VM_EXTERNAL_VARIABLE (SCM_VM_EXTERNAL_LINK (SCM_VM_EXTERNAL_LINK (SCM_PROGRAM_ENV (SCM_VM_FRAME_PROGRAM (fp)))), OFFSET)
+
+#undef TOPLEVEL_VAR
+#define TOPLEVEL_VAR(CELL) SCM_CDR (CELL)
+#undef TOPLEVEL_VAR_SET
+#define TOPLEVEL_VAR_SET(CELL,OBJ) SCM_SETCDR (CELL, OBJ)
+
+\f
+/*
+ * Basic operations
+ */
+
+/* Must be the first instruction! */
+SCM_DEFINE_INSTRUCTION (nop, "%nop", INST_NONE)
+{
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (halt, "%halt", INST_NONE)
+{
+ SYNC ();
+ VM_HALT_HOOK ();
+ return ac;
+}
+
+\f
+/*
+ * %push family
+ */
+
+SCM_DEFINE_INSTRUCTION (push, "%push", INST_NONE)
+{
+ PUSH (ac);
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushc, "%pushc", INST_SCM)
+{
+ PUSH (FETCH ());
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushl, "%pushl", INST_INUM)
+{
+ PUSH (LOCAL_VAR (SCM_INUM (FETCH ())));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushl_0, "%pushl:0", INST_NONE)
+{
+ PUSH (LOCAL_VAR (0));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushl_1, "%pushl:1", INST_NONE)
+{
+ PUSH (LOCAL_VAR (1));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe, "%pushe", INST_EXT)
+{
+ SCM env;
+ SCM loc = FETCH ();
+ EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
+ PUSH (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_0, "%pushe:0", INST_INUM)
+{
+ PUSH (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_0_0, "%pushe:0:0", INST_NONE)
+{
+ PUSH (EXTERNAL_VAR0 (0));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_0_1, "%pushe:0:1", INST_NONE)
+{
+ PUSH (EXTERNAL_VAR0 (1));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_1, "%pushe:1", INST_INUM)
+{
+ PUSH (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_1_0, "%pushe:1:0", INST_NONE)
+{
+ PUSH (EXTERNAL_VAR1 (0));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_1_1, "%pushe:1:1", INST_NONE)
+{
+ PUSH (EXTERNAL_VAR1 (1));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pushe_2, "%pushe:2", INST_INUM)
+{
+ PUSH (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (pusht, "%pusht", INST_TOP)
+{
+ ac = FETCH ();
+ VM_ASSERT_BOUND (ac);
+ PUSH (TOPLEVEL_VAR (ac));
+ NEXT;
+}
+
+\f
+/*
+ * %load family
+ */
+
+SCM_DEFINE_INSTRUCTION (load_unspecified, "%load-unspecified", INST_NONE)
+{
+ RETURN (SCM_UNSPECIFIED);
+}
+
+SCM_DEFINE_INSTRUCTION (loadc, "%loadc", INST_SCM)
+{
+ RETURN (FETCH ());
+}
+
+SCM_DEFINE_INSTRUCTION (loadl, "%loadl", INST_INUM)
+{
+ RETURN (LOCAL_VAR (SCM_INUM (FETCH ())));
+}
+
+SCM_DEFINE_INSTRUCTION (loadl_0, "%loadl:0", INST_NONE)
+{
+ RETURN (LOCAL_VAR (0));
+}
+
+SCM_DEFINE_INSTRUCTION (loadl_1, "%loadl:1", INST_NONE)
+{
+ RETURN (LOCAL_VAR (1));
+}
+
+SCM_DEFINE_INSTRUCTION (loade, "%loade", INST_EXT)
+{
+ SCM env;
+ SCM loc = FETCH ();
+ EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
+ RETURN (EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_0, "%loade:0", INST_INUM)
+{
+ RETURN (EXTERNAL_VAR0 (SCM_INUM (FETCH ())));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_0_0, "%loade:0:0", INST_NONE)
+{
+ RETURN (EXTERNAL_VAR0 (0));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_0_1, "%loade:0:1", INST_NONE)
+{
+ RETURN (EXTERNAL_VAR0 (1));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_1, "%loade:1", INST_INUM)
+{
+ RETURN (EXTERNAL_VAR1 (SCM_INUM (FETCH ())));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_1_0, "%loade:1:0", INST_NONE)
+{
+ RETURN (EXTERNAL_VAR1 (0));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_1_1, "%loade:1:1", INST_NONE)
+{
+ RETURN (EXTERNAL_VAR1 (1));
+}
+
+SCM_DEFINE_INSTRUCTION (loade_2, "%loade:2", INST_INUM)
+{
+ RETURN (EXTERNAL_VAR2 (SCM_INUM (FETCH ())));
+}
+
+SCM_DEFINE_INSTRUCTION (loadt, "%loadt", INST_TOP)
+{
+ ac = FETCH ();
+ VM_ASSERT_BOUND (ac);
+ RETURN (TOPLEVEL_VAR (ac));
+}
+
+\f
+/*
+ * %save family
+ */
+
+SCM_DEFINE_INSTRUCTION (savel, "%savel", INST_INUM)
+{
+ LOCAL_VAR (SCM_INUM (FETCH ())) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savel_0, "%savel:0", INST_NONE)
+{
+ LOCAL_VAR (0) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savel_1, "%savel:1", INST_NONE)
+{
+ LOCAL_VAR (1) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee, "%savee", INST_EXT)
+{
+ SCM env;
+ SCM loc = FETCH ();
+ EXTERNAL_FOCUS (SCM_INUM (SCM_CAR (loc)));
+ EXTERNAL_VAR (SCM_INUM (SCM_CDR (loc))) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_0, "%savee:0", INST_INUM)
+{
+ EXTERNAL_VAR0 (SCM_INUM (FETCH ())) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_0_0, "%savee:0:0", INST_NONE)
+{
+ EXTERNAL_VAR0 (0) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_0_1, "%savee:0:1", INST_NONE)
+{
+ EXTERNAL_VAR0 (1) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_1, "%savee:1", INST_INUM)
+{
+ EXTERNAL_VAR1 (SCM_INUM (FETCH ())) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_1_0, "%savee:1:0", INST_NONE)
+{
+ EXTERNAL_VAR1 (0) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_1_1, "%savee:1:1", INST_NONE)
+{
+ EXTERNAL_VAR1 (1) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savee_2, "%savee:2", INST_INUM)
+{
+ EXTERNAL_VAR2 (SCM_INUM (FETCH ())) = ac;
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (savet, "%savet", INST_TOP)
+{
+ SCM cell = FETCH ();
+ scm_set_object_property_x (ac, scm_sym_name, SCM_CAR (cell));
+ TOPLEVEL_VAR_SET (cell, ac);
+ NEXT;
+}
+
+\f
+/*
+ * branch and jump
+ */
+
+SCM_DEFINE_INSTRUCTION (br_if, "%br-if", INST_ADDR)
+{
+ SCM addr = FETCH (); /* must always fetch */
+ if (!SCM_FALSEP (ac))
+ pc = SCM_VM_ADDRESS (addr);
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (br_if_not, "%br-if-not", INST_ADDR)
+{
+ SCM addr = FETCH (); /* must always fetch */
+ if (SCM_FALSEP (ac))
+ pc = SCM_VM_ADDRESS (addr);
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (br_if_null, "%br-if-null", INST_ADDR)
+{
+ SCM addr = FETCH (); /* must always fetch */
+ if (SCM_NULLP (ac))
+ pc = SCM_VM_ADDRESS (addr);
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (br_if_not_null, "%br-if-not-null", INST_ADDR)
+{
+ SCM addr = FETCH (); /* must always fetch */
+ if (!SCM_NULLP (ac))
+ pc = SCM_VM_ADDRESS (addr);
+ NEXT;
+}
+
+SCM_DEFINE_INSTRUCTION (jump, "%jump", INST_ADDR)
+{
+ pc = SCM_VM_ADDRESS (*pc);
+ NEXT;
+}
+
+\f
+/*
+ * Subprogram call
+ */
+
+SCM_DEFINE_INSTRUCTION (make_program, "%make-program", INST_CODE)
+{
+ SYNC (); /* must be called before GC */
+ RETURN (SCM_MAKE_PROGRAM (FETCH (), SCM_VM_FRAME_PROGRAM (fp)));
+}
+
+/* Before:
+ ac = program
+ pc[0] = the number of arguments
+
+ After:
+ pc = program's address
+*/
+SCM_DEFINE_INSTRUCTION (call, "%call", INST_INUM)
+{
+ an = SCM_INUM (FETCH ()); /* the number of arguments */
+
+ vm_call:
+ /*
+ * Subprogram call
+ */
+ if (SCM_PROGRAM_P (ac))
+ {
+ /* Create a new frame */
+ SCM *last_fp = fp;
+ SCM *last_sp = sp + an;
+ VM_NEW_FRAME (fp, ac,
+ SCM_VM_MAKE_ADDRESS (last_fp),
+ SCM_VM_MAKE_ADDRESS (last_sp),
+ SCM_VM_MAKE_ADDRESS (pc));
+ VM_CALL_HOOK ();
+
+ /* Jump to the program */
+ pc = SCM_PROGRAM_BASE (ac);
+ VM_APPLY_HOOK ();
+ NEXT;
+ }
+ /*
+ * Function call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (ac)))
+ {
+ /* Construct an argument list */
+ SCM list = SCM_EOL;
+ POP_LIST (an, list);
+ RETURN (scm_apply (ac, list, SCM_EOL));
+ }
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (ac))
+ {
+ vm_call_cc:
+ /* Check the number of arguments */
+ if (an != 1)
+ scm_wrong_num_args (ac);
+
+ /* Reinstate the continuation */
+ SCM_VM_REINSTATE_CONT (vmp, ac);
+ LOAD ();
+ POP (ac); /* return value */
+ VM_RETURN_HOOK ();
+ NEXT;
+ }
+
+ SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac));
+}
+
+/* Before:
+ ac = program
+ pc[0] = the number of arguments
+
+ After:
+ pc = program's address
+*/
+SCM_DEFINE_INSTRUCTION (tail_call, "%tail-call", INST_INUM)
+{
+ an = SCM_INUM (FETCH ()); /* the number of arguments */
+
+ /*
+ * Subprogram call
+ */
+ if (SCM_PROGRAM_P (ac))
+ {
+ if (SCM_EQ_P (ac, SCM_VM_FRAME_PROGRAM (fp)))
+ /* Tail recursive call */
+ {
+ /* Setup arguments */
+ int nvars = SCM_PROGRAM_NVARS (ac); /* the number of local vars */
+ int nreqs = SCM_PROGRAM_NREQS (ac); /* the number of require args */
+ int restp = SCM_PROGRAM_RESTP (ac); /* have a rest argument */
+ VM_SETUP_ARGS (ac, nreqs, restp);
+
+ /* Move arguments */
+ nreqs += restp;
+ while (nreqs-- > 0)
+ {
+ SCM obj;
+ POP (obj);
+ SCM_VM_FRAME_VARIABLE (fp, nvars++) = obj;
+ }
+ VM_EXPORT_ARGS (fp, ac);
+ }
+ else
+ /* Dynamic return call */
+ {
+ /* Create a new frame */
+ SCM *p = fp;
+ VM_NEW_FRAME (fp, ac,
+ SCM_VM_FRAME_DYNAMIC_LINK (p),
+ SCM_VM_FRAME_STACK_POINTER (p),
+ SCM_VM_FRAME_RETURN_ADDRESS (p));
+ VM_CALL_HOOK ();
+ }
+
+ /* Jump to the program */
+ pc = SCM_PROGRAM_BASE (ac);
+ VM_APPLY_HOOK ();
+ NEXT;
+ }
+ /*
+ * Function call
+ */
+ if (!SCM_FALSEP (scm_procedure_p (ac)))
+ {
+ /* Construct an argument list */
+ SCM list = SCM_EOL;
+ POP_LIST (an, list);
+ ac = scm_apply (ac, list, SCM_EOL);
+ goto vm_return;
+ }
+ /*
+ * Continuation call
+ */
+ if (SCM_VM_CONT_P (ac))
+ goto vm_call_cc;
+
+ SCM_MISC_ERROR ("Wrong type to apply: ~S", SCM_LIST1 (ac));
+}
+
+SCM_DEFINE_INSTRUCTION (return, "%return", INST_NONE)
+{
+ SCM *last_fp;
+ vm_return:
+ VM_RETURN_HOOK ();
+ last_fp = fp;
+ fp = SCM_VM_ADDRESS (SCM_VM_FRAME_DYNAMIC_LINK (last_fp));
+ sp = SCM_VM_ADDRESS (SCM_VM_FRAME_STACK_POINTER (last_fp));
+ pc = SCM_VM_ADDRESS (SCM_VM_FRAME_RETURN_ADDRESS (last_fp));
+ NEXT;
+}
--- /dev/null
+SOURCE_FILES = control.scm procedure.scm queens.scm
+COMPILED_FILES = control.scc procedure.scc queens.scc
+EXTRA_DIST = test.scm $(SOURCE_FILES)
+CLEANFILES = $(COMPILED_FILES)
+MAINTAINERCLEANFILES = Makefile.in
+
+GUILE = $(top_srcdir)/src/$(PACKAGE)
+
+test: $(COMPILED_FILES)
+ @for file in $(COMPILED_FILES); do \
+ $(GUILE) -s test.scm $$file; \
+ done
+
+SUFFIXES = .scm .scc
+.scm.scc:
+ guile-compile $<
--- /dev/null
+
+(define income-tax
+ (lambda (income)
+ (cond
+ ((<= income 10000)
+ (* income .05))
+ ((<= income 20000)
+ (+ (* (- income 10000) .08)
+ 500.00))
+ ((<= income 30000)
+ (+ (* (- income 20000) .13)
+ 1300.00))
+ (else
+ (+ (* (- income 30000) .21)
+ 2600.00)))))
+
+(test (income-tax 5000) 250.0)
+(test (income-tax 15000) 900.0)
+(test (income-tax 25000) 1950.0)
+(test (income-tax 50000) 6800.0)
--- /dev/null
+(define length
+ (lambda (ls)
+ (if (null? ls)
+ 0
+ (+ (length (cdr ls)) 1))))
+
+(test (length '()) 0)
+(test (length '(a)) 1)
+(test (length '(a b)) 2)
+
+(define remv
+ (lambda (x ls)
+ (cond
+ ((null? ls) '())
+ ((eqv? (car ls) x) (remv x (cdr ls)))
+ (else (cons (car ls) (remv x (cdr ls)))))))
+
+(test (remv 'a '(a b b d)) '(b b d))
+(test (remv 'b '(a b b d)) '(a d))
+(test (remv 'c '(a b b d)) '(a b b d))
+(test (remv 'd '(a b b d)) '(a b b))
+
+(define tree-copy
+ (lambda (tr)
+ (if (not (pair? tr))
+ tr
+ (cons (tree-copy (car tr))
+ (tree-copy (cdr tr))))))
+
+(test (tree-copy '((a . b) . c)) '((a . b) . c))
+
+(define quadratic-formula
+ (lambda (a b c)
+ (let ((root1 0) (root2 0) (minusb 0) (radical 0) (divisor 0))
+ (set! minusb (- 0 b))
+ (set! radical (sqrt (- (* b b) (* 4 (* a c)))))
+ (set! divisor (* 2 a))
+ (set! root1 (/ (+ minusb radical) divisor))
+ (set! root2 (/ (- minusb radical) divisor))
+ (cons root1 root2))))
+
+(test (quadratic-formula 2 -4 -6) '(3.0 . -1.0))
+
+(define count
+ (let ((n 0))
+ (lambda ()
+ (set! n (1+ n))
+ n)))
+
+(test (count) 1)
+(test (count) 2)
+
+(define (fibonacci i)
+ (cond ((= i 0) 0)
+ ((= i 1) 1)
+ (else (+ (fibonacci (- i 1)) (fibonacci (- i 2))))))
+
+(test (fibonacci 0) 0)
+(test (fibonacci 5) 5)
+(test (fibonacci 10) 55)
--- /dev/null
+(define (filter predicate sequence)
+ (cond ((null? sequence) '())
+ ((predicate (car sequence))
+ (cons (car sequence)
+ (filter predicate (cdr sequence))))
+ (else (filter predicate (cdr sequence)))))
+
+(define (accumulate op initial sequence)
+ (if (null? sequence)
+ initial
+ (op (car sequence)
+ (accumulate op initial (cdr sequence)))))
+
+(define (flatmap proc seq)
+ (accumulate append '() (map proc seq)))
+
+(define (enumerate-interval low high)
+ (if (> low high)
+ '()
+ (cons low (enumerate-interval (+ low 1) high))))
+
+(define empty-board '())
+
+(define (rest bs k rest-of-queens)
+ (map (lambda (new-row)
+ (adjoin-position new-row k rest-of-queens))
+ (enumerate-interval 1 bs)))
+
+(define (queen-cols board-size k)
+ (if (= k 0)
+ (list empty-board)
+ (filter (lambda (positions) (safe? k positions))
+ (flatmap (lambda (r) (rest board-size k r))
+ (queen-cols board-size (- k 1))))))
+
+(define (queens board-size)
+ (queen-cols board-size board-size))
+
+(define (adjoin-position new-row k rest-of-queens)
+ (append rest-of-queens (list new-row)))
+
+(define (safe? k positions)
+ (let ((new (car (last-pair positions)))
+ (bottom (car positions)))
+ (cond ((= k 1) #t)
+ ((= new bottom) #f)
+ ((or (= new (- bottom (- k 1))) (= new (+ bottom (- k 1)))) #f)
+ (else (safe? (- k 1) (cdr positions))))))
+
+(test (queens 4) '((2 4 1 3) (3 1 4 2)))
--- /dev/null
+
+(set! %load-path (cons ".." %load-path))
+(use-modules (vm vm))
+
+(define (test a b)
+ (if (equal? a b)
+ (display "OK\n")
+ (display "failed\n")))
+
+(let ((file (cadr (command-line))))
+ (format #t "Testing ~S...\n" file)
+ (load file))
--- /dev/null
+vmdatadir = $(datadir)/guile/vm
+vmdata_DATA = utils.scm types.scm bytecomp.scm compile.scm shell.scm
+noinst_DATA = libvm.so
+
+EXTRA_DIST = $(vmdata_DATA)
+CLEANFILES = $(noinst_DATA)
+MAINTAINERCLEANFILES = Makefile.in
+
+libvm.so:
+ $(LN_S) -f ../src/.libs/libguilevm.so ./libvm.so
+
+install-data-local:
+ rm -f $(vmdatadir)/libvm.so \
+ && $(LN_S) $(libdir)/libguilevm.so $(vmdatadir)/libvm.so
--- /dev/null
+;;; bytecomp.scm --- convert an intermediate code to an assemble code
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (vm bytecomp)
+ :use-module (vm vm)
+ :use-module (vm utils)
+ :use-module (vm types)
+ :export (byte-compile))
+
+(define (byte-compile nreqs restp code)
+ (vector (byte-header nreqs restp (code-env code))
+ (byte-finalize (byte-optimize (byte-translate code)))))
+
+\f
+;;;
+;;; Bytecode header
+;;;
+
+(define (byte-header nreqs restp env)
+ (list->vector (cons* nreqs restp (env-header env))))
+
+\f
+;;;
+;;; Bytecode translation
+;;;
+
+(define (byte-translate code)
+ (let ((stack '()))
+ ;; push opcode
+ (define (push-code! . args)
+ (set! stack (cons args stack)))
+ (let trans ((code code) (use-stack #f) (tail #t))
+ (let ((tag (code-tag code))
+ (env (code-env code))
+ (args (code-args code)))
+ ;;;
+ ;;; Utilities
+ ;;;
+ ;; push the result into the stack
+ (define (trans-use-stack code) (trans code #t #f))
+ ;; just set the accumulator
+ (define (trans-non-stack code) (trans code #f #f))
+ ;; code can be a tail position
+ (define (trans-tail code) (trans code #f tail))
+ ;; set unspecified when a tail position
+ (define (unspecified-position) (if tail (push-code! '%load-unspecified)))
+ ;; return here when a tail position
+ (define (return-position) (if tail (push-code! '%return)))
+ ;; push the result into the stack
+ (define (push-position) (if use-stack (push-code! '%push)))
+ ;; return or push
+ (define (return-or-push) (return-position) (push-position))
+
+ ;;;
+ ;;; Translators
+ ;;;
+ (define (translate-unspecified)
+ ;; #:unspecified
+ ;; %load-unspecified
+ (push-code! '%load-unspecified)
+ (return-or-push))
+
+ (define (translate-constant obj)
+ ;; #:constant OBJ
+ ;; %pushc OBJ (if use-stack)
+ ;; %loadc OBJ (if non-stack)
+ (if use-stack
+ (push-code! '%pushc obj)
+ (push-code! '%loadc obj))
+ (return-position))
+
+ (define (translate-local-var name var)
+ (let* ((offset (env-variable-address env var))
+ (abbrev (string->symbol (format #f "~A:~A" name offset))))
+ (if (instruction-name? abbrev)
+ (push-code! abbrev)
+ (push-code! name offset))))
+
+ (define (translate-external-var name var)
+ (let* ((addr (env-variable-address env var))
+ (depth (car addr))
+ (offset (cdr addr))
+ (abbrev1 (string->symbol
+ (format #f "~A:~A" name depth)))
+ (abbrev2 (string->symbol
+ (format #f "~A:~A:~A" name depth offset))))
+ (cond ((instruction-name? abbrev2) (push-code! abbrev2))
+ ((instruction-name? abbrev1) (push-code! abbrev1 offset))
+ (else (push-code! name addr)))))
+
+ (define (translate-top-level-var name var)
+ (push-code! name (variable-name var)))
+
+ (define (translate-local-ref var)
+ ;; #:ref #<vm:local-var>
+ ;; %pushl OFFSET (if use-stack)
+ ;; %loadl OFFSET (if non-stack)
+ (assert variable? var)
+ (translate-local-var (if use-stack '%pushl '%loadl) var)
+ (return-position))
+
+ (define (translate-external-ref var)
+ ;; #:ref #<vm:external-var>
+ ;; %pushe (DEPTH . OFFSET) (if use-stack)
+ ;; %loade (DEPTH . OFFSET) (if non-stack)
+ (assert variable? var)
+ (translate-external-var (if use-stack '%pushe '%loade) var)
+ (return-position))
+
+ (define (translate-top-level-ref var)
+ ;; #:ref #<vm:top-level-var>
+ ;; %pusht SYMBOL (if use-stack)
+ ;; %loadt SYMBOL (if non-stack)
+ (assert variable? var)
+ (translate-top-level-var (if use-stack '%pusht '%loadt) var)
+ (return-position))
+
+ (define (translate-local-set var obj)
+ ;; #:set #<vm:local-var> OBJ
+ ;; OBJ
+ ;; %savel OFFSET
+ (assert variable? var)
+ (trans-non-stack obj)
+ (translate-local-var '%savel var)
+ (unspecified-position)
+ (return-or-push))
+
+ (define (translate-external-set var obj)
+ ;; #:set #<vm:external-var> OBJ
+ ;; OBJ
+ ;; %savee (DEPTH . OFFSET)
+ (assert variable? var)
+ (trans-non-stack obj)
+ (translate-external-var '%savee var)
+ (unspecified-position)
+ (return-or-push))
+
+ (define (translate-top-level-set var obj)
+ ;; #:set #<vm:top-level-var> OBJ
+ ;; OBJ
+ ;; %savet SYMBOL
+ (assert variable? var)
+ (trans-non-stack obj)
+ (translate-top-level-var '%savet var)
+ (unspecified-position)
+ (return-or-push))
+
+ (define (translate-and . args)
+ ;; #:and ARG1 ARG2...
+ ;; ARG1
+ ;; %br-if-not L0
+ ;; ARG2
+ ;; %br-if-not L0
+ ;; ...
+ ;; L0:
+ (assert-for-each code? args)
+ (let ((L0 (make-label)))
+ (for-each (lambda (arg)
+ (trans-non-stack arg)
+ (push-code! '%br-if-not L0))
+ args)
+ (push-code! #:label L0))
+ (return-or-push))
+
+ (define (translate-or . args)
+ ;; #:or ARG1 ARG2...
+ ;; ARG1
+ ;; %br-if L0
+ ;; ARG2
+ ;; %br-if L0
+ ;; ...
+ ;; L0:
+ (assert-for-each code? args)
+ (let ((L0 (make-label)))
+ (for-each (lambda (arg)
+ (trans-non-stack arg)
+ (push-code! '%br-if L0))
+ args)
+ (push-code! #:label L0))
+ (return-or-push))
+
+ (define (translate-program nreqs restp code)
+ ;; #:make-program NREQS RESTP CODE
+ ;; %make-program BYTECODE
+ (push-code! '%make-program (byte-compile nreqs restp code))
+ (return-or-push))
+
+ (define (translate-label label)
+ ;; #:label is processed by byte-finalize
+ (assert label? label)
+ (push-code! #:label label))
+
+ (define (translate-goto label)
+ ;; #:goto LABEL
+ ;; %jump ADDR (calculated in byte-finalize)
+ (assert label? label)
+ (push-code! '%jump label))
+
+ (define (translate-if test then else)
+ ;; #:if TEST THEN ELSE
+ ;; TEST
+ ;; %br-if-not L1
+ ;; THEN (tail position)
+ ;; %jump L2 (if not tail)
+ ;; L1: ELSE (tail position)
+ ;; L2:
+ (assert code? test)
+ (assert code? then)
+ (assert code? else)
+ (let ((L1 (make-label))
+ (L2 (make-label)))
+ (trans-non-stack test)
+ (push-code! '%br-if-not L1)
+ (trans-tail then)
+ (if (not tail)
+ (push-code! '%jump L2))
+ (push-code! #:label L1)
+ (trans-tail else)
+ (push-code! #:label L2))
+ (push-position))
+
+ (define (translate-until test . body)
+ ;; #:until TEST BODY...
+ ;; L0: TEST
+ ;; %br-if L1
+ ;; BODY...
+ ;; %jump L0
+ ;; L1:
+ (assert code? test)
+ (assert-for-each code? body)
+ (let ((L0 (make-label))
+ (L1 (make-label)))
+ (push-code! #:label L0)
+ (trans-non-stack test)
+ (push-code! '%br-if L1)
+ (for-each trans-non-stack body)
+ (push-code! '%jump L0)
+ (push-code! #:label L1))
+ (unspecified-position)
+ (return-position))
+
+ (define (translate-begin . body)
+ ;; #:begin BODY... TAIL
+ ;; BODY...
+ ;; TAIL (tail position)
+ (assert-for-each code? body)
+ (let* ((list (reverse body))
+ (tail (car list))
+ (body (reverse! (cdr list))))
+ (for-each trans-non-stack body)
+ (trans-tail tail))
+ (push-position))
+
+ (define (translate-regular-call code . args)
+ ;; #:call CODE ARGS...
+ ;; ARGS... (-> stack)
+ ;; CODE
+ ;; %(tail-)call NARGS
+ (let ((nargs (length args)))
+ (for-each trans-use-stack args)
+ (trans-non-stack code)
+ (if tail
+ (push-code! '%tail-call nargs)
+ (push-code! '%call nargs)))
+ (push-position))
+
+ (define (translate-function-call inst . args)
+ ;; #:call INST ARGS...
+ (let ((name (instruction-name inst))
+ (nargs (length args)))
+ (cond
+ ((cadr (instruction-arity inst))
+ ;; ARGS... (-> stack)
+ ;; INST NARGS
+ (for-each trans-use-stack args)
+ (push-code! name nargs))
+ (else
+ (case nargs
+ ((0)
+ ;; INST
+ (push-code! name))
+ ((1)
+ ;; ARG1
+ ;; INST
+ (trans-non-stack (car args))
+ (push-code! name))
+ ((2)
+ ;; ARG1 (-> stack)
+ ;; ARG2
+ ;; INST
+ (trans-use-stack (car args))
+ (trans-non-stack (cadr args))
+ (push-code! name))
+ ((3)
+ ;; ARG1 (-> stack)
+ ;; ARG2 (-> stack)
+ ;; ARG3
+ ;; INST
+ (trans-use-stack (car args))
+ (trans-use-stack (cadr args))
+ (trans-non-stack (caddr args))
+ (push-code! name))))))
+ (return-or-push))
+
+ (define (translate-call obj . args)
+ (assert-for-each code? args)
+ (if (variable? obj)
+ (if (eq? (variable-type obj) 'function)
+ (cond
+ ((and (variable-bound? obj)
+ (and-let* ((obj (variable-value obj))
+ (def (assq-ref *vm-function-table* obj)))
+ (or (list-ref def (min (length args) 4))
+ (error "Wrong number of arguments"))))
+ => (lambda (inst)
+ (apply translate-function-call inst args)))
+ ((top-level-variable? obj)
+ (apply translate-regular-call
+ (make-code #:ref env obj) args)))
+ (apply translate-regular-call
+ (make-code #:ref env obj) args))
+ (apply translate-regular-call obj args)))
+
+ ;;;
+ ;;; Dispatch
+ ;;;
+ (case tag
+ ((#:unspecified)
+ ;; #:unspecified
+ (check-nargs args = 0)
+ (translate-unspecified))
+ ((#:constant)
+ ;; #:constant OBJ
+ (check-nargs args = 1)
+ (translate-constant (car args)))
+ ((#:ref)
+ ;; #:ref VAR
+ (check-nargs args = 1)
+ (let ((var (car args)))
+ (cond
+ ((local-variable? var) (translate-local-ref var))
+ ((external-variable? var) (translate-external-ref var))
+ ((top-level-variable? var) (translate-top-level-ref var)))))
+ ((#:set)
+ ;; #:set VAR OBJ
+ (check-nargs args = 2)
+ (let ((var (car args)) (obj (cadr args)))
+ (cond
+ ((local-variable? var) (translate-local-set var obj))
+ ((external-variable? var) (translate-external-set var obj))
+ ((top-level-variable? var) (translate-top-level-set var obj)))))
+ ((#:and)
+ ;; #:and ARGS...
+ (apply translate-and args))
+ ((#:or)
+ ;; #:or ARGS...
+ (apply translate-or args))
+ ((#:make-program)
+ ;; #:make-program NREQS RESTP CODE
+ (check-nargs args = 3)
+ (translate-program (car args) (cadr args) (caddr args)))
+ ((#:label)
+ ;; #:label LABEL
+ (check-nargs args = 1)
+ (translate-label (car args)))
+ ((#:goto)
+ ;; #:goto LABEL
+ (check-nargs args = 1)
+ (translate-goto (car args)))
+ ((#:if)
+ ;; #:if TEST THEN ELSE
+ (check-nargs args = 3)
+ (translate-if (car args) (cadr args) (caddr args)))
+ ((#:until)
+ ;; #:until TEST BODY...
+ (check-nargs args >= 2)
+ (apply translate-until (car args) (cdr args)))
+ ((#:begin)
+ ;; #:begin BODY...
+ (check-nargs args >= 1)
+ (apply translate-begin args))
+ ((#:call)
+ ;; #:call OBJ ARGS...
+ (check-nargs args >= 1)
+ (apply translate-call (car args) (cdr args)))
+ (else
+ (error "Unknown tag:" tag)))))
+ ;; that's it for this stage
+ (reverse! stack)))
+
+\f
+;;;
+;;; Bytecode optimization
+;;;
+
+(define (byte-optimize code)
+ (let loop ((last (car code)) (code (cdr code)) (result '()))
+ (define (continue) (loop (car code) (cdr code) (cons last result)))
+ (if (null? code)
+ (reverse! (cons last result))
+ (let ((this (car code)))
+ (case (car this)
+ ((%br-if)
+ (case (car last)
+ ((null?)
+ (loop (cons '%br-if-null (cdr this)) (cdr code) result))
+ (else
+ (continue))))
+ ((%br-if-not)
+ (case (car last)
+ ((null?)
+ (loop (cons '%br-if-not-null (cdr this)) (cdr code) result))
+ (else
+ (continue))))
+ (else
+ (continue)))))))
+
+\f
+;;;
+;;; Bytecode finalization
+;;;
+
+(define (byte-finalize code)
+ (let loop ((code code) (result '()))
+ (cond
+ ((null? code)
+ ;; Return the final assemble code
+ (let ((finalize (lambda (obj)
+ (if (label? obj)
+ (label-position obj)
+ obj))))
+ (list->vector (reverse! (map finalize result)))))
+ ((eq? (caar code) #:label)
+ ;; Calculate the label position
+ (set! (label-position (cadar code)) (length result))
+ (loop (cdr code) result))
+ (else
+ ;; Append to the result
+ (loop (cdr code) (append! (reverse! (car code)) result))))))
+
+\f
+;;;
+;;; Function table
+;;;
+
+(define (functional-instruction-alist)
+ (let ((alist '()))
+ (define (add! name inst)
+ (let ((pair (assq name alist)))
+ (if pair
+ (set-cdr! pair (cons inst (cdr pair)))
+ (set! alist (acons name (list inst) alist)))))
+ (for-each (lambda (inst)
+ (and-let* ((name (instruction-scheme-name inst)))
+ (add! name inst)))
+ (instruction-list))
+ alist))
+
+(define (build-table-data pair)
+ (let ((name (car pair)) (insts (cdr pair)))
+ (let ((vec (make-vector 5 #f)))
+ (define (build-data! inst)
+ (let ((arity (instruction-arity inst)))
+ (let ((nargs (car arity))
+ (restp (cadr arity)))
+ (if restp
+ (do ((i nargs (1+ i)))
+ ((>= i 4)
+ (vector-set! vec 4 inst))
+ (if (not (vector-ref vec i))
+ (vector-set! vec i inst)))
+ (vector-set! vec nargs inst)))))
+ (for-each build-data! insts)
+ (let ((func (eval name (interaction-environment))))
+ (cons func (vector->list vec))))))
+
+(define *vm-function-table*
+ (map build-table-data (functional-instruction-alist)))
+
+;;; bytecomp.scm ends here
--- /dev/null
+;;; compile.scm --- Compile Scheme codes
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (vm compile)
+ :use-module (vm vm)
+ :use-module (vm utils)
+ :use-module (vm types)
+ :use-module (vm bytecomp)
+ :use-module (ice-9 syncase)
+ :export (compile compile-file))
+
+(define (compile form . opts)
+ (catch 'result
+ (lambda ()
+ (let ((x (syncase form)))
+ (if (or (memq #:e opts) (memq #:expand-only opts))
+ (throw 'result x))
+ (set! x (parse x (make-env '() (make-top-level-env))))
+ (if (or (memq #:p opts) (memq #:parse-only opts))
+ (throw 'result x))
+ (set! x (byte-compile 0 #f x))
+ (if (or (memq #:c opts) (memq #:compile-only opts))
+ (throw 'result x))
+ (make-program (make-bytecode x) #f)))
+ (lambda (key arg) arg)))
+
+(define (compile-file file)
+ (let ((out-file (string-append (substring file 0 (1- (string-length file)))
+ "c")))
+ (with-input-from-file file
+ (lambda ()
+ (with-output-to-file out-file
+ (lambda ()
+ (format #t ";;; Compiled from ~A\n\n" file)
+ (display "(let ((vm (make-vm)))\n")
+ (display " (define (vm-exec code)\n")
+ (display " (vm-run vm (make-program (make-bytecode code) #f)))\n")
+ (do ((input (read) (read)))
+ ((eof-object? input))
+ (display "(vm-exec ")
+ (write (compile input #:compile-only))
+ (display ")\n"))
+ (display ")\n")))))))
+
+\f
+;;;
+;;; Parser
+;;;
+
+(define (parse x env)
+ (cond ((pair? x) (parse-pair x env))
+ ((symbol? x) (make-code:ref env (env-ref env x)))
+ (else (make-code:constant env x))))
+
+(define (parse-pair x env)
+ (let ((name (car x)) (args (cdr x)))
+ (if (assq name *syntax-alist*)
+ ;; syntax
+ ((assq-ref *syntax-alist* name) args env)
+ ;; procedure
+ (let ((proc (if (symbol? name)
+ (env-ref env name)
+ (parse name env))))
+ (if (and (variable? proc)
+ (variable-bound? proc)
+ (assq (variable-value proc) *procedure-alist*))
+ ;; procedure macro
+ ((assq-ref *procedure-alist* (variable-value proc)) args env)
+ ;; procedure call
+ (apply make-code:call env proc (map-parse args env)))))))
+
+(define (map-parse x env)
+ (map (lambda (x) (parse x env)) x))
+
+\f
+;;;
+;;; Syntax
+;;;
+
+(define *syntax-list*
+ '(quote lambda set! define if cond and or begin let let* letrec
+ local-set! until))
+
+(define (parse-quote args env)
+ (make-code:constant env (car args)))
+
+(define (canon-formals formals)
+ ;; foo -> (() . foo)
+ ;; (foo bar baz) -> ((foo bar baz) . #f)
+ ;; (foo bar . baz) -> ((foo bar) . baz)
+ (cond ((symbol? formals)
+ (cons '() formals))
+ ((or (null? formals)
+ (null? (cdr (last-pair formals))))
+ (cons formals #f))
+ (else
+ (let* ((copy (list-copy formals))
+ (pair (last-pair copy))
+ (last (cdr pair)))
+ (set-cdr! pair '())
+ (cons copy last)))))
+
+(define (parse-lambda args env)
+ (let ((formals (car args)) (body (cdr args)))
+ (let* ((pair (canon-formals formals))
+ (reqs (car pair))
+ (rest (cdr pair))
+ (syms (append reqs (if rest (list rest) '())))
+ (new-env (make-env syms env)))
+ (make-code:program env (length reqs) (if rest #t #f)
+ (parse-begin body new-env)))))
+
+(define (parse-set! args env)
+ (let ((var (env-ref env (car args)))
+ (val (parse (cadr args) env)))
+ (variable-externalize! var)
+ (make-code:set env var val)))
+
+(define (parse-local-set! args env)
+ (let ((var (env-ref env (car args)))
+ (val (parse (cadr args) env)))
+ (make-code:set env var val)))
+
+(define (parse-define args env)
+ (parse-set! args env))
+
+(define (parse-if args env)
+ (let ((test (parse (car args) env))
+ (consequent (parse (cadr args) env))
+ (alternate (if (null? (cddr args))
+ (make-code:unspecified env)
+ (parse (caddr args) env))))
+ (make-code:if env test consequent alternate)))
+
+;; FIXME: This should be expanded by syncase.
+(define (parse-cond args env)
+ (cond ((null? args) (make-code:unspecified env))
+ ((eq? (caar args) 'else)
+ (parse-begin (cdar args) env))
+ (else
+ (let* ((clause (car args))
+ (test (parse (car clause) env))
+ (body (parse-begin (cdr clause) env))
+ (alternate (parse-cond (cdr args) env)))
+ (make-code:if env test body alternate)))))
+
+(define (parse-and args env)
+ (apply make-code:and env (map-parse args env)))
+
+(define (parse-or args env)
+ (apply make-code:or env (map-parse args env)))
+
+(define (parse-begin args env)
+ (apply make-code:begin env (map-parse args env)))
+
+(define (%parse-let:finish env bindings init body)
+ (for-each (lambda (binding)
+ (env-remove-variable! env (car binding)))
+ bindings)
+ (apply make-code:begin env (append! init body)))
+
+(define (parse-let args env)
+ (if (symbol? (car args))
+ ;; named let
+ (let ((tag (car args)) (bindings (cadr args)) (body (cddr args)))
+ (let* ((var (env-add-variable! env tag))
+ (proc (parse-lambda (cons (map car bindings) body) env))
+ (init (make-code:set env var proc))
+ (call (apply make-code:call env var
+ (map-parse (map cadr bindings) env))))
+ (env-remove-variable! env tag)
+ (make-code:begin env init call)))
+ ;; normal let
+ (let ((bindings (car args)) (body (cdr args)))
+ (let* (;; create values before binding
+ (vals (map-parse (map cadr bindings) env))
+ ;; create bindings
+ (init (map (lambda (sym val)
+ (let ((var (env-add-variable! env sym)))
+ (make-code:set env var val)))
+ (map car bindings) vals)))
+ (%parse-let:finish env bindings init (map-parse body env))))))
+
+(define (parse-let* args env)
+ (let ((bindings (car args)) (body (cdr args)))
+ (let (;; create values and bindings one after another
+ (init (map (lambda (binding)
+ (let* ((val (parse (cadr binding) env))
+ (var (env-add-variable! env (car binding))))
+ (make-code:set env var val)))
+ bindings)))
+ (%parse-let:finish env bindings init (map-parse body env)))))
+
+(define (parse-letrec args env)
+ (let ((bindings (car args)) (body (cdr args)))
+ (let* (;; create all variables before values
+ (vars (map (lambda (sym)
+ (env-add-variable! env sym))
+ (map car bindings)))
+ ;; create and set values
+ (init (map (lambda (var val)
+ (make-code:set env var (parse val env)))
+ vars (map cadr bindings))))
+ (%parse-let:finish env bindings init (map-parse body env)))))
+
+(define (parse-until args env)
+ (apply make-code:until env (parse (car args) env)
+ (map-parse (cdr args) env)))
+
+(define *syntax-alist*
+ (map (lambda (name)
+ (cons name (eval (symbol-append 'parse- name) (current-module))))
+ *syntax-list*))
+
+\f
+;;;
+;;; Procedure
+;;;
+
+(define *procedure-list*
+ '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ map for-each))
+
+(define (parse-caar args env) (parse `(car (car ,@args)) env))
+(define (parse-cadr args env) (parse `(car (cdr ,@args)) env))
+(define (parse-cdar args env) (parse `(cdr (car ,@args)) env))
+(define (parse-cddr args env) (parse `(cdr (cdr ,@args)) env))
+
+(define (parse-caaar args env) (parse `(car (car (car ,@args))) env))
+(define (parse-caadr args env) (parse `(car (car (cdr ,@args))) env))
+(define (parse-cadar args env) (parse `(car (cdr (car ,@args))) env))
+(define (parse-caddr args env) (parse `(car (cdr (cdr ,@args))) env))
+(define (parse-cdaar args env) (parse `(cdr (car (car ,@args))) env))
+(define (parse-cdadr args env) (parse `(cdr (car (cdr ,@args))) env))
+(define (parse-cddar args env) (parse `(cdr (cdr (car ,@args))) env))
+(define (parse-cdddr args env) (parse `(cdr (cdr (cdr ,@args))) env))
+
+(define (parse-caaaar args env) (parse `(car (car (car (car ,@args)))) env))
+(define (parse-caaadr args env) (parse `(car (car (car (cdr ,@args)))) env))
+(define (parse-caadar args env) (parse `(car (car (cdr (car ,@args)))) env))
+(define (parse-caaddr args env) (parse `(car (car (cdr (cdr ,@args)))) env))
+(define (parse-cadaar args env) (parse `(car (cdr (car (car ,@args)))) env))
+(define (parse-cadadr args env) (parse `(car (cdr (car (cdr ,@args)))) env))
+(define (parse-caddar args env) (parse `(car (cdr (cdr (car ,@args)))) env))
+(define (parse-cadddr args env) (parse `(car (cdr (cdr (cdr ,@args)))) env))
+(define (parse-cdaaar args env) (parse `(cdr (car (car (car ,@args)))) env))
+(define (parse-cdaadr args env) (parse `(cdr (car (car (cdr ,@args)))) env))
+(define (parse-cdadar args env) (parse `(cdr (car (cdr (car ,@args)))) env))
+(define (parse-cdaddr args env) (parse `(cdr (car (cdr (cdr ,@args)))) env))
+(define (parse-cddaar args env) (parse `(cdr (cdr (car (car ,@args)))) env))
+(define (parse-cddadr args env) (parse `(cdr (cdr (car (cdr ,@args)))) env))
+(define (parse-cdddar args env) (parse `(cdr (cdr (cdr (car ,@args)))) env))
+(define (parse-cddddr args env) (parse `(cdr (cdr (cdr (cdr ,@args)))) env))
+
+(define (parse-map args env)
+ (check-nargs args >= 2)
+ (case (length args)
+ ((2)
+ (let ((proc (car args)) (list (cadr args)))
+ (parse `(let ((list ,list) (result '()))
+ (until (null? list)
+ (local-set! result (cons (,proc (car list)) result))
+ (local-set! list (cdr list)))
+ (reverse! result))
+ env)))
+ (else
+ (error "Not implemented yet"))))
+
+(define (parse-for-each args env)
+ (check-nargs args >= 2)
+ (case (length args)
+ ((2)
+ (let ((proc (car args)) (list (cadr args)))
+ (parse `(let ((list ,list))
+ (until (null? list)
+ (,proc (car list))
+ (local-set! list (cdr list))))
+ env)))
+ (else
+ (error "Not implemented yet"))))
+
+(define *procedure-alist*
+ (map (lambda (name)
+ (cons (eval name (current-module))
+ (eval (symbol-append 'parse- name) (current-module))))
+ *procedure-list*))
+
+;;; compile.scm ends here
--- /dev/null
+;;; shell.scm --- interactive VM operations
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (vm shell)
+ :use-module (vm vm)
+ :use-module (vm utils)
+ :use-module (vm compile)
+ :use-module (ice-9 format))
+
+;;;
+;;; VM Shell
+;;;
+
+(define *vm-default-prompt* "VM> ")
+
+(define *vm-boot-message* "\
+Copyright (C) 2000 Free Software Foundation, Inc.
+Guile VM is free software, covered by the GNU General Public License,
+and you are welcome to change it and/or distribute copies of it under
+certain conditions. There is absolutely no warranty for Guile VM.\n")
+
+(define (vm-init vm)
+ (vm-set-option! vm 'prompt *vm-default-prompt*)
+ (vm-set-option! vm 'verbose #f)
+ (vm-set-option! vm 'history-count 1))
+
+(define-public (vm-boot vm)
+ (format #t "Guile Virtual Machine ~A\n" (vm-version))
+ (display *vm-boot-message*)
+ (display "\nType \"help\" for information\n")
+ (vm-shell vm))
+
+(define-public (vm-shell vm)
+ (vm-init vm)
+ (let ((read-expr (lambda () (read (current-input-port)))))
+ (let loop ()
+ (display (or (vm-option vm 'prompt) *vm-default-prompt*))
+ (let ((cmd (read-expr)))
+ (if (not (eof-object? cmd))
+ (case cmd
+ ((eval) (vm-eval vm (read-expr)) (loop))
+ ((trace) (vm-trace vm (read-expr)) (loop))
+ ((parse) (vm-parse vm (read-expr)) (loop))
+ ((compile) (vm-compile vm (read-expr)) (loop))
+ ((set) (vm-set-option! vm (read-expr) (read-expr)) (loop))
+ (else
+ (error "Unknown command: ~S" cmd))))))))
+
+(define-public (vm-repl vm)
+ (vm-init vm)
+ (let loop ()
+ (display (or (vm-option vm 'prompt) *vm-default-prompt*))
+ (let ((form (read (current-input-port))))
+ (if (not (eof-object? form))
+ (begin
+ (vm-eval vm form)
+ (loop))))))
+
+(define (vm-eval vm form)
+ (let ((result (vm-run vm (compile form))))
+ (if (not (eq? result *unspecified*))
+ (let* ((n (or (vm-option vm 'history-count) 1))
+ (var (symbol-append "$" (number->string n))))
+ (intern-symbol #f var)
+ (symbol-set! #f var result)
+ (format #t "~A = ~S\n" var result)
+ (vm-set-option! vm 'history-count (1+ n))
+ result))))
+
+(define (vm-parse vm form)
+ (parse form (make-top-level-env)))
+
+(define (vm-compile vm form)
+ #f)
+
+\f
+;;;
+;;; Step
+;;;
+
+(define (vm-step-boot vm)
+ (format #t "VM: Starting a program ~S:~%"
+ (frame-program (vm-current-frame vm))))
+
+(define (vm-step-halt vm)
+ (display "VM: Program terminated with the return value: ")
+ (display (vm:ac vm))
+ (newline))
+
+(define (vm-step-next vm)
+ (if (vm-option vm 'verbose)
+ (let ((frame (vm-current-frame vm)))
+ (display "--------------------------------------------------\n")
+ (format #t "PC = 0x~X SP = 0x~X FP = 0x~X AC = ~S~%"
+ (vm:pc vm) (vm:sp vm) (vm:fp vm) (vm:ac vm))
+ (do ((frame frame (frame-dynamic-link frame))
+ (frames '() (cons frame frames)))
+ ((not frame)
+ (for-each (lambda (frame)
+ (format #t "Frame = [~S 0x~X 0x~X]~%"
+ (frame-program frame)
+ (frame-stack-pointer frame)
+ (frame-return-address frame)))
+ frames)))
+ (format #t "Local variables = ~S~%" (frame-variables frame))
+ (format #t "External variables = ~S~%" (program-external (frame-program frame)))
+ (format #t "Stack = ~S~%" (vm-stack->list vm))))
+ (format #t "0x~X:" (vm:pc vm))
+ (for-each (lambda (obj) (display " ") (write obj))
+ (vm-fetch-code vm (vm:pc vm)))
+ (newline))
+
+(define-public (vm-step vm form . opts)
+ (let ((debug-flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (add-hook! (vm-boot-hook vm) vm-step-boot)
+ (add-hook! (vm-halt-hook vm) vm-step-halt)
+ (add-hook! (vm-next-hook vm) vm-step-next)
+ (vm-set-option! vm 'debug #t))
+ (lambda ()
+ (if (pair? opts)
+ (vm-set-option! vm 'verbose #t))
+ (vm-run vm (compile form)))
+ (lambda ()
+ (remove-hook! (vm-boot-hook vm) vm-step-boot)
+ (remove-hook! (vm-halt-hook vm) vm-step-halt)
+ (remove-hook! (vm-next-hook vm) vm-step-next)
+ (vm-set-option! vm 'debug debug-flag)))))
+
+\f
+;;;
+;;; Trace
+;;;
+
+(define (vm-trace-prefix frame)
+ (and-let* ((link (frame-dynamic-link frame)))
+ (display "| ")
+ (vm-trace-prefix link)))
+
+(define (vm-frame->call frame)
+ (define (truncate! list n)
+ (let loop ((list list) (n n))
+ (if (<= n 1)
+ (set-cdr! list '())
+ (loop (cdr list) (1- n))))
+ list)
+ (let* ((prog (frame-program frame))
+ (name (or (program-name prog) prog)))
+ (cons name (reverse! (vector->list (frame-variables frame))))))
+
+(define (vm-trace-apply vm)
+ (let ((frame (vm-current-frame vm)))
+ (vm-trace-prefix frame)
+ (display (vm-frame->call frame))
+ (newline)))
+
+(define (vm-trace-return vm)
+ (vm-trace-prefix (vm-current-frame vm))
+ (display (vm:ac vm))
+ (newline))
+
+(define-public (vm-trace vm form)
+ (let ((debug-flag (vm-option vm 'debug)))
+ (dynamic-wind
+ (lambda ()
+ (add-hook! (vm-apply-hook vm) vm-trace-apply)
+ (add-hook! (vm-return-hook vm) vm-trace-return)
+ (vm-set-option! vm 'debug #t))
+ (lambda ()
+ (vm-run vm (compile form)))
+ (lambda ()
+ (remove-hook! (vm-apply-hook vm) vm-trace-apply)
+ (remove-hook! (vm-return-hook vm) vm-trace-return)
+ (vm-set-option! vm 'debug debug-flag)))))
+
+\f
+;;;
+;;; Disassemble
+;;;
+
+(define-public (disassemble program)
+ (format #t "Program at ~X:" (program-base program))
+ (let ((subprogs '())
+ (list (vector->list (bytecode-decode (program-code program)))))
+ (for-each (lambda (obj)
+ (cond ((opcode? obj)
+ (newline)
+ (display obj))
+ ((program? obj)
+ (set! subprogs (cons subprogs obj))
+ (display " ")
+ (display obj))
+ (else
+ (display " ")
+ (display obj))))
+ list)
+ (newline)
+ (for-each disassemble (reverse! subprogs))))
+
+;;; shell.scm ends here
--- /dev/null
+;;; types.scm --- data types used in the compiler and assembler
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (vm types)
+ :use-module (vm vm)
+ :use-module (vm utils)
+ :use-module (oop goops))
+
+\f
+;;;
+;;; VM code
+;;;
+
+(define-class <vm:code> ()
+ (tag #:accessor code-tag #:init-keyword #:tag)
+ (env #:accessor code-env #:init-keyword #:env)
+ (args #:accessor code-args #:init-keyword #:args)
+ (type #:accessor code-type #:init-value #f))
+
+(export code-tag code-env code-args code-type)
+
+(define-method (write (obj <vm:code>) port)
+ (display "#<vm:")
+ (display (keyword->symbol (code-tag obj)))
+ (map (lambda (obj) (display " ") (write obj port))
+ (code-args obj))
+ (display ">"))
+
+(define-public (code? obj)
+ (is-a? obj <vm:code>))
+
+(define-public (make-code tag env . args)
+ (make <vm:code> #:tag tag #:env env #:args args))
+
+\f
+;;;
+;;; VM label
+;;;
+
+(define-class <vm:label> ()
+ (pos #:accessor label-position))
+
+(export label-position)
+
+(define-public (label? obj)
+ (is-a? obj <vm:label>))
+
+(define-public (make-label)
+ (make <vm:label>))
+
+\f
+;;;
+;;; VM location
+;;;
+
+(define-class <vm:location> ())
+
+(define (make-location)
+ (make <vm:location>))
+
+\f
+;;;
+;;; VM variable
+;;;
+
+(define-class <vm:var> ()
+ (name #:accessor variable-name #:init-keyword #:name)
+ (type #:accessor variable-type #:init-value #f)
+ (value #:accessor variable-value)
+ (loc #:accessor variable-location #:init-keyword #:location)
+ (count #:accessor variable-count #:init-value 0))
+
+(define-class <vm:local-var> (<vm:var>))
+(define-class <vm:external-var> (<vm:var>))
+(define-class <vm:top-level-var> (<vm:var>))
+
+(export variable-name variable-type variable-value variable-count)
+
+(define-method (write (obj <vm:var>) port)
+ (display "#")
+ (display (class-name (class-of obj)))
+ (display " ")
+ (display (variable-name obj))
+ (display ">"))
+
+(define-public (make-local-variable name location)
+ (make <vm:local-var> #:name name #:location location))
+
+(define-public (make-top-level-variable name)
+ (make <vm:top-level-var> #:name name))
+
+(define-public (variable? obj)
+ (is-a? obj <vm:var>))
+
+(define-public (local-variable? obj)
+ (is-a? obj <vm:local-var>))
+
+(define-public (external-variable? obj)
+ (is-a? obj <vm:external-var>))
+
+(define-public (top-level-variable? obj)
+ (is-a? obj <vm:top-level-var>))
+
+(define-public (variable-bound? var)
+ (assert variable? var)
+ (slot-bound? var 'value))
+
+(define-public (variable-externalize! var)
+ (assert variable? var)
+ (if (local-variable? var)
+ (change-class var <vm:external-var>)))
+
+\f
+;;;
+;;; VM environment
+;;;
+
+(define-class <vm:env> ()
+ (space #:accessor env-name-space #:init-value '())
+ (args #:accessor env-arguments #:init-keyword #:args)
+ (vars #:accessor env-variables #:init-value '())
+ (locs #:accessor env-locations #:init-value '())
+ (exts #:accessor env-externals #:init-value #f)
+ (link #:accessor env-external-link #:init-keyword #:link))
+
+(define-public (make-env syms link)
+ (let* ((syms (reverse syms))
+ (args (map (lambda (sym)
+ (make-local-variable sym (make-location)))
+ syms))
+ (env (make <vm:env> #:args args #:link link)))
+ (for-each (lambda (sym var)
+ (set! (env-name-space env)
+ (acons sym var (env-name-space env))))
+ syms args)
+ env))
+
+(define-public (make-top-level-env)
+ (make-env '() #f))
+
+(define-public (env? obj) (is-a? obj <vm:env>))
+
+(define-public (top-level-env? obj)
+ (and (env? obj) (not (env-external-link obj))))
+
+(define-public (env-finalized? env)
+ (if (env-externals env) #t #f))
+
+(define-public (env-add-variable! env sym)
+ (assert env? env)
+ (assert symbol? sym)
+ (if (env-finalized? env)
+ (error "You may not add a variable after finalization"))
+ (let ((var (if (top-level-env? env)
+ (make-top-level-variable sym)
+ (let* ((locs (env-locations env))
+ (loc (if (null? locs)
+ (make-location)
+ (begin
+ (set! (env-locations env) (cdr locs))
+ (car locs)))))
+ (make-local-variable sym loc)))))
+ (set! (env-name-space env) (acons sym var (env-name-space env)))
+ (set! (env-variables env) (cons var (env-variables env)))
+ var))
+
+(define-public (env-remove-variable! env sym)
+ (assert env? env)
+ (assert symbol? sym)
+ (if (env-finalized? env)
+ (error "You may not remove a variable after finalization"))
+ (let ((var (assq-ref (env-name-space env) sym)))
+ (if (not var)
+ (error "No such variable: ~A\n" sym))
+ (if (local-variable? var)
+ (set! (env-locations env)
+ (cons (variable-location var) (env-locations env))))
+ (set! (env-name-space env)
+ (delq! (assq sym (env-name-space env)) (env-name-space env)))
+ var))
+
+;; Find a varialbe in the environment
+
+(define-public (env-ref env sym)
+ (assert env? env)
+ (assert symbol? sym)
+ (if (env-finalized? env)
+ (error "You may not find a variable after finalization"))
+ (or (env-local-ref env sym)
+ (env-external-ref env sym)
+ (env-top-level-ref env sym)
+ (error "No way!")))
+
+(define (env-local-ref env sym)
+ (if (assq sym (env-name-space env))
+ (let ((var (assq-ref (env-name-space env) sym)))
+ (set! (variable-count var) (1+ (variable-count var)))
+ var)
+ #f))
+
+(define (env-external-ref env sym)
+ (let ((ext-env (env-external-link env)))
+ (if (not ext-env)
+ #f
+ (let ((var (env-local-ref ext-env sym)))
+ (if var
+ (begin
+ (variable-externalize! var)
+ var)
+ (env-external-ref ext-env sym))))))
+
+(define (env-top-level-ref env sym)
+ (let ((var (make-top-level-variable sym)))
+ (if (defined? sym)
+ ;; Get the value in the top-level
+ (let ((obj (eval sym (interaction-environment))))
+ (set! (variable-value var) obj)
+ (set! (variable-type var)
+ (cond ((macro? obj) 'macro)
+ ((program? obj) 'program)
+ ((procedure? obj) 'function)
+ (else #f)))))
+ var))
+
+;; Finalization
+
+(define-public (env-finalize! env)
+ (if (not (env-finalized? env))
+ (let ((locs (uniq! (map variable-location
+ (append (filter local-variable?
+ (env-variables env))
+ (env-arguments env)))))
+ (exts (filter external-variable?
+ (append (env-variables env) (env-arguments env)))))
+ (set! (env-locations env) locs)
+ (set! (env-externals env) (reverse! exts)))))
+
+(define-public (env-header env)
+ (env-finalize! env)
+ (let ((nvars (length (uniq! (map variable-location
+ (filter local-variable?
+ (env-variables env))))))
+ (nexts (length (env-externals env)))
+ (exts (list->vector
+ (map (lambda (var)
+ (env-local-variable-address env var))
+ (filter external-variable?
+ (reverse (env-arguments env)))))))
+ (list nvars nexts exts)))
+
+(define (get-offset obj list)
+ (- (length list) (length (memq obj list))))
+
+(define-generic env-variable-address)
+
+(define-method (env-variable-address (env <vm:env>) (var <vm:local-var>))
+ (env-finalize! env)
+ (get-offset (variable-location var) (env-locations env)))
+
+(define-method (env-variable-address (env <vm:env>) (var <vm:external-var>))
+ (env-finalize! env)
+ (let loop ((depth 0) (env env))
+ (let ((list (env-externals env)))
+ (cond ((null? list)
+ (loop depth (env-external-link env)))
+ ((memq var list)
+ (cons depth (get-offset var list)))
+ (else (loop (1+ depth) (env-external-link env)))))))
+
+\f
+;;;
+;;; Intermediate codes
+;;;
+
+(define-public (make-code:unspecified env)
+ (assert env? env)
+ (make-code #:unspecified env))
+
+(define-public (make-code:constant env obj)
+ (assert env? env)
+ (make-code #:constant env obj))
+
+(define-public (make-code:ref env var)
+ (assert env? env)
+ (assert variable? var)
+ (let ((code (make-code #:ref env var)))
+ (set! (code-type code) (variable-type var))
+ code))
+
+(define-public (make-code:set env var val)
+ (assert env? env)
+ (assert variable? var)
+ (assert code? val)
+ (let ((code (make-code #:set env var val)))
+ (set! (variable-type var) (code-type val))
+ (set! (code-type code) (variable-type var))
+ code))
+
+(define-public (make-code:program env nreqs restp body)
+ (assert env? env)
+ (assert integer? nreqs)
+ (assert boolean? restp)
+ (assert code? body)
+ (let ((code (make-code #:make-program env nreqs restp body)))
+ (set! (code-type code) 'program)
+ code))
+
+(define-public (make-code:call env proc . args)
+ (assert env? env)
+ (assert (lambda (x) (or (variable? x) (code? x))) proc)
+ (assert-for-each code? args)
+ (apply make-code #:call env proc args))
+
+(define-public (make-code:if env test consequent alternate)
+ (assert env? env)
+ (assert code? test)
+ (assert code? consequent)
+ (assert code? alternate)
+ (let ((code (make-code #:if env test consequent alternate)))
+ (if (eq? (code-type consequent) (code-type alternate))
+ (set! (code-type code) (code-type consequent)))
+ code))
+
+(define-public (make-code:and env . args)
+ (assert env? env)
+ (assert-for-each code? args)
+ (apply make-code #:and args))
+
+(define-public (make-code:or env . args)
+ (assert env? env)
+ (assert-for-each code? args)
+ (apply make-code #:or args))
+
+(define-public (make-code:begin env . body)
+ (assert env? env)
+ (assert-for-each code? body)
+ (let ((code (apply make-code #:begin env body)))
+ (set! (code-type code) (code-type (last body)))
+ code))
+
+(define-public (make-code:until env test . body)
+ (assert env? env)
+ (assert code? test)
+ (assert-for-each code? body)
+ (apply make-code #:until env test body))
+
+;;; types.scm ends here
--- /dev/null
+;;; utils.scm ---
+
+;; Copyright (C) 2000 Free Software Foundation, Inc.
+
+;; This file is part of Guile VM.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (vm utils)
+ :use-module (ice-9 and-let*)
+ :use-module (ice-9 format))
+
+(export and-let*)
+
+(define-public (assert predicate obj)
+ (if (not (predicate obj))
+ (scm-error 'wrong-type-arg #f
+ "Wrong type argument: ~S, ~S"
+ (list (procedure-name predicate) obj) #f)))
+
+(define-public (assert-for-each predicate list)
+ (for-each (lambda (x) (assert predicate x)) list))
+
+(define-public (check-nargs args pred n)
+ (if (not (pred (length args) n))
+ (error "Too many or few arguments")))
+
+(define-public (last list)
+ (car (last-pair list)))
+
+(define-public (rassq key alist)
+ (let loop ((alist alist))
+ (cond ((null? alist) #f)
+ ((eq? key (cdar alist)) (car alist))
+ (else (loop (cdr alist))))))
+
+(define-public (rassq-ref alist key)
+ (let ((obj (rassq key alist)))
+ (if obj (car obj) #f)))
+
+(define-public (map-if pred func list)
+ (let loop ((list list) (result '()))
+ (if (null? list)
+ (reverse! result)
+ (if (pred (car list))
+ (loop (cdr list) (cons (func (car list)) result))
+ (loop (cdr list) result)))))
+
+(define-public (map-tree func tree)
+ (cond ((null? tree) '())
+ ((pair? tree)
+ (cons (map-tree func (car tree)) (map-tree func (cdr tree))))
+ (else (func tree))))
+
+(define-public (filter pred list)
+ (let loop ((list list) (result '()))
+ (if (null? list)
+ (reverse! result)
+ (if (pred (car list))
+ (loop (cdr list) (cons (car list) result))
+ (loop (cdr list) result)))))
+
+(define-public (uniq! list)
+ (do ((rest list (begin (set-cdr! rest (delq! (car rest) (cdr rest)))
+ (cdr rest))))
+ ((null? rest) list)))
+
+(define-public (finalize obj)
+ (if (promise? obj) (force obj) obj))
+
+(export time)
+(define-macro (time form)
+ `(let* ((gc-start (gc-run-time))
+ (tms-start (times))
+ (result ,form)
+ (tms-end (times))
+ (gc-end (gc-run-time))
+ (get (lambda (proc start end)
+ (/ (- (proc end) (proc start))
+ internal-time-units-per-second))))
+ (display "clock utime stime cutime cstime gc\n")
+ (format #t "~5a ~5a ~5a ~6a ~6a ~a~%"
+ (get tms:clock tms-start tms-end)
+ (get tms:utime tms-start tms-end)
+ (get tms:stime tms-start tms-end)
+ (get tms:cutime tms-start tms-end)
+ (get tms:cstime tms-start tms-end)
+ (get id gc-start gc-end))
+ result))
+
+;;; utils.scm ends here
HCoop / bpt / guile.git / commitdiff