merge guile-vm to guile

An attempt to pull in the original history from guile-vm into guile itself.

Makefile.am

@@ -25,7 +25,8 @@
 AUTOMAKE_OPTIONS = 1.10
 
 SUBDIRS = lib oop libguile ice-9 guile-config guile-readline emacs \
-	  scripts srfi doc examples test-suite benchmark-suite lang am
+	  scripts srfi doc examples test-suite benchmark-suite lang am \
+	  src modules testsuite
 
 bin_SCRIPTS = guile-tools
 

NEWS.guile-vm

@@ -0,0 +1,57 @@
+Guile-VM NEWS
+
+
+Guile-VM is a bytecode compiler and virtual machine for Guile.
+
+
+guile-vm 0.7 -- 2008-05-20
+==========================
+
+* Initial release with NEWS.
+
+* Revived from Keisuke Nishida's Guile-VM project from 2000-2001, with
+  the help of Ludovic Courtès.
+
+* Meta-level changes
+** Updated to compile with Guile 1.8.
+** Documentation updated, including documentation on the instructions.
+** Added benchmarking and a test harness.
+
+* Changes to the inventory
+** Renamed the library from libguilevm to libguile-vm.
+** Added new executable script, guile-disasm.
+
+* New features
+** Add support for compiling macros, both defmacros and syncase macros.
+Primitive macros produced with the procedure->macro family of procedures
+are not supported, however.
+** Improvements to the REPL
+Multiple values support, readline integration, ice-9 history integration
+** Add support for eval-case
+The compiler recognizes compile-toplevel in addition to load-toplevel
+** Completely self-compiling
+Almost, anyway: not (system repl describe), because it uses GOOPS
+
+* Internal cleanups
+** Internal objects are now based on Guile records.
+** Guile-VM's code doesn't use the dot-syntax any more.
+** Changed (ice-9 match) for Kiselyov's pmatch.scm
+** New instructions: define, link-later, link-now, late-variable-{ref,set}
+** Object code now represented as u8vectors instead of strings.
+** Remove local import of an old version of slib
+
+* Bugfixes
+** The `optimize' procedure is coming out of bitrot
+** The Scheme compiler is now more strict about placement of internal
+   defines
+** set! is now compiled differently from define
+** Module-level variables are now bound at first use instead of in the
+   program prolog
+** Bugfix to load-program (stack misinterpretation)
+
+
+Copyright (C) 2008 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification, are
+permitted in any medium without royalty provided the copyright notice
+and this notice are preserved.

README.guile-vm

@@ -0,0 +1,117 @@
+This is an attempt to revive the Guile-VM project by Keisuke Nishida
+written back in the years 2000 and 2001.  Below are a few pointers to
+relevant threads on Guile's development mailing list.
+
+Enjoy!
+
+Ludovic Courtès <ludovic.courtes@laas.fr>, Apr. 2005.
+
+
+Pointers
+--------
+
+Status of the last release, 0.5
+  http://lists.gnu.org/archive/html/guile-devel/2001-04/msg00266.html
+
+The very first release, 0.0
+  http://sources.redhat.com/ml/guile/2000-07/msg00418.html
+
+Simple benchmark
+  http://sources.redhat.com/ml/guile/2000-07/msg00425.html
+
+Performance, portability, GNU Lightning
+  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html
+
+Playing with GNU Lightning
+  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00185.html
+
+On things left to be done
+  http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00146.html
+
+
+---8<---  Original README below.  -----------------------------------------
+
+Installation
+------------
+
+1. Install the latest Guile from CVS.
+
+2. Install Guile VM:
+
+  % configure
+  % make install
+  % ln -s module/{guile,system,language} /usr/local/share/guile/
+
+3. Add the following lines to your ~/.guile:
+
+  (use-modules (system vm core)
+
+  (cond ((string=? (car (command-line)) "guile-vm")
+	 (use-modules (system repl repl))
+	 (start-repl 'scheme)
+	 (quit)))
+
+Example Session
+---------------
+
+  % guile-vm
+  Guile Scheme interpreter 0.5 on Guile 1.4.1
+  Copyright (C) 2001 Free Software Foundation, Inc.
+
+  Enter `,help' for help.
+  scheme@guile-user> (+ 1 2)
+  3
+  scheme@guile-user> ,c -c (+ 1 2)	;; Compile into GLIL
+  (@asm (0 1 0 0)
+    (module-ref #f +)
+    (const 1)
+    (const 2)
+    (tail-call 2))
+  scheme@guile-user> ,c (+ 1 2)		;; Compile into object code
+  Disassembly of #<objcode 403c5fb0>:
+
+  nlocs = 0  nexts = 0
+
+     0    link "+"                        ;; (+ . ???)
+     3    variable-ref
+     4    make-int8:1                     ;; 1
+     5    make-int8 2                     ;; 2
+     7    tail-call 2
+
+  scheme@guile-user> (define (add x y) (+ x y))
+  scheme@guile-user> (add 1 2)
+  3
+  scheme@guile-user> ,x add		;; Disassemble
+  Disassembly of #<program add>:
+
+  nargs = 2  nrest = 0  nlocs = 0  nexts = 0
+
+  Bytecode:
+
+     0    object-ref 0                    ;; (+ . #<primitive-procedure +>)
+     2    variable-ref
+     3    local-ref 0
+     5    local-ref 1
+     7    tail-call 2
+
+  Objects:
+
+     0    (+ . #<primitive-procedure +>)
+
+  scheme@guile-user> 
+
+Compile Modules
+---------------
+
+Use `guilec' to compile your modules:
+
+  % cat fib.scm
+  (define-module (fib) :export (fib))
+  (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))
+
+  % guilec fib.scm
+  Wrote fib.go
+  % guile
+  guile> (use-modules (fib))
+  guile> (fib 8)
+  34

THANKS.guile-vm

@@ -0,0 +1 @@
+Guile VM was inspired by QScheme, librep, and Objective Caml.

benchmark/lib.scm

@@ -0,0 +1,111 @@
+;; -*- Scheme -*-
+;;
+;; A library of dumb functions that may be used to benchmark Guile-VM.
+
+
+;; The comments are from Ludovic, a while ago. The speedups now are much
+;; more significant (all over 2x, sometimes 8x).
+
+(define (fibo x)
+  (if (or (= x 1) (= x 2))
+      1
+      (+ (fibo (- x 1))
+	 (fibo (- x 2)))))
+
+(define (g-c-d x y)
+  (if (= x y)
+      x
+      (if (< x y)
+	  (g-c-d x (- y x))
+	  (g-c-d (- x y) y))))
+
+(define (loop n)
+  ;; This one shows that procedure calls are no faster than within the
+  ;; interpreter: the VM yields no performance improvement.
+  (if (= 0 n)
+      0
+      (loop (1- n))))
+
+;; Disassembly of `loop'
+;;
+;; Disassembly of #<objcode b79bdf28>:
+
+;; nlocs = 0  nexts = 0
+
+;;    0    (make-int8 64)                  ;; 64
+;;    2    (load-symbol "guile-user")      ;; guile-user
+;;   14    (list 0 1)                      ;; 1 element
+;;   17    (load-symbol "loop")            ;; loop
+;;   23    (link-later)
+;;   24    (vector 0 1)                    ;; 1 element
+;;   27    (make-int8 0)                   ;; 0
+;;   29    (load-symbol "n")               ;; n
+;;   32    (make-false)                    ;; #f
+;;   33    (make-int8 0)                   ;; 0
+;;   35    (list 0 3)                      ;; 3 elements
+;;   38    (list 0 2)                      ;; 2 elements
+;;   41    (list 0 1)                      ;; 1 element
+;;   44    (make-int8 5)                   ;; 5
+;;   46    (make-false)                    ;; #f
+;;   47    (cons)
+;;   48    (make-int8 18)                  ;; 18
+;;   50    (make-false)                    ;; #f
+;;   51    (cons)
+;;   52    (make-int8 20)                  ;; 20
+;;   54    (make-false)                    ;; #f
+;;   55    (cons)
+;;   56    (list 0 4)                      ;; 4 elements
+;;   59    (load-program ##{66}#)
+;;   81    (define "loop")
+;;   87    (variable-set)
+;;   88    (void)
+;;   89    (return)
+
+;; Bytecode ##{66}#:
+
+;;    0    (make-int8 0)                   ;; 0
+;;    2    (local-ref 0)
+;;    4    (ee?)
+;;    5    (br-if-not 0 3)                 ;; -> 11
+;;    8    (make-int8 0)                   ;; 0
+;;   10    (return)
+;;   11    (late-variable-ref 0)
+;;   13    (local-ref 0)
+;;   15    (make-int8 1)                   ;; 1
+;;   17    (sub)
+;;   18    (tail-call 1)
+
+(define (loopi n)
+  ;; Same as `loop'.
+  (let loopi ((n n))
+    (if (= 0 n)
+	0
+	(loopi (1- n)))))
+
+(define (do-loop n)
+  ;; Same as `loop' using `do'.
+  (do ((i n (1- i)))
+      ((= 0 i))
+    ;; do nothing
+    ))
+
+
+(define (do-cons x)
+  ;; This one shows that the built-in `cons' instruction yields a significant
+  ;; improvement (speedup: 1.5).
+  (let loop ((x x)
+	     (result '()))
+    (if (<= x 0)
+	result
+	(loop (1- x) (cons x result)))))
+
+(define big-list (iota 500000))
+
+(define (copy-list lst)
+  ;; Speedup: 5.9.
+  (let loop ((lst lst)
+	     (result '()))
+    (if (null? lst)
+	result
+	(loop (cdr lst)
+	      (cons (car lst) result)))))

benchmark/measure.scm

@@ -0,0 +1,68 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(measure)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+
+;; A simple interpreter vs. VM performance comparison tool
+;;
+
+(define-module (measure)
+  :export (measure)
+  :use-module (system vm core)
+  :use-module (system vm disasm)
+  :use-module (system base compile)
+  :use-module (system base language))
+
+
+(define (time-for-eval sexp eval)
+  (let ((before (tms:utime (times))))
+    (eval sexp)
+    (let ((elapsed (- (tms:utime (times)) before)))
+      (format #t "elapsed time: ~a~%" elapsed)
+      elapsed)))
+
+(define *scheme* (lookup-language 'scheme))
+
+
+(define (measure . args)
+  (if (< (length args) 2)
+      (begin
+	(format #t "Usage: measure SEXP FILE-TO-LOAD...~%")
+	(format #t "~%")
+	(format #t "Example: measure '(loop 23424)' lib.scm~%~%")
+	(exit 1)))
+  (for-each load (cdr args))
+  (let* ((sexp (with-input-from-string (car args)
+		 (lambda ()
+		   (read))))
+	 (eval-here (lambda (sexp) (eval sexp (current-module))))
+	 (proc-name (car sexp))
+	 (proc-source (procedure-source (eval proc-name (current-module))))
+	 (% (format #t "proc: ~a~%source: ~a~%" proc-name proc-source))
+	 (time-interpreted (time-for-eval sexp eval-here))
+	 (& (if (defined? proc-name)
+		(eval `(set! ,proc-name #f) (current-module))
+		(format #t "unbound~%")))
+	 (objcode (compile-in proc-source
+			      (current-module) *scheme*))
+	 (the-program (vm-load (the-vm) objcode))
+
+;	 (%%% (disassemble-objcode objcode))
+	 (time-compiled (time-for-eval `(,proc-name ,@(cdr sexp))
+				       (lambda (sexp)
+					 (eval `(begin
+						  (define ,proc-name
+						    ,the-program)
+						  ,sexp)
+					       (current-module))))))
+
+    (format #t "proc:        ~a => ~a~%"
+	    proc-name (eval proc-name (current-module)))
+    (format #t "interpreted: ~a~%" time-interpreted)
+    (format #t "compiled:    ~a~%" time-compiled)
+    (format #t "speedup:     ~a~%"
+	    (exact->inexact (/ time-interpreted time-compiled)))
+    0))
+
+(define main measure)

configure.in

@@ -1467,6 +1467,16 @@ AC_CONFIG_FILES([
   srfi/Makefile
   test-suite/Makefile
   test-suite/standalone/Makefile
+  src/Makefile
+  module/Makefile
+  module/system/Makefile
+  module/system/base/Makefile
+  module/system/vm/Makefile
+  module/system/il/Makefile
+  module/system/repl/Makefile
+  module/language/Makefile
+  module/language/scheme/Makefile
+  testsuite/Makefile
 ])
 
 AC_CONFIG_FILES([check-guile], [chmod +x check-guile])

doc/Makefile.am

@@ -49,3 +49,5 @@ guile-api.alist: guile-api.alist-FORCE
 	( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
 guile-api.alist-FORCE:
 endif
+
+info_TEXINFOS = guile-vm.texi

doc/goops.mail

@@ -0,0 +1,78 @@
+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.  ;-)]
+

env

@@ -0,0 +1,5 @@
+#!/bin/bash
+thisdir=$(cd $(dirname $0) && pwd)
+export GUILE_LOAD_PATH=$thisdir/module${GUILE_LOAD_PATH:+:$GUILE_LOAD_PATH}
+export LD_LIBRARY_PATH=$thisdir/src${LD_LIBRARY_PATH:+:$LD_LIBRARY_PATH}
+exec "$@"

guilec.mk

@@ -0,0 +1,10 @@
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+
+CLEANFILES = $(GOBJECTS)
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(GUILEC) $<

module/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+slibcat

module/Makefile.am

@@ -0,0 +1 @@
+SUBDIRS = system language

module/language/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/Makefile.am

@@ -0,0 +1 @@
+SUBDIRS = scheme

module/language/elisp/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/elisp/spec.scm

@@ -0,0 +1,63 @@
+;;; Guile Emac Lisp
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (lang elisp spec)
+  :use-module (system lang language)
+  :export (elisp))
+
+
+;;;
+;;; Translator
+;;;
+
+(define (translate x)
+  (if (pair? x)
+      (translate-pair x)
+      x))
+
+(define (translate-pair x)
+  (let ((name (car x)) (args (cdr x)))
+    (case name
+      ((quote) `(@quote ,@args))
+      ((defvar) `(@define ,@(map translate args)))
+      ((setq) `(@set! ,@(map translate args)))
+      ((if) `(@if ,(translate (car args))
+		  (@begin ,@(map translate (cdr args)))))
+      ((and) `(@and ,@(map translate args)))
+      ((or) `(@or ,@(map translate args)))
+      ((progn) `(@begin ,@(map translate args)))
+      ((defun) `(@define ,(car args)
+			 (@lambda ,(cadr args) ,@(map translate (cddr args)))))
+      ((lambda) `(@lambda ,(car args) ,@(map translate (cdr args))))
+      (else x))))
+
+
+;;;
+;;; Language definition
+;;;
+
+(define-language elisp
+  #:title	"Emacs Lisp"
+  #:version	"0.0"
+  #:reader	read
+  #:expander	id
+  #:translator	translate
+  )

module/language/ghil/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/ghil/GPKG.def

@@ -0,0 +1,8 @@
+;;; GHIL package definition				-*- gscheme -*-
+
+(define-package ghil
+  :category	Language
+  :version	"0.3"
+  :author	"Keisuke Nishida <kxn30@po.cwru.edu>"
+  :modules	((spec "spec.scm" gscheme))
+  )

module/language/ghil/spec.scm

@@ -0,0 +1,32 @@
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (language ghil spec)
+  :use-module (system base language)
+  :export (ghil))
+
+(define-language ghil
+  :title	"Guile High Intermediate Language (GHIL)"
+  :version	"0.3"
+  :reader	read
+  :printer	write
+;;  :environment	(make-vmodule)
+  )

module/language/r5rs/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/r5rs/GPKG.def

@@ -0,0 +1,12 @@
+;;; r5rs package definition				-*- gscheme -*-
+
+(define-package r5rs
+  :category	Language
+  :version	"0.3"
+  :author	"Keisuke Nishida <kxn30@po.cwru.edu>"
+  :modules	((core "core.il" ghil)
+		 (null "null.il" ghil)
+		 (spec "spec.scm" gscheme)
+		 (expand "expand.scm" gscheme)
+		 (translate "translate.scm" gscheme))
+  )

module/language/r5rs/core.il

@@ -0,0 +1,325 @@
+;;; R5RS core environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+;; Non standard procedures
+
+(@define void (@lambda () (@void)))
+
+;; 6. Standard procedures
+
+;;; 6.1 Equivalence predicates
+
+(@define eq? (@lambda (x y) (@eq? x y)))
+(@define eqv? (@ Core::eqv?))
+(@define equal? (@ Core::equal?))
+
+;;; 6.2 Numbers
+
+(@define number? (@ Core::number?))
+(@define complex? (@ Core::complex?))
+(@define real? (@ Core::real?))
+(@define rational? (@ Core::rational?))
+(@define integer? (@ Core::integer?))
+
+(@define exact? (@ Core::exact?))
+(@define inexact? (@ Core::inexact?))
+
+(@define = (@ Core::=))
+(@define < (@ Core::<))
+(@define > (@ Core::>))
+(@define <= (@ Core::<=))
+(@define >= (@ Core::>=))
+
+(@define zero? (@ Core::zero?))
+(@define positive? (@ Core::positive?))
+(@define negative? (@ Core::negative?))
+(@define odd? (@ Core::odd?))
+(@define even? (@ Core::even?))
+
+(@define max (@ Core::max))
+(@define min (@ Core::min))
+
+(@define + (@ Core::+))
+(@define * (@ Core::*))
+(@define - (@ Core::-))
+(@define / (@ Core::/))
+
+(@define abs (@ Core::abs))
+
+(@define quotient (@ Core::quotient))
+(@define remainder (@ Core::remainder))
+(@define modulo (@ Core::modulo))
+
+(@define gcd (@ Core::gcd))
+(@define lcm (@ Core::lcm))
+
+;; (@define numerator (@ Core::numerator))
+;; (@define denominator (@ Core::denominator))
+
+(@define floor (@ Core::floor))
+(@define ceiling (@ Core::ceiling))
+(@define truncate (@ Core::truncate))
+(@define round (@ Core::round))
+
+;; (@define rationalize (@ Core::rationalize))
+
+(@define exp (@ Core::exp))
+(@define log (@ Core::log))
+(@define sin (@ Core::sin))
+(@define cos (@ Core::cos))
+(@define tan (@ Core::tan))
+(@define asin (@ Core::asin))
+(@define acos (@ Core::acos))
+(@define atan (@ Core::atan))
+
+(@define sqrt (@ Core::sqrt))
+(@define expt (@ Core::expt))
+
+(@define make-rectangular (@ Core::make-rectangular))
+(@define make-polar (@ Core::make-polar))
+(@define real-part (@ Core::real-part))
+(@define imag-part (@ Core::imag-part))
+(@define magnitude (@ Core::magnitude))
+(@define angle (@ Core::angle))
+
+(@define exact->inexact (@ Core::exact->inexact))
+(@define inexact->exact (@ Core::inexact->exact))
+
+(@define number->string (@ Core::number->string))
+(@define string->number (@ Core::string->number))
+
+;;; 6.3 Other data types
+
+;;;; 6.3.1 Booleans
+
+(@define not (@lambda (x) (@not x)))
+(@define boolean? (@ Core::boolean?))
+
+;;;; 6.3.2 Pairs and lists
+
+(@define pair? (@lambda (x) (@pair? x)))
+(@define cons (@lambda (x y) (@cons x y)))
+
+(@define car (@lambda (x) (@car x)))
+(@define cdr (@lambda (x) (@cdr x)))
+(@define set-car! (@ Core::set-car!))
+(@define set-cdr! (@ Core::set-cdr!))
+
+(@define caar (@lambda (x) (@caar x)))
+(@define cadr (@lambda (x) (@cadr x)))
+(@define cdar (@lambda (x) (@cdar x)))
+(@define cddr (@lambda (x) (@cddr x)))
+(@define caaar (@lambda (x) (@caaar x)))
+(@define caadr (@lambda (x) (@caadr x)))
+(@define cadar (@lambda (x) (@cadar x)))
+(@define caddr (@lambda (x) (@caddr x)))
+(@define cdaar (@lambda (x) (@cdaar x)))
+(@define cdadr (@lambda (x) (@cdadr x)))
+(@define cddar (@lambda (x) (@cddar x)))
+(@define cdddr (@lambda (x) (@cdddr x)))
+(@define caaaar (@lambda (x) (@caaaar x)))
+(@define caaadr (@lambda (x) (@caaadr x)))
+(@define caadar (@lambda (x) (@caadar x)))
+(@define caaddr (@lambda (x) (@caaddr x)))
+(@define cadaar (@lambda (x) (@cadaar x)))
+(@define cadadr (@lambda (x) (@cadadr x)))
+(@define caddar (@lambda (x) (@caddar x)))
+(@define cadddr (@lambda (x) (@cadddr x)))
+(@define cdaaar (@lambda (x) (@cdaaar x)))
+(@define cdaadr (@lambda (x) (@cdaadr x)))
+(@define cdadar (@lambda (x) (@cdadar x)))
+(@define cdaddr (@lambda (x) (@cdaddr x)))
+(@define cddaar (@lambda (x) (@cddaar x)))
+(@define cddadr (@lambda (x) (@cddadr x)))
+(@define cdddar (@lambda (x) (@cdddar x)))
+(@define cddddr (@lambda (x) (@cddddr x)))
+
+(@define null? (@lambda (x) (@null? x)))
+(@define list? (@lambda (x) (@list? x)))
+
+(@define list (@lambda x x))
+
+(@define length (@ Core::length))
+(@define append (@ Core::append))
+(@define reverse (@ Core::reverse))
+(@define list-tail (@ Core::list-tail))
+(@define list-ref (@ Core::list-ref))
+
+(@define memq (@ Core::memq))
+(@define memv (@ Core::memv))
+(@define member (@ Core::member))
+
+(@define assq (@ Core::assq))
+(@define assv (@ Core::assv))
+(@define assoc (@ Core::assoc))
+
+;;;; 6.3.3 Symbols
+
+(@define symbol? (@ Core::symbol?))
+(@define symbol->string (@ Core::symbol->string))
+(@define string->symbol (@ Core::string->symbol))
+
+;;;; 6.3.4 Characters
+
+(@define char? (@ Core::char?))
+(@define char=? (@ Core::char=?))
+(@define char<? (@ Core::char<?))
+(@define char>? (@ Core::char>?))
+(@define char<=? (@ Core::char<=?))
+(@define char>=? (@ Core::char>=?))
+(@define char-ci=? (@ Core::char-ci=?))
+(@define char-ci<? (@ Core::char-ci<?))
+(@define char-ci>? (@ Core::char-ci>?))
+(@define char-ci<=? (@ Core::char-ci<=?))
+(@define char-ci>=? (@ Core::char-ci>=?))
+(@define char-alphabetic? (@ Core::char-alphabetic?))
+(@define char-numeric? (@ Core::char-numeric?))
+(@define char-whitespace? (@ Core::char-whitespace?))
+(@define char-upper-case? (@ Core::char-upper-case?))
+(@define char-lower-case? (@ Core::char-lower-case?))
+(@define char->integer (@ Core::char->integer))
+(@define integer->char (@ Core::integer->char))
+(@define char-upcase (@ Core::char-upcase))
+(@define char-downcase (@ Core::char-downcase))
+
+;;;; 6.3.5 Strings
+
+(@define string? (@ Core::string?))
+(@define make-string (@ Core::make-string))
+(@define string (@ Core::string))
+(@define string-length (@ Core::string-length))
+(@define string-ref (@ Core::string-ref))
+(@define string-set! (@ Core::string-set!))
+
+(@define string=? (@ Core::string=?))
+(@define string-ci=? (@ Core::string-ci=?))
+(@define string<? (@ Core::string<?))
+(@define string>? (@ Core::string>?))
+(@define string<=? (@ Core::string<=?))
+(@define string>=? (@ Core::string>=?))
+(@define string-ci<? (@ Core::string-ci<?))
+(@define string-ci>? (@ Core::string-ci>?))
+(@define string-ci<=? (@ Core::string-ci<=?))
+(@define string-ci>=? (@ Core::string-ci>=?))
+
+(@define substring (@ Core::substring))
+(@define string-append (@ Core::string-append))
+(@define string->list (@ Core::string->list))
+(@define list->string (@ Core::list->string))
+(@define string-copy (@ Core::string-copy))
+(@define string-fill! (@ Core::string-fill!))
+
+;;;; 6.3.6 Vectors
+
+(@define vector? (@ Core::vector?))
+(@define make-vector (@ Core::make-vector))
+(@define vector (@ Core::vector))
+(@define vector-length (@ Core::vector-length))
+(@define vector-ref (@ Core::vector-ref))
+(@define vector-set! (@ Core::vector-set!))
+(@define vector->list (@ Core::vector->list))
+(@define list->vector (@ Core::list->vector))
+(@define vector-fill! (@ Core::vector-fill!))
+
+;;; 6.4 Control features
+
+(@define procedure? (@ Core::procedure?))
+(@define apply (@ Core::apply))
+(@define map (@ Core::map))
+(@define for-each (@ Core::for-each))
+(@define force (@ Core::force))
+
+(@define call-with-current-continuation (@ Core::call-with-current-continuation))
+(@define values (@ Core::values))
+(@define call-with-values (@ Core::call-with-values))
+(@define dynamic-wind (@ Core::dynamic-wind))
+
+;;; 6.5 Eval
+
+(@define eval
+  (@let ((l (@ Language::r5rs::spec::r5rs)))
+    (@lambda (x e)
+      (((@ System::Base::language::compile-in) x e l)))))
+
+;; (@define scheme-report-environment
+;;   (@lambda (version)
+;;     (@if (@= version 5)
+;; 	 (@ Language::R5RS::Core)
+;; 	 (@error "Unsupported environment version" version))))
+;; 
+;; (@define null-environment
+;;   (@lambda (version)
+;;     (@if (@= version 5)
+;; 	 (@ Language::R5RS::Null)
+;; 	 (@error "Unsupported environment version" version))))
+
+(@define interaction-environment (@lambda () (@current-module)))
+
+;;; 6.6 Input and output
+
+;;;; 6.6.1 Ports
+
+(@define call-with-input-file (@ Core::call-with-input-file))
+(@define call-with-output-file (@ Core::call-with-output-file))
+
+(@define input-port? (@ Core::input-port?))
+(@define output-port? (@ Core::output-port?))
+(@define current-input-port (@ Core::current-input-port))
+(@define current-output-port (@ Core::current-output-port))
+
+(@define with-input-from-file (@ Core::with-input-from-file))
+(@define with-output-to-file (@ Core::with-output-to-file))
+
+(@define open-input-file (@ Core::open-input-file))
+(@define open-output-file (@ Core::open-output-file))
+(@define close-input-port (@ Core::close-input-port))
+(@define close-output-port (@ Core::close-output-port))
+
+;;;; 6.6.2 Input
+
+(@define read (@ Core::read))
+(@define read-char (@ Core::read-char))
+(@define peek-char (@ Core::peek-char))
+(@define eof-object? (@ Core::eof-object?))
+(@define char-ready? (@ Core::char-ready?))
+
+;;;; 6.6.3 Output
+
+(@define write (@ Core::write))
+(@define display (@ Core::display))
+(@define newline (@ Core::newline))
+(@define write-char (@ Core::write-char))
+
+;;;; 6.6.4 System interface
+
+(@define load
+  (@lambda (file)
+    (call-with-input-file file
+      (@lambda (port)
+	(@let ((loop (@lambda (x)
+		       (@if (@not (eof-object? x))
+			    (@begin
+			      (eval x (interaction-environment))
+			      (loop (read port)))))))
+	  (loop (read port)))))))
+
+;; transcript-on
+;; transcript-off

module/language/r5rs/expand.scm

@@ -0,0 +1,81 @@
+;;; R5RS syntax expander
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (language r5rs expand)
+  :export (expand void
+	   identifier? free-identifier=? bound-identifier=?
+	   generate-temporaries datum->syntax-object syntax-object->datum))
+
+(define sc-expand #f)
+(define $sc-put-cte #f)
+(define $syntax-dispatch #f)
+(define syntax-rules #f)
+(define syntax-error #f)
+(define identifier? #f)
+(define free-identifier=? #f)
+(define bound-identifier=? #f)
+(define generate-temporaries #f)
+(define datum->syntax-object #f)
+(define syntax-object->datum #f)
+
+(define void (lambda () (if #f #f)))
+
+(define andmap
+  (lambda (f first . rest)
+    (or (null? first)
+	(if (null? rest)
+	    (let andmap ((first first))
+	      (let ((x (car first)) (first (cdr first)))
+		(if (null? first)
+		    (f x)
+		    (and (f x) (andmap first)))))
+	    (let andmap ((first first) (rest rest))
+	      (let ((x (car first))
+		    (xr (map car rest))
+		    (first (cdr first))
+		    (rest (map cdr rest)))
+		(if (null? first)
+		    (apply f (cons x xr))
+		    (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define ormap
+  (lambda (proc list1)
+    (and (not (null? list1))
+	 (or (proc (car list1)) (ormap proc (cdr list1))))))
+
+(define putprop set-symbol-property!)
+(define getprop symbol-property)
+(define remprop symbol-property-remove!)
+
+(define syncase-module (current-module))
+(define guile-eval eval)
+(define (eval x)
+  (if (and (pair? x) (equal? (car x) "noexpand"))
+      (cdr x)
+      (guile-eval x syncase-module)))
+
+(define guile-error error)
+(define (error who format-string why what)
+  (guile-error why what))
+
+(load "psyntax.pp")
+
+(define expand sc-expand)

module/language/r5rs/null.il

@@ -0,0 +1,20 @@
+;;; R5RS null environment
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:

module/language/r5rs/spec.scm

@@ -0,0 +1,64 @@
+;;; Guile R5RS
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (language r5rs spec)
+  :use-module (system base language)
+  :use-module (language r5rs expand)
+  :use-module (language r5rs translate)
+  :export (r5rs))
+
+
+;;;
+;;; Translator
+;;;
+
+(define (translate x) (if (pair? x) (translate-pair x) x))
+
+(define (translate-pair x)
+  (let ((head (car x)) (rest (cdr x)))
+    (case head
+      ((quote) (cons '@quote rest))
+      ((define set! if and or begin)
+       (cons (symbol-append '@ head) (map translate rest)))
+      ((let let* letrec)
+       (cons* (symbol-append '@ head)
+	      (map (lambda (b) (cons (car b) (map translate (cdr b))))
+		   (car rest))
+	      (map translate (cdr rest))))
+      ((lambda)
+       (cons* '@lambda (car rest) (map translate (cdr rest))))
+      (else
+       (cons (translate head) (map translate rest))))))
+
+
+;;;
+;;; Language definition
+;;;
+
+(define-language r5rs
+  :title	"Standard Scheme (R5RS + syntax-case)"
+  :version	"0.3"
+  :reader	read
+  :expander	expand
+  :translator	translate
+  :printer	write
+;;  :environment	(global-ref 'Language::R5RS::core)
+  )

module/language/scheme/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/language/scheme/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = translate.scm spec.scm
+moddir = $(guiledir)/language/scheme
+include $(top_srcdir)/guilec.mk

module/language/scheme/spec.scm

@@ -0,0 +1,50 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (language scheme spec)
+  :use-module (language scheme translate)
+  :use-module (system base language)
+  :export (scheme))
+
+;;;
+;;; Reader
+;;;
+
+(read-enable 'positions)
+
+(define (read-file port)
+  (do ((x (read port) (read port))
+       (l '() (cons x l)))
+      ((eof-object? x)
+       (cons 'begin (reverse! l)))))
+
+;;;
+;;; Language definition
+;;;
+
+(define-language scheme
+  :title	"Guile Scheme"
+  :version	"0.5"
+  :reader	read
+  :read-file	read-file
+  :translator	translate
+  :printer	write
+  )

module/language/scheme/translate.scm

@@ -0,0 +1,341 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (language scheme translate)
+  :use-module (system base pmatch)
+  :use-module (system base language)
+  :use-module (system il ghil)
+  :use-module (system il inline)
+  :use-module (ice-9 receive)
+  :use-module (srfi srfi-39)
+  :use-module ((system base compile) :select (syntax-error))
+  :export (translate))
+
+
+(define (translate x e)
+  (call-with-ghil-environment (make-ghil-mod e) '()
+    (lambda (env vars)
+      (make-ghil-lambda env #f vars #f (trans env #f x)))))
+
+
+;;;
+;;; Translator
+;;;
+
+(define %forbidden-primitives
+  ;; Guile's `procedure->macro' family is evil because it crosses the
+  ;; compilation boundary.  One solution might be to evaluate calls to
+  ;; `procedure->memoizing-macro' at compilation time, but it may be more
+  ;; compicated than that.
+  '(procedure->syntax procedure->macro procedure->memoizing-macro))
+
+(define (lookup-transformer e head retrans)
+  (let* ((mod (ghil-mod-module (ghil-env-mod e)))
+         (val (and=> (module-variable mod head) 
+                     (lambda (var)
+                       ;; unbound vars can happen if the module
+                       ;; definition forward-declared them
+                       (and (variable-bound? var) (variable-ref var))))))
+    (cond
+     ((or (primitive-macro? val) (eq? val eval-case))
+      (or (assq-ref primitive-syntax-table head)
+          (syntax-error #f "unhandled primitive macro" head)))
+
+     ((defmacro? val)
+      (lambda (env loc exp)
+        (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+     ((and (macro? val) (eq? (macro-name val) 'sc-macro))
+      ;; syncase!
+      (let* ((the-syncase-module (resolve-module '(ice-9 syncase)))
+             (eec (module-ref the-syncase-module 'expansion-eval-closure))
+             (sc-expand3 (module-ref the-syncase-module 'sc-expand3)))
+        (lambda (env loc exp)
+          (retrans
+           (with-fluids ((eec (module-eval-closure mod)))
+             (sc-expand3 exp 'c '(compile load eval)))))))
+
+     ((macro? val)
+      (syntax-error #f "unknown kind of macro" head))
+
+     (else #f))))
+
+(define (trans e l x)
+  (define (retrans x) (trans e l x))
+  (cond ((pair? x)
+         (let ((head (car x)) (tail (cdr x)))
+           (cond
+            ((lookup-transformer e head retrans)
+             => (lambda (t) (t e l x)))
+
+            ;; FIXME: lexical/module overrides of forbidden primitives
+            ((memq head %forbidden-primitives)
+   	     (syntax-error l (format #f "`~a' is forbidden" head)
+   			   (cons head tail)))
+
+            (else
+             (let ((tail (map retrans tail)))
+               (or (try-inline-with-env e l (cons head tail))
+                   (make-ghil-call e l (retrans head) tail)))))))
+
+	((symbol? x)
+         (make-ghil-ref e l (ghil-lookup e x)))
+
+        ;; fixme: non-self-quoting objects like #<foo>
+	(else
+         (make-ghil-quote e l #:obj x))))
+
+(define (valid-bindings? bindings . it-is-for-do)
+  (define (valid-binding? b)
+    (pmatch b 
+      ((,sym ,var) (guard (symbol? sym)) #t)
+      ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
+      (else #f)))
+  (and (list? bindings) (and-map valid-binding? bindings)))
+
+(define-macro (make-pmatch-transformers env loc retranslate . body)
+  (define exp (gensym))
+  (define (make1 clause)
+    (let ((sym (car clause))
+          (clauses (cdr clause)))
+      `(cons ',sym
+             (lambda (,env ,loc ,exp)
+               (define (,retranslate x) (trans ,env ,loc x))
+               (pmatch (cdr ,exp)
+                ,@clauses
+                (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
+  `(list ,@(map make1 body)))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+
+(define primitive-syntax-table
+  (make-pmatch-transformers
+   e l retrans
+   (quote
+    ;; (quote OBJ)
+    ((,obj) (make-ghil-quote e l obj)))
+    
+   (quasiquote
+    ;; (quasiquote OBJ)
+    ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))))
+
+   (define
+    ;; (define NAME VAL)
+    ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
+     (make-ghil-define e l (ghil-define (ghil-env-parent e) name)
+                       (retrans val)))
+    ;; (define (NAME FORMALS...) BODY...)
+    (((,name . ,formals) . ,body) (guard (symbol? name))
+     ;; -> (define NAME (lambda FORMALS BODY...))
+     (retrans `(define ,name (lambda ,formals ,@body)))))
+
+   (set!
+    ;; (set! NAME VAL)
+    ((,name ,val) (guard (symbol? name))
+     (make-ghil-set e l (ghil-lookup e name) (retrans val)))
+
+    ;; (set! (NAME ARGS...) VAL)
+    (((,name . ,args) ,val) (guard (symbol? name))
+     ;; -> ((setter NAME) ARGS... VAL)
+     (retrans `((setter ,name) . (,@args ,val)))))
+
+   (if
+    ;; (if TEST THEN [ELSE])
+    ((,test ,then)
+     (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
+    ((,test ,then ,else)
+     (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
+
+   (and
+    ;; (and EXPS...)
+    (,tail (make-ghil-and e l (map retrans tail))))
+
+   (or
+    ;; (or EXPS...)
+    (,tail (make-ghil-or e l (map retrans tail))))
+
+   (begin
+     ;; (begin EXPS...)
+     (,tail (make-ghil-begin e l (map retrans tail))))
+
+   (let
+    ;; (let NAME ((SYM VAL) ...) BODY...)
+    ((,name ,bindings . ,body) (guard (symbol? name)
+                                      (valid-bindings? bindings))
+     ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+     (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
+                 (,name ,@(map cadr bindings)))))
+
+    ;; (let () BODY...)
+    ((() . ,body)
+     ;; Note: this differs from `begin'
+     (make-ghil-begin e l (list (trans-body e l body))))
+    
+    ;; (let ((SYM VAL) ...) BODY...)
+    ((,bindings . ,body) (guard (valid-bindings? bindings))
+     (let ((vals (map retrans (map cadr bindings))))
+       (call-with-ghil-bindings e (map car bindings)
+         (lambda (vars)
+           (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+   (let*
+    ;; (let* ((SYM VAL) ...) BODY...)
+    ((() . ,body)
+     (retrans `(let () ,@body)))
+    ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
+     (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
+
+   (letrec
+    ;; (letrec ((SYM VAL) ...) BODY...)
+    ((,bindings . ,body) (guard (valid-bindings? bindings))
+     (call-with-ghil-bindings e (map car bindings)
+        (lambda (vars)
+          (let ((vals (map retrans (map cadr bindings))))
+            (make-ghil-bind e l vars vals (trans-body e l body)))))))
+
+   (cond
+    ;; (cond (CLAUSE BODY...) ...)
+    (() (retrans '(begin)))
+    (((else . ,body)) (retrans `(begin ,@body)))
+    (((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
+    (((,test => ,proc) . ,rest)
+     ;; FIXME hygiene!
+     (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
+    (((,test . ,body) . ,rest)
+     (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
+
+   (case
+    ;; (case EXP ((KEY...) BODY...) ...)
+    ((,exp . ,clauses)
+     (retrans
+      ;; FIXME hygiene!
+      `(let ((_t ,exp))
+         ,(let loop ((ls clauses))
+            (cond ((null? ls) '(begin))
+                  ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
+                  (else `(if (memv _t ',(caar ls))
+                             (begin ,@(cdar ls))
+                             ,(loop (cdr ls))))))))))
+
+    (do
+     ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+     ((,bindings (,test . ,result) . ,body)
+      (let ((sym (map car bindings))
+            (val (map cadr bindings))
+            (update (map cddr bindings)))
+        (define (next s x) (if (pair? x) (car x) s))
+        (retrans
+         ;; FIXME hygiene!
+         `(letrec ((_l (lambda ,sym
+                         (if ,test
+                             (begin ,@result)
+                             (begin ,@body
+                                    (_l ,@(map next sym update)))))))
+            (_l ,@val))))))
+
+    (lambda
+     ;; (lambda FORMALS BODY...)
+     ((,formals . ,body)
+      (receive (syms rest) (parse-formals formals)
+        (call-with-ghil-environment e syms
+       (lambda (env vars)
+            (make-ghil-lambda env l vars rest (trans-body env l body)))))))
+
+    (eval-case
+     (,clauses
+      (retrans
+       `(begin
+          ,@(let ((toplevel? (ghil-env-toplevel? e)))
+              (let loop ((seen '()) (in clauses) (runtime '()))
+                (cond
+                 ((null? in) runtime)
+                 (else
+                  (pmatch (car in)
+                   ((else . ,body)
+                    (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
+                        (primitive-eval `(begin ,@body)))
+                    (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
+                        runtime
+                        body))
+                   ((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
+                    (for-each (lambda (k)
+                                (if (memq k seen)
+                                    (syntax-error l "eval-case condition seen twice" k)))
+                              keys)
+                    (if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
+                        (primitive-eval `(begin ,@body)))
+                    (loop (append keys seen)
+                          (cdr in)
+                          (if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
+                              (append runtime body)
+                              runtime)))
+                   (else (syntax-error l "bad eval-case clause" (car in))))))))))))))
+
+(define (trans-quasiquote e l x)
+  (cond ((not (pair? x)) x)
+	((memq (car x) '(unquote unquote-splicing))
+	 (let ((l (location x)))
+	   (pmatch (cdr x)
+	     ((,obj)
+	      (if (eq? (car x) 'unquote)
+		  (make-ghil-unquote e l (trans e l obj))
+		  (make-ghil-unquote-splicing e l (trans e l obj))))
+	     (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+	(else (cons (trans-quasiquote e l (car x))
+		    (trans-quasiquote e l (cdr x))))))
+
+(define (trans-body e l body)
+  (define (define->binding df)
+    (pmatch (cdr df)
+      ((,name ,val) (guard (symbol? name)) (list name val))
+      (((,name . ,formals) . ,body) (guard (symbol? name))
+       (list name `(lambda ,formals ,@body)))
+      (else (syntax-error (location df) "bad define" df))))
+  ;; main
+  (let loop ((ls body) (ds '()))
+    (pmatch ls
+      (() (syntax-error l "bad body" body))
+      (((define . _) . _)
+       (loop (cdr ls) (cons (car ls) ds)))
+      (else
+       (if (null? ds)
+           (trans e l `(begin ,@ls))
+           (trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
+
+(define (parse-formals formals)
+  (cond
+   ;; (lambda x ...)
+   ((symbol? formals) (values (list formals) #t))
+   ;; (lambda (x y z) ...)
+   ((list? formals) (values formals #f))
+   ;; (lambda (x y . z) ...)
+   ((pair? formals)
+    (let loop ((l formals) (v '()))
+      (if (pair? l)
+	  (loop (cdr l) (cons (car l) v))
+	  (values (reverse! (cons l v)) #t))))
+   (else (syntax-error (location formals) "bad formals" formals))))
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+	      (cons (assq-ref props 'line) (assq-ref props 'column))))))

module/system/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/Makefile.am

@@ -0,0 +1 @@
+SUBDIRS = base il vm repl

module/system/base/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/base/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = pmatch.scm syntax.scm compile.scm language.scm
+moddir = $(guiledir)/system/base
+include $(top_srcdir)/guilec.mk

module/system/base/compile.scm

@@ -0,0 +1,167 @@
+;;; High-level compiler interface
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base compile)
+  :use-syntax (system base syntax)
+  :use-module (system base language)
+  :use-module (system il compile)
+  :use-module (system il glil)
+  :use-module ((system vm core)
+	       :select (the-vm vm-load objcode->u8vector load-objcode))
+  :use-module (system vm assemble)
+  :use-module (ice-9 regex)
+  :export (syntax-error compile-file load-source-file load-file
+           compiled-file-name
+           scheme-eval read-file-in compile-in
+           load/compile))
+
+;;;
+;;; Compiler environment
+;;;
+
+(define (syntax-error loc msg exp)
+  (throw 'syntax-error loc msg exp))
+
+(define-macro (call-with-compile-error-catch thunk)
+  `(catch 'syntax-error
+	 ,thunk
+	 (lambda (key loc msg exp)
+	   (if (pair? loc)
+	       (format #t "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
+	       (format #t "unknown location: ~A: ~A~%" msg exp)))))
+
+(export-syntax  call-with-compile-error-catch)
+
+
+
+;;;
+;;; Compiler
+;;;
+
+(define (scheme) (lookup-language 'scheme))
+
+(define (compile-file file . opts)
+  (let ((comp (compiled-file-name file))
+        (scheme (scheme)))
+    (catch 'nothing-at-all
+      (lambda ()
+	(call-with-compile-error-catch
+	 (lambda ()
+	   (call-with-output-file comp
+	     (lambda (port)
+	       (let* ((source (read-file-in file scheme))
+		      (objcode (apply compile-in source (current-module)
+				      scheme opts)))
+		 (if (memq :c opts)
+		   (pprint-glil objcode port)
+		   (uniform-vector-write (objcode->u8vector objcode) port)))))
+	   (format #t "wrote `~A'\n" comp))))
+      (lambda (key . args)
+	(format #t "ERROR: during compilation of ~A:\n" file)
+	(display "ERROR: ")
+	(apply format #t (cadr args) (caddr args))
+	(newline)
+	(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
+	(delete-file comp)))))
+
+; (let ((c-f compile-file))
+;   ;; XXX:  Debugging output
+;   (set! compile-file
+; 	(lambda (file . opts)
+; 	  (format #t "compile-file: ~a ~a~%" file opts)
+; 	  (let ((result (apply c-f (cons file opts))))
+; 	    (format #t "compile-file: returned ~a~%" result)
+; 	    result))))
+
+(define (load-source-file file . opts)
+  (let ((source (read-file-in file (scheme))))
+    (apply compile-in source (current-module) (scheme) opts)))
+
+(define (load-file file . opts)
+  (let ((comp (compiled-file-name file)))
+    (if (file-exists? comp)
+	(load-objcode comp)
+	(apply load-source-file file opts))))
+
+(define (compiled-file-name file)
+  (let ((base (basename file)))
+    (let ((m (string-match "\\.scm$" base)))
+      (string-append (if m (match:prefix m) base) ".go"))))
+
+(define (scheme-eval x e)
+  (vm-load (the-vm) (compile-in x e (scheme))))
+
+
+;;;
+;;; Scheme compiler interface
+;;;
+
+(define (read-file-in file lang)
+  (call-with-input-file file (language-read-file lang)))
+
+(define (compile-in x e lang . opts)
+  (save-module-excursion
+   (lambda ()
+     (catch 'result
+      (lambda ()
+        ;; expand
+        (set! x ((language-expander lang) x e))
+        (if (memq :e opts) (throw 'result x))
+        ;; translate
+        (set! x ((language-translator lang) x e))
+        (if (memq :t opts) (throw 'result x))
+        ;; compile
+        (set! x (apply compile x e opts))
+        (if (memq :c opts) (throw 'result x))
+        ;; assemble
+        (apply assemble x e opts))
+      (lambda (key val) val)))))
+
+;;;
+;;;
+;;;
+
+(define (compile-and-load file . opts)
+  (let ((comp (object-file-name file)))
+    (if (or (not (file-exists? comp))
+	    (> (stat:mtime (stat file)) (stat:mtime (stat comp))))
+	(compile-file file))
+    (load-compiled-file comp)))
+
+(define (load/compile file . opts)
+  (let* ((file (file-full-name file))
+	 (compiled (object-file-name file)))
+    (if (or (not (file-exists? compiled))
+	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
+	(apply compile-file file #f opts))
+    (if (memq #:b opts)
+	(apply vm-trace (the-vm) (load-objcode compiled) opts)
+	((the-vm) (load-objcode compiled)))))
+
+(define (file-full-name filename)
+  (let* ((port (current-load-port))
+	 (oldname (and port (port-filename port))))
+    (if (and oldname
+	     (> (string-length filename) 0)
+	     (not (char=? (string-ref filename 0) #\/))
+	     (not (string=? (dirname oldname) ".")))
+	(string-append (dirname oldname) "/" filename)
+	filename)))

module/system/base/language.scm

@@ -0,0 +1,48 @@
+;;; Multi-language support
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base language)
+  :use-syntax (system base syntax)
+  :export (define-language lookup-language make-language
+           language-name language-title language-version language-reader
+           language-printer language-read-file language-expander
+           language-translator language-evaluator language-environment))
+
+
+;;;
+;;; Language class
+;;;
+
+(define-record (<language> name title version reader printer read-file
+			   (expander (lambda (x e) x))
+			   (translator (lambda (x e) x))
+			   (evaluator #f)
+			   (environment #f)
+			   ))
+
+(define-macro (define-language name . spec)
+  `(define ,name (make-language :name ',name ,@spec)))
+
+(define (lookup-language name)
+  (let ((m (resolve-module `(language ,name spec))))
+    (if (module-bound? m name)
+	(module-ref m name)
+	(error "no such language" name))))

module/system/base/pmatch.scm

@@ -0,0 +1,42 @@
+(define-module (system base pmatch)
+  #:use-module (ice-9 syncase)
+  #:export (pmatch ppat))
+;; FIXME: shouldn't have to export ppat...
+
+;; Originally written by Oleg Kiselyov. Taken from:
+;; αKanren: A Fresh Name in Nominal Logic Programming
+;; by William E. Byrd and Daniel P. Friedman
+;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;; Université Laval Technical Report DIUL-RT-0701
+
+;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
+
+(define-syntax pmatch
+  (syntax-rules (else guard)
+    ((_ (op arg ...) cs ...)
+     (let ((v (op arg ...)))
+       (pmatch v cs ...)))
+    ((_ v) (if #f #f))
+    ((_ v (else e0 e ...)) (begin e0 e ...))
+    ((_ v (pat (guard g ...) e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch v cs ...))))
+       (ppat v pat
+             (if (and g ...) (begin e0 e ...) (fk))
+             (fk))))
+    ((_ v (pat e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch v cs ...))))
+       (ppat v pat (begin e0 e ...) (fk))))))
+
+(define-syntax ppat
+  (syntax-rules (_ quote unquote)
+    ((_ v _ kt kf) kt)
+    ((_ v () kt kf) (if (null? v) kt kf))
+    ((_ v (quote lit) kt kf)
+     (if (equal? v (quote lit)) kt kf))
+    ((_ v (unquote var) kt kf) (let ((var v)) kt))
+    ((_ v (x . y) kt kf)
+     (if (pair? v)
+         (let ((vx (car v)) (vy (cdr v)))
+           (ppat vx x (ppat vy y kt kf) kf))
+         kf))
+    ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))

module/system/base/syntax.scm

@@ -0,0 +1,126 @@
+;;; Guile VM specific syntaxes and utilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system base syntax)
+  :export (%compute-initargs)
+  :export-syntax (define-type define-record record-case))
+(export-syntax |) ;; emacs doesn't like the |
+
+
+;;;
+;;; Keywords by `:KEYWORD
+;;;
+
+(read-set! keywords 'prefix)
+
+
+;;;
+;;; Type
+;;;
+
+(define-macro (define-type name sig) sig)
+
+;;;
+;;; Record
+;;;
+
+(define (symbol-trim-both sym pred)
+  (string->symbol (string-trim-both (symbol->string sym) pred)))
+
+(define-macro (define-record def)
+  (let* ((name (car def)) (slots (cdr def))
+         (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+                          slots))
+         (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+    `(begin
+       (define ,name (make-record-type ,(symbol->string name) ',slot-names))
+       (define ,(symbol-append 'make- stem)
+         (let ((slots (list ,@(map (lambda (slot)
+                                     (if (pair? slot)
+                                         `(cons ',(car slot) ,(cadr slot))
+                                         `',slot))
+                                   slots)))
+               (constructor (record-constructor ,name)))
+           (lambda args
+             (apply constructor (%compute-initargs args slots)))))
+       (define ,(symbol-append stem '?) (record-predicate ,name))
+       ,@(map (lambda (sname)
+                `(define ,(symbol-append stem '- sname)
+                   (make-procedure-with-setter
+                    (record-accessor ,name ',sname)
+                    (record-modifier ,name ',sname))))
+              slot-names))))
+
+(define (%compute-initargs args slots)
+  (define (finish out)
+    (map (lambda (slot)
+           (let ((name (if (pair? slot) (car slot) slot)))
+             (cond ((assq name out) => cdr)
+                   ((pair? slot) (cdr slot))
+                   (else (error "unbound slot" args slots name)))))
+         slots))
+  (let lp ((in args) (positional slots) (out '()))
+    (cond
+     ((null? in)
+      (finish out))
+     ((keyword? (car in))
+      (let ((sym (keyword->symbol (car in))))
+        (cond
+         ((and (not (memq sym slots))
+               (not (assq sym (filter pair? slots))))
+          (error "unknown slot" sym))
+         ((assq sym out) (error "slot already set" sym out))
+         (else (lp (cddr in) '() (acons sym (cadr in) out))))))
+     ((null? positional)
+      (error "too many initargs" args slots))
+     (else
+      (lp (cdr in) (cdr positional)
+          (acons (car positional) (car in) out))))))
+
+(define-macro (record-case record . clauses)
+  (let ((r (gensym)))
+    (define (process-clause clause)
+      (if (eq? (car clause) 'else)
+          clause
+          (let ((record-type (caar clause))
+                (slots (cdar clause))
+                (body (cdr clause)))
+            `(((record-predicate ,record-type) ,r)
+              (let ,(map (lambda (slot)
+                           (if (pair? slot)
+                               `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+                               `(,slot ((record-accessor ,record-type ',slot) ,r))))
+                         slots)
+                ,@body)))))
+    `(let ((,r ,record))
+       (cond ,@(let ((clauses (map process-clause clauses)))
+                 (if (assq 'else clauses)
+                     clauses
+                     (append clauses `((else (error "unhandled record" ,r))))))))))
+
+
+
+;;;
+;;; Variants
+;;;
+
+(define-macro (| . rest)
+  `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))

module/system/il/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/il/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = glil.scm ghil.scm inline.scm compile.scm
+moddir = $(guiledir)/system/il
+include $(top_srcdir)/guilec.mk

module/system/il/compile.scm

@@ -0,0 +1,329 @@
+;;; GHIL -> GLIL compiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il compile)
+  :use-syntax (system base syntax)
+  :use-module (system il glil)
+  :use-module (system il ghil)
+  :use-module (ice-9 common-list)
+  :export (compile))
+
+(define (compile x e . opts)
+  (if (memq :O opts) (set! x (optimize x)))
+  (codegen x))
+
+
+;;;
+;;; Stage 2: Optimization
+;;;
+
+(define (optimize x)
+  (record-case x
+    ((<ghil-set> env loc var val)
+     (make-ghil-set env var (optimize val)))
+
+    ((<ghil-if> env loc test then else)
+     (make-ghil-if env loc (optimize test) (optimize then) (optimize else)))
+
+    ((<ghil-begin> env loc exps)
+     (make-ghil-begin env loc (map optimize exps)))
+
+    ((<ghil-bind> env loc vars vals body)
+     (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
+
+    ((<ghil-lambda> env loc vars rest body)
+     (make-ghil-lambda env loc vars rest (optimize body)))
+
+    ((<ghil-inline> env loc instruction args)
+     (make-ghil-inline env loc instruction (map optimize args)))
+
+    ((<ghil-call> env loc proc args)
+     (let ((parent-env env))
+       (record-case proc
+         ;; ((@lambda (VAR...) BODY...) ARG...) =>
+         ;;   (@let ((VAR ARG) ...) BODY...)
+         ((<ghil-lambda> env loc vars rest body)
+          (cond
+           ((not rest)
+            (for-each (lambda (v)
+                        (case (ghil-var-kind v)
+                          ((argument) (set! (ghil-var-kind v) 'local)))
+                        (set! (ghil-var-env v) parent-env)
+                        (ghil-env-add! parent-env v))
+                      (ghil-env-variables env)))
+           (else
+            (make-ghil-call parent-env loc (optimize proc) (map optimize args)))))
+         (else
+          (make-ghil-call parent-env loc (optimize proc) (map optimize args))))))
+
+    (else x)))
+
+
+;;;
+;;; Stage 3: Code generation
+;;;
+
+(define *ia-void* (make-glil-void))
+(define *ia-drop* (make-glil-call 'drop 0))
+(define *ia-return* (make-glil-call 'return 0))
+
+(define (make-label) (gensym ":L"))
+
+(define (make-glil-var op env var)
+  (case (ghil-var-kind var)
+    ((argument)
+     (make-glil-argument op (ghil-var-index var)))
+    ((local)
+     (make-glil-local op (ghil-var-index var)))
+    ((external)
+     (do ((depth 0 (1+ depth))
+	  (e env (ghil-env-parent e)))
+	 ((eq? e (ghil-var-env var))
+	  (make-glil-external op depth (ghil-var-index var)))))
+    ((module)
+     (let ((env (ghil-var-env var)))
+       (make-glil-module op (ghil-mod-module (ghil-env-mod env))
+                         (ghil-var-name var))))
+    (else (error "Unknown kind of variable:" var))))
+
+(define (codegen ghil)
+  (let ((stack '()))
+    (define (push-code! code)
+      (set! stack (cons code stack)))
+    (define (push-bindings! vars)
+      (if (not (null? vars))
+          (push-code!
+           (make-glil-bind
+            (map list
+                 (map ghil-var-name vars)
+                 (map ghil-var-kind vars)
+                 (map ghil-var-index vars))))))
+    (define (comp tree tail drop)
+      (define (push-label! label)
+	(push-code! (make-glil-label label)))
+      (define (push-branch! inst label)
+	(push-code! (make-glil-branch inst label)))
+      (define (push-call! loc inst args)
+	(for-each comp-push args)
+	(push-code! (make-glil-call inst (length args)))
+	(push-code! (make-glil-source loc)))
+      ;; possible tail position
+      (define (comp-tail tree) (comp tree tail drop))
+      ;; push the result
+      (define (comp-push tree) (comp tree #f #f))
+      ;; drop the result
+      (define (comp-drop tree) (comp tree #f #t))
+      ;; drop the result if unnecessary
+      (define (maybe-drop)
+	(if drop (push-code! *ia-drop*)))
+      ;; return here if necessary
+      (define (maybe-return)
+	(if tail (push-code! *ia-return*)))
+      ;; return this code if necessary
+      (define (return-code! code)
+	(if (not drop) (push-code! code))
+	(maybe-return))
+      ;; return void if necessary
+      (define (return-void!)
+	(return-code! *ia-void*))
+      ;; return object if necessary
+      (define (return-object! obj)
+	(return-code! (make-glil-const #:obj obj)))
+      ;;
+      ;; dispatch
+      (record-case tree
+	((<ghil-void>)
+	 (return-void!))
+
+	((<ghil-quote> env loc obj)
+	 (return-object! obj))
+
+	((<ghil-quasiquote> env loc exp)
+	 (let loop ((x exp))
+           (cond
+            ((list? x)
+             (push-call! #f 'mark '())
+             (for-each loop x)
+             (push-call! #f 'list-mark '()))
+            ((pair? x)
+             (loop (car x))
+             (loop (cdr x))
+             (push-code! (make-glil-call 'cons 2)))
+            ((record? x)
+             (record-case x
+              ((<ghil-unquote> env loc exp)
+               (comp-push exp))
+              ((<ghil-unquote-splicing> env loc exp)
+               (comp-push exp)
+               (push-call! #f 'list-break '()))))
+            (else
+             (push-code! (make-glil-const #:obj x)))))
+	 (maybe-drop)
+	 (maybe-return))
+
+	((<ghil-ref> env loc var)
+	 (return-code! (make-glil-var 'ref env var)))
+
+	((<ghil-set> env loc var val)
+	 (comp-push val)
+	 (push-code! (make-glil-var 'set env var))
+	 (return-void!))
+
+	((<ghil-define> env loc var val)
+	 (comp-push val)
+	 (push-code! (make-glil-var 'define env var))
+	 (return-void!))
+
+	((<ghil-if> env loc test then else)
+	 ;;     TEST
+	 ;;     (br-if-not L1)
+	 ;;     THEN
+	 ;;     (br L2)
+	 ;; L1: ELSE
+	 ;; L2:
+	 (let ((L1 (make-label)) (L2 (make-label)))
+	   (comp-push test)
+	   (push-branch! 'br-if-not L1)
+	   (comp-tail then)
+	   (if (not tail) (push-branch! 'br L2))
+	   (push-label! L1)
+	   (comp-tail else)
+	   (if (not tail) (push-label! L2))))
+
+	((<ghil-and> env loc exps)
+	 ;;     EXP
+	 ;;     (br-if-not L1)
+	 ;;     ...
+	 ;;     TAIL
+	 ;;     (br L2)
+	 ;; L1: (const #f)
+	 ;; L2:
+	 (let ((L1 (make-label)) (L2 (make-label)))
+	   (if (null? exps)
+	       (return-object! #t)
+	       (do ((exps exps (cdr exps)))
+		   ((null? (cdr exps))
+		    (comp-tail (car exps))
+		    (if (not tail) (push-branch! 'br L2))
+		    (push-label! L1)
+		    (return-object! #f)
+		    (if (not tail) (push-label! L2))
+		    (maybe-drop)
+		    (maybe-return))
+		 (comp-push (car exps))
+		 (push-branch! 'br-if-not L1)))))
+
+	((<ghil-or> env loc exps)
+	 ;;     EXP
+	 ;;     (dup)
+	 ;;     (br-if L1)
+	 ;;     (drop)
+	 ;;     ...
+	 ;;     TAIL
+	 ;; L1:
+	 (let ((L1 (make-label)))
+	   (if (null? exps)
+	       (return-object! #f)
+	       (do ((exps exps (cdr exps)))
+		   ((null? (cdr exps))
+		    (comp-tail (car exps))
+		    (push-label! L1)
+		    (maybe-drop)
+		    (maybe-return))
+		 (comp-push (car exps))
+		 (push-call! #f 'dup '())
+		 (push-branch! 'br-if L1)
+		 (push-call! #f 'drop '())))))
+
+	((<ghil-begin> env loc exps)
+	 ;; EXPS...
+	 ;; TAIL
+	 (if (null? exps)
+	     (return-void!)
+	     (do ((exps exps (cdr exps)))
+		 ((null? (cdr exps))
+		  (comp-tail (car exps)))
+	       (comp-drop (car exps)))))
+
+	((<ghil-bind> env loc vars vals body)
+	 ;; VALS...
+	 ;; (set VARS)...
+	 ;; BODY
+	 (for-each comp-push vals)
+         (push-bindings! vars)
+	 (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
+		   (reverse vars))
+	 (comp-tail body)
+	 (push-code! (make-glil-unbind)))
+
+	((<ghil-lambda> env loc vars rest body)
+	 (return-code! (codegen tree)))
+
+	((<ghil-inline> env loc inline args)
+	 ;; ARGS...
+	 ;; (INST NARGS)
+	 (push-call! loc inline args)
+	 (maybe-drop)
+	 (maybe-return))
+
+	((<ghil-call> env loc proc args)
+	 ;; PROC
+	 ;; ARGS...
+	 ;; ([tail-]call NARGS)
+	 (comp-push proc)
+	 (push-call! loc (if tail 'tail-call 'call) args)
+	 (maybe-drop))))
+    ;;
+    ;; main
+    (record-case ghil
+      ((<ghil-lambda> env loc vars rest body)
+       (let* ((evars (ghil-env-variables env))
+	      (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+	      (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
+	 ;; initialize variable indexes
+	 (finalize-index! vars)
+	 (finalize-index! locs)
+	 (finalize-index! exts)
+	 ;; meta bindings
+         (push-bindings! vars)
+	 ;; export arguments
+	 (do ((n 0 (1+ n))
+	      (l vars (cdr l)))
+	     ((null? l))
+	   (let ((v (car l)))
+	     (case (ghil-var-kind v)
+               ((external)
+                (push-code! (make-glil-argument 'ref n))
+                (push-code! (make-glil-external 'set 0 (ghil-var-index v)))))))
+	 ;; compile body
+	 (comp body #t #f)
+	 ;; create GLIL
+	 (let ((vars (make-glil-vars :nargs (length vars)
+                                     :nrest (if rest 1 0)
+                                     :nlocs (length locs)
+                                     :nexts (length exts))))
+	   (make-glil-asm vars (reverse! stack))))))))
+
+(define (finalize-index! list)
+  (do ((n 0 (1+ n))
+       (l list (cdr l)))
+      ((null? l))
+    (let ((v (car l))) (set! (ghil-var-index v) n))))

module/system/il/ghil.scm

@@ -0,0 +1,393 @@
+;;; Guile High Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il ghil)
+  :use-syntax (system base syntax)
+  :use-module (ice-9 regex)
+  :export
+  (<ghil-void> make-ghil-void ghil-void?
+   ghil-void-env ghil-void-loc
+
+   <ghil-quote> make-ghil-quote ghil-quote?
+   ghil-quote-env ghil-quote-loc ghil-quote-obj
+
+   <ghil-quasiquote> make-ghil-quasiquote ghil-quasiquote?
+   ghil-quasiquote-env ghil-quasiquote-loc ghil-quasiquote-exp
+
+   <ghil-unquote> make-ghil-unquote ghil-unquote?
+   ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+   <ghil-unquote-splicing> make-ghil-unquote-splicing ghil-unquote-splicing?
+   ghil-unquote-env ghil-unquote-loc ghil-unquote-exp
+
+   <ghil-ref> make-ghil-ref ghil-ref?
+   ghil-ref-env ghil-ref-loc ghil-ref-var
+
+   <ghil-set> make-ghil-set ghil-set?
+   ghil-set-env ghil-set-loc ghil-set-var ghil-set-val
+
+   <ghil-define> make-ghil-define ghil-define?
+   ghil-define-env ghil-define-loc ghil-define-var ghil-define-val
+
+   <ghil-if> make-ghil-if ghil-if?
+   ghil-if-env ghil-if-loc ghil-if-test ghil-if-then ghil-if-else
+
+   <ghil-and> make-ghil-and ghil-and?
+   ghil-and-env ghil-and-loc ghil-and-exps
+
+   <ghil-or> make-ghil-or ghil-or?
+   ghil-or-env ghil-or-loc ghil-or-exps
+
+   <ghil-begin> make-ghil-begin ghil-begin?
+   ghil-begin-env ghil-begin-loc ghil-begin-exps
+
+   <ghil-bind> make-ghil-bind ghil-bind?
+   ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
+
+   <ghil-lambda> make-ghil-lambda ghil-lambda?
+   ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
+
+   <ghil-inline> make-ghil-inline ghil-inline?
+   ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
+
+   <ghil-call> make-ghil-call ghil-call?
+   ghil-call-env ghil-call-loc ghil-call-proc ghil-call-args
+
+   <ghil-var> make-ghil-var ghil-var?
+   ghil-var-env ghil-var-name ghil-var-kind ghil-var-type ghil-var-value
+   ghil-var-index
+
+   <ghil-mod> make-ghil-mod ghil-mod?
+   ghil-mod-module ghil-mod-table ghil-mod-imports
+
+   <ghil-env> make-ghil-env ghil-env?
+   ghil-env-mod ghil-env-parent ghil-env-table ghil-env-variables
+
+   ghil-env-add! ghil-lookup ghil-define
+   ghil-env-toplevel?
+   call-with-ghil-environment call-with-ghil-bindings))
+
+
+;;;
+;;; Parse tree
+;;;
+
+(define-type <ghil>
+  (|
+   ;; Objects
+   (<ghil-void> env loc)
+   (<ghil-quote> env loc obj)
+   (<ghil-quasiquote> env loc exp)
+   (<ghil-unquote> env loc exp)
+   (<ghil-unquote-splicing> env loc exp)
+   ;; Variables
+   (<ghil-ref> env loc var)
+   (<ghil-set> env loc var val)
+   (<ghil-define> env loc var val)
+   ;; Controls
+   (<ghil-if> env loc test then else)
+   (<ghil-and> env loc exps)
+   (<ghil-or> env loc exps)
+   (<ghil-begin> env loc exps)
+   (<ghil-bind> env loc vars vals body)
+   (<ghil-lambda> env loc vars rest body)
+   (<ghil-call> env loc proc args)
+   (<ghil-inline> env loc inline args)))
+
+
+;;;
+;;; Variables
+;;;
+
+(define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
+
+
+;;;
+;;; Modules
+;;;
+
+(define-record (<ghil-mod> module (table '()) (imports '())))
+
+
+;;;
+;;; Environments
+;;;
+
+(define-record (<ghil-env> mod parent (table '()) (variables '())))
+
+(define %make-ghil-env make-ghil-env)
+(define (make-ghil-env e)
+  (record-case e
+    ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
+    ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
+
+(define (ghil-env-toplevel? e)
+  (eq? (ghil-env-mod e) (ghil-env-parent e)))
+
+(define (ghil-env-ref env sym)
+  (assq-ref (ghil-env-table env) sym))
+
+(define-macro (push! item loc)
+  `(set! ,loc (cons ,item ,loc)))
+(define-macro (apush! k v loc)
+  `(set! ,loc (acons ,k ,v ,loc)))
+(define-macro (apopq! k loc)
+  `(set! ,loc (assq-remove! ,loc ,k)))
+
+(define (ghil-env-add! env var)
+  (apush! (ghil-var-name var) var (ghil-env-table env))
+  (push! var (ghil-env-variables env)))
+
+(define (ghil-env-remove! env var)
+  (apopq! (ghil-var-name var) (ghil-env-table env)))
+
+
+;;;
+;;; Public interface
+;;;
+
+(define (fix-ghil-mod! mod for-sym)
+  ;;; So, these warnings happen for all instances of define-module.
+  ;;; Rather than fixing the problem, I'm going to suppress the common
+  ;;; warnings.
+  (if (not (eq? for-sym 'process-define-module))
+      (warn "during lookup of" for-sym ":"
+            (ghil-mod-module mod) "!= current" (current-module)))
+  (if (not (null? (ghil-mod-table mod)))
+      (warn "throwing away old variable table"
+            (ghil-mod-module) (ghil-mod-table mod)))
+  (set! (ghil-mod-module mod) (current-module))
+  (set! (ghil-mod-table mod) '())
+  (set! (ghil-mod-imports mod) '()))
+
+;; looking up a var has side effects?
+(define (ghil-lookup env sym)
+  (or (ghil-env-ref env sym)
+      (let loop ((e (ghil-env-parent env)))
+        (record-case e
+          ((<ghil-mod> module table imports)
+           (cond ((not (eq? module (current-module)))
+                  ;; FIXME: the primitive-eval in eval-case and/or macro
+                  ;; expansion can have side effects on the compilation
+                  ;; environment, for example changing the current
+                  ;; module. We probably need to add a special case in
+                  ;; compilation to handle define-module.
+                  (fix-ghil-mod! e sym)
+                  (loop e))
+                 ((assq-ref table sym)) ;; when does this hit?
+                 (else
+                  ;; although we could bind the variable here, in
+                  ;; practice further toplevel definitions in this
+                  ;; compilation unit could change how we would resolve
+                  ;; this binding, so punt and memoize the lookup at
+                  ;; runtime always.
+                  (let ((var (make-ghil-var (make-ghil-env e) sym 'module)))
+                    (apush! sym var table)
+                    var))))
+          ((<ghil-env> mod parent table variables)
+           (let ((found (assq-ref table sym)))
+             (if found
+                 (begin (set! (ghil-var-kind found) 'external) found)
+                 (loop parent))))))))
+
+(define (ghil-define mod sym)
+  (if (not (eq? (ghil-mod-module mod) (current-module)))
+      (fix-ghil-mod! mod sym))
+  (or (assq-ref (ghil-mod-table mod) sym)
+      (let ((var (make-ghil-var (make-ghil-env mod) sym 'module)))
+        (apush! sym var (ghil-mod-table mod))
+        var)))
+          
+(define (call-with-ghil-environment e syms func)
+  (let* ((e (make-ghil-env e))
+	 (vars (map (lambda (s)
+		      (let ((v (make-ghil-var e s 'argument)))
+			(ghil-env-add! e v) v))
+		    syms)))
+    (func e vars)))
+
+(define (call-with-ghil-bindings e syms func)
+  (let* ((vars (map (lambda (s)
+		      (let ((v (make-ghil-var e s 'local)))
+			(ghil-env-add! e v) v))
+		    syms))
+	 (ret (func vars)))
+    (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+    ret))
+
+
+;;;
+;;; Parser
+;;;
+
+;;; (define-public (parse-ghil x e)
+;;;   (parse `(@lambda () ,x) (make-ghil-mod e)))
+;;; 
+;;; (define (parse x e)
+;;;   (cond ((pair? x) (parse-pair x e))
+;;; 	((symbol? x)
+;;; 	 (let ((str (symbol->string x)))
+;;; 	   (case (string-ref str 0)
+;;; 	     ((#\@) (error "Invalid use of IL primitive" x))
+;;; 	     ((#\:) (let ((sym (string->symbol (substring str 1))))
+;;; 		      (<ghil-quote> (symbol->keyword sym))))
+;;; 	     (else (<ghil-ref> e (ghil-lookup e x))))))
+;;; 	(else (<ghil-quote> x))))
+;;; 
+;;; (define (map-parse x e)
+;;;   (map (lambda (x) (parse x e)) x))
+;;; 
+;;; (define (parse-pair x e)
+;;;   (let ((head (car x)) (tail (cdr x)))
+;;;     (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
+;;; 	(if (ghil-primitive-macro? head)
+;;; 	    (parse (apply (ghil-macro-expander head) tail) e)
+;;; 	    (parse-primitive head tail e))
+;;; 	(<ghil-call> e (parse head e) (map-parse tail e)))))
+;;; 
+;;; (define (parse-primitive prim args e)
+;;;   (case prim
+;;;     ;; (@ IDENTIFIER)
+;;;     ((@)
+;;;      (match args
+;;;        (()
+;;; 	(<ghil-ref> e (make-ghil-var '@ '@ 'module)))
+;;;        ((identifier)
+;;; 	(receive (module name) (identifier-split identifier)
+;;; 	  (<ghil-ref> e (make-ghil-var module name 'module))))))
+;;; 
+;;;     ;; (@@ OP ARGS...)
+;;;     ((@@)
+;;;      (match args
+;;;        ((op . args)
+;;; 	(<ghil-inline> op (map-parse args e)))))
+;;; 
+;;;     ;; (@void)
+;;;     ((@void)
+;;;      (match args
+;;;        (() (<ghil-void>))))
+;;; 
+;;;     ;; (@quote OBJ)
+;;;     ((@quote)
+;;;      (match args
+;;;        ((obj)
+;;; 	(<ghil-quote> obj))))
+;;; 
+;;;     ;; (@define NAME VAL)
+;;;     ((@define)
+;;;      (match args
+;;;        ((name val)
+;;; 	(let ((v (ghil-lookup e name)))
+;;; 	  (<ghil-set> e v (parse val e))))))
+;;; 
+;;;     ;; (@set! NAME VAL)
+;;;     ((@set!)
+;;;      (match args
+;;;        ((name val)
+;;; 	(let ((v (ghil-lookup e name)))
+;;; 	  (<ghil-set> e v (parse val e))))))
+;;; 
+;;;     ;; (@if TEST THEN [ELSE])
+;;;     ((@if)
+;;;      (match args
+;;;        ((test then)
+;;; 	(<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
+;;;        ((test then else)
+;;; 	(<ghil-if> (parse test e) (parse then e) (parse else e)))))
+;;; 
+;;;     ;; (@begin BODY...)
+;;;     ((@begin)
+;;;      (parse-body args e))
+;;; 
+;;;     ;; (@let ((SYM INIT)...) BODY...)
+;;;     ((@let)
+;;;      (match args
+;;;        ((((sym init) ...) body ...)
+;;; 	(let* ((vals (map-parse init e))
+;;; 	       (vars (map (lambda (s)
+;;; 			    (let ((v (make-ghil-var e s 'local)))
+;;; 			      (ghil-env-add! e v) v))
+;;; 			  sym))
+;;; 	       (body (parse-body body e)))
+;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; 	  (<ghil-bind> e vars vals body)))))
+;;; 
+;;;     ;; (@letrec ((SYM INIT)...) BODY...)
+;;;     ((@letrec)
+;;;      (match args
+;;;        ((((sym init) ...) body ...)
+;;; 	(let* ((vars (map (lambda (s)
+;;; 			    (let ((v (make-ghil-var e s 'local)))
+;;; 			      (ghil-env-add! e v) v))
+;;; 			  sym))
+;;; 	       (vals (map-parse init e))
+;;; 	       (body (parse-body body e)))
+;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
+;;; 	  (<ghil-bind> e vars vals body)))))
+;;; 
+;;;     ;; (@lambda FORMALS BODY...)
+;;;     ((@lambda)
+;;;      (match args
+;;;        ((formals . body)
+;;; 	(receive (syms rest) (parse-formals formals)
+;;; 	  (let* ((e (make-ghil-env e))
+;;; 		 (vars (map (lambda (s)
+;;; 			      (let ((v (make-ghil-var e s 'argument)))
+;;; 				(ghil-env-add! e v) v))
+;;; 			    syms)))
+;;; 	    (<ghil-lambda> e vars rest (parse-body body e)))))))
+;;; 
+;;;     ;; (@eval-case CLAUSE...)
+;;;     ((@eval-case)
+;;;      (let loop ((clauses args))
+;;;        (cond ((null? clauses) (<ghil-void>))
+;;; 	     ((or (eq? (caar clauses) '@else)
+;;; 		  (and (memq 'load-toplevel (caar clauses))
+;;; 		       (ghil-env-toplevel? e)))
+;;; 	      (parse-body (cdar clauses) e))
+;;; 	     (else
+;;; 	      (loop (cdr clauses))))))
+;;; 
+;;;     (else (error "Unknown primitive:" prim))))
+;;; 
+;;; (define (parse-body x e)
+;;;   (<ghil-begin> (map-parse x e)))
+;;; 
+;;; (define (parse-formals formals)
+;;;   (cond
+;;;    ;; (@lambda x ...)
+;;;    ((symbol? formals) (values (list formals) #t))
+;;;    ;; (@lambda (x y z) ...)
+;;;    ((list? formals) (values formals #f))
+;;;    ;; (@lambda (x y . z) ...)
+;;;    ((pair? formals)
+;;;     (let loop ((l formals) (v '()))
+;;;       (if (pair? l)
+;;; 	  (loop (cdr l) (cons (car l) v))
+;;; 	  (values (reverse! (cons l v)) #t))))
+;;;    (else (error "Invalid formals:" formals))))
+;;; 
+;;; (define (identifier-split identifier)
+;;;   (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
+;;;     (if m
+;;; 	(values (string->symbol (match:prefix m))
+;;; 		(string->symbol (match:substring m 1)))
+;;; 	(values #f identifier))))

module/system/il/glil.scm

@@ -0,0 +1,211 @@
+;;; Guile Low Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il glil)
+  :use-syntax (system base syntax)
+  :export
+  (pprint-glil
+   <glil-vars> make-glil-vars
+   glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
+
+   <glil-asm> make-glil-asm glil-asm?
+   glil-asm-vars glil-asm-body
+
+   <glil-bind> make-glil-bind glil-bind?
+   glil-bind-vars
+
+   <glil-unbind> make-glil-unbind glil-unbind?
+
+   <glil-source> make-glil-source glil-source?
+   glil-source-loc
+
+   <glil-void> make-glil-void glil-void?
+
+   <glil-const> make-glil-const glil-const?
+   glil-const-obj
+
+   <glil-argument> make-glil-argument glil-argument?
+   glil-argument-op glil-argument-index
+
+   <glil-local> make-glil-local glil-local?
+   glil-local-op glil-local-index
+
+   <glil-external> make-glil-external glil-external?
+   glil-external-op glil-external-depth glil-external-index
+
+   <glil-module> make-glil-module glil-module?
+   glil-module-op glil-module-module glil-module-index
+
+   <glil-late-bound> make-glil-late-bound glil-late-bound?
+   glil-late-bound-op glil-late-bound-name
+
+   <glil-label> make-glil-label glil-label?
+   glil-label-label
+
+   <glil-branch> make-glil-branch glil-branch?
+   glil-branch-int glil-branch-label
+
+   <glil-call> make-glil-call glil-call?
+   glil-call-int glil-call-nargs))
+
+(define-record (<glil-vars> nargs nrest nlocs nexts))
+
+(define-type <glil>
+  (|
+   ;; Meta operations
+   (<glil-asm> vars body)
+   (<glil-bind> vars)
+   (<glil-unbind>)
+   (<glil-source> loc)
+   ;; Objects
+   (<glil-void>)
+   (<glil-const> obj)
+   ;; Variables
+   (<glil-argument> op index)
+   (<glil-local> op index)
+   (<glil-external> op depth index)
+   (<glil-module> op module name)
+   (<glil-late-bound> op name)
+   ;; Controls
+   (<glil-label> label)
+   (<glil-branch> inst label)
+   (<glil-call> inst nargs)))
+
+
+;;;
+;;; Parser
+;;;
+
+;;; (define (parse-glil x)
+;;;   (match x
+;;;     (('@asm args . body)
+;;;      (let* ((env (make-new-env e))
+;;; 	    (args (parse-args args env)))
+;;;        (make-asm env args (map-parse body env))))
+;;;     (else
+;;;      (error "Invalid assembly code:" x))))
+;;; 
+;;; (define (parse-args x e)
+;;;   (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
+;;; 		    ((list? x) (make-args (map make-local-var x) #f))
+;;; 		    (else (let loop ((l x) (v '()))
+;;; 			    (if (pair? l)
+;;; 				(loop (cdr l) (cons (car l) v))
+;;; 				(make-args (map make-local-var
+;;; 						(reverse! (cons l v)))
+;;; 					   #t)))))))
+;;;     (for-each (lambda (v) (env-add! e v)) (args-vars args))
+;;;     args))
+;;; 
+;;; (define (map-parse x e)
+;;;   (map (lambda (x) (parse x e)) x))
+;;; 
+;;; (define (parse x e)
+;;;   (match x
+;;;     ;; (@asm ARGS BODY...)
+;;;     (('@asm args . body)
+;;;      (parse-asm x e))
+;;;     ;; (@bind VARS BODY...)
+;;;     ;; (@block VARS BODY...)
+;;;     (((or '@bind '@block) vars . body)
+;;;      (let* ((offset (env-nvars e))
+;;; 	    (vars (args-vars (parse-args vars e)))
+;;; 	    (block (make-block (car x) offset vars (map-parse body e))))
+;;;        (for-each (lambda (v) (env-remove! e)) vars)
+;;;        block))
+;;;     ;; (void)
+;;;     (('void)
+;;;      (make-void))
+;;;     ;; (const OBJ)
+;;;     (('const obj)
+;;;      (make-const obj))
+;;;     ;; (ref NAME)
+;;;     ;; (set NAME)
+;;;     (((or 'ref 'set) name)
+;;;      (make-access (car x) (env-ref e name)))
+;;;     ;; (label LABEL)
+;;;     (('label label)
+;;;      (make-label label))
+;;;     ;; (br-if LABEL)
+;;;     ;; (jump LABEL)
+;;;     (((or 'br-if 'jump) label)
+;;;      (make-instl (car x) label))
+;;;     ;; (call NARGS)
+;;;     ;; (tail-call NARGS)
+;;;     (((or 'call 'tail-call) n)
+;;;      (make-instn (car x) n))
+;;;     ;; (INST)
+;;;     ((inst)
+;;;      (if (instruction? inst)
+;;; 	 (make-inst inst)
+;;; 	 (error "Unknown instruction:" inst)))))
+
+
+;;;
+;;; Unparser
+;;;
+
+(define (unparse glil)
+  (record-case glil
+    ;; meta
+    ((<glil-asm> vars body)
+     `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
+             ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
+	    ,@(map unparse body)))
+    ((<glil-bind> vars) `(@bind ,@vars))
+    ((<glil-unbind>) `(@unbind))
+    ((<glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
+    ;; constants
+    ((<glil-void>) `(void))
+    ((<glil-const> obj) `(const ,obj))
+    ;; variables
+    ((<glil-argument> op index)
+     `(,(symbol-append 'argument- op) ,index))
+    ((<glil-local> op index)
+     `(,(symbol-append 'local- op) ,index))
+    ((<glil-external> op depth index)
+     `(,(symbol-append 'external- op) ,depth ,index))
+    ((<glil-module> op module name)
+     `(,(symbol-append 'module- op) ,module ,name))
+    ;; controls
+    ((<glil-label> label) label)
+    ((<glil-branch> inst label) `(,inst ,label))
+    ((<glil-call> inst nargs) `(,inst ,nargs))))
+
+
+;;;
+;;; Printer
+;;;
+
+(define (pprint-glil glil . port)
+  (let ((port (if (pair? port) (car port) (current-output-port))))
+    (let print ((code (unparse glil)) (column 0))
+      (display (make-string column #\space) port)
+      (cond ((and (pair? code) (eq? (car code) '@asm))
+	     (format port "(@asm ~A\n" (cadr code))
+	     (let ((col (+ column 2)))
+	       (let loop ((l (cddr code)))
+		 (print (car l) col)
+		 (if (null? (cdr l))
+		   (display ")" port)
+		   (begin (newline port) (loop (cdr l)))))))
+	    (else (write code port))))
+    (newline port)))

module/system/il/inline.scm

@@ -0,0 +1,206 @@
+;;; GHIL macros
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system il inline)
+  :use-module (system base syntax)
+  :use-module (system il ghil)
+  :use-module (srfi srfi-16)
+  :export (*inline-table* define-inline try-inline try-inline-with-env))
+
+(define *inline-table* '())
+
+(define-macro (define-inline sym . clauses)
+  (define (inline-args args)
+    (let lp ((in args) (out '()))
+      (cond ((null? in) `(list ,@(reverse out)))
+            ((symbol? in) `(cons* ,@(reverse out) ,in))
+            ((pair? (car in))
+             (lp (cdr in)
+                 (cons `(or (try-inline ,(caar in) ,(inline-args (cdar in)))
+                            (error "what" ',(car in)))
+                       out)))
+            ((symbol? (car in))
+             ;; assume it's locally bound
+             (lp (cdr in) (cons (car in) out)))
+            ((number? (car in))
+             (lp (cdr in) (cons `(make-ghil-quote #f #f ,(car in)) out)))
+            (else
+             (error "what what" (car in))))))
+  (define (consequent exp)
+    (cond
+     ((pair? exp)
+      `(make-ghil-inline #f #f ',(car exp) ,(inline-args (cdr exp))))
+     ((symbol? exp)
+      ;; assume locally bound
+      exp)
+     ((number? exp)
+      `(make-ghil-quote #f #f ,exp))
+     (else (error "bad consequent yall" exp))))
+  `(set! *inline-table*
+         (assq-set! *inline-table*
+                    ,sym
+                    (case-lambda
+                     ,@(let lp ((in clauses) (out '()))
+                         (if (null? in)
+                             (reverse (cons '(else #f) out))
+                             (lp (cddr in)
+                                 (cons `(,(car in)
+                                         ,(consequent (cadr in))) out))))))))
+
+(define (try-inline head-value args)
+  (and=> (assq-ref *inline-table* head-value)
+         (lambda (proc) (apply proc args))))
+
+(define (ghil-env-ref env sym)
+  (assq-ref (ghil-env-table env) sym))
+
+
+(define (try-inline-with-env env loc exp)
+  (let ((sym (car exp)))
+    (and (not (ghil-env-ref env sym))
+         (let loop ((e (ghil-env-parent env)))
+           (record-case e
+            ((<ghil-mod> module table imports)
+             (and (not (assq-ref table sym))
+                  (module-bound? module sym)
+                  (try-inline (module-ref module sym) (cdr exp))))
+            ((<ghil-env> mod parent table variables)
+             (and (not (assq-ref table sym))
+                  (loop parent))))))))
+
+(define-inline eq? (x y)
+  (eq? x y))
+
+(define-inline eqv? (x y)
+  (eqv? x y))
+
+(define-inline equal? (x y)
+  (equal? x y))
+  
+(define-inline = (x y)
+  (ee? x y))
+
+(define-inline < (x y)
+  (lt? x y))
+
+(define-inline > (x y)
+  (gt? x y))
+
+(define-inline <= (x y)
+  (le? x y))
+
+(define-inline >= (x y)
+  (ge? x y))
+
+(define-inline zero? (x)
+  (ee? x 0))
+  
+(define-inline +
+  () 0
+  (x) x
+  (x y) (add x y)
+  (x y . rest) (add x (+ y . rest)))
+  
+(define-inline *
+  () 1
+  (x) x
+  (x y) (mul x y)
+  (x y . rest) (mul x (* y . rest)))
+  
+(define-inline -
+  (x) (sub 0 x)
+  (x y) (sub x y)
+  (x y . rest) (sub x (+ y . rest)))
+  
+(define-inline 1-
+  (x) (sub x 1))
+
+(define-inline /
+  (x) (div 1 x)
+  (x y) (div x y)
+  (x y . rest) (div x (* y . rest)))
+  
+(define-inline quotient (x y)
+  (quo x y))
+
+(define-inline remainder (x y)
+  (rem x y))
+
+(define-inline modulo (x y)
+  (mod x y))
+
+(define-inline not (x)
+  (not x))
+
+(define-inline pair? (x)
+  (pair? x))
+
+(define-inline cons (x y)
+  (cons x y))
+
+(define-inline car (x) (car x))
+(define-inline cdr (x) (cdr x))
+
+(define-inline set-car! (x y) (set-car! x y))
+(define-inline set-cdr! (x y) (set-cdr! x y))
+
+(define-inline caar (x) (car (car x)))
+(define-inline cadr (x) (car (cdr x)))
+(define-inline cdar (x) (cdr (car x)))
+(define-inline cddr (x) (cdr (cdr x)))
+(define-inline caaar (x) (car (car (car x))))
+(define-inline caadr (x) (car (car (cdr x))))
+(define-inline cadar (x) (car (cdr (car x))))
+(define-inline caddr (x) (car (cdr (cdr x))))
+(define-inline cdaar (x) (cdr (car (car x))))
+(define-inline cdadr (x) (cdr (car (cdr x))))
+(define-inline cddar (x) (cdr (cdr (car x))))
+(define-inline cdddr (x) (cdr (cdr (cdr x))))
+(define-inline caaaar (x) (car (car (car (car x)))))
+(define-inline caaadr (x) (car (car (car (cdr x)))))
+(define-inline caadar (x) (car (car (cdr (car x)))))
+(define-inline caaddr (x) (car (car (cdr (cdr x)))))
+(define-inline cadaar (x) (car (cdr (car (car x)))))
+(define-inline cadadr (x) (car (cdr (car (cdr x)))))
+(define-inline caddar (x) (car (cdr (cdr (car x)))))
+(define-inline cadddr (x) (car (cdr (cdr (cdr x)))))
+(define-inline cdaaar (x) (cdr (car (car (car x)))))
+(define-inline cdaadr (x) (cdr (car (car (cdr x)))))
+(define-inline cdadar (x) (cdr (car (cdr (car x)))))
+(define-inline cdaddr (x) (cdr (car (cdr (cdr x)))))
+(define-inline cddaar (x) (cdr (cdr (car (car x)))))
+(define-inline cddadr (x) (cdr (cdr (car (cdr x)))))
+(define-inline cdddar (x) (cdr (cdr (cdr (car x)))))
+(define-inline cddddr (x) (cdr (cdr (cdr (cdr x)))))
+
+(define-inline null? (x)
+  (null? x))
+
+(define-inline list? (x)
+  (list? x))
+
+(define-inline apply (proc . args)
+  (apply proc . args))
+
+(define-inline cons*
+  (x) x
+  (x y) (cons x y)
+  (x y . rest) (cons x (cons* y . rest)))

module/system/repl/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/repl/Makefile.am

@@ -0,0 +1,4 @@
+NOCOMP_SOURCES = describe.scm
+SOURCES = repl.scm common.scm command.scm
+moddir = $(guiledir)/system/repl
+include $(top_srcdir)/guilec.mk

module/system/repl/command.scm

@@ -0,0 +1,450 @@
+;;; Repl commands
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl command)
+  :use-syntax (system base syntax)
+  :use-module (system base pmatch)
+  :use-module (system base compile)
+  :use-module (system repl common)
+  :use-module (system vm core)
+  :autoload (system base language) (lookup-language)
+  :autoload (system il glil) (pprint-glil)
+  :autoload (system vm disasm) (disassemble-program disassemble-objcode)
+  :autoload (system vm debug) (vm-debugger vm-backtrace)
+  :autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
+  :autoload (system vm profile) (vm-profile)
+  :use-module (ice-9 format)
+  :use-module (ice-9 session)
+  :use-module (ice-9 documentation)
+  :use-module (ice-9 and-let-star)
+  :export (meta-command))
+
+
+;;;
+;;; Meta command interface
+;;;
+
+(define *command-table*
+  '((help     (help h) (apropos a) (describe d) (option o) (quit q))
+    (module   (module m) (import i) (load l) (binding b))
+    (language (language L))
+    (compile  (compile c) (compile-file cc)
+	      (disassemble x) (disassemble-file xx))
+    (profile  (time t) (profile pr))
+    (debug    (backtrace bt) (debugger db) (trace tr) (step st))
+    (system   (gc) (statistics stat))))
+
+(define (group-name g) (car g))
+(define (group-commands g) (cdr g))
+
+(define *command-module* (current-module))
+(define (command-name c) (car c))
+(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-doc c) (procedure-documentation (command-procedure c)))
+
+(define (command-usage c)
+  (let ((doc (command-doc c)))
+    (substring doc 0 (string-index doc #\newline))))
+
+(define (command-summary c)
+  (let* ((doc (command-doc c))
+	 (start (1+ (string-index doc #\newline))))
+    (cond ((string-index doc #\newline start)
+	   => (lambda (end) (substring doc start end)))
+	  (else (substring doc start)))))
+
+(define (lookup-group name)
+  (assq name *command-table*))
+
+(define (lookup-command key)
+  (let loop ((groups *command-table*) (commands '()))
+    (cond ((and (null? groups) (null? commands)) #f)
+	  ((null? commands)
+	   (loop (cdr groups) (cdar groups)))
+	  ((memq key (car commands)) (car commands))
+	  (else (loop groups (cdr commands))))))
+
+(define (display-group group . opts)
+  (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+  (for-each (lambda (c)
+	      (display-summary (command-usage c)
+			       (command-abbrev c)
+			       (command-summary c)))
+	    (group-commands group))
+  (newline))
+
+(define (display-command command)
+  (display "Usage: ")
+  (display (command-doc command))
+  (newline))
+
+(define (display-summary usage abbrev summary)
+  (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+    (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+
+(define (meta-command repl line)
+  (let ((input (call-with-input-string (string-append "(" line ")") read)))
+    (if (not (null? input))
+	(do ((key (car input))
+	     (args (cdr input) (cdr args))
+	     (opts '() (cons (make-keyword-from-dash-symbol (car args)) opts)))
+	    ((or (null? args)
+		 (not (symbol? (car args)))
+		 (not (eq? (string-ref (symbol->string (car args)) 0) #\-)))
+	     (let ((c (lookup-command key)))
+	       (if c
+		   (cond ((memq :h opts) (display-command c))
+			 (else (apply (command-procedure c)
+				      repl (append! args (reverse! opts)))))
+		   (user-error "Unknown meta command: ~A" key))))))))
+
+
+;;;
+;;; Help commands
+;;;
+
+(define (help repl . args)
+  "help [GROUP]
+List available meta commands.
+A command group name can be given as an optional argument.
+Without any argument, a list of help commands and command groups
+are displayed, as you have already seen ;)"
+  (pmatch args
+    (()
+     (display-group (lookup-group 'help))
+     (display "Command Groups:\n\n")
+     (display-summary "help all" #f "List all commands")
+     (for-each (lambda (g)
+		 (let* ((name (symbol->string (group-name g)))
+			(usage (string-append "help " name))
+			(header (string-append "List " name " commands")))
+		   (display-summary usage #f header)))
+	       (cdr *command-table*))
+     (newline)
+     (display "Type `,COMMAND -h' to show documentation of each command.")
+     (newline))
+    ((all)
+     (for-each display-group *command-table*))
+    ((,group) (guard (lookup-group group))
+     (display-group (lookup-group group)))
+    (else
+     (user-error "Unknown command group: ~A" (car args)))))
+
+(define guile:apropos apropos)
+(define (apropos repl regexp)
+  "apropos REGEXP
+Find bindings/modules/packages."
+  (guile:apropos (->string regexp)))
+
+(define (describe repl obj)
+  "describe OBJ
+Show description/documentation."
+  (display (object-documentation (repl-eval repl obj)))
+  (newline))
+
+(define (option repl . args)
+  "option [KEY VALUE]
+List/show/set options."
+  (pmatch args
+    (()
+     (for-each (lambda (key+val)
+		 (format #t "~A\t~A\n" (car key+val) (cdr key+val)))
+	       (repl-options repl)))
+    ((,key)
+     (display (repl-option-ref repl key))
+     (newline))
+    ((,key ,val)
+     (repl-option-set! repl key val)
+     (case key
+       ((trace)
+        (let ((vm (repl-vm repl)))
+          (if val
+              (apply vm-trace-on vm val)
+              (vm-trace-off vm))))))))
+
+(define (quit repl)
+  "quit
+Quit this session."
+  (throw 'quit))
+
+
+;;;
+;;; Module commands
+;;;
+
+(define (module repl . args)
+  "module [MODULE]
+Change modules / Show current module."
+  (pmatch args
+    (() (puts (module-name (current-module))))
+    ((,mod-name) (set-current-module (resolve-module mod-name)))))
+
+(define (import repl . args)
+  "import [MODULE ...]
+Import modules / List those imported."
+  (let ()
+    (define (use name)
+      (let ((mod (resolve-interface name)))
+        (if mod
+            (module-use! (current-module) mod)
+            (user-error "No such module: ~A" name))))
+    (if (null? args)
+        (for-each puts (map module-name (module-uses (current-module))))
+        (for-each use args))))
+
+(define (load repl file . opts)
+  "load FILE
+Load a file in the current module.
+
+  -f    Load source file (see `compile')"
+  (let* ((file (->string file))
+	 (objcode (if (memq :f opts)
+		      (apply load-source-file file opts)
+		      (apply load-file file opts))))
+    (vm-load (repl-vm repl) objcode)))
+
+(define (binding repl . opts)
+  "binding
+List current bindings."
+  (module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
+                   (current-module)))
+
+
+;;;
+;;; Language commands
+;;;
+
+(define (language repl name)
+  "language LANGUAGE
+Change languages."
+  (set! (repl-language repl) (lookup-language name))
+  (repl-welcome repl))
+
+
+;;;
+;;; Compile commands
+;;;
+
+(define (compile repl form . opts)
+  "compile FORM
+Generate compiled code.
+
+  -e    Stop after expanding syntax/macro
+  -t    Stop after translating into GHIL
+  -c    Stop after generating GLIL
+
+  -O    Enable optimization
+  -D    Add debug information"
+  (let ((x (apply repl-compile repl form opts)))
+    (cond ((or (memq :e opts) (memq :t opts)) (puts x))
+	  ((memq :c opts) (pprint-glil x))
+	  (else (disassemble-objcode x)))))
+
+(define guile:compile-file compile-file)
+(define (compile-file repl file . opts)
+  "compile-file FILE
+Compile a file."
+  (apply guile:compile-file (->string file) opts))
+
+(define (disassemble repl prog)
+  "disassemble PROGRAM
+Disassemble a program."
+  (disassemble-program (repl-eval repl prog)))
+
+(define (disassemble-file repl file)
+  "disassemble-file FILE
+Disassemble a file."
+  (disassemble-objcode (load-objcode (->string file))))
+
+
+;;;
+;;; Profile commands
+;;;
+
+(define (time repl form)
+  "time FORM
+Time execution."
+  (let* ((vms-start (vm-stats (repl-vm repl)))
+	 (gc-start (gc-run-time))
+	 (tms-start (times))
+	 (result (repl-eval repl form))
+	 (tms-end (times))
+	 (gc-end (gc-run-time))
+	 (vms-end (vm-stats (repl-vm repl))))
+    (define (get proc start end)
+      (/ (- (proc end) (proc start)) internal-time-units-per-second))
+    (repl-print repl result)
+    (display "clock utime stime cutime cstime gctime\n")
+    (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+	    (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 identity gc-start gc-end))
+    result))
+
+(define (profile repl form . opts)
+  "profile FORM
+Profile execution."
+  (apply vm-profile
+         (repl-vm repl)
+         (repl-compile repl form)
+         opts))
+
+
+;;;
+;;; Debug commands
+;;;
+
+(define (backtrace repl)
+  "backtrace
+Display backtrace."
+  (vm-backtrace (repl-vm repl)))
+
+(define (debugger repl)
+  "debugger
+Start debugger."
+  (vm-debugger (repl-vm repl)))
+
+(define (trace repl form . opts)
+  "trace FORM
+Trace execution.
+
+  -s    Display stack
+  -l    Display local variables
+  -e    Display external variables
+  -b    Bytecode level trace"
+  (apply vm-trace (repl-vm repl) (repl-compile repl form) opts))
+
+(define (step repl)
+  "step FORM
+Step execution."
+  (display "Not implemented yet\n"))
+
+
+;;;
+;;; System commands 
+;;;
+
+(define guile:gc gc)
+(define (gc repl)
+  "gc
+Garbage collection."
+  (guile:gc))
+
+(define (statistics repl)
+  "statistics
+Display statistics."
+  (let ((this-tms (times))
+	(this-vms (vm-stats (repl-vm repl)))
+	(this-gcs (gc-stats))
+	(last-tms (repl-tm-stats repl))
+	(last-vms (repl-vm-stats repl))
+	(last-gcs (repl-gc-stats repl)))
+    ;; GC times
+    (let ((this-times  (assq-ref this-gcs 'gc-times))
+	  (last-times  (assq-ref last-gcs 'gc-times)))
+      (display-diff-stat "GC times:" #t this-times last-times "times")
+      (newline))
+    ;; Memory size
+    (let ((this-cells  (assq-ref this-gcs 'cells-allocated))
+	  (this-heap   (assq-ref this-gcs 'cell-heap-size))
+	  (this-bytes  (assq-ref this-gcs 'bytes-malloced))
+	  (this-malloc (assq-ref this-gcs 'gc-malloc-threshold)))
+      (display-stat-title "Memory size:" "current" "limit")
+      (display-stat "heap" #f this-cells this-heap "cells")
+      (display-stat "malloc" #f this-bytes this-malloc "bytes")
+      (newline))
+    ;; Cells collected
+    (let ((this-marked (assq-ref this-gcs 'cells-marked))
+	  (last-marked (assq-ref last-gcs 'cells-marked))
+	  (this-swept  (assq-ref this-gcs 'cells-swept))
+	  (last-swept  (assq-ref last-gcs 'cells-swept)))
+      (display-stat-title "Cells collected:" "diff" "total")
+      (display-diff-stat "marked" #f this-marked last-marked "cells")
+      (display-diff-stat "swept" #f this-swept last-swept "cells")
+      (newline))
+    ;; GC time taken
+    (let ((this-mark  (assq-ref this-gcs 'gc-mark-time-taken))
+	  (last-mark  (assq-ref last-gcs 'gc-mark-time-taken))
+	  (this-sweep (assq-ref this-gcs 'gc-sweep-time-taken))
+	  (last-sweep (assq-ref last-gcs 'gc-sweep-time-taken))
+	  (this-total (assq-ref this-gcs 'gc-time-taken))
+	  (last-total (assq-ref last-gcs 'gc-time-taken)))
+      (display-stat-title "GC time taken:" "diff" "total")
+      (display-time-stat "mark" this-mark last-mark)
+      (display-time-stat "sweep" this-sweep last-sweep)
+      (display-time-stat "total" this-total last-total)
+      (newline))
+    ;; Process time spent
+    (let ((this-utime  (tms:utime this-tms))
+	  (last-utime  (tms:utime last-tms))
+	  (this-stime  (tms:stime this-tms))
+	  (last-stime  (tms:stime last-tms))
+	  (this-cutime (tms:cutime this-tms))
+	  (last-cutime (tms:cutime last-tms))
+	  (this-cstime (tms:cstime this-tms))
+	  (last-cstime (tms:cstime last-tms)))
+      (display-stat-title "Process time spent:" "diff" "total")
+      (display-time-stat "user" this-utime last-utime)
+      (display-time-stat "system" this-stime last-stime)
+      (display-time-stat "child user" this-cutime last-cutime)
+      (display-time-stat "child system" this-cstime last-cstime)
+      (newline))
+    ;; VM statistics
+    (let ((this-time  (vms:time this-vms))
+	  (last-time  (vms:time last-vms))
+	  (this-clock (vms:clock this-vms))
+	  (last-clock (vms:clock last-vms)))
+      (display-stat-title "VM statistics:" "diff" "total")
+      (display-time-stat "time spent" this-time last-time)
+      (display-diff-stat "bogoclock" #f this-clock last-clock "clock")
+      (display-mips-stat "bogomips" this-time this-clock last-time last-clock)
+      (newline))
+    ;; Save statistics
+    ;; Save statistics
+    (set! (repl-tm-stats repl) this-tms)
+    (set! (repl-vm-stats repl) this-vms)
+    (set! (repl-gc-stats repl) this-gcs)))
+
+(define (display-stat title flag field1 field2 unit)
+  (let ((str (format #f "~~20~AA ~~10@A /~~10@A ~~A~~%" (if flag "" "@"))))
+    (format #t str title field1 field2 unit)))
+
+(define (display-stat-title title field1 field2)
+  (display-stat title #t field1 field2 ""))
+
+(define (display-diff-stat title flag this last unit)
+  (display-stat title flag (- this last) this unit))
+
+(define (display-time-stat title this last)
+  (define (conv num)
+    (format #f "~10,2F" (/ num internal-time-units-per-second)))
+  (display-stat title #f (conv (- this last)) (conv this) "s"))
+
+(define (display-mips-stat title this-time this-clock last-time last-clock)
+  (define (mips time clock)
+    (if (= time 0) "----" (format #f "~10,2F" (/ clock time 1000000))))
+  (display-stat title #f
+		(mips (- this-time last-time) (- this-clock last-clock))
+		(mips this-time this-clock) "mips"))

module/system/repl/common.scm

@@ -0,0 +1,98 @@
+;;; Repl common routines
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl common)
+  :use-syntax (system base syntax)
+  :use-module (system base compile)
+  :use-module (system base language)
+  :use-module (system vm core)
+  :export (<repl> make-repl repl-vm repl-language repl-options
+                  repl-tm-stats repl-gc-stats repl-vm-stats
+           repl-welcome repl-prompt repl-read repl-compile repl-eval
+           repl-print repl-option-ref repl-option-set!
+           puts ->string user-error))
+
+
+;;;
+;;; Repl type
+;;;
+
+(define-record (<repl> vm language options tm-stats gc-stats vm-stats))
+
+(define repl-default-options
+  '((trace . #f)))
+
+(define %make-repl make-repl)
+(define (make-repl lang)
+  (%make-repl :vm (the-vm)
+              :language (lookup-language lang)
+              :options repl-default-options
+              :tm-stats (times)
+              :gc-stats (gc-stats)
+              :vm-stats (vm-stats (the-vm))))
+
+(define (repl-welcome repl)
+  (let ((language (repl-language repl)))
+    (format #t "~A interpreter ~A on Guile ~A\n"
+            (language-title language) (language-version language) (version)))
+  (display "Copyright (C) 2001-2008 Free Software Foundation, Inc.\n\n")
+  (display "Enter `,help' for help.\n"))
+
+(define (repl-prompt repl)
+  (format #f "~A@~A> " (language-name (repl-language repl))
+          (module-name (current-module))))
+
+(define (repl-read repl)
+  ((language-reader (repl-language repl))))
+
+(define (repl-compile repl form . opts)
+  (apply compile-in form (current-module) (repl-language repl) opts))
+
+(define (repl-eval repl form)
+  (let ((eval (language-evaluator (repl-language repl))))
+    (if eval
+	(eval form (current-module))
+	(vm-load (repl-vm repl) (repl-compile repl form)))))
+
+(define (repl-print repl val)
+  (if (not (eq? val *unspecified*))
+      (begin
+	((language-printer (repl-language repl)) val)
+	(newline))))
+
+(define (repl-option-ref repl key)
+  (assq-ref (repl-options repl) key))
+
+(define (repl-option-set! repl key val)
+  (set! (repl-options repl) (assq-set! (repl-options repl) key val)))
+
+
+;;;
+;;; Utilities
+;;;
+
+(define (puts x) (display x) (newline))
+
+(define (->string x)
+  (object->string x display))
+
+(define (user-error msg . args)
+  (throw 'user-error #f msg args #f))

module/system/repl/describe.scm

@@ -0,0 +1,361 @@
+;;; Describe objects
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl describe)
+  :use-module (oop goops)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 format)
+  :use-module (ice-9 and-let-star)
+  :export (describe))
+
+(define-method (describe (symbol <symbol>))
+  (format #t "`~s' is " symbol)
+  (if (not (defined? symbol))
+      (display "not defined in the current module.\n")
+      (describe-object (module-ref (current-module) symbol))))
+
+
+;;;
+;;; Display functions
+;;;
+
+(define (safe-class-name class)
+  (if (slot-bound? class 'name)
+      (class-name class)
+      class))
+
+(define-method (display-class class . args)
+  (let* ((name (safe-class-name class))
+	 (desc (if (pair? args) (car args) name)))
+    (if (eq? *describe-format* 'tag)
+	(format #t "@class{~a}{~a}" name desc)
+	(format #t "~a" desc))))
+
+(define (display-list title list)
+  (if title (begin (display title) (display ":\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each display-summary list)))
+
+(define (display-slot-list title instance list)
+  (if title (begin (display title) (display ":\n\n")))
+  (if (null? list)
+      (display "(not defined)\n")
+      (for-each (lambda (slot)
+		  (let ((name (slot-definition-name slot)))
+		    (display "Slot: ")
+		    (display name)
+		    (if (and instance (slot-bound? instance name))
+			(begin
+			  (display " = ")
+			  (display (slot-ref instance name))))
+		    (newline)))
+		list)))
+
+(define (display-file location)
+  (display "Defined in ")
+  (if (eq? *describe-format* 'tag)
+      (format #t "@location{~a}.\n" location)
+      (format #t "`~a'.\n" location)))
+
+(define (format-documentation doc)
+  (with-current-buffer (make-buffer #:text doc)
+    (lambda ()
+      (let ((regexp (make-regexp "@([a-z]*)(\\{([^}]*)\\})?")))
+	(do-while (match (re-search-forward regexp))
+	  (let ((key (string->symbol (match:substring match 1)))
+		(value (match:substring match 3)))
+	    (case key
+	      ((deffnx)
+	       (delete-region! (match:start match)
+			       (begin (forward-line) (point))))
+	      ((var)
+	       (replace-match! match 0 (string-upcase value)))
+	      ((code)
+	       (replace-match! match 0 (string-append "`" value "'")))))))
+      (display (string (current-buffer)))
+      (newline))))
+
+
+;;;
+;;; Top
+;;;
+
+(define description-table
+  (list
+   (cons <boolean>   "a boolean")
+   (cons <null>      "an empty list")
+   (cons <integer>   "an integer")
+   (cons <real>      "a real number")
+   (cons <complex>   "a complex number")
+   (cons <char>      "a character")
+   (cons <symbol>    "a symbol")
+   (cons <keyword>   "a keyword")
+   (cons <promise>   "a promise")
+   (cons <hook>      "a hook")
+   (cons <fluid>     "a fluid")
+   (cons <stack>     "a stack")
+   (cons <variable>  "a variable")
+   (cons <regexp>    "a regexp object")
+   (cons <module>    "a module object")
+   (cons <unknown>   "an unknown object")))
+
+(define-generic describe-object)
+(export describe-object)
+
+(define-method (describe-object (obj <top>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-value obj)
+  (newline)
+  (display-documentation obj))
+
+(define-generic display-object)
+(define-generic display-summary)
+(define-generic display-type)
+(define-generic display-value)
+(define-generic display-location)
+(define-generic display-description)
+(define-generic display-documentation)
+(export display-object display-summary display-type display-value
+	display-location display-description display-documentation)
+
+(define-method (display-object (obj <top>))
+  (write obj))
+
+(define-method (display-summary (obj <top>))
+  (display "Value: ")
+  (display-object obj)
+  (newline))
+
+(define-method (display-type (obj <top>))
+  (cond
+   ((eof-object? obj) (display "the end-of-file object"))
+   ((unspecified? obj) (display "unspecified"))
+   (else (let ((class (class-of obj)))
+	   (display-class class (or (assq-ref description-table class)
+				    (safe-class-name class))))))
+  (display ".\n"))
+
+(define-method (display-value (obj <top>))
+  (if (not (unspecified? obj))
+      (begin (display-object obj) (newline))))
+
+(define-method (display-location (obj <top>))
+  *unspecified*)
+
+(define-method (display-description (obj <top>))
+  (let* ((doc (with-output-to-string (lambda () (display-documentation obj))))
+	 (index (string-index doc #\newline)))
+    (display (make-shared-substring doc 0 (1+ index)))))
+
+(define-method (display-documentation (obj <top>))
+  (display "Not documented.\n"))
+
+
+;;;
+;;; Pairs
+;;;
+
+(define-method (display-type (obj <pair>))
+  (cond
+   ((list? obj) (display-class <list> "a list"))
+   ((pair? (cdr obj)) (display "an improper list"))
+   (else (display-class <pair> "a pair")))
+  (display ".\n"))
+
+
+;;;
+;;; Strings
+;;;
+
+(define-method (display-type (obj <string>))
+  (if (read-only-string? 'obj)
+      (display "a read-only string")
+      (display-class <string> "a string"))
+  (display ".\n"))
+
+
+;;;
+;;; Procedures
+;;;
+
+(define-method (display-object (obj <procedure>))
+  (cond
+   ((closure? obj)
+    ;; Construct output from the source.
+    (display "(")
+    (display (procedure-name obj))
+    (let ((args (cadr (procedure-source obj))))
+      (cond ((null? args) (display ")"))
+	    ((pair? args)
+	     (let ((str (with-output-to-string (lambda () (display args)))))
+	       (format #t " ~a" (string-upcase! (substring str 1)))))
+	    (else
+	     (format #t " . ~a)" (string-upcase! (symbol->string args)))))))
+   (else
+    ;; Primitive procedure.  Let's lookup the dictionary.
+    (and-let* ((entry (lookup-procedure obj)))
+      (let ((name (entry-property entry 'name))
+	    (print-arg (lambda (arg)
+			 (display " ")
+			 (display (string-upcase (symbol->string arg))))))
+	(display "(")
+	(display name)
+	(and-let* ((args (entry-property entry 'args)))
+	  (for-each print-arg args))
+	(and-let* ((opts (entry-property entry 'opts)))
+	  (display " &optional")
+	  (for-each print-arg opts))
+	(and-let* ((rest (entry-property entry 'rest)))
+	  (display " &rest")
+	  (print-arg rest))
+	(display ")"))))))
+
+(define-method (display-summary (obj <procedure>))
+  (display "Procedure: ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <procedure>))
+  (cond
+   ((and (thunk? obj) (not (procedure-name obj))) (display "a thunk"))
+   ((closure? obj) (display-class <procedure> "a procedure"))
+   ((procedure-with-setter? obj)
+    (display-class <procedure-with-setter> "a procedure with setter"))
+   ((not (struct? obj)) (display "a primitive procedure"))
+   (else (display-class <procedure> "a procedure")))
+  (display ".\n"))
+
+(define-method (display-location (obj <procedure>))
+  (and-let* ((entry (lookup-procedure obj)))
+    (display-file (entry-file entry))))
+
+(define-method (display-documentation (obj <procedure>))
+  (cond ((cond ((closure? obj) (procedure-documentation obj))
+	       ((lookup-procedure obj) => entry-text)
+	       (else #f))
+	 => format-documentation)
+	(else (next-method))))
+
+
+;;;
+;;; Classes
+;;;
+
+(define-method (describe-object (obj <class>))
+  (display-type obj)
+  (display-location obj)
+  (newline)
+  (display-documentation obj)
+  (newline)
+  (display-value obj))
+
+(define-method (display-summary (obj <class>))
+  (display "Class: ")
+  (display-class obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <class>))
+  (display-class <class> "a class")
+  (if (not (eq? (class-of obj) <class>))
+      (begin (display " of ") (display-class (class-of obj))))
+  (display ".\n"))
+
+(define-method (display-value (obj <class>))
+  (display-list "Class precedence list" (class-precedence-list obj))
+  (newline)
+  (display-list "Direct superclasses" (class-direct-supers obj))
+  (newline)
+  (display-list "Direct subclasses" (class-direct-subclasses obj))
+  (newline)
+  (display-slot-list "Direct slots" #f (class-direct-slots obj))
+  (newline)
+  (display-list "Direct methods" (class-direct-methods obj)))
+
+
+;;;
+;;; Instances
+;;;
+
+(define-method (display-type (obj <object>))
+  (display-class <object> "an instance")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <object>))
+  (display-slot-list #f obj (class-slots (class-of obj))))
+
+
+;;;
+;;; Generic functions
+;;;
+
+(define-method (display-type (obj <generic>))
+  (display-class <generic> "a generic function")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-value (obj <generic>))
+  (display-list #f (generic-function-methods obj)))
+
+
+;;;
+;;; Methods
+;;;
+
+(define-method (display-object (obj <method>))
+  (display "(")
+  (let ((gf (method-generic-function obj)))
+    (display (if gf (generic-function-name gf) "#<anonymous>")))
+  (let loop ((args (method-specializers obj)))
+    (cond
+     ((null? args))
+     ((pair? args)
+      (display " ")
+      (display-class (car args))
+      (loop (cdr args)))
+     (else (display " . ") (display-class args))))
+  (display ")"))
+
+(define-method (display-summary (obj <method>))
+  (display "Method: ")
+  (display-object obj)
+  (newline)
+  (display "  ")
+  (display-description obj))
+
+(define-method (display-type (obj <method>))
+  (display-class <method> "a method")
+  (display " of class ")
+  (display-class (class-of obj))
+  (display ".\n"))
+
+(define-method (display-documentation (obj <method>))
+  (let ((doc (procedure-documentation (method-procedure obj))))
+    (if doc (format-documentation doc) (next-method))))

module/system/repl/repl.scm

@@ -0,0 +1,128 @@
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system repl repl)
+  :use-syntax (system base syntax)
+  :use-module (system base pmatch)
+  :use-module (system base compile)
+  :use-module (system base language)
+  :use-module (system repl common)
+  :use-module (system repl command)
+  :use-module (system vm core)
+  :use-module (system vm debug)
+  :use-module (ice-9 rdelim)
+  :export (start-repl))
+
+(define meta-command-token (cons 'meta 'command))
+
+(define (meta-reader read)
+  (lambda read-args
+    (with-input-from-port
+        (if (pair? read-args) (car read-args) (current-input-port))
+      (lambda ()
+        (if (eqv? (next-char #t) #\,)
+            (begin (read-char) meta-command-token)
+            (read))))))
+        
+;; repl-reader is a function defined in boot-9.scm, and is replaced by
+;; something else if readline has been activated. much of this hoopla is
+;; to be able to re-use the existing readline machinery.
+(define (prompting-meta-read repl)
+  (let ((prompt (lambda () (repl-prompt repl)))
+        (lread (language-reader (repl-language repl))))
+    (with-fluid* current-reader (meta-reader lread)
+      (lambda () (repl-reader (lambda () (repl-prompt repl)))))))
+
+(define (default-pre-unwind-handler key . args)
+  (save-stack default-pre-unwind-handler)
+  (apply throw key args))
+
+(define (default-catch-handler . args)
+  (pmatch args
+    ((quit . _)
+     (apply throw args))
+    ((vm-error ,fun ,msg ,args)
+     (display "VM error: ")
+     (apply format #t msg args)
+     (vm-backtrace (the-vm))
+     (newline))
+    ((,key ,subr ,msg ,args . ,rest)
+     (let ((cep (current-error-port)))
+       (cond ((not (stack? (fluid-ref the-last-stack))))
+             ((memq 'backtrace (debug-options-interface))
+              (let ((highlights (if (or (eq? key 'wrong-type-arg)
+                                        (eq? key 'out-of-range))
+                                    (car rest)
+                                    '())))
+                (run-hook before-backtrace-hook)
+                (newline cep)
+                (display "Backtrace:\n")
+                (display-backtrace (fluid-ref the-last-stack) cep
+                                   #f #f highlights)
+                (newline cep)
+                (run-hook after-backtrace-hook))))
+       (run-hook before-error-hook)
+       (apply display-error (fluid-ref the-last-stack) cep subr msg args rest)
+       (run-hook after-error-hook)
+       (set! stack-saved? #f)
+       (force-output cep)))
+    (else
+     (apply bad-throw args))))
+
+(eval-case
+ ((compile-toplevel)
+  (define-macro (start-stack tag expr)
+    expr)))
+
+(define (start-repl lang)
+  (let ((repl (make-repl lang)))
+    (repl-welcome repl)
+    (let prompt-loop ()
+      (let ((exp (prompting-meta-read repl)))
+        (cond
+         ((eq? exp meta-command-token)
+          (meta-command repl (read-line)))
+         ((eof-object? exp)
+          (throw 'quit))
+         (else
+          (catch #t
+                 (lambda ()
+                   (call-with-values (lambda ()
+                                       (run-hook before-eval-hook exp)
+                                       (start-stack repl-eval
+                                                    (repl-eval repl exp)))
+                     (lambda l
+                       (for-each (lambda (v)
+                                   (run-hook before-print-hook v)
+                                   (repl-print repl v))
+                                 l))))
+                 default-catch-handler
+                 default-pre-unwind-handler)))
+        (next-char #f) ;; consume trailing whitespace
+        (prompt-loop)))))
+
+(define (next-char wait)
+  (if (or wait (char-ready?))
+      (let ((ch (peek-char)))
+	(cond ((eof-object? ch) (throw 'quit))
+	      ((char-whitespace? ch) (read-char) (next-char wait))
+	      (else ch)))
+      #f))

module/system/vm/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+Makefile.in
+*.go

module/system/vm/Makefile.am

@@ -0,0 +1,4 @@
+SOURCES = assemble.scm bootstrap.scm conv.scm core.scm debug.scm \
+	  disasm.scm frame.scm profile.scm trace.scm
+moddir = $(guiledir)/system/vm
+include $(top_srcdir)/guilec.mk

module/system/vm/assemble.scm

@@ -0,0 +1,317 @@
+;;; Guile VM assembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm assemble)
+  :use-syntax (system base syntax)
+  :use-module (system il glil)
+  :use-module ((system vm core)
+	       :select (instruction? instruction-pops
+		        make-binding
+			bytecode->objcode))
+  :use-module (system vm conv)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 common-list)
+  :use-module (srfi srfi-4)
+  :use-module ((srfi srfi-1) :select (append-map))
+  :export (preprocess codegen assemble))
+
+(define (assemble glil env . opts)
+  (codegen (preprocess glil #f) #t))
+
+
+;;;
+;;; Types
+;;;
+
+(define-record (<vm-asm> venv glil body))
+(define-record (<venv> parent nexts closure?))
+(define-record (<vmod> id))
+(define-record (<vlink-now> name))
+(define-record (<vlink-later> module name))
+(define-record (<vdefine> module name))
+(define-record (<bytespec> vars bytes meta objs closure?))
+
+
+;;;
+;;; Stage 1: Preprocess
+;;;
+
+(define (preprocess x e)
+  (record-case x
+    ((<glil-asm> vars body)
+     (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
+	    (body (map (lambda (x) (preprocess x venv)) body)))
+       (make-vm-asm :venv venv :glil x :body body)))
+    ((<glil-external> op depth index)
+     (do ((d depth (- d 1))
+ 	  (e e (venv-parent e)))
+ 	 ((= d 0))
+       (set! (venv-closure? e) #t))
+     x)
+    (else x)))
+
+
+;;;
+;;; Stage 2: Bytecode generation
+;;;
+
+(define (codegen glil toplevel)
+  (record-case glil
+    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars)
+     (let ((stack '())
+	   (binding-alist '())
+	   (source-alist '())
+	   (label-alist '())
+	   (object-alist '()))
+       (define (push-code! code)
+;	 (format #t "push-code! ~a~%" code)
+	 (set! stack (cons (code->bytes code) stack)))
+       (define (push-object! x)
+	 (cond ((object->code x) => push-code!)
+	       (toplevel (dump-object! push-code! x))
+	       (else
+		(let ((i (cond ((object-assoc x object-alist) => cdr)
+			       (else
+				(let ((i (length object-alist)))
+				  (set! object-alist (acons x i object-alist))
+				  i)))))
+		  (push-code! `(object-ref ,i))))))
+       (define (current-address)
+	 (define (byte-length x)
+	   (cond ((u8vector? x) (u8vector-length x))
+		 (else 3)))
+	 (apply + (map byte-length stack)))
+       (define (generate-code x)
+	 (record-case x
+	   ((<vm-asm> venv)
+	    (push-object! (codegen x #f))
+	    (if (venv-closure? venv) (push-code! `(make-closure))))
+
+	   ((<glil-bind> (binds vars))
+	    (let ((bindings
+		   (map (lambda (v)
+			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
+			    (case type
+			      ((argument) (make-binding name #f i))
+			      ((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
+			      ((external) (make-binding name #t i)))))
+			binds)))
+	      (set! binding-alist
+		    (acons (current-address) bindings binding-alist))))
+
+	   ((<glil-unbind>)
+	    (set! binding-alist (acons (current-address) #f binding-alist)))
+
+	   ((<glil-source> loc)
+	    (set! source-alist (acons (current-address) loc source-alist)))
+
+	   ((<glil-void>)
+	    (push-code! '(void)))
+
+	   ((<glil-const> obj)
+	    (push-object! obj))
+
+	   ((<glil-argument> op index)
+	    (if (eq? op 'ref)
+		(push-code! `(local-ref ,index))
+		(push-code! `(local-set ,index))))
+
+	   ((<glil-local> op index)
+	    (if (eq? op 'ref)
+		(push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
+		(push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
+
+	   ((<glil-external> op depth index)
+	    (do ((e venv (venv-parent e))
+		 (d depth (1- d))
+		 (n 0 (+ n (venv-nexts e))))
+		((= d 0)
+		 (if (eq? op 'ref)
+		     (push-code! `(external-ref ,(+ n index)))
+		     (push-code! `(external-set ,(+ n index)))))))
+
+	   ((<glil-module> op module name)
+            (case op
+              ((ref set)
+               (cond
+                (toplevel
+                 (push-object! (make-vlink-now :name name))
+                 (push-code! (case op
+                               ((ref) '(variable-ref))
+                               ((set) '(variable-set)))))
+                (else
+                 (let* ((var (make-vlink-later :module module :name name))
+                        (i (cond ((object-assoc var object-alist) => cdr)
+                                 (else
+                                  (let ((i (length object-alist)))
+                                    (set! object-alist (acons var i object-alist))
+                                    i)))))
+                   (push-code! (case op
+                                 ((ref) `(late-variable-ref ,i))
+                                 ((set) `(late-variable-set ,i))))))))
+              ((define)
+               (push-object! (make-vdefine :module module :name name))
+               (push-code! '(variable-set)))
+              (else
+               (error "unknown toplevel var kind" op name))))
+
+	   ((<glil-label> label)
+	    (set! label-alist (assq-set! label-alist label (current-address))))
+
+	   ((<glil-branch> inst label)
+	    (set! stack (cons (list inst label) stack)))
+
+	   ((<glil-call> inst nargs)
+	    (if (instruction? inst)
+		(let ((pops (instruction-pops inst)))
+		  (cond ((< pops 0)
+			 (push-code! (list inst nargs)))
+			((= pops nargs)
+			 (push-code! (list inst)))
+			(else
+			 (error "Wrong number of arguments:" inst nargs))))
+		(error "Unknown instruction:" inst)))))
+       ;;
+       ;; main
+       (for-each generate-code body)
+;       (format #t "codegen: stack = ~a~%" (reverse stack))
+       (let ((bytes (stack->bytes (reverse! stack) label-alist)))
+	 (if toplevel
+	     (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
+	     (make-bytespec :vars vars :bytes bytes
+                            :meta (if (and (null? binding-alist)
+                                           (null? source-alist))
+                                      #f
+                                      (cons (reverse! binding-alist)
+                                            (reverse! source-alist)))
+                            :objs (let ((objs (map car (reverse! object-alist))))
+                                    (if (null? objs) #f (list->vector objs)))
+                            :closure? (venv-closure? venv))))))))))
+
+(define (object-assoc x alist)
+  (record-case x
+    ((<vlink-now>) (assoc x alist))
+    ((<vlink-later>) (assoc x alist))
+    (else        (assq x alist))))
+
+(define (stack->bytes stack label-alist)
+  (let loop ((result '()) (stack stack) (addr 0))
+    (if (null? stack)
+	(list->u8vector(append-map u8vector->list
+                                   (reverse! result)))
+	(let ((bytes (car stack)))
+	  (if (pair? bytes)
+	      (let* ((offset (- (assq-ref label-alist (cadr bytes))
+				(+ addr 3)))
+		     (n (if (< offset 0) (+ offset 65536) offset)))
+		(set! bytes (code->bytes (list (car bytes)
+					       (quotient n 256)
+					       (modulo n 256))))))
+	  (loop (cons bytes result)
+		(cdr stack)
+		(+ addr (u8vector-length bytes)))))))
+
+
+;;;
+;;; Object dump
+;;;
+
+;; NOTE: undumpped in vm_system.c
+
+(define (dump-object! push-code! x)
+  (define (too-long x)
+    (error (string-append x " too long")))
+
+  (let dump! ((x x))
+    (cond
+     ((object->code x) => push-code!)
+     ((record? x)
+      (record-case x
+	((<bytespec> vars bytes meta objs closure?)
+	 ;; dump parameters
+	 (let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
+	       (nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
+	   (cond
+	     ((and (< nargs 4) (< nlocs 8) (< nexts 4))
+	      ;; 8-bit representation
+	      (let ((x (+ (* nargs 64) (* nrest 32) (* nlocs 4) nexts)))
+		(push-code! `(make-int8 ,x))))
+	     ((and (< nargs 16) (< nlocs 128) (< nexts 16))
+	      ;; 16-bit representation
+	      (let ((x (+ (* nargs 4096) (* nrest 2048) (* nlocs 16) nexts)))
+		(push-code! `(make-int16 ,(quotient x 256) ,(modulo x 256)))))
+	     (else
+	      ;; Other cases
+	      (push-code! (object->code nargs))
+	      (push-code! (object->code nrest))
+	      (push-code! (object->code nlocs))
+	      (push-code! (object->code nexts))
+	      (push-code! (object->code #f)))))
+	 ;; dump object table
+	 (if objs (dump! objs))
+	 ;; dump meta data
+	 (if meta (dump! meta))
+	 ;; dump bytecode
+	 (push-code! `(load-program ,bytes)))
+	((<vlink-later> module name)
+         (dump! (module-name module))
+         (dump! name)
+	 (push-code! '(link-later)))
+	((<vlink-now> name)
+         (dump! name)
+	 (push-code! '(link-now)))
+	((<vdefine> module name)
+	 ;; FIXME: dump module
+	 (push-code! `(define ,(symbol->string name))))
+	((<vmod> id)
+	 (push-code! `(load-module ,id)))
+        (else
+         (error "assemble: unknown record type" (record-type-descriptor x)))))
+     ((and (integer? x) (exact? x))
+      (let ((str (do ((n x (quotient n 256))
+                      (l '() (cons (modulo n 256) l)))
+                     ((= n 0)
+                      (apply u8vector l)))))
+        (push-code! `(load-integer ,str))))
+     ((number? x)
+      (push-code! `(load-number ,(number->string x))))
+     ((string? x)
+      (push-code! `(load-string ,x)))
+     ((symbol? x)
+      (push-code! `(load-symbol ,(symbol->string x))))
+     ((keyword? x)
+      (push-code! `(load-keyword ,(symbol->string (keyword->symbol x)))))
+     ((list? x)
+      (for-each dump! x)
+      (let ((len (length x)))
+        (if (>= len 65536) (too-long 'list))
+        (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
+     ((pair? x)
+      (dump! (car x))
+      (dump! (cdr x))
+      (push-code! `(cons)))
+     ((vector? x)
+      (for-each dump! (vector->list x))
+      (let ((len (vector-length x)))
+        (if (>= len 65536) (too-long 'vector))
+        (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
+     (else
+      (error "assemble: unrecognized object" x)))))

module/system/vm/bootstrap.scm

@@ -0,0 +1,39 @@
+;;; Bootstrapping the VM into the interpreter
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm bootstrap))
+
+;;;
+;;; Core procedures
+;;;
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
+
+(module-export! (current-module)
+		(delq! '%module-public-interface
+		       (hash-fold (lambda (k v d) (cons k d)) '()
+				  (module-obarray (current-module)))))
+
+;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
+;; and friends.
+(set! load-compiled
+      (lambda (file)
+        ((the-vm) (objcode->program (load-objcode file)))))

module/system/vm/conv.scm

@@ -0,0 +1,196 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm conv)
+  :use-module ((system vm core)
+	       :select (instruction? instruction-length
+			instruction->opcode opcode->instruction))
+  :use-module (system base pmatch)
+  :use-module (ice-9 regex)
+  :use-module (srfi srfi-4)
+  :use-module (srfi srfi-1)
+  :export (code-pack code-unpack object->code code->object code->bytes
+	   make-byte-decoder))
+
+;;;
+;;; Code compress/decompression
+;;;
+
+(define (code-pack code)
+  (pmatch code
+    ((inst ,n) (guard (integer? n))
+     (cond ((< n 10)
+	    (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
+	      (if (instruction? abbrev) (list abbrev) code)))
+	   (else code)))
+    (else code)))
+
+(define (code-unpack code)
+  (let ((inst (symbol->string (car code))))
+    (cond
+     ((string-match "^([^:]*):([0-9]+)$" inst) =>
+      (lambda (data)
+	(cons* (string->symbol (match:substring data 1))
+	       (string->number (match:substring data 2))
+	       (cdr code))))
+     (else code))))
+
+
+;;;
+;;; Encoder/decoder
+;;;
+
+(define (object->code x)
+  (cond ((eq? x #t) `(make-true))
+	((eq? x #f) `(make-false))
+	((null? x) `(make-eol))
+	((and (integer? x) (exact? x))
+	 (cond ((and (<= -128 x) (< x 128))
+		`(make-int8 ,(modulo x 256)))
+	       ((and (<= -32768 x) (< x 32768))
+		(let ((n (if (< x 0) (+ x 65536) x)))
+		  `(make-int16 ,(quotient n 256) ,(modulo n 256))))
+	       (else #f)))
+	((char? x) `(make-char8 ,(char->integer x)))
+	(else #f)))
+
+(define (code->object code)
+  (pmatch code
+    ((make-true) #t)
+    ((make-false) #f) ;; FIXME: Same as the `else' case!
+    ((make-eol) '())
+    ((make-int8 ,n)
+     (if (< n 128) n (- n 256)))
+    ((make-int16 ,n1 ,n2)
+     (let ((n (+ (* n1 256) n2)))
+       (if (< n 32768) n (- n 65536))))
+    ((make-char8 ,n)
+     (integer->char n))
+    ((load-string ,s) s)
+    ((load-symbol ,s) (string->symbol s))
+    ((load-keyword ,s) (symbol->keyword (string->symbol s)))
+    (else #f)))
+
+; (let ((c->o code->object))
+;   (set! code->object
+; 	(lambda (code)
+; 	  (format #t "code->object: ~a~%" code)
+; 	  (let ((ret (c->o code)))
+; 	    (format #t "code->object returned ~a~%" ret)
+; 	    ret))))
+
+(define (code->bytes code)
+  (define (string->u8vector str)
+    (apply u8vector (map char->integer (string->list str))))
+
+  (let* ((code (code-pack code))
+	 (inst (car code))
+	 (rest (cdr code))
+	 (len (instruction-length inst))
+	 (head (instruction->opcode inst)))
+    (cond ((< len 0)
+	   ;; Variable-length code
+	   ;; Typical instructions are `link' and `load-program'.
+	   (if (string? (car rest))
+	       (set-car! rest (string->u8vector (car rest))))
+	   (let* ((str (car rest))
+		  (str-len (u8vector-length str))
+		  (encoded-len (encode-length str-len))
+		  (encoded-len-len (u8vector-length encoded-len)))
+	     (apply u8vector
+		    (append (cons head (u8vector->list encoded-len))
+			    (u8vector->list str)))))
+	  ((= len (length rest))
+	   ;; Fixed-length code
+	   (apply u8vector (cons head rest)))
+	  (else
+	   (error "Invalid code:" code)))))
+
+; (let ((c->b code->bytes))
+;   ;; XXX: Debugging output
+;   (set! code->bytes
+; 	(lambda (code)
+; 	  (format #t "code->bytes: ~a~%" code)
+; 	  (let ((result (c->b code)))
+; 	    (format #t "code->bytes: returned ~a~%" result)
+; 	    result))))
+
+
+(define (make-byte-decoder bytes)
+  (let ((addr 0) (size (u8vector-length bytes)))
+    (define (pop)
+      (let ((byte (u8vector-ref bytes addr)))
+	(set! addr (1+ addr))
+	byte))
+    (define (sublist lst start end)
+      (take (drop lst start) (- end start)))
+    (lambda ()
+      (if (< addr size)
+	  (let* ((start addr)
+		 (inst (opcode->instruction (pop)))
+		 (n (instruction-length inst))
+		 (code (if (< n 0)
+			   ;; variable length
+			   (let* ((end (+ (decode-length pop) addr))
+				  (subbytes (sublist
+					     (u8vector->list bytes)
+					     addr end))
+				  (->string? (not (eq? inst 'load-program))))
+			     (set! addr end)
+			     (list inst
+				   (if ->string?
+				       (list->string
+					(map integer->char subbytes))
+				       (apply u8vector subbytes))))
+			   ;; fixed length
+			   (do ((n n (1- n))
+				(l '() (cons (pop) l)))
+			       ((= n 0) (cons* inst (reverse! l)))))))
+	    (values start code))
+	  #f))))
+
+
+;;;
+;;; Variable-length interface
+;;;
+
+;; NOTE: decoded in vm_fetch_length in vm.c as well.
+
+(define (encode-length len)
+  (cond ((< len 254) (u8vector len))
+	((< len (* 256 256))
+	 (u8vector 254 (quotient len 256) (modulo len 256)))
+	((< len most-positive-fixnum)
+	 (u8vector 255
+		   (quotient len (* 256 256 256))
+		   (modulo (quotient len (* 256 256)) 256)
+		   (modulo (quotient len 256) 256)
+		   (modulo len 256)))
+	(else (error "Too long code length:" len))))
+
+(define (decode-length pop)
+  (let ((len (pop)))
+    (cond ((< len 254) len)
+	  ((= len 254) (+ (* (pop) 256) (pop)))
+	  (else (+ (* (pop) 256 256 256)
+		   (* (pop) 256 256)
+		   (* (pop) 256)
+		   (pop))))))

module/system/vm/core.scm

@@ -0,0 +1,173 @@
+;;; Guile VM core
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm core)
+  :use-module (system vm bootstrap)
+  :export (arity:nargs arity:nrest arity:nlocs arity:nexts
+           make-binding binding:name binding:extp binding:index
+           program-bindings program-sources
+           frame-arguments frame-local-variables frame-external-variables
+           frame-environment
+           frame-variable-exists? frame-variable-ref frame-variable-set!
+           frame-object-name
+           vm-fetch-locals vm-fetch-externals vm-return-value
+           vms:time vms:clock vm-load))
+
+;;;
+;;; Core procedures
+;;;
+
+;; FIXME
+(module-re-export! (current-module)
+                   (hash-fold (lambda (k v d) (cons k d)) '()
+                              (module-obarray
+                               (resolve-interface '(system vm bootstrap)))))
+
+
+;;;
+;;; Programs
+;;;
+
+(define arity:nargs car)
+(define arity:nrest cadr)
+(define arity:nlocs caddr)
+(define arity:nexts cadddr)
+
+(define (make-binding name extp index)
+  (list name extp index))
+
+(define binding:name car)
+(define binding:extp cadr)
+(define binding:index caddr)
+
+(define (program-bindings prog)
+  (cond ((program-meta prog) => car)
+	(else '())))
+
+(define (program-sources prog)
+  (cond ((program-meta prog) => cdr)
+	(else '())))
+
+
+;;;
+;;; Frames
+;;;
+
+(define (frame-arguments frame)
+  (let* ((prog (frame-program frame))
+	 (arity (program-arity prog)))
+    (do ((n (+ (arity:nargs arity) -1) (1- n))
+	 (l '() (cons (frame-local-ref frame n) l)))
+	((< n 0) l))))
+
+(define (frame-local-variables frame)
+  (let* ((prog (frame-program frame))
+	 (arity (program-arity prog)))
+    (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
+	 (l '() (cons (frame-local-ref frame n) l)))
+	((< n 0) l))))
+
+(define (frame-external-variables frame)
+  (frame-external-link frame))
+
+(define (frame-external-ref frame index)
+  (list-ref (frame-external-link frame) index))
+
+(define (frame-external-set! frame index val)
+  (list-set! (frame-external-link frame) index val))
+
+(define (frame-binding-ref frame binding)
+  (if (binding:extp binding)
+    (frame-external-ref frame (binding:index binding))
+    (frame-local-ref frame (binding:index binding))))
+
+(define (frame-binding-set! frame binding val)
+  (if (binding:extp binding)
+    (frame-external-set! frame (binding:index binding) val)
+    (frame-local-set! frame (binding:index binding) val)))
+
+(define (frame-bindings frame addr)
+  (do ((bs (program-bindings (frame-program frame)) (cdr bs))
+       (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
+      ((or (null? bs) (> (caar bs) addr))
+       (apply append ls))))
+
+(define (frame-lookup-binding frame addr sym)
+  (do ((bs (frame-bindings frame addr) (cdr bs)))
+      ((or (null? bs) (eq? sym (binding:name (car bs))))
+       (and (pair? bs) (car bs)))))
+
+(define (frame-object-binding frame addr obj)
+  (do ((bs (frame-bindings frame addr) (cdr bs)))
+      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+       (and (pair? bs) (car bs)))))
+
+(define (frame-environment frame addr)
+  (map (lambda (binding)
+	 (cons (binding:name binding) (frame-binding-ref frame binding)))
+       (frame-bindings frame addr)))
+
+(define (frame-variable-exists? frame addr sym)
+  (if (frame-lookup-binding frame addr sym) #t #f))
+
+(define (frame-variable-ref frame addr sym)
+  (cond ((frame-lookup-binding frame addr sym) =>
+	 (lambda (binding) (frame-binding-ref frame binding)))
+	(else (error "Unknown variable:" sym))))
+
+(define (frame-variable-set! frame addr sym val)
+  (cond ((frame-lookup-binding frame addr sym) =>
+	 (lambda (binding) (frame-binding-set! frame binding val)))
+	(else (error "Unknown variable:" sym))))
+
+(define (frame-object-name frame addr obj)
+  (cond ((frame-object-binding frame addr obj) => binding:name)
+	(else #f)))
+
+
+;;;
+;;; Current status
+;;;
+
+(define (vm-fetch-locals vm)
+  (frame-local-variables (vm-this-frame vm)))
+
+(define (vm-fetch-externals vm)
+  (frame-external-variables (vm-this-frame vm)))
+
+(define (vm-return-value vm)
+  (car (vm-fetch-stack vm)))
+
+
+;;;
+;;; Statistics
+;;;
+
+(define (vms:time stat) (vector-ref stat 0))
+(define (vms:clock stat) (vector-ref stat 1))
+
+
+;;;
+;;; Loader
+;;;
+
+(define (vm-load vm objcode)
+  (vm (objcode->program objcode)))

module/system/vm/debug.scm

@@ -0,0 +1,65 @@
+;;; Guile VM debugging facilities
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm debug)
+  :use-syntax (system base syntax)
+;;  :use-module ((system vm core)
+;;	       :select (vm-last-frame-chain vm-backtrace))
+  :use-module (system vm frame)
+  :use-module (ice-9 format)
+  :export (vm-debugger vm-backtrace))
+
+
+;;;
+;;; Debugger
+;;;
+
+(define-record (<debugger> vm chain index))
+
+(define (vm-debugger vm)
+  (let ((chain (vm-last-frame-chain vm)))
+    (if (null? chain)
+      (display "Nothing to debug\n")
+      (debugger-repl (make-debugger
+                      :vm vm :chain chain :index (length chain))))))
+
+(define (debugger-repl db)
+  (let loop ()
+    (display "debug> ")
+    (let ((cmd (read)))
+      (case cmd
+	((bt) (vm-backtrace (debugger-vm db)))
+	((stack)
+	 (write (vm-fetch-stack (debugger-vm db)))
+	 (newline))
+	(else
+	 (format #t "Unknown command: ~A" cmd))))))
+
+
+;;;
+;;; Backtrace
+;;;
+
+(define (vm-backtrace vm)
+  (let ((chain (vm-last-frame-chain vm)))
+    (if (null? chain)
+      (display "No backtrace available\n")
+      (for-each print-frame (reverse! chain)))))

module/system/vm/disasm.scm

@@ -0,0 +1,159 @@
+;;; Guile VM Disassembler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm disasm)
+  :use-module (system base pmatch)
+  :use-module (system vm core)
+  :use-module (system vm conv)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 format)
+  :use-module (ice-9 receive)
+  :export (disassemble-objcode disassemble-program disassemble-bytecode))
+
+(define (disassemble-objcode objcode . opts)
+  (let* ((prog  (objcode->program objcode))
+	 (arity (program-arity prog))
+	 (nlocs (arity:nlocs arity))
+	 (nexts (arity:nexts arity))
+	 (bytes (program-bytecode prog)))
+    (format #t "Disassembly of ~A:\n\n" objcode)
+    (format #t "nlocs = ~A  nexts = ~A\n\n" nlocs nexts)
+    (disassemble-bytecode bytes #f)))
+
+(define (disassemble-program prog . opts)
+  (let* ((arity (program-arity prog))
+	 (nargs (arity:nargs arity))
+	 (nrest (arity:nrest arity))
+	 (nlocs (arity:nlocs arity))
+	 (nexts (arity:nexts arity))
+	 (bytes (program-bytecode prog))
+	 (objs  (program-objects prog))
+	 (exts  (program-external prog)))
+    ;; Disassemble this bytecode
+    (format #t "Disassembly of ~A:\n\n" prog)
+    (format #t "nargs = ~A  nrest = ~A  nlocs = ~A  nexts = ~A\n\n"
+	    nargs nrest nlocs nexts)
+    (format #t "Bytecode:\n\n")
+    (disassemble-bytecode bytes objs)
+    (if (> (vector-length objs) 0)
+	(disassemble-objects objs))
+    (if (pair? exts)
+	(disassemble-externals exts))
+    ;; Disassemble other bytecode in it
+    (for-each
+     (lambda (x)
+       (if (program? x)
+	   (begin (display "----------------------------------------\n")
+		  (apply disassemble-program x opts))))
+     (vector->list objs))))
+
+(define (disassemble-bytecode bytes objs)
+  (let ((decode (make-byte-decoder bytes))
+	(programs '()))
+    (do ((addr+code (decode) (decode)))
+	((not addr+code) (newline))
+      (receive (addr code) addr+code
+	(pmatch code
+	  ((load-program ,x)
+	   (let ((sym (gensym "")))
+	     (set! programs (acons sym x programs))
+	     (print-info addr (format #f "(load-program #~A)" sym) #f)))
+	  (else
+	   (let ((info (list->info code))
+		 (extra (original-value addr code objs)))
+	     (print-info addr info extra))))))
+    (for-each (lambda (sym+bytes)
+		(format #t "Bytecode #~A:\n\n" (car sym+bytes))
+		(disassemble-bytecode (cdr sym+bytes) #f))
+	      (reverse! programs))))
+
+(define (disassemble-objects objs)
+  (display "Objects:\n\n")
+  (let ((len (vector-length objs)))
+    (do ((n 0 (1+ n)))
+	((= n len) (newline))
+      (let ((info (object->string (vector-ref objs n))))
+	(print-info n info #f)))))
+
+(define (disassemble-externals exts)
+  (display "Externals:\n\n")
+  (let ((len (length exts)))
+    (do ((n 0 (1+ n))
+	 (l exts (cdr l)))
+	((null? l) (newline))
+      (let ((info (object->string (car l))))
+	(print-info n info #f)))))
+
+(define (disassemble-meta meta)
+  (display "Meta info:\n\n")
+  (for-each (lambda (data)
+	      (print-info (car data) (list->info (cdr data)) #f))
+	    meta)
+  (newline))
+
+(define (original-value addr code objs)
+  (define (branch-code? code)
+    (string-match "^br" (symbol->string (car code))))
+  (define (list-or-vector? code)
+    (case (car code)
+      ((list vector) #t)
+      (else #f)))
+
+  (let ((code (code-unpack code)))
+    (cond ((list-or-vector? code)
+	   (let ((len (+ (* (cadr code) 256) (caddr code))))
+	     (format #f "~a element~a" len (if (> len 1) "s" ""))))
+	  ((code->object code) => object->string)
+	  ((branch-code? code)
+	   (let ((offset (+ (* (cadr code) 256) (caddr code))))
+	     (format #f "-> ~A" (+ addr offset 3))))
+	  (else
+	   (let ((inst (car code)) (args (cdr code)))
+	     (case inst
+	       ((make-false) "#f")
+	       ((object-ref)
+		(if objs (object->string (vector-ref objs (car args))) #f))
+	       (else #f)))))))
+
+(define (list->info list)
+  (object->string list))
+
+;   (define (u8vector->string vec)
+;     (list->string (map integer->char (u8vector->list vec))))
+
+;   (case (car list)
+;     ((link)
+;      (object->string `(link ,(u8vector->string (cadr list)))))
+;     (else
+;      (object->string list))))
+
+(define (print-info addr info extra)
+  (if extra
+      (format #t "~4@A    ~32A;; ~A\n" addr info extra)
+      (format #t "~4@A    ~A\n" addr info)))
+
+(define (simplify x)
+  (cond ((string? x)
+	 (cond ((string-index x #\newline) =>
+		(lambda (i) (set! x (substring x 0 i)))))
+	 (cond ((> (string-length x) 16)
+		(set! x (string-append (substring x 0 13) "..."))))))
+  x)

module/system/vm/frame.scm

@@ -0,0 +1,83 @@
+;;; Guile VM frame functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
+;;;
+;;; 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 of the License, 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 program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm frame)
+  :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:))
+  :export (frame-number frame-address
+           vm-current-frame-chain vm-last-frame-chain
+           print-frame print-frame-call))
+
+
+;;;
+;;; Frame chain
+;;;
+
+(define frame-number (make-object-property))
+(define frame-address (make-object-property))
+
+(define (vm-current-frame-chain vm)
+  (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm)))
+
+(define (vm-last-frame-chain vm)
+  (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm)))
+
+(define (make-frame-chain frame addr)
+  (let* ((link (vm:frame-dynamic-link frame))
+	 (chain (if (eq? link #t)
+		  '()
+		  (cons frame (make-frame-chain
+			       link (vm:frame-return-address frame))))))
+    (set! (frame-number frame) (length chain))
+    (set! (frame-address frame)
+	  (- addr (program-base (vm:frame-program frame))))
+    chain))
+
+
+;;;
+;;; Pretty printing
+;;;
+
+(define (print-frame frame)
+  (format #t "#~A " (vm:frame-number frame))
+  (print-frame-call frame)
+  (newline))
+
+(define (print-frame-call frame)
+  (define (abbrev x)
+    (cond ((list? x)   (if (> (length x) 3)
+			 (list (abbrev (car x)) (abbrev (cadr x)) '...)
+			 (map abbrev x)))
+	  ((pair? x)   (cons (abbrev (car x)) (abbrev (cdr x))))
+	  ((vector? x) (case (vector-length x)
+			 ((0) x)
+			 ((1) (vector (abbrev (vector-ref x 0))))
+			 (else (vector (abbrev (vector-ref x 0)) '...))))
+	  (else x)))
+  (write (abbrev (cons (program-name frame)
+		       (vm:frame-arguments frame)))))
+
+(define (program-name frame)
+  (let ((prog (vm:frame-program frame))
+	(link (vm:frame-dynamic-link frame)))
+    (or (object-property prog 'name)
+	(vm:frame-object-name link (1- (vm:frame-address link)) prog)
+	(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
+		   prog (module-obarray (current-module))))))

module/system/vm/profile.scm

@@ -0,0 +1,65 @@
+;;; Guile VM profiler
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm profile)
+  :use-module (system vm core)
+  :use-module (ice-9 format)
+  :export (vm-profile))
+
+(define (vm-profile vm objcode . opts)
+  (let ((flag (vm-option vm 'debug)))
+    (dynamic-wind
+	(lambda ()
+	  (set-vm-option! vm 'debug #t)
+	  (set-vm-option! vm 'profile-data '())
+	  (add-hook! (vm-next-hook vm) profile-next)
+	  (add-hook! (vm-enter-hook vm) profile-enter)
+	  (add-hook! (vm-exit-hook vm) profile-exit))
+	(lambda ()
+	  (vm-load vm objcode)
+	  (print-result vm))
+	(lambda ()
+	  (set-vm-option! vm 'debug flag)
+	  (remove-hook! (vm-next-hook vm) profile-next)
+	  (remove-hook! (vm-enter-hook vm) profile-enter)
+	  (remove-hook! (vm-exit-hook vm) profile-exit)))))
+
+(define (profile-next vm)
+  (set-vm-option! vm 'profile-data
+		  (cons (vm-fetch-code vm) (vm-option vm 'profile-data))))
+
+(define (profile-enter vm)
+  #f)
+
+(define (profile-exit vm)
+  #f)
+
+(define (print-result vm . opts)
+  (do ((data (vm-option vm 'profile-data) (cdr data))
+       (summary '() (let ((inst (caar data)))
+		      (assq-set! summary inst
+				 (1+ (or (assq-ref summary inst) 0))))))
+      ((null? data)
+       (display "Count  Instruction\n")
+       (display "-----  -----------\n")
+       (for-each (lambda (entry)
+		   (format #t "~5@A  ~A\n" (cdr entry) (car entry)))
+		 (sort summary (lambda (e1 e2) (> (cdr e1) (cdr e2))))))))

module/system/vm/trace.scm

@@ -0,0 +1,78 @@
+;;; Guile VM tracer
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; 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 (system vm trace)
+  :use-syntax (system base syntax)
+  :use-module (system vm core)
+  :use-module (system vm frame)
+  :use-module (ice-9 format)
+  :export (vm-trace vm-trace-on vm-trace-off))
+
+(define (vm-trace vm objcode . opts)
+  (dynamic-wind
+      (lambda () (apply vm-trace-on vm opts))
+      (lambda () (vm-load vm objcode))
+      (lambda () (apply vm-trace-off vm opts))))
+
+(define (vm-trace-on vm . opts)
+  (set-vm-option! vm 'trace-first #t)
+  (if (memq :b opts) (add-hook! (vm-next-hook vm) trace-next))
+  (set-vm-option! vm 'trace-options opts)
+  (add-hook! (vm-apply-hook vm) trace-apply)
+  (add-hook! (vm-return-hook vm) trace-return))
+
+(define (vm-trace-off vm . opts)
+  (if (memq :b opts) (remove-hook! (vm-next-hook vm) trace-next))
+  (remove-hook! (vm-apply-hook vm) trace-apply)
+  (remove-hook! (vm-return-hook vm) trace-return))
+
+(define (trace-next vm)
+  (define (puts x) (display #\tab) (write x))
+  (define (truncate! x n)
+    (if (> (length x) n)
+      (list-cdr-set! x (1- n) '(...))) x)
+  ;; main
+  (format #t "0x~8X  ~16S" (vm:ip vm) (vm-fetch-code vm))
+  (do ((opts (vm-option vm 'trace-options) (cdr opts)))
+      ((null? opts) (newline))
+    (case (car opts)
+      ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
+      ((:l) (puts (vm-fetch-locals vm)))
+      ((:e) (puts (vm-fetch-externals vm))))))
+
+(define (trace-apply vm)
+  (if (vm-option vm 'trace-first)
+    (set-vm-option! vm 'trace-first #f)
+    (let ((chain (vm-current-frame-chain vm)))
+      (print-indent chain)
+      (print-frame-call (car chain))
+      (newline))))
+
+(define (trace-return vm)
+  (let ((chain (vm-current-frame-chain vm)))
+    (print-indent chain)
+    (write (vm-return-value vm))
+    (newline)))
+
+(define (print-indent chain)
+  (cond ((pair? (cdr chain))
+	 (display "| ")
+	 (print-indent (cdr chain)))))

src/.cvsignore

@@ -0,0 +1,14 @@
+.libs
+.deps
+guilec
+guile-vm
+stamp-h
+config.h
+config.h.in
+stamp-h.in
+Makefile
+Makefile.in
+*.x
+*.i
+*.lo
+*.la

src/Makefile.am

@@ -0,0 +1,52 @@
+bin_PROGRAMS = guile-vm
+bin_SCRIPTS = guilec guile-disasm
+guile_vm_SOURCES = guile-vm.c
+guile_vm_LDADD = libguile-vm.la 
+guile_vm_LDFLAGS = $(GUILE_LDFLAGS)
+
+AM_CFLAGS = -Wall -g
+
+lib_LTLIBRARIES = libguile-vm.la
+libguile_vm_la_SOURCES =						\
+	envs.c frames.c instructions.c objcodes.c programs.c vm.c	\
+	envs.h frames.h instructions.h objcodes.h programs.h vm.h	\
+	vm_engine.h vm_expand.h
+libguile_vm_la_LDFLAGS = -version-info 0:0:0 -export-dynamic
+EXTRA_DIST = vm_engine.c vm_system.c vm_scheme.c vm_loader.c \
+             guilec.in guile-disasm.in
+BUILT_SOURCES = vm_system.i vm_scheme.i vm_loader.i \
+	envs.x frames.x instructions.x objcodes.x programs.x vm.x
+
+INCLUDES = $(GUILE_CFLAGS)
+CLEANFILES = guilec guile-disasm
+DISTCLEANFILES = $(BUILT_SOURCES)
+MAINTAINERCLEANFILES = Makefile.in config.h.in stamp-h.in
+
+ETAGS_ARGS = --regex='/SCM_\(SYMBOL\|VCELL\).*\"\([^\"]\)*\"/\3/' \
+   --regex='/SCM_DEFINE[ \t]*(\([^,]*\),[^,]*/\1/'
+
+SNARF = guile-snarf
+SUFFIXES = .i .x
+
+.c.i:
+	grep '^VM_DEFINE' $< > $@
+
+.c.x:
+	$(SNARF) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ \
+	|| { rm $@; false; }
+
+
+# Extra rules for debugging purposes.
+
+%.I: %.c
+	$(CPP) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(CPPFLAGS) $< > $@
+
+%.s: %.c
+	$(CC) -S -dA $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(CFLAGS) $(CPPFLAGS) -o $@ $<
+
+
+%: %.in
+	sed "s!@guile@!$(GUILE)!" $^ > $@
+	@chmod 755 $@
+
+$(BUILT_SOURCES): config.h vm_expand.h

src/envs.c

@@ -0,0 +1,259 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "envs.h"
+
+#define ENV_OBARRAY_SIZE 31
+
+
+scm_t_bits scm_tc16_env;
+
+SCM
+scm_c_make_env (void)
+{
+  struct scm_env *p = scm_gc_malloc (sizeof (struct scm_env),
+				     "env");
+  p->identifier = SCM_BOOL_F;
+  p->obarray    = scm_c_make_hash_table (ENV_OBARRAY_SIZE);
+  SCM_RETURN_NEWSMOB (scm_tc16_env, p);
+}
+
+static SCM
+env_mark (SCM obj)
+{
+  struct scm_env *p = SCM_ENV_DATA (obj);
+  scm_gc_mark (p->identifier);
+  return p->obarray;
+}
+
+static scm_sizet
+env_free (SCM obj)
+{
+  scm_gc_free (SCM_ENV_DATA (obj), sizeof (struct scm_env),
+	       "env");
+  return 0;
+}
+
+
+/*
+ * C interface
+ */
+
+static SCM env_table;
+static SCM load_env;
+
+SCM
+scm_c_lookup_env (SCM identifier)
+{
+  /* Check if the env is already loaded */
+  SCM vcell = scm_hash_get_handle (env_table, identifier);
+
+  /* If not, load the env */
+  if (SCM_FALSEP (vcell))
+    {
+      SCM env = scm_apply (SCM_CDR (load_env),
+			   SCM_LIST1 (identifier), SCM_EOL);
+      if (!SCM_ENV_P (env))
+	scm_misc_error ("scm_c_lookup_env",
+			"Invalid env: ~S", SCM_LIST1 (env));
+      vcell = scm_hash_create_handle_x (env_table, identifier, env);
+    }
+
+  return (SCM_CDR (vcell));
+}
+
+SCM
+scm_c_env_vcell (SCM env, SCM name, int intern)
+{
+  SCM vcell;
+  SCM ob = SCM_ENV_OBARRAY (env);
+
+  if (intern)
+    vcell = scm_hash_create_handle_x (ob, name, SCM_UNSPECIFIED);
+  else
+    vcell = scm_hash_get_handle (ob, name);
+
+  return vcell;
+}
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_make_env, "make-env", 0, 0, 0,
+	    (),
+	    "")
+#define FUNC_NAME s_scm_make_env
+{
+  return scm_c_make_env ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_p, "env?", 1, 0, 0,
+	    (SCM x),
+	    "")
+#define FUNC_NAME s_scm_env_p
+{
+  return SCM_BOOL (SCM_ENV_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_identifier, "env-identifier", 1, 0, 0,
+	    (SCM env),
+	    "")
+#define FUNC_NAME s_scm_env_identifier
+{
+  SCM_VALIDATE_ENV (1, env);
+  return SCM_ENV_IDENTIFIER (env);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_env_identifier_x, "set-env-identifier!", 2, 0, 0,
+	    (SCM env, SCM identifier),
+	    "")
+#define FUNC_NAME s_scm_set_env_identifier_x
+{
+  SCM_VALIDATE_ENV (1, env);
+  SCM_VALIDATE_SYMBOL (2, identifier);
+  SCM_ENV_IDENTIFIER (env) = identifier;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_bound_p, "env-bound?", 2, 0, 0,
+	    (SCM env, SCM name),
+	    "")
+#define FUNC_NAME s_scm_env_bound_p
+{
+  SCM obarray, vcell;
+  SCM_VALIDATE_ENV (1, env);
+  SCM_VALIDATE_SYMBOL (2, name);
+
+  obarray = SCM_ENV_OBARRAY (env);
+  vcell = scm_hash_get_handle (obarray, name);
+
+  return SCM_BOOL (!SCM_FALSEP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_ref, "env-ref", 2, 0, 0,
+	    (SCM env, SCM name),
+	    "")
+#define FUNC_NAME s_scm_env_ref
+{
+  SCM vcell;
+  SCM_VALIDATE_ENV (1, env);
+  SCM_VALIDATE_SYMBOL (2, name);
+  vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
+  if (SCM_FALSEP (vcell) || SCM_UNBNDP (SCM_CDR (vcell)))
+    SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
+		    SCM_LIST2 (env, name));
+  return SCM_CDR (vcell);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_set_x, "env-set!", 3, 0, 0,
+	    (SCM env, SCM name, SCM val),
+	    "")
+#define FUNC_NAME s_scm_env_set_x
+{
+  SCM vcell;
+  SCM_VALIDATE_ENV (1, env);
+  SCM_VALIDATE_SYMBOL (2, name);
+  vcell = scm_hash_get_handle (name, SCM_ENV_OBARRAY (env));
+  if (SCM_FALSEP (vcell))
+    SCM_MISC_ERROR ("Unbound variable in env: ~A, ~A",
+		    SCM_LIST2 (env, name));
+  SCM_SETCDR (vcell, val);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_env_define, "env-define", 3, 0, 0,
+	    (SCM env, SCM name, SCM val),
+	    "")
+#define FUNC_NAME s_scm_env_define
+{
+  SCM vcell;
+  SCM_VALIDATE_ENV (1, env);
+  SCM_VALIDATE_SYMBOL (2, name);
+  vcell = scm_c_env_vcell (env, name, 1);
+  SCM_SETCDR (vcell, val);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_envs (void)
+{
+  SCM mod;
+
+  scm_tc16_env = scm_make_smob_type ("env", 0);
+  scm_set_smob_mark (scm_tc16_env, env_mark);
+  scm_set_smob_free (scm_tc16_env, env_free);
+
+  env_table = scm_permanent_object (scm_c_make_hash_table (51));
+
+#ifndef SCM_MAGIC_SNARFER
+#include "envs.x"
+#endif
+
+  mod = scm_current_module ();
+  load_env = scm_eval_closure_lookup (scm_standard_eval_closure (mod),
+				      scm_str2symbol ("load-env"),
+				      SCM_BOOL_T);
+  load_env = scm_variable_ref (load_env);
+  /* Was: SCM_VARVCELL (load_env); */
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/envs.h

@@ -0,0 +1,74 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_ENVS_H_
+#define _SCM_ENVS_H_
+
+#include <libguile.h>
+
+extern scm_t_bits scm_tc16_env;
+
+struct scm_env
+{
+  SCM identifier;
+  SCM obarray;
+};
+typedef struct scm_env scm_env_t;
+
+#define SCM_ENV_P(x)		SCM_SMOB_PREDICATE (scm_tc16_env, x)
+#define SCM_ENV_DATA(x)		((struct scm_env *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_ENV(p,x)	SCM_MAKE_VALIDATE (p, x, ENV_P)
+
+#define SCM_ENV_IDENTIFIER(x)	(SCM_ENV_DATA(x)->identifier)
+#define SCM_ENV_OBARRAY(x)	(SCM_ENV_DATA(x)->obarray)
+
+extern SCM scm_c_lookup_env (SCM identifier);
+extern SCM scm_c_env_vcell (SCM env, SCM name, int intern);
+
+extern void scm_init_envs (void);
+
+#endif /* _SCM_ENVS_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/frames.c

@@ -0,0 +1,190 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "frames.h"
+
+
+scm_t_bits scm_tc16_heap_frame;
+
+SCM
+scm_c_make_heap_frame (SCM *fp)
+{
+  SCM frame;
+  SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+  SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+  size_t size = sizeof (SCM) * (upper - lower + 1);
+  SCM *p = scm_gc_malloc (size, "frame");
+
+  SCM_NEWSMOB (frame, scm_tc16_heap_frame, p);
+  p[0] = frame; /* self link */
+  memcpy (p + 1, lower, size - sizeof (SCM));
+
+  return frame;
+}
+
+static SCM
+heap_frame_mark (SCM obj)
+{
+  SCM *sp;
+  SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+  SCM *limit = &SCM_FRAME_HEAP_LINK (fp);
+
+  for (sp = SCM_FRAME_LOWER_ADDRESS (fp); sp <= limit; sp++)
+    if (SCM_NIMP (*sp))
+      scm_gc_mark (*sp);
+
+  return SCM_BOOL_F;
+}
+
+static scm_sizet
+heap_frame_free (SCM obj)
+{
+  SCM *fp = SCM_HEAP_FRAME_POINTER (obj);
+  SCM *lower = SCM_FRAME_LOWER_ADDRESS (fp);
+  SCM *upper = SCM_FRAME_UPPER_ADDRESS (fp);
+  size_t size = sizeof (SCM) * (upper - lower + 1);
+
+  scm_gc_free (SCM_HEAP_FRAME_DATA (obj), size, "frame");
+
+  return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_frame_p
+{
+  return SCM_BOOL (SCM_HEAP_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_program, "frame-program", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_program
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  return SCM_FRAME_PROGRAM (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0,
+	    (SCM frame, SCM index),
+	    "")
+#define FUNC_NAME s_scm_frame_local_ref
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+  return SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+			     SCM_I_INUM (index));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0,
+	    (SCM frame, SCM index, SCM val),
+	    "")
+#define FUNC_NAME s_scm_frame_local_set_x
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  SCM_MAKE_VALIDATE (2, index, I_INUMP); /* FIXME: Check the range! */
+  SCM_FRAME_VARIABLE (SCM_HEAP_FRAME_POINTER (frame),
+		      SCM_I_INUM (index)) = val;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_return_address
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  return scm_from_ulong ((unsigned long)
+			 (SCM_FRAME_RETURN_ADDRESS
+			  (SCM_HEAP_FRAME_POINTER (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_dynamic_link
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  return SCM_FRAME_HEAP_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_frame_external_link
+{
+  SCM_VALIDATE_HEAP_FRAME (1, frame);
+  return SCM_FRAME_EXTERNAL_LINK (SCM_HEAP_FRAME_POINTER (frame));
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_frames (void)
+{
+  scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
+  scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
+  scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "frames.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/frames.h

@@ -0,0 +1,116 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_FRAMES_H_
+#define _SCM_FRAMES_H_
+
+#include <libguile.h>
+#include "programs.h"
+
+
+/*
+ * VM frames
+ */
+
+/* VM Frame Layout
+   ---------------
+
+   |                  | <- fp + bp->nargs + bp->nlocs + 4
+   +------------------+    = SCM_FRAME_UPPER_ADDRESS (fp)
+   | Return address   |
+   | Dynamic link     |
+   | Heap link        |
+   | External link    | <- fp + bp->nargs + bp->nlocs
+   | Local variable 1 |    = SCM_FRAME_DATA_ADDRESS (fp)
+   | Local variable 0 | <- fp + bp->nargs
+   | Argument 1       |
+   | Argument 0       | <- fp
+   | Program          | <- fp - 1
+   +------------------+    = SCM_FRAME_LOWER_ADDRESS (fp)
+   |                  |
+
+   As can be inferred from this drawing, it is assumed that
+   `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are
+   assumed to be as long as SCM objects.  */
+
+#define SCM_FRAME_DATA_ADDRESS(fp)				\
+  (fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs	\
+      + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
+#define SCM_FRAME_UPPER_ADDRESS(fp)	(SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_LOWER_ADDRESS(fp)	(fp - 1)
+
+#define SCM_FRAME_BYTE_CAST(x)		((scm_byte_t *) SCM_UNPACK (x))
+#define SCM_FRAME_STACK_CAST(x)		((SCM *) SCM_UNPACK (x))
+
+#define SCM_FRAME_RETURN_ADDRESS(fp)				\
+  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
+#define SCM_FRAME_DYNAMIC_LINK(fp)				\
+  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl)		\
+  ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(dl);
+#define SCM_FRAME_HEAP_LINK(fp)		(SCM_FRAME_DATA_ADDRESS (fp)[1])
+#define SCM_FRAME_EXTERNAL_LINK(fp)	(SCM_FRAME_DATA_ADDRESS (fp)[0])
+#define SCM_FRAME_VARIABLE(fp,i)	fp[i]
+#define SCM_FRAME_PROGRAM(fp)		fp[-1]
+
+
+/*
+ * Heap frames
+ */
+
+extern scm_t_bits scm_tc16_heap_frame;
+
+#define SCM_HEAP_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_heap_frame, x)
+#define SCM_HEAP_FRAME_DATA(f)		((SCM *) SCM_SMOB_DATA (f))
+#define SCM_HEAP_FRAME_SELF(f)		(SCM_HEAP_FRAME_DATA (f) + 0)
+#define SCM_HEAP_FRAME_POINTER(f)	(SCM_HEAP_FRAME_DATA (f) + 2)
+#define SCM_VALIDATE_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
+
+extern SCM scm_c_make_heap_frame (SCM *fp);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/guile-disasm.in

@@ -0,0 +1,11 @@
+#!@guile@ -s
+!#
+
+;; Obviously, this is -*- Scheme -*-.
+
+(use-modules (system vm core)
+	     (system vm disasm))
+
+(for-each (lambda (file)
+	    (disassemble-objcode (load-objcode file)))
+	  (cdr (command-line)))

src/guile-vm.c

@@ -0,0 +1,54 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <libguile.h>
+
+int
+main (int argc, char **argv)
+{
+  scm_init_guile ();
+  scm_shell (argc, argv);
+  return 0; /* never reached */
+}

src/guilec.in

@@ -0,0 +1,76 @@
+#!@guile@ -s
+# -*- Scheme -*-
+!#
+;;; guilec -- Command-line Guile Scheme compiler.
+;;;
+;;; Copyright 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; 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 of the License, 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 program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+
+(use-modules (system vm bootstrap)
+             (system base compile)
+	     (ice-9 getopt-long))
+
+(read-set! keywords 'prefix)
+
+(define %guilec-options
+  '((help           (single-char #\h) (value #f))
+    (optimize       (single-char #\O) (value #f))
+    (expand-only    (single-char #\e) (value #f))
+    (translate-only (single-char #\t) (value #f))
+    (compile-only   (single-char #\c) (value #f))))
+
+(let* ((options         (getopt-long (command-line) %guilec-options))
+       (help?           (option-ref options 'help #f))
+       (optimize?       (option-ref options 'optimize #f))
+       (expand-only?    (option-ref options 'expand-only #f))
+       (translate-only? (option-ref options 'translate-only #f))
+       (compile-only?   (option-ref options 'compile-only #f)))
+  (if help?
+      (begin
+	(format #t "Usage: guilec [OPTION] FILE...
+Compile each Guile Scheme source file FILE into a Guile object.
+
+  -h, --help           print this help message
+  -O, --optimize       turn on optimizations
+  -e, --expand-only    only go through the code expansion stage
+  -t, --translate-only stop after the translation to GHIL
+  -c, --compile-only   stop after the compilation to GLIL
+
+Report bugs to <guile-user@gnu.org>.~%")
+	(exit 0)))
+
+  (let ((compile-opts (append (if optimize? '(:O) '())
+			      (if expand-only? '(:e) '())
+			      (if translate-only? '(:t) '())
+			      (if compile-only? '(:c) '()))))
+
+    (catch #t
+      (lambda ()
+	(for-each (lambda (file)
+		    (apply compile-file (cons file compile-opts)))
+		  (option-ref options '() '())))
+      (lambda (key . args)
+	(format (current-error-port) "exception `~a' caught~a~%" key
+		(if (null? args) ""
+		    (if (string? (car args))
+			(string-append " in subr `" (car args) "'")
+			"")))
+
+	(format (current-error-port) "removing compiled files due to errors~%")
+	(false-if-exception
+	 (for-each unlink (map compiled-file-name files)))
+	(exit 1)))))

src/instructions.c

@@ -0,0 +1,173 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "instructions.h"
+
+struct scm_instruction scm_instruction_table[] = {
+#define VM_INSTRUCTION_TO_TABLE 1
+#include "vm_expand.h"
+#include "vm_system.i"
+#include "vm_scheme.i"
+#include "vm_loader.i"
+#undef VM_INSTRUCTION_TO_TABLE
+  {scm_op_last}
+};
+
+/* C interface */
+
+struct scm_instruction *
+scm_lookup_instruction (SCM name)
+{
+  struct scm_instruction *ip;
+  char *symbol;
+
+  if (SCM_SYMBOLP (name))
+    for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+      {
+	symbol = scm_to_locale_string (scm_symbol_to_string (name));
+	if ((symbol) && (strcmp (ip->name, symbol) == 0))
+	  {
+	    free (symbol);
+	    return ip;
+	  }
+
+	if (symbol)
+	  free (symbol);
+      }
+
+  return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_instruction_list
+{
+  SCM list = SCM_EOL;
+  struct scm_instruction *ip;
+  for (ip = scm_instruction_table; ip->opcode != scm_op_last; ip++)
+    list = scm_cons (scm_from_locale_symbol (ip->name), list);
+  return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_instruction_p
+{
+  return SCM_BOOL (SCM_INSTRUCTION_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_length
+{
+  SCM_VALIDATE_INSTRUCTION (1, inst);
+  return SCM_I_MAKINUM (SCM_INSTRUCTION_LENGTH (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_pops
+{
+  SCM_VALIDATE_INSTRUCTION (1, inst);
+  return SCM_I_MAKINUM (SCM_INSTRUCTION_POPS (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_pushes
+{
+  SCM_VALIDATE_INSTRUCTION (1, inst);
+  return SCM_I_MAKINUM (SCM_INSTRUCTION_PUSHES (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+  SCM_VALIDATE_INSTRUCTION (1, inst);
+  return SCM_I_MAKINUM (SCM_INSTRUCTION_OPCODE (inst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
+	    (SCM op),
+	    "")
+#define FUNC_NAME s_scm_opcode_to_instruction
+{
+  int i;
+  SCM_MAKE_VALIDATE (1, op, I_INUMP);
+  i = SCM_I_INUM (op);
+  SCM_ASSERT_RANGE (1, op, 0 <= i && i < scm_op_last);
+  return scm_from_locale_symbol (scm_instruction_table[i].name);
+}
+#undef FUNC_NAME
+
+void
+scm_init_instructions (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "instructions.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/instructions.h

@@ -0,0 +1,90 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_INSTRUCTIONS_H_
+#define _SCM_INSTRUCTIONS_H_
+
+#include <libguile.h>
+
+enum scm_opcode {
+#define VM_INSTRUCTION_TO_OPCODE 1
+#include "vm_expand.h"
+#include "vm_system.i"
+#include "vm_scheme.i"
+#include "vm_loader.i"
+#undef VM_INSTRUCTION_TO_OPCODE
+  scm_op_last
+};
+
+struct scm_instruction {
+  enum scm_opcode opcode;	/* opcode */
+  const char *name;		/* instruction name */
+  signed char len;		/* Instruction length.  This may be -1 for
+				   the loader (see the `VM_LOADER'
+				   macro).  */
+  signed char npop;		/* The number of values popped.  This may be
+				   -1 for insns like `call' which can take
+				   any number of arguments.  */
+  char npush;			/* the number of values pushed */
+};
+
+#define SCM_INSTRUCTION_P(x)		(scm_lookup_instruction (x))
+#define SCM_INSTRUCTION_OPCODE(i)	(scm_lookup_instruction (i)->opcode)
+#define SCM_INSTRUCTION_NAME(i)		(scm_lookup_instruction (i)->name)
+#define SCM_INSTRUCTION_LENGTH(i)	(scm_lookup_instruction (i)->len)
+#define SCM_INSTRUCTION_POPS(i)		(scm_lookup_instruction (i)->npop)
+#define SCM_INSTRUCTION_PUSHES(i)	(scm_lookup_instruction (i)->npush)
+#define SCM_VALIDATE_INSTRUCTION(p,x)	SCM_MAKE_VALIDATE (p, x, INSTRUCTION_P)
+
+#define SCM_INSTRUCTION(i)		(&scm_instruction_table[i])
+
+extern struct scm_instruction scm_instruction_table[];
+extern struct scm_instruction *scm_lookup_instruction (SCM name);
+
+extern void scm_init_instructions (void);
+
+#endif /* _SCM_INSTRUCTIONS_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/objcodes.c

@@ -0,0 +1,294 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "programs.h"
+#include "objcodes.h"
+
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode (size_t size)
+#define FUNC_NAME "make_objcode"
+{
+  struct scm_objcode *p = scm_gc_malloc (sizeof (struct scm_objcode),
+					 "objcode");
+  p->size = size;
+  p->base = scm_gc_malloc (size, "objcode-base");
+  p->fd   = -1;
+  SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+  int ret;
+  char *addr;
+  struct stat st;
+  struct scm_objcode *p;
+
+  ret = fstat (fd, &st);
+  if (ret < 0)
+    SCM_SYSERROR;
+
+  if (st.st_size <= strlen (OBJCODE_COOKIE))
+    scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
+		    SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
+
+  addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
+  if (addr == MAP_FAILED)
+    SCM_SYSERROR;
+
+  if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
+    SCM_SYSERROR;
+
+  p = scm_gc_malloc (sizeof (struct scm_objcode), "objcode");
+  p->size = st.st_size;
+  p->base = addr;
+  p->fd   = fd;
+  SCM_RETURN_NEWSMOB (scm_tc16_objcode, p);
+}
+#undef FUNC_NAME
+
+static scm_sizet
+objcode_free (SCM obj)
+#define FUNC_NAME "objcode_free"
+{
+  size_t size = sizeof (struct scm_objcode);
+  struct scm_objcode *p = SCM_OBJCODE_DATA (obj);
+
+  if (p->fd >= 0)
+    {
+      int rv;
+      rv = munmap (p->base, p->size);
+      if (rv < 0) SCM_SYSERROR;
+      rv = close (p->fd);
+      if (rv < 0) SCM_SYSERROR;
+    }
+  else
+    scm_gc_free (p->base, p->size, "objcode-base");
+
+  scm_gc_free (p, size, "objcode");
+
+  return 0;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Scheme interface
+ */
+
+#if 0
+SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0,
+	    (SCM car, SCM cdr),
+	    "This is a stupid test to see how cells work.  (Ludo)")
+{
+  static SCM room[512];
+  static SCM *where = &room[0];
+  SCM the_pair;
+  size_t incr;
+
+  if ((scm_t_bits)where & 6)
+    {
+      /* Align the cell pointer so that Guile considers it as a
+	 non-immediate object (see tags.h).  */
+      incr = (scm_t_bits)where & 6;
+      incr = (~incr) & 7;
+      where += incr;
+    }
+
+  printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where);
+  where[0] = car;
+  where[1] = cdr;
+
+  the_pair = PTR2SCM (where);
+  /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
+     "mark bitmap" at the end of a supposed cell segment which doesn't
+     exist.  */
+
+  return (the_pair);
+}
+#endif
+
+SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_objcode_p
+{
+  return SCM_BOOL (SCM_OBJCODE_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 3, 0, 0,
+	    (SCM bytecode, SCM nlocs, SCM nexts),
+	    "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+  size_t size;
+  ssize_t increment;
+  scm_t_array_handle handle;
+  char *base;
+  const scm_t_uint8 *c_bytecode;
+  SCM objcode;
+
+  if (scm_u8vector_p (bytecode) != SCM_BOOL_T)
+    scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+  SCM_VALIDATE_NUMBER (2, nlocs);
+  SCM_VALIDATE_NUMBER (3, nexts);
+
+  c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+  assert (increment == 1);
+
+  /* Account for the 10 byte-long header.  */
+  size += 10;
+  objcode = make_objcode (size);
+  base = SCM_OBJCODE_BASE (objcode);
+
+  memcpy (base, OBJCODE_COOKIE, 8);
+  base[8] = scm_to_uint8 (nlocs);
+  base[9] = scm_to_uint8 (nexts);
+
+  memcpy (base + 10, c_bytecode, size - 10);
+
+  scm_array_handle_release (&handle);
+
+  return objcode;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0,
+	    (SCM file),
+	    "")
+#define FUNC_NAME s_scm_load_objcode
+{
+  int fd;
+  char *c_file;
+
+  SCM_VALIDATE_STRING (1, file);
+
+  c_file = scm_to_locale_string (file);
+  fd = open (c_file, O_RDONLY);
+  free (c_file);
+  if (fd < 0) SCM_SYSERROR;
+
+  return make_objcode_by_mmap (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_u8vector, "objcode->u8vector", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_to_u8vector
+{
+  scm_t_uint8 *u8vector;
+  size_t size;
+
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  size = SCM_OBJCODE_SIZE (objcode);
+  /* FIXME:  Is `gc_malloc' ok here? */
+  u8vector = scm_gc_malloc (size, "objcode-u8vector");
+  memcpy (u8vector, SCM_OBJCODE_BASE (objcode), size);
+
+  return scm_take_u8vector (u8vector, size);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_to_program
+{
+  SCM prog;
+  size_t size;
+  char *base;
+  struct scm_program *p;
+
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  base = SCM_OBJCODE_BASE (objcode);
+  size = SCM_OBJCODE_SIZE (objcode);
+  prog = scm_c_make_program (base + 10, size - 10, objcode);
+  p = SCM_PROGRAM_DATA (prog);
+  p->nlocs = base[8];
+  p->nexts = base[9];
+  return prog;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_objcodes (void)
+{
+  scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+  scm_set_smob_free (scm_tc16_objcode, objcode_free);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "objcodes.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/objcodes.h

@@ -0,0 +1,71 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+
+struct scm_objcode {
+  size_t size;			/* objcode size */
+  char *base;			/* objcode base address */
+  int fd;			/* file descriptor when mmap'ed */
+};
+
+extern scm_t_bits scm_tc16_objcode;
+
+#define SCM_OBJCODE_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
+#define SCM_OBJCODE_DATA(x)	((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
+
+#define SCM_OBJCODE_SIZE(x)	(SCM_OBJCODE_DATA (x)->size)
+#define SCM_OBJCODE_BASE(x)	(SCM_OBJCODE_DATA (x)->base)
+#define SCM_OBJCODE_FD(x)	(SCM_OBJCODE_DATA (x)->fd)
+
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/programs.c

@@ -0,0 +1,248 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "instructions.h"
+#include "programs.h"
+#include "vm.h"
+
+
+scm_t_bits scm_tc16_program;
+
+static SCM zero_vector;
+
+SCM
+scm_c_make_program (void *addr, size_t size, SCM holder)
+#define FUNC_NAME "scm_c_make_program"
+{
+  struct scm_program *p = scm_gc_malloc (sizeof (struct scm_program),
+					 "program");
+  p->size     = size;
+  p->nargs    = 0;
+  p->nrest    = 0;
+  p->nlocs    = 0;
+  p->nexts    = 0;
+  p->meta     = SCM_BOOL_F;
+  p->objs     = zero_vector;
+  p->external = SCM_EOL;
+  p->holder   = holder;
+
+  /* If nobody holds bytecode's address, then allocate a new memory */
+  if (SCM_FALSEP (holder))
+    p->base = scm_gc_malloc (size, "program-base");
+  else
+    p->base = addr;
+
+  SCM_RETURN_NEWSMOB (scm_tc16_program, p);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_closure (SCM program, SCM external)
+{
+  SCM prog = scm_c_make_program (0, 0, program);
+  *SCM_PROGRAM_DATA (prog) = *SCM_PROGRAM_DATA (program);
+  SCM_PROGRAM_DATA (prog)->external = external;
+  return prog;
+}
+
+static SCM
+program_mark (SCM obj)
+{
+  struct scm_program *p = SCM_PROGRAM_DATA (obj);
+  scm_gc_mark (p->meta);
+  scm_gc_mark (p->objs);
+  scm_gc_mark (p->external);
+  return p->holder;
+}
+
+static scm_sizet
+program_free (SCM obj)
+{
+  struct scm_program *p = SCM_PROGRAM_DATA (obj);
+  scm_sizet size = (sizeof (struct scm_program));
+
+  if (SCM_FALSEP (p->holder))
+    scm_gc_free (p->base, p->size, "program-base");
+
+  scm_gc_free (p, size, "program");
+
+  return 0;
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+  return scm_vm_apply (scm_the_vm (), program, args);
+}
+
+
+/*
+ * Scheme interface
+ */
+
+SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_program_p
+{
+  return SCM_BOOL (SCM_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_base
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_arity
+{
+  struct scm_program *p;
+
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  p = SCM_PROGRAM_DATA (program);
+  return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
+		    SCM_I_MAKINUM (p->nrest),
+		    SCM_I_MAKINUM (p->nlocs),
+		    SCM_I_MAKINUM (p->nexts));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_meta
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return SCM_PROGRAM_DATA (program)->meta;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_objects
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return SCM_PROGRAM_DATA (program)->objs;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_external
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return SCM_PROGRAM_DATA (program)->external;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
+	    (SCM program, SCM external),
+	    "Modify the list of closure variables of @var{program} (for "
+	    "debugging purposes).")
+#define FUNC_NAME s_scm_program_external_set_x
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  SCM_VALIDATE_LIST (2, external);
+  SCM_PROGRAM_DATA (program)->external = external;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
+	    (SCM program),
+	    "Return a u8vector containing @var{program}'s bytecode.")
+#define FUNC_NAME s_scm_program_bytecode
+{
+  size_t size;
+  scm_t_uint8 *c_bytecode;
+
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  size = SCM_PROGRAM_DATA (program)->size;
+  c_bytecode = malloc (size);
+  if (!c_bytecode)
+    return SCM_BOOL_F;
+
+  memcpy (c_bytecode, SCM_PROGRAM_DATA (program)->base, size);
+
+  return scm_take_u8vector (c_bytecode, size);
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_init_programs (void)
+{
+  zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
+
+  scm_tc16_program = scm_make_smob_type ("program", 0);
+  scm_set_smob_mark (scm_tc16_program, program_mark);
+  scm_set_smob_free (scm_tc16_program, program_free);
+  scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+
+#ifndef SCM_MAGIC_SNARFER
+#include "programs.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/programs.h

@@ -0,0 +1,83 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_PROGRAMS_H_
+#define _SCM_PROGRAMS_H_
+
+#include <libguile.h>
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+struct scm_program {
+  size_t size;			/* the size of the program  */
+  unsigned char nargs;		/* the number of arguments */
+  unsigned char nrest;		/* the number of rest argument (0 or 1) */
+  unsigned char nlocs;		/* the number of local variables */
+  unsigned char nexts;		/* the number of external variables */
+  scm_byte_t *base;		/* program base address */
+  SCM meta;			/* meta data */
+  SCM objs;			/* constant objects */
+  SCM external;			/* external environment */
+  SCM holder;			/* the owner of bytecode */
+};
+
+extern scm_t_bits scm_tc16_program;
+
+#define SCM_PROGRAM_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_DATA(x)	((struct scm_program *) SCM_SMOB_DATA (x))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+
+extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
+extern SCM scm_c_make_closure (SCM program, SCM external);
+
+extern void scm_init_programs (void);
+
+#endif /* _SCM_PROGRAMS_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm.c

@@ -0,0 +1,592 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "envs.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
+#include "vm.h"
+
+/* I sometimes use this for debugging. */
+#define vm_puts(OBJ)				\
+{						\
+  scm_display (OBJ, scm_current_error_port ()); \
+  scm_newline (scm_current_error_port ());      \
+}
+
+
+/*
+ * VM Continuation
+ */
+
+scm_t_bits scm_tc16_vm_cont;
+
+
+#define SCM_VM_CONT_P(OBJ)	SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
+#define SCM_VM_CONT_VP(CONT)	((struct scm_vm *) SCM_CELL_WORD_1 (CONT))
+
+static SCM
+capture_vm_cont (struct scm_vm *vp)
+{
+  struct scm_vm *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+  p->stack_size = vp->stack_limit - vp->sp;
+  p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+				 "capture_vm_cont");
+  p->stack_limit = p->stack_base + p->stack_size - 2;
+  p->ip = vp->ip;
+  p->sp = (SCM *) (vp->stack_limit - vp->sp);
+  p->fp = (SCM *) (vp->stack_limit - vp->fp);
+  memcpy (p->stack_base, vp->sp + 1, vp->stack_size * sizeof (SCM));
+  SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+}
+
+static void
+reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+{
+  struct scm_vm *p = SCM_VM_CONT_VP (cont);
+  if (vp->stack_size < p->stack_size)
+    {
+      /* puts ("FIXME: Need to expand"); */
+      abort ();
+    }
+  vp->ip = p->ip;
+  vp->sp = vp->stack_limit - (int) p->sp;
+  vp->fp = vp->stack_limit - (int) p->fp;
+  memcpy (vp->sp + 1, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+  SCM *p;
+  struct scm_vm *vp = SCM_VM_CONT_VP (obj);
+  for (p = vp->stack_base; p <= vp->stack_limit; p++)
+    if (SCM_NIMP (*p))
+      scm_gc_mark (*p);
+  return SCM_BOOL_F;
+}
+
+static scm_sizet
+vm_cont_free (SCM obj)
+{
+  struct scm_vm *p = SCM_VM_CONT_VP (obj);
+
+  scm_gc_free (p->stack_base, p->stack_size * sizeof (SCM), "stack-base");
+  scm_gc_free (p, sizeof (struct scm_vm), "vm");
+
+  return 0;
+}
+
+
+/*
+ * VM Internal functions
+ */
+
+SCM_SYMBOL (sym_vm_run, "vm-run");
+SCM_SYMBOL (sym_vm_error, "vm-error");
+
+static scm_byte_t *
+vm_fetch_length (scm_byte_t *ip, size_t *lenp)
+{
+  /* NOTE: format defined in system/vm/conv.scm */
+  *lenp = *ip++;
+  if (*lenp < 254)
+    return ip;
+  else if (*lenp == 254)
+    {
+      int b1 = *ip++;
+      int b2 = *ip++;
+      *lenp = (b1 << 8) + b2;
+    }
+  else
+    {
+      int b1 = *ip++;
+      int b2 = *ip++;
+      int b3 = *ip++;
+      int b4 = *ip++;
+      *lenp = (b1 << 24) + (b2 << 16) + (b3 << 8) + b4;
+    }
+  return ip;
+}
+
+static SCM
+vm_heapify_frames_1 (struct scm_vm *vp, SCM *fp, SCM *sp, SCM **destp)
+{
+  SCM frame;
+  SCM *dl = SCM_FRAME_DYNAMIC_LINK (fp);
+  SCM *src = SCM_FRAME_UPPER_ADDRESS (fp);
+  SCM *dest = SCM_FRAME_LOWER_ADDRESS (fp);
+
+  if (!dl)
+    {
+      /* The top frame */
+      frame = scm_c_make_heap_frame (fp);
+      fp = SCM_HEAP_FRAME_POINTER (frame);
+      SCM_FRAME_HEAP_LINK (fp) = SCM_BOOL_T;
+    }
+  else
+    {
+      /* Child frames */
+      SCM link = SCM_FRAME_HEAP_LINK (dl);
+      if (!SCM_FALSEP (link))
+	link = SCM_FRAME_LOWER_ADDRESS (dl)[-1]; /* self link */
+      else
+	link = vm_heapify_frames_1 (vp, dl, dest - 1, &dest);
+      frame = scm_c_make_heap_frame (fp);
+      fp = SCM_HEAP_FRAME_POINTER (frame);
+      SCM_FRAME_HEAP_LINK (fp)    = link;
+      SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_HEAP_FRAME_POINTER (link));
+    }
+
+  /* Move stack data */
+  for (; src <= sp; src++, dest++)
+    *dest = *src;
+  *destp = dest;
+
+  return frame;
+}
+
+static SCM
+vm_heapify_frames (SCM vm)
+{
+  struct scm_vm *vp = SCM_VM_DATA (vm);
+  if (SCM_FALSEP (SCM_FRAME_HEAP_LINK (vp->fp)))
+    {
+      SCM *dest;
+      vp->this_frame = vm_heapify_frames_1 (vp, vp->fp, vp->sp, &dest);
+      vp->fp = SCM_HEAP_FRAME_POINTER (vp->this_frame);
+      vp->sp = dest - 1;
+    }
+  return vp->this_frame;
+}
+
+
+/*
+ * VM
+ */
+
+#define VM_DEFAULT_STACK_SIZE	(16 * 1024)
+
+#define VM_REGULAR_ENGINE	0
+#define VM_DEBUG_ENGINE		1
+
+#if 0
+#define VM_NAME   vm_regular_engine
+#define VM_ENGINE VM_REGULAR_ENGINE
+#include "vm_engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+#endif
+
+#define VM_NAME	  vm_debug_engine
+#define VM_ENGINE VM_DEBUG_ENGINE
+#include "vm_engine.c"
+#undef VM_NAME
+#undef VM_ENGINE
+
+scm_t_bits scm_tc16_vm;
+
+static SCM the_vm;
+
+static SCM
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+  int i;
+  struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
+
+  vp->stack_size  = VM_DEFAULT_STACK_SIZE;
+  vp->stack_base  = scm_gc_malloc (vp->stack_size * sizeof (SCM),
+				   "stack-base");
+  vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+  vp->ip    	  = NULL;
+  vp->sp    	  = vp->stack_base - 1;
+  vp->fp    	  = NULL;
+  vp->time        = 0;
+  vp->clock       = 0;
+  vp->options     = SCM_EOL;
+  vp->this_frame  = SCM_BOOL_F;
+  vp->last_frame  = SCM_BOOL_F;
+  for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+    vp->hooks[i] = SCM_BOOL_F;
+  SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+}
+#undef FUNC_NAME
+
+static SCM
+vm_mark (SCM obj)
+{
+  int i;
+  struct scm_vm *vp = SCM_VM_DATA (obj);
+
+  /* mark the stack conservatively */
+  scm_mark_locations ((SCM_STACKITEM *) vp->stack_base,
+		      sizeof (SCM) * (vp->sp - vp->stack_base + 1));
+
+  /* mark other objects  */
+  for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+    scm_gc_mark (vp->hooks[i]);
+  scm_gc_mark (vp->this_frame);
+  scm_gc_mark (vp->last_frame);
+  return vp->options;
+}
+
+static scm_sizet
+vm_free (SCM obj)
+{
+  struct scm_vm *vp = SCM_VM_DATA (obj);
+
+  scm_gc_free (vp->stack_base, vp->stack_size * sizeof (SCM),
+	       "stack-base");
+  scm_gc_free (vp, sizeof (struct scm_vm), "vm");
+
+  return 0;
+}
+
+SCM_SYMBOL (sym_debug, "debug");
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return vm_run (vm, program, args);
+}
+#undef FUNC_NAME
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_vm_version
+{
+  return scm_from_locale_string (VERSION);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+	    (),
+	    "")
+#define FUNC_NAME s_scm_the_vm
+{
+  return the_vm;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_vm_p
+{
+  return SCM_BOOL (SCM_VM_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_make_vm,
+{
+  return make_vm ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_ip
+{
+  SCM_VALIDATE_VM (1, vm);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_sp
+{
+  SCM_VALIDATE_VM (1, vm);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_fp
+{
+  SCM_VALIDATE_VM (1, vm);
+  return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp);
+}
+#undef FUNC_NAME
+
+#define VM_DEFINE_HOOK(n)				\
+{							\
+  struct scm_vm *vp;					\
+  SCM_VALIDATE_VM (1, vm);				\
+  vp = SCM_VM_DATA (vm);				\
+  if (SCM_FALSEP (vp->hooks[n]))			\
+    vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1));	\
+  return vp->hooks[n];					\
+}
+
+SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_boot_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_halt_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_HALT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_next_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_break_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_enter_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_apply_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_exit_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_return_hook
+{
+  VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0,
+	    (SCM vm, SCM key),
+	    "")
+#define FUNC_NAME s_scm_vm_option
+{
+  SCM_VALIDATE_VM (1, vm);
+  return scm_assq_ref (SCM_VM_DATA (vm)->options, key);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0,
+	    (SCM vm, SCM key, SCM val),
+	    "")
+#define FUNC_NAME s_scm_set_vm_option_x
+{
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VM_DATA (vm)->options
+    = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val);
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_stats
+{
+  SCM stats;
+
+  SCM_VALIDATE_VM (1, vm);
+
+  stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED);
+  scm_vector_set_x (stats, SCM_I_MAKINUM (0),
+		    scm_from_ulong (SCM_VM_DATA (vm)->time));
+  scm_vector_set_x (stats, SCM_I_MAKINUM (1),
+		    scm_from_ulong (SCM_VM_DATA (vm)->clock));
+
+  return stats;
+}
+#undef FUNC_NAME
+
+#define VM_CHECK_RUNNING(vm) 				\
+  if (!SCM_VM_DATA (vm)->ip)				\
+    SCM_MISC_ERROR ("Not running", SCM_LIST1 (vm))
+
+SCM_DEFINE (scm_vm_this_frame, "vm-this-frame", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_this_frame
+{
+  SCM_VALIDATE_VM (1, vm);
+  return SCM_VM_DATA (vm)->this_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_last_frame, "vm-last-frame", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_last_frame
+{
+  SCM_VALIDATE_VM (1, vm);
+  return SCM_VM_DATA (vm)->last_frame;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_code, "vm-fetch-code", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_fetch_code
+{
+  int i;
+  SCM list;
+  scm_byte_t *ip;
+  struct scm_instruction *p;
+
+  SCM_VALIDATE_VM (1, vm);
+  VM_CHECK_RUNNING (vm);
+
+  ip = SCM_VM_DATA (vm)->ip;
+  p = SCM_INSTRUCTION (*ip);
+
+  list = SCM_LIST1 (scm_str2symbol (p->name));
+  for (i = 1; i <= p->len; i++)
+    list = scm_cons (SCM_I_MAKINUM (ip[i]), list);
+  return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_fetch_stack
+{
+  SCM *sp;
+  SCM ls = SCM_EOL;
+  struct scm_vm *vp;
+
+  SCM_VALIDATE_VM (1, vm);
+  VM_CHECK_RUNNING (vm);
+
+  vp = SCM_VM_DATA (vm);
+  for (sp = vp->stack_base; sp <= vp->sp; sp++)
+    ls = scm_cons (*sp, ls);
+  return ls;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Initialize
+ */
+
+void
+scm_init_vm (void)
+{
+  scm_init_frames ();
+  scm_init_instructions ();
+  scm_init_objcodes ();
+  scm_init_programs ();
+
+  scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
+  scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
+  scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
+
+  scm_tc16_vm = scm_make_smob_type ("vm", 0);
+  scm_set_smob_mark (scm_tc16_vm, vm_mark);
+  scm_set_smob_free (scm_tc16_vm, vm_free);
+  scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
+
+  the_vm = scm_permanent_object (make_vm ());
+
+#ifndef SCM_MAGIC_SNARFER
+#include "vm.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm.h

@@ -0,0 +1,90 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_VM_H_
+#define _SCM_VM_H_
+
+#include <libguile.h>
+
+#define SCM_VM_BOOT_HOOK	0
+#define SCM_VM_HALT_HOOK	1
+#define SCM_VM_NEXT_HOOK	2
+#define SCM_VM_BREAK_HOOK	3
+#define SCM_VM_ENTER_HOOK	4
+#define SCM_VM_APPLY_HOOK	5
+#define SCM_VM_EXIT_HOOK	6
+#define SCM_VM_RETURN_HOOK	7
+#define SCM_VM_NUM_HOOKS	8
+
+struct scm_vm {
+  scm_byte_t *ip;		/* instruction pointer */
+  SCM *sp;			/* stack pointer */
+  SCM *fp;			/* frame pointer */
+  size_t stack_size;		/* stack size */
+  SCM *stack_base;		/* stack base address */
+  SCM *stack_limit;		/* stack limit address */
+  SCM this_frame;		/* currrent frame */
+  SCM last_frame;		/* last frame */
+  SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
+  SCM options;			/* options */
+  unsigned long time;		/* time spent */
+  unsigned long clock;		/* bogos clock */
+};
+
+#define SCM_VM_P(x)		SCM_SMOB_PREDICATE (scm_tc16_vm, x)
+#define SCM_VM_DATA(vm)		((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VALIDATE_VM(pos,x)	SCM_MAKE_VALIDATE (pos, x, VM_P)
+
+extern SCM scm_the_vm ();
+extern SCM scm_make_vm (void);
+extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+extern SCM scm_vm_option_ref (SCM vm, SCM key);
+extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+extern void scm_init_vm (void);
+
+#endif /* _SCM_VM_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_engine.c

@@ -0,0 +1,197 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm.c twice */
+
+#include "vm_engine.h"
+
+
+static SCM
+vm_run (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "vm-engine"
+{
+  /* VM registers */
+  register scm_byte_t *ip IP_REG;	/* instruction pointer */
+  register SCM *sp SP_REG;		/* stack pointer */
+  register SCM *fp FP_REG;		/* frame pointer */
+
+  /* Cache variables */
+  struct scm_vm *vp = SCM_VM_DATA (vm);	/* VM data pointer */
+  struct scm_program *bp = NULL;	/* program base pointer */
+  SCM external = SCM_EOL;		/* external environment */
+  SCM *objects = NULL;			/* constant objects */
+  scm_t_array_handle objects_handle;    /* handle of the OBJECTS array */
+  size_t object_count;                  /* length of OBJECTS */
+  SCM *stack_base = vp->stack_base;	/* stack base address */
+  SCM *stack_limit = vp->stack_limit;	/* stack limit address */
+
+  /* Internal variables */
+  int nargs = 0;
+  long start_time = scm_c_get_internal_run_time ();
+  // SCM dynwinds = SCM_EOL;
+  SCM err_msg;
+  SCM err_args;
+#if VM_USE_HOOKS
+  SCM hook_args = SCM_LIST1 (vm);
+#endif
+
+#ifdef HAVE_LABELS_AS_VALUES
+  /* Jump table */
+  static void *jump_table[] = {
+#define VM_INSTRUCTION_TO_LABEL 1
+#include "vm_expand.h"
+#include "vm_system.i"
+#include "vm_scheme.i"
+#include "vm_loader.i"
+#undef VM_INSTRUCTION_TO_LABEL
+  };
+#endif
+
+  /* Initialization */
+  {
+    SCM prog = program;
+
+    /* Boot program */
+    scm_byte_t bytes[3] = {scm_op_call, 0, scm_op_halt};
+    bytes[1] = scm_ilength (args); /* FIXME: argument overflow */
+    program = scm_c_make_program (bytes, 3, SCM_BOOL_T);
+
+    /* Initial frame */
+    CACHE_REGISTER ();
+    CACHE_PROGRAM ();
+    PUSH (program);
+    NEW_FRAME ();
+
+    /* Initial arguments */
+    PUSH (prog);
+    for (; !SCM_NULLP (args); args = SCM_CDR (args))
+      PUSH (SCM_CAR (args));
+  }
+
+  /* Let's go! */
+  BOOT_HOOK ();
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start:
+  switch (*ip++) {
+#endif
+
+#include "vm_expand.h"
+#include "vm_system.c"
+#include "vm_scheme.c"
+#include "vm_loader.c"
+
+#ifndef HAVE_LABELS_AS_VALUES
+  }
+#endif
+
+  /* Errors */
+  {
+  vm_error_unbound:
+    err_msg  = scm_from_locale_string ("VM: Unbound variable: ~A");
+    goto vm_error;
+
+  vm_error_wrong_type_arg:
+    err_msg  = scm_from_locale_string ("VM: Wrong type argument");
+    err_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_wrong_num_args:
+    err_msg  = scm_from_locale_string ("VM: Wrong number of arguments");
+    err_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_wrong_type_apply:
+    err_msg  = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+				       "[IP offset: ~a]");
+    err_args = SCM_LIST2 (program,
+			  SCM_I_MAKINUM (ip - bp->base));
+    goto vm_error;
+
+  vm_error_stack_overflow:
+    err_msg  = scm_from_locale_string ("VM: Stack overflow");
+    err_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_stack_underflow:
+    err_msg  = scm_from_locale_string ("VM: Stack underflow");
+    err_args = SCM_EOL;
+    goto vm_error;
+
+#if VM_CHECK_IP
+  vm_error_invalid_address:
+    err_msg  = scm_from_locale_string ("VM: Invalid program address");
+    err_args = SCM_EOL;
+    goto vm_error;
+#endif
+
+#if VM_CHECK_EXTERNAL
+  vm_error_external:
+    err_msg  = scm_from_locale_string ("VM: Invalid external access");
+    err_args = SCM_EOL;
+    goto vm_error;
+#endif
+
+#if VM_CHECK_OBJECT
+  vm_error_object:
+    err_msg = scm_from_locale_string ("VM: Invalid object table access");
+    err_args = SCM_EOL;
+    goto vm_error;
+#endif
+
+  vm_error:
+    SYNC_ALL ();
+    if (objects)
+      scm_array_handle_release (&objects_handle);
+
+    vp->last_frame = vm_heapify_frames (vm);
+    scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, err_args), 1);
+  }
+
+  abort (); /* never reached */
+}
+#undef FUNC_NAME
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_engine.h

@@ -0,0 +1,466 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm_engine.c */
+
+/*
+ * Options
+ */
+
+#define VM_USE_HOOKS		1	/* Various hooks */
+#define VM_USE_CLOCK		1	/* Bogoclock */
+#define VM_CHECK_EXTERNAL	1	/* Check external link */
+#define VM_CHECK_OBJECT         1       /* Check object table */
+
+
+/*
+ * Registers
+ */
+
+/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ]
+
+   Some compilers underestimate the use of the local variables representing
+   the abstract machine registers, and don't put them in hardware registers,
+   which slows down the interpreter considerably.
+   For GCC, I have hand-assigned hardware registers for several architectures.
+*/
+
+#ifdef __GNUC__
+#ifdef __mips__
+#define IP_REG asm("$16")
+#define SP_REG asm("$17")
+#define FP_REG asm("$18")
+#endif
+#ifdef __sparc__
+#define IP_REG asm("%l0")
+#define SP_REG asm("%l1")
+#define FP_REG asm("%l2")
+#endif
+#ifdef __alpha__
+#ifdef __CRAY__
+#define IP_REG asm("r9")
+#define SP_REG asm("r10")
+#define FP_REG asm("r11")
+#else
+#define IP_REG asm("$9")
+#define SP_REG asm("$10")
+#define FP_REG asm("$11")
+#endif
+#endif
+#ifdef __i386__
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
+#endif
+
+
+/*
+ * Cache/Sync
+ */
+
+#define CACHE_REGISTER()			\
+{						\
+  ip = vp->ip;					\
+  sp = vp->sp;					\
+  fp = vp->fp;					\
+}
+
+#define SYNC_REGISTER()				\
+{						\
+  vp->ip = ip;					\
+  vp->sp = sp;					\
+  vp->fp = fp;					\
+}
+
+/* Get a local copy of the program's "object table" (i.e. the vector of
+   external bindings that are referenced by the program), initialized by
+   `load-program'.  */
+/* XXX:  We could instead use the "simple vector macros", thus not having to
+   call `scm_vector_writable_elements ()' and the likes.  */
+#define CACHE_PROGRAM()							\
+{									\
+  ssize_t _vincr;							\
+									\
+  if (bp != SCM_PROGRAM_DATA (program)) {                               \
+    bp = SCM_PROGRAM_DATA (program);					\
+    /* Was: objects = SCM_VELTS (bp->objs); */				\
+									\
+    if (objects)                                                        \
+      scm_array_handle_release (&objects_handle);                       \
+									\
+    objects = scm_vector_writable_elements (bp->objs, &objects_handle,	\
+                                            &object_count, &_vincr);	\
+  }                                                                     \
+}
+
+#define SYNC_BEFORE_GC()			\
+{						\
+  SYNC_REGISTER ();				\
+}
+
+#define SYNC_ALL()				\
+{						\
+  SYNC_REGISTER ();				\
+}
+
+
+/*
+ * Error check
+ */
+
+#undef CHECK_EXTERNAL
+#if VM_CHECK_EXTERNAL
+#define CHECK_EXTERNAL(e) \
+  do { if (!SCM_CONSP (e)) goto vm_error_external; } while (0)
+#else
+#define CHECK_EXTERNAL(e)
+#endif
+
+/* Accesses to a program's object table.  */
+#if VM_CHECK_OBJECT
+#define CHECK_OBJECT(_num) \
+  do { if ((_num) >= object_count) goto vm_error_object; } while (0)
+#else
+#define CHECK_OBJECT(_num)
+#endif
+
+
+/*
+ * Hooks
+ */
+
+#undef RUN_HOOK
+#if VM_USE_HOOKS
+#define RUN_HOOK(h)				\
+{						\
+  if (!SCM_FALSEP (vp->hooks[h]))		\
+    {						\
+      SYNC_REGISTER ();				\
+      vm_heapify_frames (vm);			\
+      scm_c_run_hook (vp->hooks[h], hook_args);	\
+      CACHE_REGISTER ();			\
+    }						\
+}
+#else
+#define RUN_HOOK(h)
+#endif
+
+#define BOOT_HOOK()	RUN_HOOK (SCM_VM_BOOT_HOOK)
+#define HALT_HOOK()	RUN_HOOK (SCM_VM_HALT_HOOK)
+#define NEXT_HOOK()	RUN_HOOK (SCM_VM_NEXT_HOOK)
+#define BREAK_HOOK()	RUN_HOOK (SCM_VM_BREAK_HOOK)
+#define ENTER_HOOK()	RUN_HOOK (SCM_VM_ENTER_HOOK)
+#define APPLY_HOOK()	RUN_HOOK (SCM_VM_APPLY_HOOK)
+#define EXIT_HOOK()	RUN_HOOK (SCM_VM_EXIT_HOOK)
+#define RETURN_HOOK()	RUN_HOOK (SCM_VM_RETURN_HOOK)
+
+
+/*
+ * Stack operation
+ */
+
+#define CHECK_OVERFLOW()			\
+  if (sp > stack_limit)				\
+    goto vm_error_stack_overflow
+
+#define CHECK_UNDERFLOW()			\
+  if (sp < stack_base)				\
+    goto vm_error_stack_underflow
+
+#define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
+#define DROP()	do { CHECK_UNDERFLOW (); sp--; } while (0)
+#define DROPN(_n)	do { CHECK_UNDERFLOW (); sp -= (_n); } while (0)
+#define POP(x)	do { x = *sp; DROP (); } while (0)
+
+/* A fast CONS.  This has to be fast since its used, for instance, by
+   POP_LIST when fetching a function's argument list.  Note: `scm_cell' is an
+   inlined function in Guile 1.7.  Unfortunately, it calls
+   `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the
+   heap.  XXX  */
+#define CONS(x,y,z)					\
+{							\
+  SYNC_BEFORE_GC ();					\
+  x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z));	\
+}
+
+/* Pop the N objects on top of the stack and push a list that contains
+   them.  */
+#define POP_LIST(n)				\
+do						\
+{						\
+  int i;					\
+  SCM l = SCM_EOL;				\
+  sp -= n;					\
+  for (i = n; i; i--)				\
+    CONS (l, sp[i], l);				\
+  PUSH (l);					\
+} while (0)
+
+
+/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
+   allocate cells on the stack.  This is a significant improvement for
+   programs which call a lot of procedures, since the procedure call
+   mechanism uses POP_LIST which normally uses `scm_cons'.
+
+   What it does is that it creates a list whose cells are allocated on the
+   VM's stack instead of being allocated on the heap via `scm_cell'.  This is
+   much faster.  However, if the callee does something like:
+
+     (lambda (. args)
+       (set! the-args args))
+
+   then terrible things may happen since the list of arguments may be
+   overwritten later on.  */
+
+
+/* Awful hack that aligns PTR so that it can be considered as a non-immediate
+   value by Guile.  */
+#define ALIGN_AS_NON_IMMEDIATE(_ptr)		\
+{						\
+  if ((scm_t_bits)(_ptr) & 6)			\
+    {						\
+      size_t _incr;				\
+						\
+      _incr = (scm_t_bits)(_ptr) & 6;		\
+      _incr = (~_incr) & 7;			\
+      (_ptr) += _incr;				\
+    }						\
+}
+
+#define POP_LIST_ON_STACK(n)			\
+do						\
+{						\
+  int i;					\
+  if (n == 0)					\
+    {						\
+      sp -= n;					\
+      PUSH (SCM_EOL);				\
+    }						\
+  else						\
+    {						\
+      SCM *list_head, *list;			\
+						\
+      list_head = sp + 1;			\
+      ALIGN_AS_NON_IMMEDIATE (list_head);	\
+      list = list_head;				\
+						\
+      sp -= n;					\
+      for (i = 1; i <= n; i++)			\
+	{					\
+	  /* The cell's car and cdr.  */	\
+	  *(list) = sp[i];			\
+	  *(list + 1) = PTR2SCM (list + 2);	\
+	  list += 2;				\
+	}					\
+						\
+      /* The last pair's cdr is '().  */	\
+      list--;					\
+      *list = SCM_EOL;				\
+      /* Push the SCM object that points */	\
+      /* to the first cell.  */			\
+      PUSH (PTR2SCM (list_head));		\
+    }						\
+}						\
+while (0)
+
+/* end of the experiment */
+
+
+#define POP_LIST_MARK()				\
+do {						\
+  SCM o;					\
+  SCM l = SCM_EOL;				\
+  POP (o);					\
+  while (!SCM_UNBNDP (o))			\
+    {						\
+      CONS (l, o, l);				\
+      POP (o);					\
+    }						\
+  PUSH (l);					\
+} while (0)
+
+
+/*
+ * Instruction operation
+ */
+
+#define FETCH()		(*ip++)
+#define FETCH_LENGTH(len) do { ip = vm_fetch_length (ip, &len); } while (0)
+
+#undef CLOCK
+#if VM_USE_CLOCK
+#define CLOCK(n)	vp->clock += n
+#else
+#define CLOCK(n)
+#endif
+
+#undef NEXT_JUMP
+#ifdef HAVE_LABELS_AS_VALUES
+#define NEXT_JUMP()		goto *jump_table[FETCH ()]
+#else
+#define NEXT_JUMP()		goto vm_start
+#endif
+
+#define NEXT					\
+{						\
+  CLOCK (1);					\
+  NEXT_HOOK ();					\
+  NEXT_JUMP ();					\
+}
+
+
+/*
+ * Stack frame
+ */
+
+#define INIT_ARGS()				\
+{						\
+  if (bp->nrest)				\
+    {						\
+      int n = nargs - (bp->nargs - 1);		\
+      if (n < 0)				\
+	goto vm_error_wrong_num_args;		\
+      POP_LIST (n);				\
+    }						\
+  else						\
+    {						\
+      if (nargs != bp->nargs)			\
+	goto vm_error_wrong_num_args;		\
+    }						\
+}
+
+/* See frames.h for the layout of stack frames */
+
+#define NEW_FRAME()				\
+{						\
+  int i;					\
+  SCM ra = SCM_PACK (ip);			\
+  SCM dl = SCM_PACK (fp);			\
+  SCM *p = sp + 1;				\
+  SCM *q = p + bp->nlocs;			\
+						\
+  /* New pointers */				\
+  ip = bp->base;				\
+  fp = p - bp->nargs;				\
+  sp = q + 3;					\
+  CHECK_OVERFLOW ();				\
+						\
+  /* Init local variables */			\
+  for (; p < q; p++)				\
+    *p = SCM_UNDEFINED;				\
+						\
+  /* Create external variables */		\
+  external = bp->external;			\
+  for (i = 0; i < bp->nexts; i++)		\
+    CONS (external, SCM_UNDEFINED, external);	\
+						\
+  /* Set frame data */				\
+  p[3] = ra;					\
+  p[2] = dl;					\
+  p[1] = SCM_BOOL_F;				\
+  p[0] = external;				\
+}
+
+#define FREE_FRAME()				\
+{						\
+  SCM *last_sp = sp;				\
+  SCM *last_fp = fp;				\
+  SCM *p = fp + bp->nargs + bp->nlocs;		\
+						\
+  /* Restore pointers */			\
+  ip = SCM_FRAME_BYTE_CAST (p[3]);		\
+  fp = SCM_FRAME_STACK_CAST (p[2]);		\
+						\
+  if (!SCM_FALSEP (p[1]))			\
+    {						\
+      /* Unlink the heap stack */		\
+      vp->this_frame = p[1];			\
+    }						\
+  else						\
+    {						\
+      /* Move stack items */			\
+      p += 4;					\
+      sp = SCM_FRAME_LOWER_ADDRESS (last_fp);	\
+      while (p <= last_sp)			\
+	*sp++ = *p++;				\
+      sp--;					\
+    }						\
+}
+
+#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
+
+
+/*
+ * Function support
+ */
+
+#define ARGS1(a1)	SCM a1 = sp[0];
+#define ARGS2(a1,a2)	SCM a1 = sp[-1], a2 = sp[0]; sp--;
+#define ARGS3(a1,a2,a3)	SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2;
+
+#define RETURN(x)	do { *sp = x; NEXT; } while (0)
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_expand.h

@@ -0,0 +1,103 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef VM_LABEL
+#define VM_LABEL(tag) l_##tag
+#define VM_OPCODE(tag) scm_op_##tag
+
+#ifdef HAVE_LABELS_AS_VALUES
+#define VM_TAG(tag) VM_LABEL(tag):
+#define VM_ADDR(tag) &&VM_LABEL(tag)
+#else /* not HAVE_LABELS_AS_VALUES */
+#define VM_TAG(tag) case VM_OPCODE(tag):
+#define VM_ADDR(tag) NULL
+#endif /* not HAVE_LABELS_AS_VALUES */
+#endif /* VM_LABEL */
+
+#undef VM_DEFINE_INSTRUCTION
+#undef VM_DEFINE_FUNCTION
+#undef VM_DEFINE_LOADER
+#ifdef VM_INSTRUCTION_TO_TABLE
+/*
+ * These will go to scm_instruction_table in vm.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush) \
+  {VM_OPCODE (tag), name, len, npop, npush},
+#define VM_DEFINE_FUNCTION(tag,name,nargs) \
+  {VM_OPCODE (tag), name, 0, nargs, 1},
+#define VM_DEFINE_LOADER(tag,name) \
+  {VM_OPCODE (tag), name, -1, 0, 1},
+
+#else
+#ifdef VM_INSTRUCTION_TO_LABEL
+/*
+ * These will go to jump_table in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_ADDR (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_ADDR (tag),
+#define VM_DEFINE_LOADER(tag,name)			VM_ADDR (tag),
+
+#else
+#ifdef VM_INSTRUCTION_TO_OPCODE
+/*
+ * These will go to scm_opcode in vm.h
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_OPCODE (tag),
+#define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_OPCODE (tag),
+#define VM_DEFINE_LOADER(tag,name)			VM_OPCODE (tag),
+
+#else /* Otherwise */
+/*
+ * These are directly included in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(tag,name,len,npop,npush)	VM_TAG (tag)
+#define VM_DEFINE_FUNCTION(tag,name,nargs)		VM_TAG (tag)
+#define VM_DEFINE_LOADER(tag,name)			VM_TAG (tag)
+
+#endif /* VM_INSTRUCTION_TO_OPCODE */
+#endif /* VM_INSTRUCTION_TO_LABEL */
+#endif /* VM_INSTRUCTION_TO_TABLE */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_loader.c

@@ -0,0 +1,227 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm_engine.c */
+
+VM_DEFINE_LOADER (load_integer, "load-integer")
+{
+  size_t len;
+
+  FETCH_LENGTH (len);
+  if (len <= 4)
+    {
+      long val = 0;
+      while (len-- > 0)
+	val = (val << 8) + FETCH ();
+      PUSH (scm_from_ulong (val));
+      NEXT;
+    }
+  else
+    SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (load_number, "load-number")
+{
+  size_t len;
+
+  FETCH_LENGTH (len);
+  PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
+			      SCM_UNDEFINED /* radix = 10 */));
+  /* Was: scm_istring2number (ip, len, 10)); */
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (load_string, "load-string")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  PUSH (scm_from_locale_stringn ((char *)ip, len));
+  /* Was: scm_makfromstr (ip, len, 0) */
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (load_symbol, "load-symbol")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  PUSH (scm_from_locale_symboln ((char *)ip, len));
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (load_keyword, "load-keyword")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  PUSH (scm_from_locale_keywordn ((char *)ip, len));
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (load_module, "load-module")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  PUSH (scm_c_lookup_env (scm_from_locale_symboln ((char *)ip, len)));
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (load_program, "load-program")
+{
+  size_t len;
+  SCM prog, x;
+  struct scm_program *p;
+
+  FETCH_LENGTH (len);
+  prog = scm_c_make_program (ip, len, program);
+  p = SCM_PROGRAM_DATA (prog);
+  ip += len;
+
+  POP (x);
+
+  /* init meta data */
+  if (SCM_CONSP (x))
+    {
+      p->meta = x;
+      POP (x);
+    }
+
+  /* init object table */
+  if (scm_is_vector (x))
+    {
+#if 0
+      if (scm_is_simple_vector (x))
+	printf ("is_simple_vector!\n");
+      else
+	printf ("NOT is_simple_vector\n");
+#endif
+      p->objs = x;
+      POP (x);
+    }
+
+  /* init parameters */
+  /* NOTE: format defined in system/vm/assemble.scm */
+  if (SCM_I_INUMP (x))
+    {
+      int i = SCM_I_INUM (x);
+      if (-128 <= i && i <= 127)
+	{
+	  /* 8-bit representation */
+	  p->nargs = (i >> 6) & 0x03;	/* 7-6 bits */
+	  p->nrest = (i >> 5) & 0x01;	/*   5 bit  */
+	  p->nlocs = (i >> 2) & 0x07;	/* 4-2 bits */
+	  p->nexts = i & 0x03;		/* 1-0 bits */
+	}
+      else
+	{
+	  /* 16-bit representation */
+	  p->nargs = (i >> 12) & 0x07;	/* 15-12 bits */
+	  p->nrest = (i >> 11) & 0x01;	/*    11 bit  */
+	  p->nlocs = (i >> 4)  & 0x7f;	/* 10-04 bits */
+	  p->nexts = i & 0x0f;		/* 03-00 bits */
+	}
+    }
+  else
+    {
+      /* Other cases */
+      /* x is #f, and already popped off */
+      p->nargs = SCM_I_INUM (sp[-3]);
+      p->nrest = SCM_I_INUM (sp[-2]);
+      p->nlocs = SCM_I_INUM (sp[-1]);
+      p->nexts = SCM_I_INUM (sp[0]);
+      sp -= 4;
+    }
+
+  PUSH (prog);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_now, "link-now", 0, 1, 1)
+{
+  SCM sym;
+  POP (sym);
+  PUSH (scm_lookup (sym)); /* might longjmp */
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (link_later, "link-later", 0, 2, 1)
+{
+  SCM modname, sym;
+  POP (sym);
+  POP (modname);
+  PUSH (scm_cons (modname, sym));
+  NEXT;
+}
+
+VM_DEFINE_LOADER (define, "define")
+{
+  SCM sym;
+  size_t len;
+
+  FETCH_LENGTH (len);
+  sym = scm_from_locale_symboln ((char *)ip, len);
+  ip += len;
+
+  PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
+  NEXT;
+}
+
+VM_DEFINE_LOADER (late_bind, "late-bind")
+{
+  SCM sym;
+  size_t len;
+
+  FETCH_LENGTH (len);
+  sym = scm_from_locale_symboln ((char *)ip, len);
+  ip += len;
+
+  PUSH (sym);
+  NEXT;
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_scheme.c

@@ -0,0 +1,275 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm_engine.c */
+
+
+/*
+ * Predicates
+ */
+
+VM_DEFINE_FUNCTION (not, "not", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_not, "not-not", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (eq, "eq?", 2)
+{
+  ARGS2 (x, y);
+  RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (not_eq, "not-eq?", 2)
+{
+  ARGS2 (x, y);
+  RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (nullp, "null?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (not_nullp, "not-null?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (eqv, "eqv?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_BEFORE_GC ();
+  RETURN (scm_eqv_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (equal, "equal?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_BEFORE_GC ();
+  RETURN (scm_equal_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (pairp, "pair?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_CONSP (x)));
+}
+
+VM_DEFINE_FUNCTION (listp, "list?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+}
+
+
+/*
+ * Basic data
+ */
+
+VM_DEFINE_FUNCTION (cons, "cons", 2)
+{
+  ARGS2 (x, y);
+  CONS (x, x, y);
+  RETURN (x);
+}
+
+VM_DEFINE_FUNCTION (car, "car", 1)
+{
+  ARGS1 (x);
+  SCM_VALIDATE_CONS (1, x);
+  RETURN (SCM_CAR (x));
+}
+
+VM_DEFINE_FUNCTION (cdr, "cdr", 1)
+{
+  ARGS1 (x);
+  SCM_VALIDATE_CONS (1, x);
+  RETURN (SCM_CDR (x));
+}
+
+VM_DEFINE_FUNCTION (set_car, "set-car!", 2)
+{
+  ARGS2 (x, y);
+  SCM_VALIDATE_CONS (1, x);
+  SCM_SETCAR (x, y);
+  RETURN (SCM_UNSPECIFIED);
+}
+
+VM_DEFINE_FUNCTION (set_cdr, "set-cdr!", 2)
+{
+  ARGS2 (x, y);
+  SCM_VALIDATE_CONS (1, x);
+  SCM_SETCDR (x, y);
+  RETURN (SCM_UNSPECIFIED);
+}
+
+
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel)						\
+{								\
+  ARGS2 (x, y);							\
+  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))			\
+    RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y)));	\
+  RETURN (srel (x, y));						\
+}
+
+VM_DEFINE_FUNCTION (ee, "ee?", 2)
+{
+  REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (lt, "lt?", 2)
+{
+  REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (le, "le?", 2)
+{
+  REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (gt, "gt?", 2)
+{
+  REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (ge, "ge?", 2)
+{
+  REL (>=, scm_geq_p);
+}
+
+
+/*
+ * Numeric functions
+ */
+
+#undef FUNC1
+#define FUNC1(CEXP,SEXP)			\
+{						\
+  ARGS1 (x);					\
+  if (SCM_I_INUMP (x))				\
+    {						\
+      int n = CEXP;				\
+      if (SCM_FIXABLE (n))			\
+	RETURN (SCM_I_MAKINUM (n));		\
+    }						\
+  RETURN (SEXP);				\
+}
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC)				\
+{							\
+  ARGS2 (x, y);						\
+  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))		\
+    {							\
+      int n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);	\
+      if (SCM_FIXABLE (n))				\
+	RETURN (SCM_I_MAKINUM (n));			\
+    }							\
+  RETURN (SFUNC (x, y));				\
+}
+
+VM_DEFINE_FUNCTION (add, "add", 2)
+{
+  FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (sub, "sub", 2)
+{
+  FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (mul, "mul", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (div, "div", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (quo, "quo", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (rem, "rem", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (mod, "mod", 2)
+{
+  ARGS2 (x, y);
+  RETURN (scm_modulo (x, y));
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

src/vm_system.c

@@ -0,0 +1,574 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm_engine.c */
+
+
+/*
+ * Basic operations
+ */
+
+/* This must be the first instruction! */
+VM_DEFINE_INSTRUCTION (nop, "nop", 0, 0, 0)
+{
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (halt, "halt", 0, 0, 0)
+{
+  SCM ret;
+  vp->time += scm_c_get_internal_run_time () - start_time;
+  HALT_HOOK ();
+  POP (ret);
+  FREE_FRAME ();
+  SYNC_ALL ();
+  return ret;
+}
+
+VM_DEFINE_INSTRUCTION (break, "break", 0, 0, 0)
+{
+  BREAK_HOOK ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (drop, "drop", 0, 0, 0)
+{
+  DROP ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (mark, "mark", 0, 0, 1)
+{
+  PUSH (SCM_UNDEFINED);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (dup, "dup", 0, 0, 1)
+{
+  SCM x = *sp;
+  PUSH (x);
+  NEXT;
+}
+
+
+/*
+ * Object creation
+ */
+
+VM_DEFINE_INSTRUCTION (void, "void", 0, 0, 1)
+{
+  PUSH (SCM_UNSPECIFIED);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_true, "make-true", 0, 0, 1)
+{
+  PUSH (SCM_BOOL_T);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_false, "make-false", 0, 0, 1)
+{
+  PUSH (SCM_BOOL_F);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0, 0, 1)
+{
+  PUSH (SCM_EOL);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1, 0, 1)
+{
+  PUSH (SCM_I_MAKINUM ((signed char) FETCH ()));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0, 0, 1)
+{
+  PUSH (SCM_INUM0);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0, 0, 1)
+{
+  PUSH (SCM_I_MAKINUM (1));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2, 0, 1)
+{
+  int h = FETCH ();
+  int l = FETCH ();
+  PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1, 0, 1)
+{
+  PUSH (SCM_MAKE_CHAR (FETCH ()));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list, "list", 2, -1, 1)
+{
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector, "vector", 2, -1, 1)
+{
+  unsigned h = FETCH ();
+  unsigned l = FETCH ();
+  unsigned len = ((h << 8) + l);
+  POP_LIST (len);
+  *sp = scm_vector (*sp);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_mark, "list-mark", 0, 0, 0)
+{
+  POP_LIST_MARK ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (vector_mark, "vector-mark", 0, 0, 0)
+{
+  POP_LIST_MARK ();
+  *sp = scm_vector (*sp);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (list_break, "list-break", 0, 0, 0)
+{
+  SCM l;
+  POP (l);
+  for (; !SCM_NULLP (l); l = SCM_CDR (l))
+    PUSH (SCM_CAR (l));
+  NEXT;
+}
+
+
+/*
+ * Variable access
+ */
+
+#define OBJECT_REF(i)		objects[i]
+#define OBJECT_SET(i,o)		objects[i] = o
+
+#define LOCAL_REF(i)		SCM_FRAME_VARIABLE (fp, i)
+#define LOCAL_SET(i,o)		SCM_FRAME_VARIABLE (fp, i) = o
+
+/* For the variable operations, we _must_ obviously avoid function calls to
+   `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do
+   nothing more than the corresponding macros.  */
+#define VARIABLE_REF(v)		SCM_VARIABLE_REF (v)
+#define VARIABLE_SET(v,o)	SCM_VARIABLE_SET (v, o)
+#define VARIABLE_BOUNDP(v)      (VARIABLE_REF (v) != SCM_UNDEFINED)
+
+/* ref */
+
+VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1, 0, 1)
+{
+  register unsigned objnum = FETCH ();
+  CHECK_OBJECT (objnum);
+  PUSH (OBJECT_REF (objnum));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1, 0, 1)
+{
+  PUSH (LOCAL_REF (FETCH ()));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1, 0, 1)
+{
+  unsigned int i;
+  SCM e = external;
+  for (i = FETCH (); i; i--)
+    {
+      CHECK_EXTERNAL(e);
+      e = SCM_CDR (e);
+    }
+  CHECK_EXTERNAL(e);
+  PUSH (SCM_CAR (e));
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0, 0, 1)
+{
+  SCM x = *sp;
+
+  if (!VARIABLE_BOUNDP (x))
+    {
+      err_args = SCM_LIST1 (x);
+      /* Was: err_args = SCM_LIST1 (SCM_CAR (x)); */
+      goto vm_error_unbound;
+    }
+  else
+    {
+      SCM o = VARIABLE_REF (x);
+      *sp = o;
+    }
+
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_ref, "late-variable-ref", 1, 0, 1)
+{
+  unsigned objnum = FETCH ();
+  SCM pair_or_var;
+  CHECK_OBJECT (objnum);
+  pair_or_var = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (pair_or_var)) 
+    {
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+      /* module_lookup might longjmp */
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+      OBJECT_SET (objnum, pair_or_var);
+      if (!VARIABLE_BOUNDP (pair_or_var))
+        {
+          err_args = SCM_LIST1 (pair_or_var);
+          goto vm_error_unbound;
+        }
+    }
+
+  PUSH (VARIABLE_REF (pair_or_var));
+  NEXT;
+}
+
+/* set */
+
+VM_DEFINE_INSTRUCTION (local_set, "local-set", 1, 1, 0)
+{
+  LOCAL_SET (FETCH (), *sp);
+  DROP ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
+{
+  unsigned int i;
+  SCM e = external;
+  for (i = FETCH (); i; i--)
+    {
+      CHECK_EXTERNAL(e);
+      e = SCM_CDR (e);
+    }
+  CHECK_EXTERNAL(e);
+  SCM_SETCAR (e, *sp);
+  DROP ();
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
+{
+  VARIABLE_SET (sp[0], sp[-1]);
+  scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
+  sp -= 2;
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (late_variable_set, "late-variable-set", 1, 1, 0)
+{
+  unsigned objnum = FETCH ();
+  SCM pair_or_var;
+  CHECK_OBJECT (objnum);
+  pair_or_var = OBJECT_REF (objnum);
+
+  if (!SCM_VARIABLEP (pair_or_var)) 
+    {
+      SCM mod = scm_resolve_module (SCM_CAR (pair_or_var));
+      /* module_lookup might longjmp */
+      pair_or_var = scm_module_lookup (mod, SCM_CDR (pair_or_var));
+      OBJECT_SET (objnum, pair_or_var);
+    }
+
+  VARIABLE_SET (pair_or_var, *sp);
+  DROP ();
+  NEXT;
+}
+
+
+/*
+ * branch and jump
+ */
+
+#define BR(p)					\
+{						\
+  int h = FETCH ();				\
+  int l = FETCH ();				\
+  signed short offset = (h << 8) + l;		\
+  if (p)					\
+    ip += offset;				\
+  DROP ();					\
+  NEXT;						\
+}
+
+VM_DEFINE_INSTRUCTION (br, "br", 2, 0, 0)
+{
+  int h = FETCH ();
+  int l = FETCH ();
+  ip += (signed short) (h << 8) + l;
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (br_if, "br-if", 2, 0, 0)
+{
+  BR (!SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 2, 0, 0)
+{
+  BR (SCM_FALSEP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 2, 0, 0)
+{
+  BR (SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+{
+  BR (!SCM_EQ_P (sp[0], sp--[1]));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 2, 0, 0)
+{
+  BR (SCM_NULLP (*sp));
+}
+
+VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 2, 0, 0)
+{
+  BR (!SCM_NULLP (*sp));
+}
+
+
+/*
+ * Subprogram call
+ */
+
+VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0, 1, 1)
+{
+  SYNC_BEFORE_GC ();
+  *sp = scm_c_make_closure (*sp, external);
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
+{
+  SCM x;
+  nargs = FETCH ();
+
+ vm_call:
+  x = sp[-nargs];
+
+  /*
+   * Subprogram call
+   */
+  if (SCM_PROGRAM_P (x))
+    {
+      program = x;
+    vm_call_program:
+      CACHE_PROGRAM ();
+      INIT_ARGS ();
+      NEW_FRAME ();
+      ENTER_HOOK ();
+      APPLY_HOOK ();
+      NEXT;
+    }
+  /*
+   * Function call
+   */
+  if (!SCM_FALSEP (scm_procedure_p (x)))
+    {
+      /* At this point, the stack contains the procedure and each one of its
+	 arguments.  */
+      SCM args;
+
+#if 1
+      POP_LIST (nargs);
+#else
+      /* Experimental:  Build the arglist on the VM stack.  XXX  */
+      POP_LIST_ON_STACK (nargs);
+#endif
+      POP (args);
+      *sp = scm_apply (x, args, SCM_EOL);
+      NEXT;
+    }
+  /*
+   * Continuation call
+   */
+  if (SCM_VM_CONT_P (x))
+    {
+    vm_call_cc:
+      /* Check the number of arguments */
+      if (nargs != 1)
+	scm_wrong_num_args (x);
+
+      /* Reinstate the continuation */
+      EXIT_HOOK ();
+      reinstate_vm_cont (vp, x);
+      CACHE_REGISTER ();
+      program = SCM_FRAME_PROGRAM (fp);
+      CACHE_PROGRAM ();
+      NEXT;
+    }
+
+  program = x;
+  goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1, -1, 1)
+{
+  register SCM x;
+  nargs = FETCH ();
+  x = sp[-nargs];
+
+  SCM_TICK;	/* allow interrupt here */
+
+  /*
+   * Tail recursive call
+   */
+  if (SCM_EQ_P (x, program))
+    {
+      int i;
+
+      /* Move arguments */
+      INIT_ARGS ();
+      sp -= bp->nargs - 1;
+      for (i = 0; i < bp->nargs; i++)
+	LOCAL_SET (i, sp[i]);
+
+      /* Drop the first argument and the program itself.  */
+      sp -= 2;
+
+      /* Call itself */
+      ip = bp->base;
+      APPLY_HOOK ();
+      NEXT;
+    }
+  /*
+   * Proper tail call
+   */
+  if (SCM_PROGRAM_P (x))
+    {
+      EXIT_HOOK ();
+      FREE_FRAME ();
+      program = x;
+      goto vm_call_program;
+    }
+  /*
+   * Function call
+   */
+  if (!SCM_FALSEP (scm_procedure_p (x)))
+    {
+      SCM args;
+      POP_LIST (nargs);
+      POP (args);
+      *sp = scm_apply (x, args, SCM_EOL);
+      goto vm_return;
+    }
+  /*
+   * Continuation call
+   */
+  if (SCM_VM_CONT_P (x))
+    goto vm_call_cc;
+
+  program = x;
+  goto vm_error_wrong_type_apply;
+}
+
+VM_DEFINE_INSTRUCTION (apply, "apply", 1, -1, 1)
+{
+  int len;
+  SCM ls;
+  POP (ls);
+
+  nargs = FETCH ();
+  if (nargs < 2)
+    goto vm_error_wrong_num_args;
+
+  len = scm_ilength (ls);
+  if (len < 0)
+    goto vm_error_wrong_type_arg;
+
+  for (; !SCM_NULLP (ls); ls = SCM_CDR (ls))
+    PUSH (SCM_CAR (ls));
+
+  nargs += len - 2;
+  goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1, 1, 1)
+{
+  SYNC_BEFORE_GC ();
+  PUSH (capture_vm_cont (vp));
+  POP (program);
+  nargs = 1;
+  goto vm_call;
+}
+
+VM_DEFINE_INSTRUCTION (return, "return", 0, 0, 1)
+{
+ vm_return:
+  EXIT_HOOK ();
+  RETURN_HOOK ();
+  FREE_FRAME ();
+
+  /* Restore the last program */
+  program = SCM_FRAME_PROGRAM (fp);
+  CACHE_PROGRAM ();
+  CACHE_EXTERNAL ();
+  NEXT;
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

testsuite/Makefile.am

@@ -0,0 +1,27 @@
+# The test programs.
+
+# The Libtool executable.
+GUILE_VM = $(top_builddir)/src/guile-vm
+
+vm_test_files =					\
+      t-basic-contructs.scm			\
+      t-global-bindings.scm			\
+      t-closure.scm				\
+      t-closure2.scm				\
+      t-closure3.scm				\
+      t-do-loop.scm				\
+      t-macros.scm				\
+      t-macros2.scm				\
+      t-proc-with-setter.scm			\
+      t-values.scm				\
+      t-records.scm				\
+      t-match.scm				\
+      t-mutual-toplevel-defines.scm
+
+EXTRA_DIST = run-vm-tests.scm $(vm_test_files)
+
+
+check:
+	$(GUILE_VM) -L $(top_srcdir)/module		\
+	            -l run-vm-tests.scm -e run-vm-tests	\
+		    $(vm_test_files)

testsuite/run-vm-tests.scm

@@ -0,0 +1,97 @@
+;;; run-vm-tests.scm -- Run Guile-VM's test suite.
+;;;
+;;; Copyright 2005  Ludovic Courtès <ludovic.courtes@laas.fr>
+;;;
+;;;
+;;; 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 of the License, 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 program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+
+
+(use-modules (system vm core)
+	     (system vm disasm)
+	     (system base compile)
+	     (system base language)
+
+	     (srfi srfi-1)
+	     (ice-9 r5rs))
+
+
+(define %scheme (lookup-language 'scheme))
+
+(define (fetch-sexp-from-file file)
+  (with-input-from-file file
+    (lambda ()
+      (let loop ((sexp (read))
+		 (result '()))
+	(if (eof-object? sexp)
+	    (cons 'begin (reverse result))
+	    (loop (read) (cons sexp result)))))))
+
+(define (compile-to-objcode sexp)
+  "Compile the expression @var{sexp} into a VM program and return it."
+  (compile-in sexp (current-module) %scheme))
+
+(define (run-vm-program objcode)
+  "Run VM program contained into @var{objcode}."
+  (vm-load (the-vm) objcode))
+
+(define (compile/run-test-from-file file)
+  "Run test from source file @var{file} and return a value indicating whether
+it succeeded."
+  (run-vm-program (compile-to-objcode (fetch-sexp-from-file file))))
+
+
+(define-macro (watch-proc proc-name str)
+  `(let ((orig-proc ,proc-name))
+     (set! ,proc-name
+	   (lambda args
+	     (format #t (string-append ,str "...  "))
+	     (apply orig-proc args)))))
+
+(watch-proc fetch-sexp-from-file  "reading")
+(watch-proc compile-to-objcode    "compiling")
+(watch-proc run-vm-program        "running")
+
+
+;; The program.
+
+(define (run-vm-tests files)
+  "For each file listed in @var{files}, load it and run it through both the
+interpreter and the VM (after having it compiled).  Both results must be
+equal in the sense of @var{equal?}."
+  (let* ((res (map (lambda (file)
+		     (format #t "running `~a'...  " file)
+		     (if (catch #t
+				(lambda ()
+				  (equal? (compile/run-test-from-file file)
+					  (eval (fetch-sexp-from-file file)
+						(interaction-environment))))
+				(lambda (key . args)
+				  (format #t "[~a/~a] " key args)
+				  #f))
+			 (format #t "ok~%")
+			 (begin (format #t "FAILED~%") #f)))
+		   files))
+	 (total (length files))
+	 (failed (length (filter not res))))
+
+    (if (= 0 failed)
+	(begin
+	  (format #t "~%All ~a tests passed~%" total)
+	  (exit 0))
+	(begin
+	  (format #t "~%~a tests failed out of ~a~%"
+		  failed total)
+	  (exit failed)))))
+

testsuite/t-basic-contructs.scm

@@ -0,0 +1,16 @@
+;;; Basic RnRS constructs.
+
+(and (eq? 2 (begin (+ 2 4) 5 2))
+     ((lambda (x y)
+	(and (eq? x 1) (eq? y 2)
+	     (begin
+	       (set! x 11) (set! y 22)
+	       (and (eq? x 11) (eq? y 22)))))
+      1 2)
+     (let ((x 1) (y 3))
+       (and (eq? x 1) (eq? y 3)))
+     (let loop ((x #t))
+       (if (not x)
+	   #t
+	   (loop #f))))
+

testsuite/t-closure.scm

@@ -0,0 +1,8 @@
+(define func
+  (let ((x 2))
+    (lambda ()
+      (let ((x++ (+ 1 x)))
+	(set! x x++)
+	x++))))
+
+(list (func) (func) (func))

testsuite/t-closure2.scm

@@ -0,0 +1,10 @@
+
+(define (uid)
+  (let* ((x 2)
+	 (do-uid (lambda ()
+		   (let ((x++ (+ 1 x)))
+		     (set! x x++)
+		     x++))))
+    (do-uid)))
+
+(list (uid) (uid) (uid))

testsuite/t-closure3.scm

@@ -0,0 +1,7 @@
+(define (stuff)
+  (let* ((x 2)
+	 (chbouib (lambda (z)
+		    (+ 7 z x))))
+    (chbouib 77)))
+
+(stuff)

testsuite/t-do-loop.scm

@@ -0,0 +1,5 @@
+(let ((n+ 0))
+  (do ((n- 5  (1- n-))
+       (n+ n+ (1+ n+)))
+      ((= n- 0))
+    (format #f "n- = ~a~%" n-)))

testsuite/t-global-bindings.scm

@@ -0,0 +1,13 @@
+;; Are global bindings reachable at run-time?  This relies on the
+;; `object-ref' and `object-set' instructions.
+
+(begin
+
+  (define the-binding "hello")
+
+  ((lambda () the-binding))
+
+  ((lambda () (set! the-binding "world")))
+
+  ((lambda () the-binding)))
+

testsuite/t-macros.scm

@@ -0,0 +1,4 @@
+;; Are built-in macros well-expanded at compilation-time?
+
+(false-if-exception (+ 2 2))
+(read-options)

testsuite/t-macros2.scm

@@ -0,0 +1,17 @@
+;; Are macros well-expanded at compilation-time?
+
+(defmacro minus-binary (a b)
+  `(- ,a ,b))
+
+(define-macro (plus . args)
+  `(let ((res (+ ,@args)))
+     ;;(format #t "plus -> ~a~%" res)
+     res))
+
+
+(plus (let* ((x (minus-binary 12 7)) ;; 5
+	     (y (minus-binary x 1))) ;; 4
+	(plus x y 5)) ;; 14
+      12              ;; 26
+      (expt 2 3))     ;; => 34
+

testsuite/t-match.scm

@@ -0,0 +1,26 @@
+;;; Pattern matching with `(ice-9 match)'.
+;;;
+
+(use-modules (ice-9 match)
+             (srfi srfi-9))  ;; record type (FIXME: See `t-records.scm')
+
+(define-record-type <stuff>
+  (%make-stuff chbouib)
+  stuff?
+  (chbouib stuff:chbouib stuff:set-chbouib!))
+
+(define (matches? obj)
+;  (format #t "matches? ~a~%" obj)
+  (match obj
+	 (($ stuff) => #t)
+;	 (blurps    #t)
+	 ("hello"   #t)
+	 (else #f)))
+
+
+;(format #t "go!~%")
+(and (matches? (%make-stuff 12))
+     (matches? (%make-stuff 7))
+     (matches? "hello")
+;     (matches? 'blurps)
+     (not (matches? 66)))

testsuite/t-mutual-toplevel-defines.scm

@@ -0,0 +1,8 @@
+(define (even? x)
+  (or (zero? x)
+      (not (odd? (1- x)))))
+
+(define (odd? x)
+  (not (even? (1- x))))
+
+(even? 20)