Merge branch 'master' into boehm-demers-weiser-gc

Conflicts:
	libguile/continuations.c
	libguile/gc-freelist.c
	libguile/gc-mark.c
	libguile/symbols.c
	libguile/threads.c
	module/ice-9/boot-9.scm

.gitignore

@@ -37,7 +37,7 @@ autom4te.cache
 benchmark-guile
 check-guile
 check-guile.log
-compile
+build-aux/compile
 confdefs.h
 config.build-subdirs
 config.cache
@@ -68,8 +68,10 @@ guile-procedures.txt
 guile-config/guile-config
 guile-readline/guile-readline-config.h
 guile-readline/guile-readline-config.h.in
+*.go
 TAGS
 guile-1.8.pc
+gdb-pre-inst-guile
 libguile/stack-limit-calibration.scm
 cscope.out
 cscope.files

Makefile.am

@@ -24,8 +24,9 @@
 #
 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
+SUBDIRS = lib libguile guile-config guile-readline emacs \
+	  scripts srfi doc examples test-suite benchmark-suite lang am \
+	  module testsuite
 
 bin_SCRIPTS = guile-tools
 

NEWS

@@ -43,6 +43,10 @@ indicating length of the `scm_t_option' array.
 ** Primitive procedures (aka. "subrs") are now stored in double cells
 This removes the subr table and simplifies the code.
 
+** Primitive procedures with more than 3 arguments (aka. "gsubrs") are
+no longer implemented using the "compiled closure" mechanism.  This
+simplifies code and reduces both the storage and run-time overhead.
+
 
 Changes in 1.8.7 (since 1.8.6)
 
@@ -60,6 +64,8 @@ transformed by (ice-9 syncase) would cause an "Invalid syntax" error.
 Now it works as you would expect (giving the value of the specified
 module binding).
 
+** Have `scm_take_locale_symbol ()' return an interned symbol (bug #25865)
+
 
 Changes in 1.8.6 (since 1.8.5)
 

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.

am/Makefile.am

@@ -21,7 +21,7 @@
 
 AUTOMAKE_OPTIONS = gnu
 
-am_frags = pre-inst-guile maintainer-dirs
+am_frags = pre-inst-guile maintainer-dirs guilec
 
 EXTRA_DIST = $(am_frags) ChangeLog-2008
 

am/guilec

@@ -0,0 +1,13 @@
+# -*- makefile -*-
+GOBJECTS = $(SOURCES:%.scm=%.go)
+
+moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
+nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS)
+EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)
+
+CLEANFILES = $(GOBJECTS)
+
+SUFFIXES = .scm .go
+.scm.go:
+	$(MKDIR_P) `dirname $@`
+	$(top_builddir)/pre-inst-guile-env $(top_builddir)/guile-tools compile -o "$@" "$<"

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    (toplevel-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,64 @@
+#!/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 vm)
+  :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~%")))
+	 (the-program (compile proc-source))
+
+	 (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

@@ -288,6 +288,8 @@ AC_CHECK_LIB(uca, __uc_get_ar_bsp)
 
 AC_C_BIGENDIAN
 
+AC_C_LABELS_AS_VALUES
+
 AC_CHECK_SIZEOF(char)
 AC_CHECK_SIZEOF(unsigned char)
 AC_CHECK_SIZEOF(short)
@@ -1557,17 +1559,20 @@ AC_CONFIG_FILES([
   examples/safe/Makefile
   examples/scripts/Makefile
   guile-config/Makefile
-  ice-9/Makefile
-  ice-9/debugger/Makefile
-  ice-9/debugging/Makefile
   lang/Makefile
   libguile/Makefile
-  oop/Makefile
-  oop/goops/Makefile
   scripts/Makefile
   srfi/Makefile
   test-suite/Makefile
   test-suite/standalone/Makefile
+  module/Makefile
+  module/ice-9/Makefile
+  module/ice-9/debugger/Makefile
+  module/ice-9/debugging/Makefile
+  module/srfi/Makefile
+  module/oop/Makefile
+  module/oop/goops/Makefile
+  testsuite/Makefile
 ])
 
 AC_CONFIG_FILES([guile-1.8.pc])
@@ -1576,6 +1581,7 @@ AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile])
 AC_CONFIG_FILES([guile-tools], [chmod +x guile-tools])
 AC_CONFIG_FILES([pre-inst-guile], [chmod +x pre-inst-guile])
 AC_CONFIG_FILES([pre-inst-guile-env], [chmod +x pre-inst-guile-env])
+AC_CONFIG_FILES([gdb-pre-inst-guile], [chmod +x gdb-pre-inst-guile])
 AC_CONFIG_FILES([libguile/guile-snarf],
                 [chmod +x libguile/guile-snarf])
 AC_CONFIG_FILES([libguile/guile-doc-snarf],

doc/Makefile.am

@@ -44,3 +44,4 @@ guile-api.alist: guile-api.alist-FORCE
 	( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
 guile-api.alist-FORCE:
 
+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.  ;-)]
+

doc/ref/Makefile.am

@@ -68,6 +68,9 @@ guile_TEXINFOS = preface.texi			\
 		 autoconf.texi			\
 		 autoconf-macros.texi		\
 		 tools.texi			\
+		 history.texi			\
+		 vm.texi			\
+		 compiler.texi			\
 		 fdl.texi			\
 		 libguile-concepts.texi		\
 		 libguile-smobs.texi		\

doc/ref/api-compound.texi

@@ -2797,11 +2797,11 @@ structure.
 @example
 (make-vtable "prpw"
              (lambda (struct port)
-               (display "#<")
-               (display (struct-ref 0))
-               (display " and ")
-               (display (struct-ref 1))
-               (display ">")))
+               (display "#<" port)
+               (display (struct-ref struct 0) port)
+               (display " and " port)
+               (display (struct-ref struct 1) port)
+               (display ">" port)))
 @end example
 @end deffn
 

doc/ref/api-debug.texi

@@ -1889,6 +1889,8 @@ this-is-a-matric
 guile> 
 @end lisp
 
+@anchor{Memoization}
+@cindex Memoization
 (For anyone wondering why the first @code{(do-main 4)} call above
 generates lots more trace lines than the subsequent calls: these
 examples also demonstrate how the Guile evaluator ``memoizes'' code.

doc/ref/api-evaluation.texi

@@ -5,20 +5,22 @@
 @c See the file guile.texi for copying conditions.
 
 @page
-@node Read/Load/Eval
+@node Read/Load/Eval/Compile
 @section Reading and Evaluating Scheme Code
 
 This chapter describes Guile functions that are concerned with reading,
-loading and evaluating Scheme code at run time.
+loading, evaluating, and compiling Scheme code at run time.
 
 @menu
 * Scheme Syntax::               Standard and extended Scheme syntax.
 * Scheme Read::                 Reading Scheme code.
 * Fly Evaluation::              Procedures for on the fly evaluation.
+* Compilation::                 How to compile Scheme files and procedures.
 * Loading::                     Loading Scheme code from file.
 * Delayed Evaluation::          Postponing evaluation until it is needed.
 * Local Evaluation::            Evaluation in a local environment.
 * Evaluator Behaviour::         Modifying Guile's evaluator.
+* VM Behaviour::                Modifying Guile's virtual machine.
 @end menu
 
 
@@ -411,6 +413,69 @@ the current module.
 @end deffn
 
 
+@node Compilation
+@subsection Compiling Scheme Code
+
+The @code{eval} procedure directly interprets the S-expression
+representation of Scheme. An alternate strategy for evaluation is to
+determine ahead of time what computations will be necessary to
+evaluate the expression, and then use that recipe to produce the
+desired results. This is known as @dfn{compilation}.
+
+While it is possible to compile simple Scheme expressions such as
+@code{(+ 2 2)} or even @code{"Hello world!"}, compilation is most
+interesting in the context of procedures. Compiling a lambda expression
+produces a compiled procedure, which is just like a normal procedure
+except typically much faster, because it can bypass the generic
+interpreter.
+
+Functions from system modules in a Guile installation are normally
+compiled already, so they load and run quickly.
+
+Note that well-written Scheme programs will not typically call the
+procedures in this section, for the same reason that it is often bad
+taste to use @code{eval}. The normal interface to the compiler is the
+command-line file compiler, which can be invoked from the shell as
+@code{guile-tools compile @var{foo.scm}}. This interface needs more
+documentation.
+
+(Why are calls to @code{eval} and @code{compile} usually in bad taste?
+Because they are limited, in that they can only really make sense for
+top-level expressions. Also, most needs for ``compile-time''
+computation are fulfilled by macros and closures. Of course one good
+counterexample is the REPL itself, or any code that reads expressions
+from a port.)
+
+For more information on the compiler itself, see @ref{Compiling to the
+Virtual Machine}. For information on the virtual machine, see @ref{A
+Virtual Machine for Guile}.
+
+@deffn {Scheme Procedure} compile exp [env=#f] [from=(current-language)] [to=value] [opts=()]
+Compile the expression @var{exp} in the environment @var{env}. If
+@var{exp} is a procedure, the result will be a compiled procedure;
+otherwise @code{compile} is mostly equivalent to @code{eval}.
+
+For a discussion of languages and compiler options, @xref{Compiling to
+the Virtual Machine}.
+@end deffn
+
+@deffn {Scheme Procedure} compile-file file [to=objcode] [opts='()]
+Compile the file named @var{file}.
+
+Output will be written to a file in the current directory whose name
+is computed as @code{(compiled-file-name @var{file})}.
+@end deffn
+
+@deffn {Scheme Procedure} compiled-file-name file
+Compute an appropriate name for a compiled version of a Scheme file
+named @var{file}.
+
+Usually, the result will be the original file name with the
+@code{.scm} suffix replaced with @code{.go}, but the exact behavior
+depends on the contents of the @code{%load-extensions} and
+@code{%load-compiled-extensions} lists.
+@end deffn
+
 @node Loading
 @subsection Loading Scheme Code from File
 
@@ -435,9 +500,19 @@ procedure that will be called before any code is loaded.  See
 documentation for @code{%load-hook} later in this section.
 @end deffn
 
+@deffn {Scheme Procedure} load-compiled filename
+Load the compiled file named @var{filename}. The load paths are not
+searched.
+
+Compiling a source file (@pxref{Read/Load/Eval/Compile}) and then
+calling @code{load-compiled} on the resulting file is equivalent to
+calling @code{load} on the source file.
+@end deffn
+
 @deffn {Scheme Procedure} load-from-path filename
 Similar to @code{load}, but searches for @var{filename} in the load
-paths.
+paths. Preferentially loads a compiled version of the file, if it is
+available and up-to-date.
 @end deffn
 
 @deffn {Scheme Procedure} primitive-load filename
@@ -461,7 +536,8 @@ documentation for @code{%load-hook} later in this section.
 Search @code{%load-path} for the file named @var{filename} and
 load it into the top-level environment.  If @var{filename} is a
 relative pathname and is not found in the list of search paths,
-an error is signalled.
+an error is signalled. Preferentially loads a compiled version of the
+file, if it is available and up-to-date.
 @end deffn
 
 @deffn {Scheme Procedure} %search-load-path filename
@@ -639,6 +715,30 @@ trap handlers.
 Option interface for the evaluator trap options.
 @end deffn
 
+@node VM Behaviour
+@subsection VM Behaviour
+
+Like the procedures from the previous section that operate on the
+evaluator, there are also procedures to modify the behavior of a
+virtual machine.
+
+The most useful thing that a user can do is to add to one of the
+virtual machine's predefined hooks:
+
+@deffn {Scheme Procedure} vm-next-hook vm
+@deffnx {Scheme Procedure} vm-apply-hook vm
+@deffnx {Scheme Procedure} vm-boot-hook vm
+@deffnx {Scheme Procedure} vm-return-hook vm
+@deffnx {Scheme Procedure} vm-break-hook vm
+@deffnx {Scheme Procedure} vm-exit-hook vm
+@deffnx {Scheme Procedure} vm-halt-hook vm
+@deffnx {Scheme Procedure} vm-enter-hook vm
+Accessors to a virtual machine's hooks. Usually you pass
+@code{(the-vm)} as the @var{vm}.
+@end deffn
+
+@xref{A Virtual Machine for Guile}, for more information on Guile's
+virtual machine.
 
 @c Local Variables:
 @c TeX-master: "guile.texi"

doc/ref/api-procedures.texi

@@ -11,6 +11,7 @@
 @menu
 * Lambda::                      Basic procedure creation using lambda.
 * Primitive Procedures::        Procedures defined in C.
+* Compiled Procedures::         Scheme procedures can be compiled.
 * Optional Arguments::          Handling keyword, optional and rest arguments.
 * Procedure Properties::        Procedure properties and meta-information.
 * Procedures with Setters::     Procedures with setters.
@@ -131,6 +132,164 @@ use @code{scm_c_make_subr} and also @code{scm_makcclo} if necessary.
 It is advisable to use the gsubr variants since they provide a
 slightly higher-level abstraction of the Guile implementation.
 
+@node Compiled Procedures
+@subsection Compiled Procedures
+
+Procedures that were created when loading a compiled file are
+themselves compiled. (In contrast, procedures that are defined by
+loading a Scheme source file are interpreted, and often not as fast as
+compiled procedures.)
+
+Loading compiled files is the normal way that compiled procedures come
+to being, though procedures can be compiled at runtime as well.
+@xref{Read/Load/Eval/Compile}, for more information on runtime
+compilation.
+
+Compiled procedures, also known as @dfn{programs}, respond all
+procedures that operate on procedures. In addition, there are a few
+more accessors for low-level details on programs.
+
+Most people won't need to use the routines described in this section,
+but it's good to have them documented. You'll have to include the
+appropriate module first, though:
+
+@example
+(use-modules (system vm program))
+@end example
+
+@deffn {Scheme Procedure} program? obj
+@deffnx {C Function} scm_program_p (obj)
+Returns @code{#t} iff @var{obj} is a compiled procedure.
+@end deffn
+
+@deffn {Scheme Procedure} program-bytecode program
+@deffnx {C Function} scm_program_bytecode (program)
+Returns the object code associated with this program, as a
+@code{u8vector}.
+@end deffn
+
+@deffn {Scheme Procedure} program-base program
+@deffnx {C Function} scm_program_base (program)
+Returns the address in memory corresponding to the start of
+@var{program}'s object code, as an integer. This is useful mostly when
+you map the value of an instruction pointer from the VM to actual
+instructions.
+@end deffn
+
+@deffn {Scheme Procedure} program-objects program
+@deffnx {C Function} scm_program_objects (program)
+Returns the ``object table'' associated with this program, as a
+vector. @xref{VM Programs}, for more information.
+@end deffn
+
+@deffn {Scheme Procedure} program-module program
+@deffnx {C Function} scm_program_module (program)
+Returns the module that was current when this program was created.
+Free variables in this program are looked up with respect to this
+module.
+@end deffn
+
+@deffn {Scheme Procedure} program-external program
+@deffnx {C Function} scm_program_external (program)
+Returns the set of heap-allocated variables that this program captures
+in its closure, as a list. If a closure is code with data, you can get
+the code from @code{program-bytecode}, and the data via
+@code{program-external}.
+
+Users must not modify the returned value unless they think they're
+really clever.
+@end deffn
+
+@deffn {Scheme Procedure} program-external-set! program external
+@deffnx {C Function} scm_program_external_set_x (program, external)
+Set @var{external} as the set of closure variables on @var{program}.
+
+The Guile maintainers will not be held responsible for side effects of
+calling this function, including but not limited to replacement of
+shampoo with hair dye, and a slight salty taste in tomorrow's dinner.
+@end deffn
+
+@deffn {Scheme Procedure} program-arity program
+@deffnx {C Function} scm_program_arity (program)
+@deffnx {Scheme Procedure} arity:nargs arity
+@deffnx {Scheme Procedure} arity:nrest arity
+@deffnx {Scheme Procedure} arity:nlocs arity
+@deffnx {Scheme Procedure} arity:nexts arity
+Accessors for a representation of the ``arity'' of a program.
+
+@code{nargs} is the number of arguments to the procedure, and
+@code{nrest} will be non-zero if the last argument is a rest argument.
+
+The other two accessors determine the number of local and external
+(heap-allocated) variables that this procedure will need to have
+allocated.
+@end deffn
+
+@deffn {Scheme Procedure} program-meta program
+@deffnx scm_program_meta (program)
+Return the metadata thunk of @var{program}, or @code{#f} if it has no
+metadata.
+
+When called, a metadata thunk returns a list of the following form:
+@code{(@var{bindings} @var{sources} . @var{properties})}. The format
+of each of these elements is discussed below.
+@end deffn
+
+@deffn {Scheme Procedure} program-bindings program
+@deffnx {Scheme Procedure} make-binding name extp index start end
+@deffnx {Scheme Procedure} binding:name binding
+@deffnx {Scheme Procedure} binding:extp binding
+@deffnx {Scheme Procedure} binding:index binding
+@deffnx {Scheme Procedure} binding:start binding
+@deffnx {Scheme Procedure} binding:end binding
+Bindings annotations for programs, along with their accessors.
+
+Bindings declare names and liveness extents for block-local variables.
+The best way to see what these are is to play around with them at a
+REPL. The only tricky bit is that @var{extp} is a boolean, declaring
+whether the binding is heap-allocated or not. @xref{VM Concepts}, for
+more information.
+
+Note that bindings information are stored in a program as part of its
+metadata thunk, so including them in the generated object code does
+not impose a runtime performance penalty.
+@end deffn
+
+@deffn {Scheme Procedure} program-sources program
+@deffnx {Scheme Procedure} source:addr source
+@deffnx {Scheme Procedure} source:line source
+@deffnx {Scheme Procedure} source:column source
+@deffnx {Scheme Procedure} source:file source
+Source location annotations for programs, along with their accessors.
+
+Source location information propagates through the compiler and ends
+up being serialized to the program's metadata. This information is
+keyed by the offset of the instruction pointer within the object code
+of the program. Specifically, it is keyed on the @code{ip} @emph{just
+following} an instruction, so that backtraces can find the source
+location of a call that is in progress.
+@end deffn
+
+@deffn {Scheme Procedure} program-properties program
+Return the properties of a @code{program} as an association list,
+keyed by property name (a symbol). 
+
+Some interesting properties include:
+@itemize
+@item @code{name}, the name of the procedure
+@item @code{documentation}, the procedure's docstring
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} program-property program name
+Access a program's property by name, returning @code{#f} if not found.
+@end deffn
+
+@deffn {Scheme Procedure} program-documentation program
+@deffnx {Scheme Procedure} program-name program
+Accessors for specific properties.
+@end deffn
+
 @node Optional Arguments
 @subsection Optional Arguments
 

doc/ref/compiler.texi

@@ -0,0 +1,698 @@
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C)  2008
+@c   Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Compiling to the Virtual Machine
+@section Compiling to the Virtual Machine
+
+Compilers have a mystique about them that is attractive and
+off-putting at the same time. They are attractive because they are
+magical -- they transform inert text into live results, like throwing
+the switch on Frankenstein's monster. However, this magic is perceived
+by many to be impenetrable.
+
+This section aims to pay attention to the small man behind the
+curtain.
+
+@xref{Read/Load/Eval/Compile}, if you're lost and you just wanted to
+know how to compile your .scm file.
+
+@menu
+* Compiler Tower::                   
+* The Scheme Compiler::                   
+* GHIL::                 
+* GLIL::                
+* Object Code::                   
+* Extending the Compiler::
+@end menu
+
+@node Compiler Tower
+@subsection Compiler Tower
+
+Guile's compiler is quite simple, actually -- its @emph{compilers}, to
+put it more accurately. Guile defines a tower of languages, starting
+at Scheme and progressively simplifying down to languages that
+resemble the VM instruction set (@pxref{Instruction Set}).
+
+Each language knows how to compile to the next, so each step is simple
+and understandable. Furthermore, this set of languages is not
+hardcoded into Guile, so it is possible for the user to add new
+high-level languages, new passes, or even different compilation
+targets.
+
+Languages are registered in the module, @code{(system base language)}:
+
+@example
+(use-modules (system base language))
+@end example
+
+They are registered with the @code{define-language} form.
+
+@deffn {Scheme Syntax} define-language @
+name title version reader printer @
+[parser=#f] [read-file=#f] [compilers='()] [evaluator=#f]
+Define a language.
+
+This syntax defines a @code{#<language>} object, bound to @var{name}
+in the current environment. In addition, the language will be added to
+the global language set. For example, this is the language definition
+for Scheme:
+
+@example
+(define-language scheme
+  #:title	"Guile Scheme"
+  #:version	"0.5"
+  #:reader	read
+  #:read-file	read-file
+  #:compilers   `((,ghil . ,compile-ghil))
+  #:evaluator	(lambda (x module) (primitive-eval x))
+  #:printer	write)
+@end example
+
+In this example, from @code{(language scheme spec)}, @code{read-file}
+reads expressions from a port and wraps them in a @code{begin} block.
+@end deffn
+
+The interesting thing about having languages defined this way is that
+they present a uniform interface to the read-eval-print loop. This
+allows the user to change the current language of the REPL:
+
+@example
+$ guile
+Guile Scheme interpreter 0.5 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+scheme@@(guile-user)> ,language ghil
+Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+ghil@@(guile-user)> 
+@end example
+
+Languages can be looked up by name, as they were above.
+
+@deffn {Scheme Procedure} lookup-language name
+Looks up a language named @var{name}, autoloading it if necessary.
+
+Languages are autoloaded by looking for a variable named @var{name} in
+a module named @code{(language @var{name} spec)}.
+
+The language object will be returned, or @code{#f} if there does not
+exist a language with that name.
+@end deffn
+
+Defining languages this way allows us to programmatically determine
+the necessary steps for compiling code from one language to another.
+
+@deffn {Scheme Procedure} lookup-compilation-order from to
+Recursively traverses the set of languages to which @var{from} can
+compile, depth-first, and return the first path that can transform
+@var{from} to @var{to}. Returns @code{#f} if no path is found.
+
+This function memoizes its results in a cache that is invalidated by
+subsequent calls to @code{define-language}, so it should be quite
+fast.
+@end deffn
+
+There is a notion of a ``current language'', which is maintained in
+the @code{*current-language*} fluid. This language is normally Scheme,
+and may be rebound by the user. The run-time compilation interfaces
+(@pxref{Read/Load/Eval/Compile}) also allow you to choose other source
+and target languages.
+
+The normal tower of languages when compiling Scheme goes like this:
+
+@itemize
+@item Scheme, which we know and love
+@item Guile High Intermediate Language (GHIL)
+@item Guile Low Intermediate Language (GLIL)
+@item Object code
+@end itemize
+
+Object code may be serialized to disk directly, though it has a cookie
+and version prepended to the front. But when compiling Scheme at
+run time, you want a Scheme value, e.g. a compiled procedure. For this
+reason, so as not to break the abstraction, Guile defines a fake
+language, @code{value}. Compiling to @code{value} loads the object
+code into a procedure, and wakes the sleeping giant.
+
+Perhaps this strangeness can be explained by example:
+@code{compile-file} defaults to compiling to object code, because it
+produces object code that has to live in the barren world outside the
+Guile runtime; but @code{compile} defaults to compiling to
+@code{value}, as its product re-enters the Guile world.
+
+Indeed, the process of compilation can circulate through these
+different worlds indefinitely, as shown by the following quine:
+
+@example
+((lambda (x) ((compile x) x)) '(lambda (x) ((compile x) x)))
+@end example
+
+@node The Scheme Compiler
+@subsection The Scheme Compiler
+
+The job of the Scheme compiler is to expand all macros and to resolve
+all symbols to lexical variables. Its target language, GHIL, is fairly
+close to Scheme itself, so this process is not very complicated.
+
+The Scheme compiler is driven by a table of @dfn{translators},
+declared with the @code{define-scheme-translator} form, defined in the
+module, @code{(language scheme compile-ghil)}.
+
+@deffn {Scheme Syntax} define-scheme-translator head clause1 clause2...
+The best documentation of this form is probably an example. Here is
+the translator for @code{if}:
+
+@example
+(define-scheme-translator 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))))
+@end example
+
+The match syntax is from the @code{pmatch} macro, defined in
+@code{(system base pmatch)}. The result of a clause should be a valid
+GHIL value. If no clause matches, a syntax error is signalled.
+
+In the body of the clauses, the following bindings are introduced:
+@itemize
+@item @code{e}, the current environment
+@item @code{l}, the current source location (or @code{#f})
+@item @code{retrans}, a procedure that may be called to compile
+subexpressions
+@end itemize
+
+Note that translators are looked up by @emph{value}, not by name. That
+is to say, the translator is keyed under the @emph{value} of
+@code{if}, which normally prints as @code{#<primitive-builtin-macro!
+if>}.
+@end deffn
+
+Users can extend the compiler by defining new translators.
+Additionally, some forms can be inlined directly to
+instructions -- @xref{Inlined Scheme Instructions}, for a list. The
+actual inliners are defined in @code{(language scheme inline)}:
+
+@deffn {Scheme Syntax} define-inline head arity1 result1 arity2 result2...
+Defines an inliner for @code{head}. As in
+@code{define-scheme-translator}, inliners are keyed by value and not
+by name.
+
+Expressions are matched on their arities. For example:
+
+@example
+(define-inline eq?
+  (x y) (eq? x y))
+@end example
+
+This inlines calls to the Scheme procedure, @code{eq?}, to the
+instruction @code{eq?}.
+
+A more complicated example would be:
+
+@example
+(define-inline +
+  () 0
+  (x) x
+  (x y) (add x y)
+  (x y . rest) (add x (+ y . rest)))
+@end example
+@end deffn
+
+Compilers take two arguments, an expression and an environment, and
+return two values as well: an expression in the target language, and
+an environment suitable for the target language. The format of the
+environment is language-dependent.
+
+For Scheme, an environment may be one of three things:
+@itemize
+@item @code{#f}, in which case compilation is performed in the context
+of the current module;
+@item a module, which specifies the context of the compilation; or
+@item a @dfn{compile environment}, which specifies lexical variables
+as well.
+@end itemize
+
+The format of a compile environment for scheme is @code{(@var{module}
+@var{lexicals} . @var{externals})}, though users are strongly
+discouraged from constructing these environments themselves. Instead,
+if you need this functionality -- as in GOOPS' dynamic method compiler
+-- capture an environment with @code{compile-time-environment}, then
+pass that environment to @code{compile}.
+
+@deffn {Scheme Procedure} compile-time-environment
+A special function known to the compiler that, when compiled, will
+return a representation of the lexical environment in place at compile
+time. Useful for supporting some forms of dynamic compilation. Returns
+@code{#f} if called from the interpreter.
+@end deffn
+
+@node GHIL
+@subsection GHIL
+
+Guile High Intermediate Language (GHIL) is a structured intermediate
+language that is close in expressive power to Scheme. It is an
+expanded, pre-analyzed Scheme.
+
+GHIL is ``structured'' in the sense that its representation is based
+on records, not S-expressions. This gives a rigidity to the language
+that ensures that compiling to a lower-level language only requires a
+limited set of transformations. Practically speaking, consider the
+GHIL type, @code{<ghil-quote>}, which has fields named @code{env},
+@code{loc}, and @code{exp}. Instances of this type are records created
+via @code{make-ghil-quote}, and whose fields are accessed as
+@code{ghil-quote-env}, @code{ghil-quote-loc}, and
+@code{ghil-quote-exp}. There is also a predicate, @code{ghil-quote?}.
+@xref{Records}, for more information on records.
+
+Expressions of GHIL name their environments explicitly, and all
+variables are referenced by identity in addition to by name.
+@code{(language ghil)} defines a number of routines to deal explicitly
+with variables and environments:
+
+@deftp {Scheme Variable} <ghil-toplevel-env> [table='()]
+A toplevel environment. The @var{table} holds all toplevel variables
+that have been resolved in this environment.
+@end deftp
+@deftp {Scheme Variable} <ghil-env> parent [table='()] [variables='()]
+A lexical environment. @var{parent} will be the enclosing lexical
+environment, or a toplevel environment. @var{table} holds an alist
+mapping symbols to variables bound in this environment, while
+@var{variables} holds a cumulative list of all variables ever defined
+in this environment.
+
+Lexical environments correspond to procedures. Bindings introduced
+e.g. by Scheme's @code{let} add to the bindings in a lexical
+environment. An example of a case in which a variable might be in
+@var{variables} but not in @var{table} would be a variable that is in
+the same procedure, but is out of scope.
+@end deftp
+@deftp {Scheme Variable} <ghil-var> env name kind [index=#f]
+A variable. @var{kind} is one of @code{argument}, @code{local},
+@code{external}, @code{toplevel}, @code{public}, or @code{private};
+see the procedures below for more information. @var{index} is used in
+compilation.
+@end deftp
+
+@deffn {Scheme Procedure} ghil-var-is-bound? env sym
+Recursively look up a variable named @var{sym} in @var{env}, and
+return it or @code{#f} if none is found.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-for-ref! env sym
+Recursively look up a variable named @var{sym} in @var{env}, and
+return it. If the symbol was not bound, return a new toplevel
+variable.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-for-set! env sym
+Like @code{ghil-var-for-ref!}, except that the returned variable will
+be marked as @code{external}. @xref{Variables and the VM}.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-define! toplevel-env sym
+Return an existing or new toplevel variable named @var{sym}.
+@var{toplevel-env} must be a toplevel environment.
+@end deffn
+@deffn {Scheme Procedure} ghil-var-at-module! env modname sym interface?
+Return a variable that will be resolved at run-time with respect to a
+specific module named @var{modname}. If @var{interface?} is true, the
+variable will be of type @code{public}, otherwise @code{private}.
+@end deffn
+@deffn {Scheme Procedure} call-with-ghil-environment env syms func
+Bind @var{syms} to fresh variables within a new lexical environment
+whose parent is @var{env}, and call @var{func} as @code{(@var{func}
+@var{new-env} @var{new-vars})}.
+@end deffn
+@deffn {Scheme Procedure} call-with-ghil-bindings env syms func
+Like @code{call-with-ghil-environment}, except the existing
+environment @var{env} is re-used. For that reason, @var{func} is
+invoked as @code{(@var{func} @var{new-vars})}
+@end deffn
+
+In the aforementioned @code{<ghil-quote>} type, the @var{env} slot
+holds a pointer to the environment in which the expression occurs. The
+@var{loc} slot holds source location information, so that errors
+corresponding to this expression can be mapped back to the initial
+expression in the higher-level language, e.g. Scheme. @xref{Compiled
+Procedures}, for more information on source location objects.
+
+GHIL also has a declarative serialization format, which makes writing
+and reading it a tractable problem for the human mind. Since all GHIL
+language constructs contain @code{env} and @code{loc} pointers, they
+are left out of the serialization. (Serializing @code{env} structures
+would be difficult, as they are often circular.) What is left is the
+type of expression, and the remaining slots defined in the expression
+type.
+
+For example, an S-expression representation of the @code{<ghil-quote>}
+expression would be:
+
+@example
+(quote 3)
+@end example
+
+It's deceptively like Scheme. The general rule is, for a type defined
+as @code{<ghil-@var{foo}> env loc @var{slot1} @var{slot2}...}, the
+S-expression representation will be @code{(@var{foo} @var{slot1}
+@var{slot2}...)}. Users may program with this format directly at the
+REPL:
+
+@example
+scheme@@(guile-user)> ,language ghil
+Guile High Intermediate Language (GHIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+ghil@@(guile-user)> (call (ref +) (quote 32) (quote 10))
+@result{} 42
+@end example
+
+For convenience, some slots are serialized as rest arguments; those
+are noted below. The other caveat is that variables are serialized as
+their names only, and not their identities.
+
+@deftp {Scheme Variable} <ghil-void> env loc
+The unspecified value.
+@end deftp
+@deftp {Scheme Variable} <ghil-quote> env loc exp
+A quoted expression.
+
+Note that unlike in Scheme, there are no self-quoting expressions; all
+constants must come from @code{quote} expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-quasiquote> env loc exp
+A quasiquoted expression. The expression is treated as a constant,
+except for embedded @code{unquote} and @code{unquote-splicing} forms.
+@end deftp
+@deftp {Scheme Variable} <ghil-unquote> env loc exp
+Like Scheme's @code{unquote}; only valid within a quasiquote.
+@end deftp
+@deftp {Scheme Variable} <ghil-unquote-splicing> env loc exp
+Like Scheme's @code{unquote-splicing}; only valid within a quasiquote.
+@end deftp
+@deftp {Scheme Variable} <ghil-ref> env loc var
+A variable reference. Note that for purposes of serialization,
+@var{var} is serialized as its name, as a symbol.
+@end deftp
+@deftp {Scheme Variable} <ghil-set> env loc var val
+A variable mutation. @var{var} is serialized as a symbol.
+@end deftp
+@deftp {Scheme Variable} <ghil-define> env loc var val
+A toplevel variable definition. See @code{ghil-var-define!}.
+@end deftp
+@deftp {Scheme Variable} <ghil-if> env loc test then else
+A conditional. Note that @var{else} is not optional.
+@end deftp
+@deftp {Scheme Variable} <ghil-and> env loc . exps
+Like Scheme's @code{and}.
+@end deftp
+@deftp {Scheme Variable} <ghil-or> env loc . exps
+Like Scheme's @code{or}.
+@end deftp
+@deftp {Scheme Variable} <ghil-begin> env loc . body
+Like Scheme's @code{begin}.
+@end deftp
+@deftp {Scheme Variable} <ghil-bind> env loc vars exprs . body
+Like a deconstructed @code{let}: each element of @var{vars} will be
+bound to the corresponding GHIL expression in @var{exprs}.
+
+Note that for purposes of the serialization format, @var{exprs} are
+evaluated before the new bindings are added to the environment. For
+@code{letrec} semantics, there also exists a @code{bindrec} parse
+flavor. This is useful for writing GHIL at the REPL, but the
+serializer does not currently have the cleverness needed to determine
+whether a @code{<ghil-bind>} has @code{let} or @code{letrec}
+semantics, and thus only serializes @code{<ghil-bind>} as @code{bind}.
+@end deftp
+@deftp {Scheme Variable} <ghil-mv-bind> env loc vars rest producer . body
+Like Scheme's @code{receive} -- binds the values returned by
+applying @code{producer}, which should be a thunk, to the
+@code{lambda}-like bindings described by @var{vars} and @var{rest}.
+@end deftp
+@deftp {Scheme Variable} <ghil-lambda> env loc vars rest meta . body
+A closure. @var{vars} is the argument list, serialized as a list of
+symbols. @var{rest} is a boolean, which is @code{#t} iff the last
+argument is a rest argument. @var{meta} is an association list of
+properties. The actual @var{body} should be a list of GHIL
+expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-call> env loc proc . args
+A procedure call.
+@end deftp
+@deftp {Scheme Variable} <ghil-mv-call> env loc producer consumer
+Like Scheme's @code{call-with-values}.
+@end deftp
+@deftp {Scheme Variable} <ghil-inline> env loc op . args
+An inlined VM instruction. @var{op} should be the instruction name as
+a symbol, and @var{args} should be its arguments, as GHIL expressions.
+@end deftp
+@deftp {Scheme Variable} <ghil-values> env loc . values
+Like Scheme's @code{values}.
+@end deftp
+@deftp {Scheme Variable} <ghil-values*> env loc . values
+@var{values} are as in the Scheme expression, @code{(apply values .
+@var{vals})}.
+@end deftp
+@deftp {Scheme Variable} <ghil-reified-env> env loc
+Produces, at run-time, a reification of the environment at compile
+time. Used in the implementation of Scheme's
+@code{compile-time-environment}.
+@end deftp
+
+GHIL implements a compiler to GLIL that recursively traverses GHIL
+expressions, writing out GLIL expressions into a linear list. The
+compiler also keeps some state as to whether the current expression is
+in tail context, and whether its value will be used in future
+computations. This state allows the compiler not to emit code for
+constant expressions that will not be used (e.g. docstrings), and to
+perform tail calls when in tail position.
+
+Just as the Scheme to GHIL compiler introduced new hidden state---the
+environment---the GHIL to GLIL compiler introduces more state, the
+stack. While not represented explicitly, the stack is present in the
+compilation of each GHIL expression: compiling a GHIL expression
+should leave the run-time value stack in the same state. For example,
+if the intermediate value stack has two elements before evaluating an
+@code{if} expression, it should have two elements after that
+expression.
+
+Interested readers are encouraged to read the implementation in
+@code{(language ghil compile-glil)} for more details.
+
+@node GLIL
+@subsection GLIL
+
+Guile Low Intermediate Language (GLIL) is a structured intermediate
+language whose expressions closely mirror the functionality of Guile's
+VM instruction set.
+
+Its expression types are defined in @code{(language glil)}, and as
+with GHIL, some of its fields parse as rest arguments.
+
+@deftp {Scheme Variable} <glil-program> nargs nrest nlocs nexts meta . body
+A unit of code that at run-time will correspond to a compiled
+procedure. @var{nargs} @var{nrest} @var{nlocs}, and @var{nexts}
+collectively define the program's arity; see @ref{Compiled
+Procedures}, for more information. @var{meta} should be an alist of
+properties, as in @code{<ghil-lambda>}. @var{body} is a list of GLIL
+expressions.
+@end deftp
+@deftp {Scheme Variable} <glil-bind> . vars
+An advisory expression that notes a liveness extent for a set of
+variables. @var{vars} is a list of @code{(@var{name} @var{type}
+@var{index})}, where @var{type} should be either @code{argument},
+@code{local}, or @code{external}.
+
+@code{<glil-bind>} expressions end up being serialized as part of a
+program's metadata and do not form part of a program's code path.
+@end deftp
+@deftp {Scheme Variable} <glil-mv-bind> vars rest
+A multiple-value binding of the values on the stack to @var{vars}. Iff
+@var{rest} is true, the last element of @var{vars} will be treated as
+a rest argument.
+
+In addition to pushing a binding annotation on the stack, like
+@code{<glil-bind>}, an expression is emitted at compilation time to
+make sure that there are enough values available to bind. See the
+notes on @code{truncate-values} in @ref{Procedural Instructions}, for
+more information.
+@end deftp
+@deftp {Scheme Variable} <glil-unbind>
+Closes the liveness extent of the most recently encountered
+@code{<glil-bind>} or @code{<glil-mv-bind>} expression. As GLIL
+expressions are compiled, a parallel stack of live bindings is
+maintained; this expression pops off the top element from that stack.
+
+Bindings are written into the program's metadata so that debuggers and
+other tools can determine the set of live local variables at a given
+offset within a VM program.
+@end deftp
+@deftp {Scheme Variable} <glil-source> loc
+Records source information for the preceding expression. @var{loc}
+should be a vector, @code{#(@var{line} @var{column} @var{filename})}.
+@end deftp
+@deftp {Scheme Variable} <glil-void>
+Pushes the unspecified value on the stack.
+@end deftp
+@deftp {Scheme Variable} <glil-const> obj
+Pushes a constant value onto the stack. @var{obj} must be a number,
+string, symbol, keyword, boolean, character, or a pair or vector or
+list thereof, or the empty list.
+@end deftp
+@deftp {Scheme Variable} <glil-argument> op index
+Accesses an argument on the stack. If @var{op} is @code{ref}, the
+argument is pushed onto the stack; if it is @code{set}, the argument
+is set from the top value on the stack, which is popped off.
+@end deftp
+@deftp {Scheme Variable} <glil-local> op index
+Like @code{<glil-argument>}, but for local variables. @xref{Stack
+Layout}, for more information.
+@end deftp
+@deftp {Scheme Variable} <glil-external> op depth index
+Accesses a heap-allocated variable, addressed by @var{depth}, the nth
+enclosing environment, and @var{index}, the variable's position within
+the environment. @var{op} is @code{ref} or @code{set}.
+@end deftp
+@deftp {Scheme Variable} <glil-toplevel> op name
+Accesses a toplevel variable. @var{op} may be @code{ref}, @code{set},
+or @code{define}.
+@end deftp
+@deftp {Scheme Variable} <glil-module> op mod name public?
+Accesses a variable within a specific module. See
+@code{ghil-var-at-module!}, for more information.
+@end deftp
+@deftp {Scheme Variable} <glil-label> label
+Creates a new label. @var{label} can be any Scheme value, and should
+be unique.
+@end deftp
+@deftp {Scheme Variable} <glil-branch> inst label
+Branch to a label. @var{label} should be a @code{<ghil-label>}.
+@code{inst} is a branching instruction: @code{br-if}, @code{br}, etc.
+@end deftp
+@deftp {Scheme Variable} <glil-call> inst nargs
+This expression is probably misnamed, as it does not correspond to
+function calls. @code{<glil-call>} invokes the VM instruction named
+@var{inst}, noting that it is called with @var{nargs} stack arguments.
+The arguments should be pushed on the stack already. What happens to
+the stack afterwards depends on the instruction.
+@end deftp
+@deftp {Scheme Variable} <glil-mv-call> nargs ra
+Performs a multiple-value call. @var{ra} is a @code{<glil-label>}
+corresponding to the multiple-value return address for the call. See
+the notes on @code{mv-call} in @ref{Procedural Instructions}, for more
+information.
+@end deftp
+
+Users may enter in GLIL at the REPL as well, though there is a bit
+more bookkeeping to do. Since GLIL needs the set of variables to be
+declared explicitly in a @code{<glil-program>}, GLIL expressions must
+be wrapped in a thunk that declares the arity of the expression:
+
+@example
+scheme@@(guile-user)> ,language glil
+Guile Lowlevel Intermediate Language (GLIL) interpreter 0.3 on Guile 1.9.0
+Copyright (C) 2001-2008 Free Software Foundation, Inc.
+
+Enter `,help' for help.
+glil@@(guile-user)> (program 0 0 0 0 () (const 3) (call return 0))
+@result{} 3
+@end example
+
+Just as in all of Guile's compilers, an environment is passed to the
+GLIL-to-object code compiler, and one is returned as well, along with
+the object code.
+
+@node Object Code
+@subsection Object Code
+
+Object code is the serialization of the raw instruction stream of a
+program, ready for interpretation by the VM. Procedures related to
+object code are defined in the @code{(system vm objcode)} module.
+
+@deffn {Scheme Procedure} objcode? obj
+@deffnx {C Function} scm_objcode_p (obj)
+Returns @code{#f} iff @var{obj} is object code, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} bytecode->objcode bytecode nlocs nexts
+@deffnx {C Function} scm_bytecode_to_objcode (bytecode, nlocs, nexts)
+Makes a bytecode object from @var{bytecode}, which should be a
+@code{u8vector}. @var{nlocs} and @var{nexts} denote the number of
+stack and heap variables to reserve when this objcode is executed.
+@end deffn
+
+@deffn {Scheme Variable} load-objcode file
+@deffnx {C Function} scm_load_objcode (file)
+Load object code from a file named @var{file}. The file will be mapped
+into memory via @code{mmap}, so this is a very fast operation.
+
+On disk, object code has an eight-byte cookie prepended to it, so that
+we will not execute arbitrary garbage. In addition, two more bytes are
+reserved for @var{nlocs} and @var{nexts}.
+@end deffn
+
+@deffn {Scheme Variable} objcode->u8vector objcode
+@deffnx {C Function} scm_objcode_to_u8vector (objcode)
+Copy object code out to a @code{u8vector} for analysis by Scheme. The
+ten-byte header is included.
+@end deffn
+
+@deffn {Scheme Variable} objcode->program objcode [external='()]
+@deffnx {C Function} scm_objcode_to_program (objcode, external)
+Load up object code into a Scheme program. The resulting program will
+be a thunk that captures closure variables from @var{external}.
+@end deffn
+
+Object code from a file may be disassembled at the REPL via the
+meta-command @code{,disassemble-file}, abbreviated as @code{,xx}.
+Programs may be disassembled via @code{,disassemble}, abbreviated as
+@code{,x}.
+
+Compiling object code to the fake language, @code{value}, is performed
+via loading objcode into a program, then executing that thunk with
+respect to the compilation environment. Normally the environment
+propagates through the compiler transparently, but users may specify
+the compilation environment manually as well:
+
+@deffn {Scheme Procedure} make-objcode-env module externals
+Make an object code environment. @var{module} should be a Scheme
+module, and @var{externals} should be a list of external variables.
+@code{#f} is also a valid object code environment.
+@end deffn
+
+@node Extending the Compiler
+@subsection Extending the Compiler
+
+At this point, we break with the impersonal tone of the rest of the
+manual, and make an intervention. Admit it: if you've read this far
+into the compiler internals manual, you are a junkie. Perhaps a course
+at your university left you unsated, or perhaps you've always harbored
+a sublimated desire to hack the holy of computer science holies: a
+compiler. Well you're in good company, and in a good position. Guile's
+compiler needs your help.
+
+There are many possible avenues for improving Guile's compiler.
+Probably the most important improvement, speed-wise, will be some form
+of native compilation, both just-in-time and ahead-of-time. This could
+be done in many ways. Probably the easiest strategy would be to extend
+the compiled procedure structure to include a pointer to a native code
+vector, and compile from bytecode to native code at run-time after a
+procedure is called a certain number of times.
+
+The name of the game is a profiling-based harvest of the low-hanging
+fruit, running programs of interest under a system-level profiler and
+determining which improvements would give the most bang for the buck.
+There are many well-known efficiency hacks in the literature: Dybvig's
+letrec optimization, individual boxing of heap-allocated values (and
+then store the boxes on the stack directory), optimized case-lambda
+expressions, stack underflow and overflow handlers, etc. Highly
+recommended papers: Dybvig's HOCS, Ghuloum's compiler paper.
+
+The compiler also needs help at the top end, enhancing the Scheme that
+it knows to also understand R6RS, and adding new high-level compilers:
+Emacs Lisp, Lua, JavaScript...

doc/ref/data-rep.texi

@@ -4,135 +4,6 @@
 @c   Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
-@c essay \input texinfo
-@c essay @c -*-texinfo-*-
-@c essay @c %**start of header
-@c essay @setfilename data-rep.info
-@c essay @settitle Data Representation in Guile
-@c essay @c %**end of header
-
-@c essay @include version.texi
-
-@c essay @dircategory The Algorithmic Language Scheme
-@c essay @direntry
-@c essay * data-rep: (data-rep).  Data Representation in Guile --- how to use
-@c essay                 Guile objects in your C code.
-@c essay @end direntry
-
-@c essay @setchapternewpage off
-
-@c essay @ifinfo
-@c essay Data Representation in Guile
-
-@c essay Copyright (C) 1998, 1999, 2000, 2003, 2006 Free Software Foundation
-
-@c essay Permission is granted to make and distribute verbatim copies of
-@c essay this manual provided the copyright notice and this permission notice
-@c essay are preserved on all copies.
-
-@c essay @ignore
-@c essay Permission is granted to process this file through TeX and print the
-@c essay results, provided the printed document carries copying permission
-@c essay notice identical to this one except for the removal of this paragraph
-@c essay (this paragraph not being relevant to the printed manual).
-@c essay @end ignore
-
-@c essay Permission is granted to copy and distribute modified versions of this
-@c essay manual under the conditions for verbatim copying, provided that the entire
-@c essay resulting derived work is distributed under the terms of a permission
-@c essay notice identical to this one.
-
-@c essay Permission is granted to copy and distribute translations of this manual
-@c essay into another language, under the above conditions for modified versions,
-@c essay except that this permission notice may be stated in a translation approved
-@c essay by the Free Software Foundation.
-@c essay @end ifinfo
-
-@c essay @titlepage
-@c essay @sp 10
-@c essay @comment The title is printed in a large font.
-@c essay @title Data Representation in Guile
-@c essay @subtitle $Id: data-rep.texi,v 1.20 2006-04-16 23:11:15 kryde Exp $
-@c essay @subtitle For use with Guile @value{VERSION}
-@c essay @author Jim Blandy
-@c essay @author Free Software Foundation
-@c essay @author @email{jimb@@red-bean.com}
-@c essay @c The following two commands start the copyright page.
-@c essay @page
-@c essay @vskip 0pt plus 1filll
-@c essay @vskip 0pt plus 1filll
-@c essay Copyright @copyright{} 1998, 2006 Free Software Foundation
-
-@c essay Permission is granted to make and distribute verbatim copies of
-@c essay this manual provided the copyright notice and this permission notice
-@c essay are preserved on all copies.
-
-@c essay Permission is granted to copy and distribute modified versions of this
-@c essay manual under the conditions for verbatim copying, provided that the entire
-@c essay resulting derived work is distributed under the terms of a permission
-@c essay notice identical to this one.
-
-@c essay Permission is granted to copy and distribute translations of this manual
-@c essay into another language, under the above conditions for modified versions,
-@c essay except that this permission notice may be stated in a translation approved
-@c essay by Free Software Foundation.
-@c essay @end titlepage
-
-@c essay @c @smallbook
-@c essay @c @finalout
-@c essay @headings double
-
-
-@c essay @node Top, Data Representation in Scheme, (dir), (dir)
-@c essay @top Data Representation in Guile
-
-@c essay @ifinfo
-@c essay This essay is meant to provide the background necessary to read and
-@c essay write C code that manipulates Scheme values in a way that conforms to
-@c essay libguile's interface.  If you would like to write or maintain a
-@c essay Guile-based application in C or C++, this is the first information you
-@c essay need.
-
-@c essay In order to make sense of Guile's @code{SCM_} functions, or read
-@c essay libguile's source code, it's essential to have a good grasp of how Guile
-@c essay actually represents Scheme values.  Otherwise, a lot of the code, and
-@c essay the conventions it follows, won't make very much sense.
-
-@c essay We assume you know both C and Scheme, but we do not assume you are
-@c essay familiar with Guile's C interface.
-@c essay @end ifinfo
-
-
-@node Data Representation
-@appendix Data Representation in Guile
-
-@strong{by Jim Blandy}
-
-[Due to the rather non-orthogonal and performance-oriented nature of the
-SCM interface, you need to understand SCM internals *before* you can use
-the SCM API.  That's why this chapter comes first.]
-
-[NOTE: this is Jim Blandy's essay almost entirely unmodified.  It has to
-be adapted to fit this manual smoothly.]
-
-In order to make sense of Guile's SCM_ functions, or read libguile's
-source code, it's essential to have a good grasp of how Guile actually
-represents Scheme values.  Otherwise, a lot of the code, and the
-conventions it follows, won't make very much sense.  This essay is meant
-to provide the background necessary to read and write C code that
-manipulates Scheme values in a way that is compatible with libguile.
-
-We assume you know both C and Scheme, but we do not assume you are
-familiar with Guile's implementation.
-
-@menu
-* Data Representation in Scheme::       Why things aren't just totally
-                                        straightforward, in general terms.
-* How Guile does it::                   How to write C code that manipulates
-                                        Guile values, with an explanation
-                                        of Guile's garbage collector.
-@end menu
-
 @node Data Representation in Scheme
 @section Data Representation in Scheme
 
@@ -159,8 +30,8 @@ The following sections will present a simple typing system, and then
 make some refinements to correct its major weaknesses.  However, this is
 not a description of the system Guile actually uses.  It is only an
 illustration of the issues Guile's system must address.  We provide all
-the information one needs to work with Guile's data in @ref{How Guile
-does it}.
+the information one needs to work with Guile's data in @ref{The
+Libguile Runtime Environment}.
 
 
 @menu
@@ -423,22 +294,21 @@ significant loss of efficiency, but the simplified system would still be
 more complex than what we've presented above.
 
 
-@node How Guile does it
-@section How Guile does it
+@node The Libguile Runtime Environment
+@section The Libguile Runtime Environment
 
 Here we present the specifics of how Guile represents its data.  We
 don't go into complete detail; an exhaustive description of Guile's
 system would be boring, and we do not wish to encourage people to write
 code which depends on its details anyway.  We do, however, present
-everything one need know to use Guile's data.
+everything one need know to use Guile's data. It is assumed that the
+reader understands the concepts laid out in @ref{Data Representation
+in Scheme}.
 
-This section is in limbo.  It used to document the 'low-level' C API
-of Guile that was used both by clients of libguile and by libguile
-itself.
-
-In the future, clients should only need to look into the sections
-@ref{Programming in C} and @ref{API Reference}.  This section will in
-the end only contain stuff about the internals of Guile.
+FIXME: much of this is outdated as of 1.8, we don't provide many of
+these macros any more. Also here we're missing sections about the
+evaluator implementation, which is interesting, and notes about tail
+recursion between scheme and c.
 
 @menu
 * General Rules::               
@@ -1127,7 +997,7 @@ This reference can be decoded to a C pointer to a heap cell using the
 @code{SCM} value is done using the @code{PTR2SCM} macro.
 
 @c (FIXME:: this name should be changed)
-@deftypefn Macro (scm_t_cell *) SCM2PTR (SCM @var{x})
+@deftypefn Macro {scm_t_cell *} SCM2PTR (SCM @var{x})
 Extract and return the heap cell pointer from a non-immediate @code{SCM}
 object @var{x}.
 @end deftypefn

doc/ref/guile.texi

@@ -177,11 +177,12 @@ x
 
 * Guile Modules::
 
+* Guile Implementation::
+
 * Autoconf Support::
 
 Appendices
 
-* Data Representation::             All the details.
 * GNU Free Documentation License::  The license of this manual.
 
 Indices
@@ -252,7 +253,9 @@ different ways to design a program around Guile, or how to embed Guile
 into existing programs.
 
 There is also a pedagogical yet detailed explanation of how the data
-representation of Guile is implemented, @xref{Data Representation}.
+representation of Guile is implemented, see @ref{Data Representation in
+Scheme} and @ref{The Libguile Runtime Environment}.
+
 You don't need to know the details given there to use Guile from C,
 but they are useful when you want to modify Guile itself or when you
 are just curious about how it is all done.
@@ -298,7 +301,7 @@ available through both Scheme and C interfaces.
 * Binding Constructs::          Definitions and variable bindings.
 * Control Mechanisms::          Controlling the flow of program execution.
 * Input and Output::            Ports, reading and writing.
-* Read/Load/Eval::              Reading and evaluating Scheme code.
+* Read/Load/Eval/Compile::      Reading and evaluating Scheme code.
 * Memory Management::           Memory management and garbage collection.
 * Objects::                     Low level object orientation support.
 * Modules::                     Designing reusable code libraries.
@@ -362,9 +365,45 @@ available through both Scheme and C interfaces.
 @include scsh.texi
 @include scheme-debugging.texi
 
+@node Guile Implementation
+@chapter Guile Implementation
+
+At some point, after one has been programming in Scheme for some time,
+another level of Scheme comes into view: its implementation. Knowledge
+of how Scheme can be implemented turns out to be necessary to become
+an expert hacker. As Peter Norvig notes in his retrospective on
+PAIP@footnote{PAIP is the common abbreviation for @cite{Paradigms of
+Artificial Intelligence Programming}, an old but still useful text on
+Lisp. Norvig's retrospective sums up the lessons of PAIP, and can be
+found at @uref{http://norvig.com/Lisp-retro.html}.}, ``The expert Lisp
+programmer eventually develops a good `efficiency model'.''
+
+By this Norvig means that over time, the Lisp hacker eventually
+develops an understanding of how much her code ``costs'' in terms of
+space and time.
+
+This chapter describes Guile as an implementation of Scheme: its
+history, how it represents and evaluates its data, and its compiler.
+This knowledge can help you to make that step from being one who is
+merely familiar with Scheme to being a real hacker.
+
+@menu
+* History::                             A brief history of Guile.
+* Data Representation in Scheme::       Why things aren't just totally
+                                        straightforward, in general terms.
+* The Libguile Runtime Environment::    Low-level details on Guile's C
+                                        runtime library.
+* A Virtual Machine for Guile::         How compiled procedures work.
+* Compiling to the Virtual Machine::    Not as hard as you might think.
+@end menu
+
+@include history.texi
+@include data-rep.texi
+@include vm.texi
+@include compiler.texi
+
 @include autoconf.texi
 
-@include data-rep.texi
 @include fdl.texi
 
 @iftex

doc/ref/history.texi

@@ -0,0 +1,285 @@
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C)  2008
+@c   Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node History
+@section A Brief History of Guile
+
+Guile is an artifact of historical processes, both as code and as a
+community of hackers. It is sometimes useful to know this history when
+hacking the source code, to know about past decisions and future
+directions.
+
+Of course, the real history of Guile is written by the hackers hacking
+and not the writers writing, so we round up the section with a note on
+current status and future directions.
+
+@menu
+* The Emacs Thesis::  
+* Early Days::                  
+* A Scheme of Many Maintainers::  
+* A Timeline of Selected Guile Releases::  
+* Status::
+@end menu
+
+@node The Emacs Thesis
+@subsection The Emacs Thesis
+
+The story of Guile is the story of bringing the development experience
+of Emacs to the mass of programs on a GNU system.
+
+Emacs, when it was first created in its GNU form in 1984, was a new
+take on the problem of ``how to make a program''. The Emacs thesis is
+that it is delightful to create composite programs based on an
+orthogonal kernel written in a low-level language together with a
+powerful, high-level extension language.
+
+Extension languages foster extensible programs, programs which adapt
+readily to different users and to changing times. Proof of this can be
+seen in Emacs' current and continued existence, spanning more than a
+quarter-century.
+
+Besides providing for modification of a program by others, extension
+languages are good for @emph{intension} as well. Programs built in
+``the Emacs way'' are pleasurable and easy for their authors to flesh
+out with the features that they need.
+
+After the Emacs experience was appreciated more widely, a number of
+hackers started to consider how to spread this experience to the rest
+of the GNU system. It was clear that the easiest way to Emacsify a
+program would be to embed a shared language implementation into it.
+
+@node Early Days
+@subsection Early Days
+
+Tom Lord was the first to fully concentrate his efforts on an
+embeddable language runtime, which he named ``GEL'', the GNU Extension
+Language.
+
+GEL was the product of converting SCM, Aubrey Jaffer's implementation
+of Scheme, into something more appropriate to embedding as a library.
+(SCM was itself based on an implementation by George Carrette, SIOD.)
+
+Lord managed to convince Richard Stallman to dub GEL the official
+extension language for the GNU project. It was a natural fit, given
+that Scheme was a cleaner, more modern Lisp than Emacs Lisp. Part of
+the argument was that eventually when GEL became more capable, it
+could gain the ability to execute other languages, especially Emacs
+Lisp.
+
+Due to a naming conflict with another programming language, Jim Blandy
+suggested a new name for GEL: ``Guile''. Besides being a recursive
+acroymn, ``Guile'' craftily follows the naming of its ancestors,
+``Planner'', ``Conniver'', and ``Schemer''. (The latter was truncated
+to ``Scheme'' due to a 6-character file name limit on an old operating
+system.) Finally, ``Guile'' suggests ``guy-ell'', or ``Guy L.
+Steele'', who, together with Gerald Sussman, originally discovered
+Scheme.
+
+Around the same time that Guile (then GEL) was readying itself for
+public release, another extension language was gaining in popularity,
+Tcl. Many developers found advantages in Tcl because of its shell-like
+syntax and its well-developed graphical widgets library, Tk. Also, at
+the time there was a large marketing push promoting Tcl as a
+``universal extension language''.
+
+Richard Stallman, as the primary author of GNU Emacs, had a particular
+vision of what extension languages should be, and Tcl did not seem to
+him to be as capable as Emacs Lisp. He posted a criticism to the
+comp.lang.tcl newsgroup, sparking one of the internet's legendary
+flamewars. As part of these discussions, retrospectively dubbed the
+``Tcl Wars'', he announced the Free Software Foundation's intent to
+promote Guile as the extension language for the GNU project.
+
+It is a common misconception that Guile was created as a reaction to
+Tcl. While it is true that the public announcement of Guile happened
+at the same time as the ``Tcl wars'', Guile was created out of a
+condition that existed outside the polemic. Indeed, the need for a
+powerful language to bridge the gap between extension of existing
+applications and a more fully dynamic programming environment is still
+with us today.
+
+@node A Scheme of Many Maintainers
+@subsection A Scheme of Many Mantainers
+
+Surveying the field, it seems that Scheme implementations correspond
+with their maintainers on an N-to-1 relationship. That is to say, that
+those people that implement Schemes might do so on a number of
+occasions, but that the lifetime of a given Scheme is tied to the
+maintainership of one individual.
+
+Guile is atypical in this regard.
+
+Tom Lord maintaned Guile for its first year and a half or so,
+corresponding to the end of 1994 through the middle of 1996. The
+releases made in this time constitute an arc from SCM as a standalone
+program to Guile as a reusable, embeddable library, but passing
+through a explosion of features: embedded Tcl and Tk, a toolchain for
+compiling and disassembling Java, addition of a C-like syntax,
+creation of a module system, and a start at a rich POSIX interface.
+
+Only some of those features remain in Guile. There were ongoing
+tensions between providing a small, embeddable language, and one which
+had all of the features (e.g. a graphical toolkit) that a modern Emacs
+might need. In the end, as Guile gained in uptake, the development
+team decided to focus on depth, documentation and orthogonality rather
+than on breadth. This has been the focus of Guile ever since, although
+there is a wide range of third-party libraries for Guile.
+
+Jim Blandy presided over that period of stabilization, in the three
+years until the end of 1999, when he too moved on to other projects.
+Since then, Guile has had a group maintainership. The first group was
+Maciej Stachowiak, Mikael Djurfeldt, and Marius Vollmer, with Vollmer
+staying on the longest. By late 2007, Vollmer had mostly moved on to
+other things, so Neil Jerram and Ludovic Courtès stepped up to take on
+the primary maintenance responsibility.
+
+Of course, a large part of the actual work on Guile has come from
+other contributors too numerous to mention, but without whom the world
+would be a poorer place.
+
+@node A Timeline of Selected Guile Releases
+@subsection A Timeline of Selected Guile Releases
+
+@table @asis
+@item guile-i --- 4 February 1995
+SCM, turned into a library.
+
+@item guile-ii --- 6 April 1995
+A low-level module system was added. Tcl/Tk support was added,
+allowing extension of Scheme by Tcl or vice versa. POSIX support was
+improved, and there was an experimental stab at Java integration.
+
+@item guile-iii --- 18 August 1995
+The C-like syntax, ctax, was improved, but mostly this release
+featured a start at the task of breaking Guile into pieces.
+
+@item 1.0 --- 5 January 1997
+@code{#f} was distinguished from @code{'()}. User-level, cooperative
+multi-threading was added. Source-level debugging became more useful,
+and programmer's and user's manuals were begun. The module system
+gained a high-level interface, which is still used today in more or
+less the same form.
+
+@item 1.1 --- 16 May 1997
+@itemx 1.2 --- 24 June 1997
+Support for Tcl/Tk and ctax were split off as separate packages, and
+have remained there since. Guile became more compatible with SCSH, and
+more useful as a UNIX scripting language. Libguile can now be built as
+a shared library, and third-party extensions written in C became
+loadable via dynamic linking.
+
+@item 1.3.0 --- 19 October 1998
+Command-line editing became much more pleasant through the use of the
+readline library. The initial support for internationalization via
+multi-byte strings was removed, and has yet to be added back, though
+UTF-8 hacks are common. Modules gained the ability to have custom
+expanders, which is still used for syntax-case macros. Initial Emacs
+Lisp support landed, ports gained better support for file descriptors,
+and fluids were added.
+
+@item 1.3.2 --- 20 August 1999
+@itemx 1.3.4 --- 25 September 1999
+@itemx 1.4 --- 21 June 2000
+A long list of lispy features were added: hooks, Common Lisp's
+@code{format}, optional and keyword procedure arguments,
+@code{getopt-long}, sorting, random numbers, and many other fixes and
+enhancements. Guile now has an interactive debugger, interactive help,
+and gives better backtraces.
+
+@item 1.6 --- 6 September 2002
+Guile gained support for the R5RS standard, and added a number of SRFI
+modules. The module system was expanded with programmatic support for
+identifier selection and renaming. The GOOPS object system was merged
+into Guile core.
+
+@item 1.8 --- 20 February 2006
+Guile's arbitrary-precision arithmetic switched to use the GMP
+library, and added support for exact rationals. Guile's embedded
+user-space threading was removed in favor of POSIX pre-emptive
+threads, providing true multiprocessing. Gettext support was added,
+and Guile's C API was cleaned up and orthogonalized in a massive way.
+
+@item 2.0 --- thus far, only unstable snapshots available
+A virtual machine was added to Guile, along with the associated
+compiler and toolchain. Support for internationalization was added.
+Running Guile instances became controllable and debuggable from within
+Emacs, via GDS, which was also backported to 1.8.5. An SRFI-18
+interface to multithreading was added, including thread cancellation.
+@end table
+
+@node Status
+@subsection Status, or: Your Help Needed
+
+Guile has achieved much of what it set out to achieve, but there is
+much remaining to do.
+
+There is still the old problem of bringing existing applications into
+a more Emacs-like experience. Guile has had some successes in this
+respect, but still most applications in the GNU system are without
+Guile integration.
+
+Getting Guile to those applications takes an investment, the
+``hacktivation energy'' needed to wire Guile into a program that only
+pays off once it is good enough to enable new kinds of behavior. This
+would be a great way for new hackers to contribute: take an
+application that you use and that you know well, think of something
+that it can't yet do, and figure out a way to integrate Guile and
+implement that task in Guile.
+
+With time, perhaps this exposure can reverse itself, whereby programs
+can run under Guile instead of vice versa, eventually resulting in the
+Emacsification of the entire GNU system. Indeed, this is the reason
+for the naming of the many Guile modules that live in the @code{ice-9}
+namespace, a nod to the fictional substance in Kurt Vonnegut's
+novel, Cat's Cradle, capable of acting as a seed crystal to
+crystallize the mass of software.
+
+Implicit to this whole discussion is the idea that dynamic languages
+are somehow better than languages like C. While languages like C have
+their place, Guile's take on this question is that yes, Scheme is more
+expressive than C, and more fun to write. This realization carries an
+imperative with it to write as much code in Scheme as possible rather
+than in other languages.
+
+These days it is possible to write extensible applications almost
+entirely from high-level languages, through byte-code and native
+compilation, speed gains in the underlying hardware, and foreign call
+interfaces in the high-level language. Smalltalk systems are like
+this, as are Common Lisp-based systems. While there already are a
+number of pure-Guile applications out there, users still need to drop
+down to C for some tasks: interfacing to system libraries that don't
+have prebuilt Guile interfaces, and for some tasks requiring high
+performance.
+
+The addition of the virtual machine in Guile 2.0, together with the
+compiler infrastructure, should go a long way to addressing the speed
+issues. But there is much optimization to be done. Interested
+contributors will find lots of delightful low-hanging fruit, from
+simple profile-driven optimization to hacking a just-in-time compiler
+from VM bytecode to native code.
+
+Still, even with an all-Guile application, sometimes you want to
+provide an opportunity for users to extend your program from a
+language with a syntax that is closer to C, or to Python. Another
+interesting idea to consider is compiling e.g. Python to Guile. It's
+not that far-fetched of an idea: see for example IronPython or JRuby.
+
+And then there's Emacs itself. Though there is a somewhat-working
+Emacs Lisp translator for Guile, it cannot yet execute all of Emacs
+Lisp. A serious integration of Guile with Emacs would replace the
+Elisp virtual machine with Guile, and provide the necessary C shims so
+that Guile could emulate Emacs' C API. This would give lots of
+exciting things to Emacs: native threads, a real object system, more
+sophisticated types, cleaner syntax, and access to all of the Guile
+extensions.
+
+Finally, there is another axis of crystallization, the axis between
+different Scheme implementations. Guile does not yet support the
+latest Scheme standard, R6RS, and should do so. Like all standards,
+R6RS is imperfect, but supporting it will allow more code to run on
+Guile without modification, and will allow Guile hackers to produce
+code compatible with other schemes. Help in this regard would be much
+appreciated.

doc/ref/libguile-concepts.texi

@@ -153,8 +153,8 @@ that have been added to Guile by third-party libraries.
 
 Also, computing with @code{SCM} is not necessarily inefficient.  Small
 integers will be encoded directly in the @code{SCM} value, for example,
-and do not need any additional memory on the heap.  See @ref{Data
-Representation} to find out the details.
+and do not need any additional memory on the heap.  See @ref{The
+Libguile Runtime Environment} to find out the details.
 
 Some special @code{SCM} values are available to C code without needing
 to convert them from C values:
@@ -170,8 +170,8 @@ In addition to @code{SCM}, Guile also defines the related type
 @code{scm_t_bits}.  This is an unsigned integral type of sufficient
 size to hold all information that is directly contained in a
 @code{SCM} value.  The @code{scm_t_bits} type is used internally by
-Guile to do all the bit twiddling explained in @ref{Data
-Representation}, but you will encounter it occasionally in low-level
+Guile to do all the bit twiddling explained in @ref{The Libguile
+Runtime Environment}, but you will encounter it occasionally in low-level
 user code as well.
 
 

doc/ref/libguile-smobs.texi

@@ -517,10 +517,10 @@ Smobs are called smob because they are small: they normally have only
 room for one @code{void*} or @code{SCM} value plus 16 bits.  The
 reason for this is that smobs are directly implemented by using the
 low-level, two-word cells of Guile that are also used to implement
-pairs, for example.  (@pxref{Data Representation} for the details.)
-One word of the two-word cells is used for @code{SCM_SMOB_DATA} (or
-@code{SCM_SMOB_OBJECT}), the other contains the 16-bit type tag and
-the 16 extra bits.
+pairs, for example.  (@pxref{The Libguile Runtime Environment} for the
+details.)  One word of the two-word cells is used for
+@code{SCM_SMOB_DATA} (or @code{SCM_SMOB_OBJECT}), the other contains
+the 16-bit type tag and the 16 extra bits.
 
 In addition to the fundamental two-word cells, Guile also has
 four-word cells, which are appropriately called @dfn{double cells}.

doc/ref/vm.texi

@@ -0,0 +1,919 @@
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C)  2008,2009
+@c   Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node A Virtual Machine for Guile
+@section A Virtual Machine for Guile
+
+Guile has both an interpreter and a compiler. To a user, the
+difference is largely transparent---interpreted and compiled
+procedures can call each other as they please.
+
+The difference is that the compiler creates and interprets bytecode
+for a custom virtual machine, instead of interpreting the
+S-expressions directly. Running compiled code is faster than running
+interpreted code.
+
+The virtual machine that does the bytecode interpretation is a part of
+Guile itself. This section describes the nature of Guile's virtual
+machine.
+
+@menu
+* Why a VM?::                   
+* VM Concepts::                 
+* Stack Layout::                
+* Variables and the VM::                   
+* VM Programs::         
+* Instruction Set::
+@end menu
+
+@node Why a VM?
+@subsection Why a VM?
+
+@cindex interpreter
+@cindex evaluator
+For a long time, Guile only had an interpreter, called the
+@dfn{evaluator}. Guile's evaluator operates directly on the
+S-expression representation of Scheme source code.
+
+But while the evaluator is highly optimized and hand-tuned, and
+contains some extensive speed trickery (@pxref{Memoization}), it still
+performs many needless computations during the course of evaluating an
+expression. For example, application of a function to arguments
+needlessly conses up the arguments in a list. Evaluation of an
+expression always has to figure out what the car of the expression is
+-- a procedure, a memoized form, or something else. All values have to
+be allocated on the heap. Et cetera.
+
+The solution to this problem is to compile the higher-level language,
+Scheme, into a lower-level language for which all of the checks and
+dispatching have already been done---the code is instead stripped to
+the bare minimum needed to ``do the job''.
+
+The question becomes then, what low-level language to choose? There
+are many options. We could compile to native code directly, but that
+poses portability problems for Guile, as it is a highly cross-platform
+project.
+
+So we want the performance gains that compilation provides, but we
+also want to maintain the portability benefits of a single code path.
+The obvious solution is to compile to a virtual machine that is
+present on all Guile installations.
+
+The easiest (and most fun) way to depend on a virtual machine is to
+implement the virtual machine within Guile itself. This way the
+virtual machine provides what Scheme needs (tail calls, multiple
+values, @code{call/cc}) and can provide optimized inline instructions
+for Guile (@code{cons}, @code{struct-ref}, etc.).
+
+So this is what Guile does. The rest of this section describes that VM
+that Guile implements, and the compiled procedures that run on it.
+
+Note that this decision to implement a bytecode compiler does not
+preclude native compilation. We can compile from bytecode to native
+code at runtime, or even do ahead of time compilation. More
+possibilities are discussed in @ref{Extending the Compiler}.
+
+@node VM Concepts
+@subsection VM Concepts
+
+A virtual machine (VM) is a Scheme object. Users may create virtual
+machines using the standard procedures described later in this manual,
+but that is usually unnecessary, as Guile ensures that there is one
+virtual machine per thread. When a VM-compiled procedure is run, Guile
+looks up the virtual machine for the current thread and executes the
+procedure using that VM.
+
+Guile's virtual machine is a stack machine---that is, it has few
+registers, and the instructions defined in the VM operate by pushing
+and popping values from a stack.
+
+Stack memory is exclusive to the virtual machine that owns it. In
+addition to their stacks, virtual machines also have access to the
+global memory (modules, global bindings, etc) that is shared among
+other parts of Guile, including other VMs.
+
+A VM has generic instructions, such as those to reference local
+variables, and instructions designed to support Guile's languages --
+mathematical instructions that support the entire numerical tower, an
+inlined implementation of @code{cons}, etc.
+
+The registers that a VM has are as follows:
+
+@itemize
+@item ip - Instruction pointer
+@item sp - Stack pointer
+@item fp - Frame pointer
+@end itemize
+
+In other architectures, the instruction pointer is sometimes called
+the ``program counter'' (pc). This set of registers is pretty typical
+for stack machines; their exact meanings in the context of Guile's VM
+is described in the next section.
+
+A virtual machine executes by loading a compiled procedure, and
+executing the object code associated with that procedure. Of course,
+that procedure may call other procedures, tail-call others, ad
+infinitum---indeed, within a guile whose modules have all been
+compiled to object code, one might never leave the virtual machine.
+
+@c wingo: I wish the following were true, but currently we just use
+@c the one engine. This kind of thing is possible tho.
+
+@c A VM may have one of three engines: reckless, regular, or debugging.
+@c Reckless engine is fastest but dangerous.  Regular engine is normally
+@c fail-safe and reasonably fast.  Debugging engine is safest and
+@c functional but very slow.
+
+@node Stack Layout
+@subsection Stack Layout
+
+While not strictly necessary to understand how to work with the VM, it
+is instructive and sometimes entertaining to consider the struture of
+the VM stack.
+
+Logically speaking, a VM stack is composed of ``frames''. Each frame
+corresponds to the application of one compiled procedure, and contains
+storage space for arguments, local variables, intermediate values, and
+some bookkeeping information (such as what to do after the frame
+computes its value).
+
+While the compiler is free to do whatever it wants to, as long as the
+semantics of a computation are preserved, in practice every time you
+call a function, a new frame is created. (The notable exception of
+course is the tail call case, @pxref{Tail Calls}.)
+
+Within a frame, you have the data associated with the function
+application itself, which is of a fixed size, and the stack space for
+intermediate values. Sometimes only the former is referred to as the
+``frame'', and the latter is the ``stack'', although all pending
+application frames can have some intermediate computations interleaved
+on the stack.
+
+The structure of the fixed part of an application frame is as follows:
+
+@example
+             Stack
+   |                  | <- fp + bp->nargs + bp->nlocs + 4
+   +------------------+    = SCM_FRAME_UPPER_ADDRESS (fp)
+   | Return address   |
+   | MV return address|
+   | Dynamic 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)
+   |                  |
+@end example
+
+In the above drawing, the stack grows upward. The intermediate values
+stored in the application of this frame are stored above
+@code{SCM_FRAME_UPPER_ADDRESS (fp)}. @code{bp} refers to the
+@code{struct scm_program*} data associated with the program at
+@code{fp - 1}. @code{nargs} and @code{nlocs} are properties of the
+compiled procedure, which will be discussed later.
+
+The individual fields of the frame are as follows:
+
+@table @asis
+@item Return address
+The @code{ip} that was in effect before this program was applied. When
+we return from this activation frame, we will jump back to this
+@code{ip}.
+
+@item MV return address
+The @code{ip} to return to if this application returns multiple
+values. For continuations that only accept one value, this value will
+be @code{NULL}; for others, it will be an @code{ip} that points to a
+multiple-value return address in the calling code. That code will
+expect the top value on the stack to be an integer---the number of
+values being returned---and that below that integer there are the
+values being returned.
+
+@item Dynamic link
+This is the @code{fp} in effect before this program was applied. In
+effect, this and the return address are the registers that are always
+``saved''.
+
+@item External link
+This field is a reference to the list of heap-allocated variables
+associated with this frame. For a discussion of heap versus stack
+allocation, @xref{Variables and the VM}.
+
+@item Local variable @var{n}
+Lambda-local variables that are allocated on the stack are all
+allocated as part of the frame. This makes access to non-captured,
+non-mutated variables very cheap.
+
+@item Argument @var{n}
+The calling convention of the VM requires arguments of a function
+application to be pushed on the stack, and here they are. Normally
+references to arguments dispatch to these locations on the stack.
+However if an argument has to be stored on the heap, it will be copied
+from its initial value here onto a location in the heap, and
+thereafter only referenced on the heap.
+
+@item Program
+This is the program being applied. For more information on how
+programs are implemented, @xref{VM Programs}.
+@end table
+
+@node Variables and the VM
+@subsection Variables and the VM
+
+Let's think about the following Scheme code as an example:
+
+@example
+  (define (foo a)
+    (lambda (b) (list foo a b)))
+@end example
+
+Within the lambda expression, "foo" is a top-level variable, "a" is a
+lexically captured variable, and "b" is a local variable.
+
+That is to say: @code{b} may safely be allocated on the stack, as
+there is no enclosed procedure that references it, nor is it ever
+mutated.
+
+@code{a}, on the other hand, is referenced by an enclosed procedure,
+that of the lambda. Thus it must be allocated on the heap, as it may
+(and will) outlive the dynamic extent of the invocation of @code{foo}.
+
+@code{foo} is a toplevel variable, as mandated by Scheme's semantics:
+
+@example
+  (define proc (foo 'bar)) ; assuming prev. definition of @code{foo}
+  (define foo 42)          ; redefinition
+  (proc 'baz)
+  @result{} (42 bar baz)
+@end example
+
+Note that variables that are mutated (via @code{set!}) must be
+allocated on the heap, even if they are local variables. This is
+because any called subprocedure might capture the continuation, which
+would need to capture locations instead of values. Thus perhaps
+counterintuitively, what would seem ``closer to the metal'', viz
+@code{set!}, actually forces heap allocation instead of stack
+allocation.
+
+@node VM Programs
+@subsection Compiled Procedures are VM Programs
+
+By default, when you enter in expressions at Guile's REPL, they are
+first compiled to VM object code, then that VM object code is executed
+to produce a value. If the expression evaluates to a procedure, the
+result of this process is a compiled procedure.
+
+A compiled procedure is a compound object, consisting of its bytecode,
+a reference to any captured lexical variables, an object array, and
+some metadata such as the procedure's arity, name, and documentation.
+You can pick apart these pieces with the accessors in @code{(system vm
+program)}. @xref{Compiled Procedures}, for a full API reference.
+
+@cindex object table
+The object array of a compiled procedure, also known as the
+@dfn{object table}, holds all Scheme objects whose values are known
+not to change across invocations of the procedure: constant strings,
+symbols, etc. The object table of a program is initialized right
+before a program is loaded with @code{load-program}.
+@xref{Loading Instructions}, for more information.
+
+Variable objects are one such type of constant object: when a global
+binding is defined, a variable object is associated to it and that
+object will remain constant over time, even if the value bound to it
+changes. Therefore, toplevel bindings only need to be looked up once.
+Thereafter, references to the corresponding toplevel variables from
+within the program are then performed via the @code{toplevel-ref}
+instruction, which uses the object vector, and are almost as fast as
+local variable references.
+
+We can see how these concepts tie together by disassembling the
+@code{foo} function to see what is going on:
+
+@smallexample
+scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b)))
+scheme@@(guile-user)> ,x foo
+Disassembly of #<program foo (a)>:
+
+Bytecode:
+
+   0    (local-ref 0)                   ;; `a' (arg)
+   2    (external-set 0)                ;; `a' (arg)
+   4    (object-ref 0)                  ;; #<program #(0 28 #f) (b)>
+   6    (make-closure)                                        at (unknown file):0:16
+   7    (return)                        
+
+----------------------------------------
+Disassembly of #<program #(0 28 #f) (b)>:
+
+Bytecode:
+
+   0    (toplevel-ref 0)                ;; `list'
+   2    (toplevel-ref 1)                ;; `foo'
+   4    (external-ref 0)                ;; (closure variable)
+   6    (local-ref 0)                   ;; `b' (arg)
+   8    (goto/args 3)                                         at (unknown file):0:28
+@end smallexample
+
+At @code{ip} 0 and 2, we do the copy from argument to heap for
+@code{a}. @code{Ip} 4 loads up the compiled lambda, and then at
+@code{ip} 6 we make a closure---binding code (from the compiled
+lambda) with data (the heap-allocated variables). Finally we return
+the closure.
+
+The second stanza disassembles the compiled lambda. Toplevel variables
+are resolved relative to the module that was current when the
+procedure was created. This lookup occurs lazily, at the first time
+the variable is actually referenced, and the location of the lookup is
+cached so that future references are very cheap. @xref{Environment
+Control Instructions}, for more details.
+
+Then we see a reference to an external variable, corresponding to
+@code{a}. The disassembler doesn't have enough information to give a
+name to that variable, so it just marks it as being a ``closure
+variable''. Finally we see the reference to @code{b}, then a tail call
+(@code{goto/args}) with three arguments.
+
+@node Instruction Set
+@subsection Instruction Set
+
+There are about 100 instructions in Guile's virtual machine. These
+instructions represent atomic units of a program's execution. Ideally,
+they perform one task without conditional branches, then dispatch to
+the next instruction in the stream.
+
+Instructions themselves are one byte long. Some instructions take
+parameters, which follow the instruction byte in the instruction
+stream.
+
+Sometimes the compiler can figure out that it is compiling a special
+case that can be run more efficiently. So, for example, while Guile
+offers a generic test-and-branch instruction, it also offers specific
+instructions for special cases, so that the following cases all have
+their own test-and-branch instructions:
+
+@example
+(if pred then else)
+(if (not pred) then else)
+(if (null? l) then else)
+(if (not (null? l)) then else)
+@end example
+
+In addition, some Scheme primitives have their own inline
+implementations, e.g. @code{cons}.
+
+So Guile's instruction set is a @emph{complete} instruction set, in
+that it provides the instructions that are suited to the problem, and
+is not concerned with making a minimal, orthogonal set of
+instructions. More instructions may be added over time.
+
+@menu
+* Environment Control Instructions::  
+* Branch Instructions::         
+* Loading Instructions::  
+* Procedural Instructions::  
+* Data Control Instructions::   
+* Miscellaneous Instructions::  
+* Inlined Scheme Instructions::  
+* Inlined Mathematical Instructions::  
+@end menu
+
+@node Environment Control Instructions
+@subsubsection Environment Control Instructions
+
+These instructions access and mutate the environment of a compiled
+procedure---the local bindings, the ``external'' bindings, and the
+toplevel bindings.
+
+@deffn Instruction local-ref index
+Push onto the stack the value of the local variable located at
+@var{index} within the current stack frame.
+
+Note that arguments and local variables are all in one block. Thus the
+first argument, if any, is at index 0, and local bindings follow the
+arguments.
+@end deffn
+
+@deffn Instruction local-set index
+Pop the Scheme object located on top of the stack and make it the new
+value of the local variable located at @var{index} within the current
+stack frame.
+@end deffn
+
+@deffn Instruction external-ref index
+Push the value of the closure variable located at position
+@var{index} within the program's list of external variables.
+@end deffn
+
+@deffn Instruction external-set index
+Pop the Scheme object located on top of the stack and make it the new
+value of the closure variable located at @var{index} within the
+program's list of external variables.
+@end deffn
+
+The external variable lookup algorithm should probably be made more
+efficient in the future via addressing by frame and index. Currently,
+external variables are all consed onto a list, which results in O(N)
+lookup time.
+
+@deffn Instruction externals
+Pushes the current list of external variables onto the stack. This
+instruction is used in the implementation of
+@code{compile-time-environment}. @xref{The Scheme Compiler}.
+@end deffn
+
+@deffn Instruction toplevel-ref index
+Push the value of the toplevel binding whose location is stored in at
+position @var{index} in the object table.
+
+Initially, a cell in the object table that is used by
+@code{toplevel-ref} is initialized to one of two forms. The normal
+case is that the cell holds a symbol, whose binding will be looked up
+relative to the module that was current when the current program was
+created.
+
+Alternately, the lookup may be performed relative to a particular
+module, determined at compile-time (e.g. via @code{@@} or
+@code{@@@@}). In that case, the cell in the object table holds a list:
+@code{(@var{modname} @var{sym} @var{interface?})}. The symbol
+@var{sym} will be looked up in the module named @var{modname} (a list
+of symbols). The lookup will be performed against the module's public
+interface, unless @var{interface?} is @code{#f}, which it is for
+example when compiling @code{@@@@}.
+
+In any case, if the symbol is unbound, an error is signalled.
+Otherwise the initial form is replaced with the looked-up variable, an
+in-place mutation of the object table. This mechanism provides for
+lazy variable resolution, and an important cached fast-path once the
+variable has been successfully resolved.
+
+This instruction pushes the value of the variable onto the stack.
+@end deffn
+
+@deffn Instruction toplevel-ref index
+Pop a value off the stack, and set it as the value of the toplevel
+variable stored at @var{index} in the object table. If the variable
+has not yet been looked up, we do the lookup as in
+@code{toplevel-ref}.
+@end deffn
+
+@deffn Instruction link-now
+Pop a value, @var{x}, from the stack. Look up the binding for @var{x},
+according to the rules for @code{toplevel-ref}, and push that variable
+on the stack. If the lookup fails, an error will be signalled.
+
+This instruction is mostly used when loading programs, because it can
+do toplevel variable lookups without an object vector.
+@end deffn
+
+@deffn Instruction variable-ref
+Dereference the variable object which is on top of the stack and
+replace it by the value of the variable it represents.
+@end deffn
+
+@deffn Instruction variable-set
+Pop off two objects from the stack, a variable and a value, and set
+the variable to the value.
+@end deffn
+
+@deffn Instruction object-ref n
+Push @var{n}th value from the current program's object vector.
+@end deffn
+
+@node Branch Instructions
+@subsubsection Branch Instructions
+
+All the conditional branch instructions described below work in the
+same way:
+
+@itemize
+@item They pop off the Scheme object located on the stack and use it as
+the branch condition;
+@item If the condition is true, then the instruction pointer is
+increased by the offset passed as an argument to the branch
+instruction;
+@item Program execution proceeds with the next instruction (that is,
+the one to which the instruction pointer points).
+@end itemize
+
+Note that the offset passed to the instruction is encoded on two 8-bit
+integers which are then combined by the VM as one 16-bit integer.
+
+@deffn Instruction br offset
+Jump to @var{offset}.
+@end deffn
+
+@deffn Instruction br-if offset
+Jump to @var{offset} if the condition on the stack is not false.
+@end deffn
+
+@deffn Instruction br-if-not offset
+Jump to @var{offset} if the condition on the stack is false.
+@end deffn
+
+@deffn Instruction br-if-eq offset
+Jump to @var{offset} if the two objects located on the stack are
+equal in the sense of @var{eq?}.  Note that, for this instruction, the
+stack pointer is decremented by two Scheme objects instead of only
+one.
+@end deffn
+
+@deffn Instruction br-if-not-eq offset
+Same as @var{br-if-eq} for non-@code{eq?} objects.
+@end deffn
+
+@deffn Instruction br-if-null offset
+Jump to @var{offset} if the object on the stack is @code{'()}.
+@end deffn
+
+@deffn Instruction br-if-not-null offset
+Jump to @var{offset} if the object on the stack is not @code{'()}.
+@end deffn
+
+
+@node Loading Instructions
+@subsubsection Loading Instructions
+
+In addition to VM instructions, an instruction stream may contain
+variable-length data embedded within it. This data is always preceded
+by special loading instructions, which interpret the data and advance
+the instruction pointer to the next VM instruction.
+
+All of these loading instructions have a @code{length} parameter,
+indicating the size of the embedded data, in bytes. The length itself
+may be encoded in 1, 2, or 4 bytes.
+
+@deffn Instruction load-integer length
+@deffnx Instruction load-unsigned-integer length
+Load a 32-bit integer (respectively unsigned integer) from the
+instruction stream.
+@end deffn
+@deffn Instruction load-number length
+Load an arbitrary number from the instruction stream. The number is
+embedded in the stream as a string.
+@end deffn
+@deffn Instruction load-string length
+Load a string from the instruction stream.
+@end deffn
+@deffn Instruction load-symbol length
+Load a symbol from the instruction stream.
+@end deffn
+@deffn Instruction load-keyword length
+Load a keyword from the instruction stream.
+@end deffn
+
+@deffn Instruction define length
+Load a symbol from the instruction stream, and look up its binding in
+the current toplevel environment, creating the binding if necessary.
+Push the variable corresponding to the binding.
+@end deffn
+
+@deffn Instruction load-program length
+Load bytecode from the instruction stream, and push a compiled
+procedure. This instruction pops the following values from the stack:
+
+@itemize
+@item Optionally, a thunk, which when called should return metadata
+associated with this program---for example its name, the names of its
+arguments, its documentation string, debugging information, etc.
+
+Normally, this thunk its itself a compiled procedure (with no
+metadata). Metadata is represented this way so that the initial load
+of a procedure is fast: the VM just mmap's the thunk and goes. The
+symbols and pairs associated with the metadata are only created if the
+user asks for them.
+
+For information on the format of the thunk's return value,
+@xref{Compiled Procedures}.
+@item Optionally, the program's object table, as a vector.
+
+A program that does not reference toplevel bindings and does not use
+@code{object-ref} does not need an object table.
+@item Finally, either one immediate integer or four immediate integers
+representing the arity of the program.
+
+In the four-fixnum case, the values are respectively the number of
+arguments taken by the function (@var{nargs}), the number of @dfn{rest
+arguments} (@var{nrest}, 0 or 1), the number of local variables
+(@var{nlocs}) and the number of external variables (@var{nexts})
+(@pxref{Environment Control Instructions}).
+
+The common single-fixnum case represents all of these values within a
+16-bit bitmask.
+@end itemize
+
+The resulting compiled procedure will not have any ``external''
+variables captured, so it will be loaded only once but may be used
+many times to create closures.
+@end deffn
+
+Finally, while this instruction is not strictly a ``loading''
+instruction, it's useful to wind up the @code{load-program} discussion
+here:
+
+@deffn Instruction make-closure
+Pop the program object from the stack, capture the current set of
+``external'' variables, and assign those external variables to a copy
+of the program. Push the new program object, which shares state with
+the original program. Also captures the current module.
+@end deffn
+
+@node Procedural Instructions
+@subsubsection Procedural Instructions
+
+@deffn Instruction return
+Free the program's frame, returning the top value from the stack to
+the current continuation. (The stack should have exactly one value on
+it.)
+
+Specifically, the @code{sp} is decremented to one below the current
+@code{fp}, the @code{ip} is reset to the current return address, the
+@code{fp} is reset to the value of the current dynamic link, and then
+the top item on the stack (formerly the procedure being applied) is
+set to the returned value.
+@end deffn
+
+@deffn Instruction call nargs
+Call the procedure located at @code{sp[-nargs]} with the @var{nargs}
+arguments located from @code{sp[0]} to @code{sp[-nargs + 1]}.
+
+For non-compiled procedures (continuations, primitives, and
+interpreted procedures), @code{call} will pop the procedure and
+arguments off the stack, and push the result of calling
+@code{scm_apply}.
+
+For compiled procedures, this instruction sets up a new stack frame,
+as described in @ref{Stack Layout}, and then dispatches to the first
+instruction in the called procedure, relying on the called procedure
+to return one value to the newly-created continuation.
+@end deffn
+
+@deffn Instruction goto/args nargs
+Like @code{call}, but reusing the current continuation. This
+instruction implements tail calling as required by RnRS.
+
+For compiled procedures, that means that @code{goto/args} reuses the
+current frame instead of building a new one. The @code{goto/*}
+instruction family is named as it is because tail calls are equivalent
+to @code{goto}, along with relabeled variables.
+
+For non-VM procedures, the result is the same, but the current VM
+invocation remains on the C stack. True tail calls are not currently
+possible between compiled and non-compiled procedures.
+@end deffn
+
+@deffn Instruction apply nargs
+@deffnx Instruction goto/apply nargs
+Like @code{call} and @code{goto/args}, except that the top item on the
+stack must be a list. The elements of that list are then pushed on the
+stack and treated as additional arguments, replacing the list itself,
+then the procedure is invoked as usual.
+@end deffn
+
+@deffn Instruction call/nargs
+@deffnx Instruction goto/nargs
+These are like @code{call} and @code{goto/args}, except they take the
+number of arguments from the stack instead of the instruction stream.
+These instructions are used in the implementation of multiple value
+returns, where the actual number of values is pushed on the stack.
+@end deffn
+
+@deffn Instruction call/cc
+@deffnx Instruction goto/cc
+Capture the current continuation, and then call (or tail-call) the
+procedure on the top of the stack, with the continuation as the
+argument.
+
+Both the VM continuation and the C continuation are captured.
+@end deffn
+
+@deffn Instruction mv-call nargs offset
+Like @code{call}, except that a multiple-value continuation is created
+in addition to a single-value continuation.
+
+The offset (a two-byte value) is an offset within the instruction
+stream; the multiple-value return address in the new frame
+(@pxref{Stack Layout}) will be set to the normal return address plus
+this offset. Instructions at that offset will expect the top value of
+the stack to be the number of values, and below that values
+themselves, pushed separately.
+@end deffn
+
+@deffn Instruction return/values nvalues
+Return the top @var{nvalues} to the current continuation.
+
+If the current continuation is a multiple-value continuation,
+@code{return/values} pushes the number of values on the stack, then
+returns as in @code{return}, but to the multiple-value return address.
+
+Otherwise if the current continuation accepts only one value, i.e. the
+multiple-value return address is @code{NULL}, then we assume the user
+only wants one value, and we give them the first one. If there are no
+values, an error is signaled.
+@end deffn
+
+@deffn Instruction return/values* nvalues
+Like a combination of @code{apply} and @code{return/values}, in which
+the top value on the stack is interpreted as a list of additional
+values. This is an optimization for the common @code{(apply values
+...)} case.
+@end deffn
+
+@deffn Instruction truncate-values nbinds nrest
+Used in multiple-value continuations, this instruction takes the
+values that are on the stack (including the number-of-value marker)
+and truncates them for a binding construct.
+
+For example, a call to @code{(receive (x y . z) (foo) ...)} would,
+logically speaking, pop off the values returned from @code{(foo)} and
+push them as three values, corresponding to @code{x}, @code{y}, and
+@code{z}. In that case, @var{nbinds} would be 3, and @var{nrest} would
+be 1 (to indicate that one of the bindings was a rest arguments).
+
+Signals an error if there is an insufficient number of values.
+@end deffn
+
+@node Data Control Instructions
+@subsubsection Data Control Instructions
+
+These instructions push simple immediate values onto the stack, or
+manipulate lists and vectors on the stack.
+
+@deffn Instruction make-int8 value
+Push @var{value}, an 8-bit integer, onto the stack.
+@end deffn
+
+@deffn Instruction make-int8:0
+Push the immediate value @code{0} onto the stack.
+@end deffn
+
+@deffn Instruction make-int8:1
+Push the immediate value @code{1} onto the stack.
+@end deffn
+
+@deffn Instruction make-int16 value
+Push @var{value}, a 16-bit integer, onto the stack.
+@end deffn
+
+@deffn Instruction make-false
+Push @code{#f} onto the stack.
+@end deffn
+
+@deffn Instruction make-true
+Push @code{#t} onto the stack.
+@end deffn
+
+@deffn Instruction make-eol
+Push @code{'()} onto the stack.
+@end deffn
+
+@deffn Instruction make-char8 value
+Push @var{value}, an 8-bit character, onto the stack.
+@end deffn
+
+@deffn Instruction list n
+Pops off the top @var{n} values off of the stack, consing them up into
+a list, then pushes that list on the stack. What was the topmost value
+will be the last element in the list.
+@end deffn
+
+@deffn Instruction vector n
+Create and fill a vector with the top @var{n} values from the stack,
+popping off those values and pushing on the resulting vector.
+@end deffn
+
+@deffn Instruction mark
+Pushes a special value onto the stack that other stack instructions
+like @code{list-mark} can use.
+@end deffn
+
+@deffn Instruction list-mark
+Create a list from values from the stack, as in @code{list}, but
+instead of knowing beforehand how many there will be, keep going until
+we see a @code{mark} value.
+@end deffn
+
+@deffn Instruction cons-mark
+As the scheme procedure @code{cons*} is to the scheme procedure
+@code{list}, so the instruction @code{cons-mark} is to the instruction
+@code{list-mark}.
+@end deffn
+
+@deffn Instruction vector-mark
+Like @code{list-mark}, but makes a vector instead of a list.
+@end deffn
+
+@deffn Instruction list-break
+The opposite of @code{list}: pops a value, which should be a list, and
+pushes its elements on the stack.
+@end deffn
+
+@node Miscellaneous Instructions
+@subsubsection Miscellaneous Instructions
+
+@deffn Instruction nop
+Does nothing!
+@end deffn
+
+@deffn Instruction halt
+Exits the VM, returning a SCM value. Normally, this instruction is
+only part of the ``bootstrap program'', a program run when a virtual
+machine is first entered; compiled Scheme procedures will not contain
+this instruction.
+
+If multiple values have been returned, the SCM value will be a
+multiple-values object (@pxref{Multiple Values}).
+@end deffn
+
+@deffn Instruction break
+Does nothing, but invokes the break hook.
+@end deffn
+
+@deffn Instruction drop
+Pops off the top value from the stack, throwing it away.
+@end deffn
+
+@deffn Instruction dup
+Re-pushes the top value onto the stack.
+@end deffn
+
+@deffn Instruction void
+Pushes ``the unspecified value'' onto the stack.
+@end deffn
+
+@node Inlined Scheme Instructions
+@subsubsection Inlined Scheme Instructions
+
+The Scheme compiler can recognize the application of standard Scheme
+procedures, or unbound variables that look like they are bound to
+standard Scheme procedures. It tries to inline these small operations
+to avoid the overhead of creating new stack frames.
+
+Since most of these operations are historically implemented as C
+primitives, not inlining them would entail constantly calling out from
+the VM to the interpreter, which has some costs---registers must be
+saved, the interpreter has to dispatch, called procedures have to do
+much typechecking, etc. It's much more efficient to inline these
+operations in the virtual machine itself.
+
+All of these instructions pop their arguments from the stack and push
+their results, and take no parameters from the instruction stream.
+Thus, unlike in the previous sections, these instruction definitions
+show stack parameters instead of parameters from the instruction
+stream.
+
+@deffn Instruction not x
+@deffnx Instruction not-not x
+@deffnx Instruction eq? x y
+@deffnx Instruction not-eq? x y
+@deffnx Instruction null?
+@deffnx Instruction not-null?
+@deffnx Instruction eqv? x y
+@deffnx Instruction equal? x y
+@deffnx Instruction pair? x y
+@deffnx Instruction list? x y
+@deffnx Instruction set-car! pair x
+@deffnx Instruction set-cdr! pair x
+@deffnx Instruction slot-ref struct n
+@deffnx Instruction slot-set struct n x
+@deffnx Instruction cons x
+@deffnx Instruction car x
+@deffnx Instruction cdr x
+Inlined implementations of their Scheme equivalents.
+@end deffn
+
+Note that @code{caddr} and friends compile to a series of @code{car}
+and @code{cdr} instructions.
+
+@node Inlined Mathematical Instructions
+@subsubsection Inlined Mathematical Instructions
+
+Inlining mathematical operations has the obvious advantage of handling
+fixnums without function calls or allocations. The trick, of course,
+is knowing when the result of an operation will be a fixnum, and there
+might be a couple bugs here.
+
+More instructions could be added here over time.
+
+As in the previous section, the definitions below show stack
+parameters instead of instruction stream parameters.
+
+@deffn Instruction add x y
+@deffnx Instruction sub x y
+@deffnx Instruction mul x y
+@deffnx Instruction div x y
+@deffnx Instruction quo x y
+@deffnx Instruction rem x y
+@deffnx Instruction mod x y
+@deffnx Instruction ee? x y
+@deffnx Instruction lt? x y
+@deffnx Instruction gt? x y
+@deffnx Instruction le? x y
+@deffnx Instruction ge? x y
+Inlined implementations of the corresponding mathematical operations.
+@end deffn

gdb-pre-inst-guile.in

@@ -0,0 +1,38 @@
+#!/bin/sh
+
+#	Copyright (C) 2002, 2006, 2008 Free Software Foundation
+#
+#   This file is part of GUILE.
+#
+#   GUILE is free software; you can redistribute it and/or modify
+#   it under the terms of the GNU General Public License as
+#   published by the Free Software Foundation; either version 2, or
+#   (at your option) any later version.
+#
+#   GUILE is distributed in the hope that it will be useful, but
+#   WITHOUT ANY WARRANTY; without even the implied warranty of
+#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#   GNU General Public License for more details.
+#
+#   You should have received a copy of the GNU General Public
+#   License along with GUILE; see the file COPYING.  If not, write
+#   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+#   Floor, Boston, MA 02110-1301 USA
+
+# Commentary:
+
+# Usage: gdb-pre-inst-guile [ARGS]
+#
+# This script runs Guile from the build tree under GDB. See
+# ./pre-inst-guile for more information.
+#
+# In addition to running ./gdb-pre-inst-guile, sometimes it's useful to
+# run e.g. ./check-guile -i ./gdb-pre-inst-guile foo.test.
+
+# Code:
+
+set -e
+# env (set by configure)
+top_builddir="@top_builddir_absolute@"
+exec ${top_builddir}/pre-inst-guile-env libtool --mode=execute \
+    gdb --args ${top_builddir}/libguile/guile "$@"

gdbinit

@@ -0,0 +1,202 @@
+# -*- GDB-Script -*-
+
+define newline
+  call (void)scm_newline (scm_current_error_port ())
+end
+
+define pp
+  call (void)scm_call_1 (scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("ice-9 pretty-print"), "pretty-print")), $arg0)
+end
+
+define gdisplay
+  call (void)scm_display ($arg0, scm_current_error_port ())
+  newline
+end
+
+define gwrite
+  call (void)scm_write ($arg0, scm_current_error_port ())
+  newline
+end
+
+define sputs
+  call (void)scm_puts ($arg0, scm_current_error_port ())
+end
+
+define gslot
+  print ((SCM**)$arg0)[1][$arg1]
+end
+
+define pslot
+  gslot $arg0 $arg1
+  gwrite $
+end
+
+define lforeach
+  set $l=$arg0
+  while $l != 0x404
+    set $x=scm_car($l)
+    $arg1 $x
+    set $l = scm_cdr($l)
+  end
+end
+
+define modsum
+  modname $arg0
+  gslot $arg0 1
+  set $uses=$
+  output "uses:\n"
+  lforeach $uses modname
+end
+
+define moduses
+  pslot $arg0 1
+end
+
+define modname
+  pslot $arg0 5
+end
+
+define modkind
+  pslot $arg0 6
+end
+
+define car
+  call scm_car ($arg0)
+end
+
+define cdr
+  call scm_cdr ($arg0)
+end
+
+define smobwordtox
+  set $x=((SCM*)$arg0)[$arg1]
+end
+
+define smobdatatox
+  smobwordtox $arg0 1
+end
+
+define program_objcode
+  smobdatatox $arg0
+  set $objcode=$x
+  smobdatatox $objcode
+  p *(struct scm_objcode*)$x
+end
+
+define proglocals
+  set $i=bp->nlocs
+  while $i > 0
+    set $i=$i-1
+    gwrite fp[bp->nargs+$i]
+  end
+end
+
+define progstack
+  set $x=sp
+  while $x > stack_base
+    gwrite *$x
+    set $x=$x-1
+  end
+end
+
+define tc16
+  p ((scm_t_bits)$arg0) & 0xffff
+end
+
+define smobdescriptor
+  p scm_smobs[0xff & (((scm_t_bits)$arg0) >> 8)]
+end
+
+define vmstackinit
+  set $vmsp=sp
+  set $vmstack_base=stack_base
+  set $vmfp=fp
+  set $vmbp=bp
+  set $vmframe=0
+end
+
+define nextframe
+  set $orig_vmsp=$vmsp
+  while $vmsp > $vmstack_base
+    output $orig_vmsp - $vmsp
+    sputs "\t"
+    output $vmsp
+    sputs "\t"
+    gwrite *$vmsp
+    set $vmsp=$vmsp-1
+  end
+  newline
+  sputs "Frame "
+  output $vmframe
+  newline
+  sputs "ra:\t"
+  output $vmsp
+  sputs "\t"
+  output (SCM*)*$vmsp
+  set $vmsp=$vmsp-1
+  newline
+  sputs "mvra:\t"
+  output $vmsp
+  sputs "\t"
+  output (SCM*)*$vmsp
+  set $vmsp=$vmsp-1
+  newline
+  sputs "dl:\t"
+  output $vmsp
+  sputs "\t"
+  set $vmdl=(SCM*)(*$vmsp)
+  output $vmdl
+  newline
+  set $vmsp=$vmsp-1
+  sputs "el:\t"
+  output $vmsp
+  sputs "\t"
+  gwrite *$vmsp
+  set $vmsp=$vmsp-1
+  set $vmnlocs=(int)$vmbp->nlocs
+  while $vmnlocs > 0
+    sputs "loc #"
+    output $vmnlocs
+    sputs ":\t"
+    output $vmsp
+    sputs "\t"
+    gwrite *$vmsp
+    set $vmsp=$vmsp-1
+    set $vmnlocs=$vmnlocs-1
+  end
+  set $vmnargs=(int)$vmbp->nargs
+  while $vmnargs > 0
+    sputs "arg #"
+    output $vmnargs
+    sputs ":\t"
+    output $vmsp
+    sputs "\t"
+    gwrite *$vmsp
+    set $vmsp=$vmsp-1
+    set $vmnargs=$vmnargs-1
+  end
+  sputs "prog:\t"
+  output $vmsp
+  sputs "\t"
+  gwrite *$vmsp
+  set $vmsp=$vmsp-1
+  newline
+  if $vmdl
+    set $vmfp=$vmdl
+    set $vmbp=(struct scm_objcode*)((SCM*)(((SCM*)($vmfp[-1]))[1])[1])
+    set $vmstack_base=$vmfp+$vmbp->nargs+$vmbp->nlocs+4
+    set $vmframe=$vmframe+1
+    newline
+  end
+end
+
+define vmstack
+  vmstackinit
+  while $vmsp > vp->stack_base
+    nextframe
+  end
+end
+
+define inst
+  p scm_instruction_table[$arg0]
+end

guile-readline/ice-9/readline.scm

@@ -215,7 +215,7 @@
 			(set-buffered-input-continuation?! (readline-port) #f)
 			(set-readline-prompt! repl-prompt "... ")
 			(set-readline-read-hook! repl-read-hook))
-		      (lambda () (read))
+		      (lambda () ((or (fluid-ref current-reader) read)))
 		      (lambda ()
 			(set-readline-prompt! outer-new-input-prompt outer-continuation-prompt)
 			(set-readline-read-hook! outer-read-hook))))))

guile-tools.in

@@ -48,10 +48,13 @@ pkgdatadir="@datadir@/@PACKAGE@"
 guileversion="@GUILE_EFFECTIVE_VERSION@"
 default_scriptsdir=$pkgdatadir/$guileversion/scripts
 
+top_srcdir="@top_srcdir_absolute@"
+top_builddir="@top_builddir_absolute@"
+
 # pre-install invocation frob
-mydir=`dirname $0`
-if [ -d "$mydir/scripts" -a -f "$mydir/scripts/Makefile.am" ] ; then
-    default_scriptsdir=`(cd $mydir/scripts ; pwd)`
+mydir=$(cd $(dirname $0) && pwd)
+if [ "$mydir" = "$top_builddir" ] ; then
+    default_scriptsdir=$top_srcdir/scripts
 fi
 
 # option processing -- basically, you can override either the script dir

libguile/.gitignore

@@ -13,3 +13,4 @@ guile_filter_doc_snarfage
 libpath.h
 scmconfig.h
 version.h
+vm-i-*.i

libguile/Makefile.am

@@ -85,7 +85,7 @@ c-tokenize.$(OBJEXT): c-tokenize.c
 	if [ "$(cross_compiling)" = "yes" ]; then \
 		$(CC_FOR_BUILD) $(DEFS) $(AM_CPPFLAGS) -c -o $@ $<; \
 	else \
-		$(COMPILE) -c -o $@ $<; \
+		$(filter-out -Werror,$(COMPILE)) -c -o $@ $<; \
 	fi
 
 ## Override default rule; this should run on BUILD host.
@@ -121,6 +121,9 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c	\
     throw.c values.c variable.c vectors.c version.c vports.c weaks.c	\
     ramap.c unif.c
 
+# vm-related sources
+libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.c
+
 libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c
 libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS =	\
    $(libguile_la_CFLAGS)
@@ -144,6 +147,9 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x	\
     strports.x struct.x symbols.x threads.x throw.x values.x		\
     variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x
 
+# vm-related snarfs
+DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
+
 EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
 
 DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc		\
@@ -166,9 +172,14 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc		\
 
 EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
 
+DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
+
+.c.i:
+	grep '^VM_DEFINE' $< > $@
+
 BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \
     version.h scmconfig.h \
-    $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+    $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
 
 EXTRA_libguile_la_SOURCES = _scm.h		\
     inet_aton.c memmove.c putenv.c strerror.c	\
@@ -196,6 +207,9 @@ noinst_HEADERS = convert.i.c					\
                  win32-uname.h win32-dirent.h win32-socket.h	\
 	         private-gc.h private-options.h
 
+# vm instructions
+noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
+
 libguile_la_DEPENDENCIES = @LIBLOBJS@
 libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
 libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
@@ -224,6 +238,9 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h	\
     pthread-threads.h null-threads.h throw.h unif.h values.h		\
     variable.h vectors.h vports.h weaks.h
 
+modinclude_HEADERS += vm-bootstrap.h frames.h instructions.h objcodes.h	\
+    programs.h vm.h vm-engine.h vm-expand.h
+
 nodist_modinclude_HEADERS = version.h scmconfig.h
 
 bin_SCRIPTS = guile-snarf

libguile/backtrace.c

@@ -467,8 +467,21 @@ static void
 display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
 {
   SCM source = SCM_FRAME_SOURCE (frame);
-  *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
-  *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
+  *file = *line = SCM_BOOL_F;
+  if (SCM_MEMOIZEDP (source))
+    {
+      *file = scm_source_property (source, scm_sym_filename);
+      *line = scm_source_property (source, scm_sym_line);
+    }
+  else if (scm_is_pair (source)
+           && scm_is_pair (scm_cdr (source))
+           && scm_is_pair (scm_cddr (source))
+           && !scm_is_pair (scm_cdddr (source)))
+    {
+      /* (addr . (filename . (line . column))), from vm compilation */
+      *file = scm_cadr (source);
+      *line = scm_caddr (source);
+    }
 }
 
 static void

libguile/continuations.c

@@ -35,6 +35,7 @@
 #include "libguile/dynwind.h"
 #include "libguile/values.h"
 #include "libguile/eval.h"
+#include "libguile/vm.h"
 
 #include "libguile/validate.h"
 #include "libguile/continuations.h"
@@ -91,6 +92,7 @@ scm_make_continuation (int *first)
 #endif
   continuation->offset = continuation->stack - src;
   memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
+  continuation->vm_conts = scm_vm_capture_continuations ();
 
   *first = !setjmp (continuation->jmpbuf);
   if (*first)
@@ -169,6 +171,7 @@ copy_stack (void *data)
   copy_stack_data *d = (copy_stack_data *)data;
   memcpy (d->dst, d->continuation->stack,
 	  sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
+  scm_vm_reinstate_continuations (d->continuation->vm_conts);
 #ifdef __ia64__
   SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
 #endif

libguile/continuations.h

@@ -51,6 +51,7 @@ typedef struct
 #endif /* __ia64__ */
   size_t num_stack_items;   /* size of the saved stack.  */
   SCM root;                 /* continuation root identifier.  */
+  SCM vm_conts;             /* vm continuations (they use separate stacks) */
 
   /* The offset from the live stack location to this copy.  This is
      used to adjust pointers from within the copied stack to the stack

libguile/debug.c

@@ -42,6 +42,7 @@
 #include "libguile/root.h"
 #include "libguile/fluids.h"
 #include "libguile/objects.h"
+#include "libguile/programs.h"
 
 #include "libguile/validate.h"
 #include "libguile/debug.h"
@@ -72,7 +73,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
       SCM_OUT_OF_RANGE (1, setting);
     }
   SCM_RESET_DEBUG_MODE;
+#ifdef STACK_CHECKING
   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
   scm_debug_eframe_size = 2 * SCM_N_FRAMES;
 
   scm_dynwind_end ();
@@ -312,6 +315,8 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
 #endif
       if (scm_is_false (name) && SCM_CLOSUREP (proc))
 	name = scm_reverse_lookup (SCM_ENV (proc), proc);
+      if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+        name = scm_program_name (proc);
       return name;
     }
   }
@@ -440,8 +445,10 @@ scm_reverse_lookup (SCM env, SCM data)
   return SCM_BOOL_F;
 }
 
-SCM
-scm_start_stack (SCM id, SCM exp, SCM env)
+SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
+            (SCM id, SCM thunk),
+	    "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
+#define FUNC_NAME s_scm_sys_start_stack
 {
   SCM answer;
   scm_t_debug_frame vframe;
@@ -451,27 +458,12 @@ scm_start_stack (SCM id, SCM exp, SCM env)
   vframe.vect = &vframe_vect_body;
   vframe.vect[0].id = id;
   scm_i_set_last_debug_frame (&vframe);
-  answer = scm_i_eval (exp, env);
+  answer = scm_call_0 (thunk);
   scm_i_set_last_debug_frame (vframe.prev);
   return answer;
 }
-
-SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
-
-static SCM
-scm_m_start_stack (SCM exp, SCM env)
-#define FUNC_NAME s_start_stack
-{
-  exp = SCM_CDR (exp);
-  if (!scm_is_pair (exp) 
-      || !scm_is_pair (SCM_CDR (exp))
-      || !scm_is_null (SCM_CDDR (exp)))
-    SCM_WRONG_NUM_ARGS ();
-  return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
-}
 #undef FUNC_NAME
 
-
 /* {Debug Objects}
  *
  * The debugging evaluator throws these on frame traps.

libguile/debug.h

@@ -138,7 +138,7 @@ SCM_API scm_t_bits scm_tc16_memoized;
 SCM_API SCM scm_debug_object_p (SCM obj);
 SCM_API SCM scm_local_eval (SCM exp, SCM env);
 SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_start_stack (SCM info_id, SCM exp, SCM env);
+SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
 SCM_API SCM scm_procedure_environment (SCM proc);
 SCM_API SCM scm_procedure_source (SCM proc);
 SCM_API SCM scm_procedure_name (SCM proc);

libguile/dynwind.c

@@ -315,7 +315,7 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 		  if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 		    scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 		}
-	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+	      else if (scm_is_true (scm_thunk_p (wind_key)))
 		scm_call_0 (wind_key);
 	    }
 	}
@@ -351,7 +351,7 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 		  if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 		    scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 		}
-	      else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+	      else if (scm_is_true (scm_thunk_p (wind_key)))
 		scm_call_0 (SCM_CDR (wind_elt));
 	    }
 	}

libguile/eval.c

@@ -52,6 +52,7 @@
 #include "libguile/ports.h"
 #include "libguile/print.h"
 #include "libguile/procprop.h"
+#include "libguile/programs.h"
 #include "libguile/root.h"
 #include "libguile/smob.h"
 #include "libguile/srcprop.h"
@@ -62,6 +63,7 @@
 #include "libguile/validate.h"
 #include "libguile/values.h"
 #include "libguile/vectors.h"
+#include "libguile/vm.h"
 
 #include "libguile/eval.h"
 #include "libguile/private-options.h"
@@ -2966,7 +2968,7 @@ scm_t_option scm_debug_opts[] = {
   { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
   { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
 
-  { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
+  { SCM_OPTION_INTEGER, "stack", 40000, "Stack size limit (measured in words; 0 = no check)." },
   { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
     "Show file names and line numbers "
     "in backtraces when not `#f'.  A value of `base' "
@@ -3050,32 +3052,56 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
 SCM
 scm_call_0 (SCM proc)
 {
-  return scm_apply (proc, SCM_EOL, SCM_EOL);
+  if (SCM_PROGRAM_P (proc))
+    return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+  else
+    return scm_apply (proc, SCM_EOL, SCM_EOL);
 }
 
 SCM
 scm_call_1 (SCM proc, SCM arg1)
 {
-  return scm_apply (proc, arg1, scm_listofnull);
+  if (SCM_PROGRAM_P (proc))
+    return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+  else
+    return scm_apply (proc, arg1, scm_listofnull);
 }
 
 SCM
 scm_call_2 (SCM proc, SCM arg1, SCM arg2)
 {
-  return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+  if (SCM_PROGRAM_P (proc))
+    {
+      SCM args[] = { arg1, arg2 };
+      return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+    }
+  else
+    return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
 }
 
 SCM
 scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 {
-  return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+  if (SCM_PROGRAM_P (proc))
+    {
+      SCM args[] = { arg1, arg2, arg3 };
+      return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+    }
+  else
+    return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
 }
 
 SCM
 scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 {
-  return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
-					   scm_cons (arg4, scm_listofnull)));
+  if (SCM_PROGRAM_P (proc))
+    {
+      SCM args[] = { arg1, arg2, arg3, arg4 };
+      return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+    }
+  else
+    return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
+                                             scm_cons (arg4, scm_listofnull)));
 }
 
 /* Simple procedure applies
@@ -3663,13 +3689,23 @@ scm_closure (SCM code, SCM env)
 
 scm_t_bits scm_tc16_promise;
 
-SCM 
-scm_makprom (SCM code)
+SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, 
+	    (SCM thunk),
+	    "Create a new promise object.\n\n"
+            "@code{make-promise} is a procedural form of @code{delay}.\n"
+            "These two expressions are equivalent:\n"
+            "@lisp\n"
+	    "(delay @var{exp})\n"
+	    "(make-promise (lambda () @var{exp}))\n"
+            "@end lisp\n")
+#define FUNC_NAME s_scm_make_promise
 {
+  SCM_VALIDATE_THUNK (1, thunk);
   SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
-		       SCM_UNPACK (code),
+		       SCM_UNPACK (thunk),
 		       scm_make_recursive_mutex ());
 }
+#undef FUNC_NAME
 
 
 static int 

libguile/eval.h

@@ -162,7 +162,7 @@ SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
 SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
 SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
 SCM_API SCM scm_closure (SCM code, SCM env);
-SCM_API SCM scm_makprom (SCM code);
+SCM_API SCM scm_make_promise (SCM thunk);
 SCM_API SCM scm_force (SCM x);
 SCM_API SCM scm_promise_p (SCM x);
 SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);

libguile/eval.i.c

@@ -732,7 +732,7 @@ dispatch:
 
 
 	case (ISYMNUM (SCM_IM_DELAY)):
-	  RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
+	  RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env)));
 
 #if 0
 	  /* See futures.h for a comment why futures are not enabled.
@@ -855,9 +855,12 @@ dispatch:
 		      args = SCM_CDR (args);
 		      z = SCM_CDR (z);
 		    }
-		  /* Fewer arguments than specifiers => CAR != ENV */
-		  if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
-		    goto apply_cmethod;
+		  /* Fewer arguments than specifiers => CAR != CLASS */
+                  if (!scm_is_pair (z))
+                    goto apply_vm_cmethod;
+                  else if (!SCM_CLASSP (SCM_CAR (z))
+                           && !scm_is_symbol (SCM_CAR (z)))
+                    goto apply_memoized_cmethod;
 		next_method:
 		  hash_value = (hash_value + 1) & mask;
 		} while (hash_value != cache_end_pos);
@@ -865,13 +868,21 @@ dispatch:
 	      /* No appropriate method was found in the cache.  */
 	      z = scm_memoize_method (x, arg1);
 
-	    apply_cmethod: /* inputs: z, arg1 */
-	      {
-		SCM formals = SCM_CMETHOD_FORMALS (z);
-		env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
-		x = SCM_CMETHOD_BODY (z);
-		goto nontoplevel_begin;
-	      }
+              if (scm_is_pair (z))
+                goto apply_memoized_cmethod;
+              
+            apply_vm_cmethod:
+              proc = z;
+              PREP_APPLY (proc, arg1);
+              goto apply_proc;
+
+	    apply_memoized_cmethod: /* inputs: z, arg1 */
+              {
+                SCM formals = SCM_CMETHOD_FORMALS (z);
+                env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+                x = SCM_CMETHOD_BODY (z);
+                goto nontoplevel_begin;
+              }
 	    }
 	  }
 

libguile/frames.c

@@ -0,0 +1,316 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+
+
+scm_t_bits scm_tc16_vm_frame;
+
+#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
+
+SCM
+scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+                     scm_byte_t *ip, scm_t_ptrdiff offset)
+{
+  struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame),
+                                          "vmframe");
+  p->stack_holder = stack_holder;
+  p->fp = fp;
+  p->sp = sp;
+  p->ip = ip;
+  p->offset = offset;
+  SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p);
+}
+
+static int
+vm_frame_print (SCM frame, SCM port, scm_print_state *pstate)
+{
+  scm_puts ("#<vm-frame ", port);
+  scm_uintprint (SCM_UNPACK (frame), 16, port);
+  scm_putc (' ', port);
+  scm_write (scm_vm_frame_program (frame), port);
+  /* don't write args, they can get us into trouble. */
+  scm_puts (">", port);
+
+  return 1;
+}
+
+static SCM
+vm_frame_mark (SCM obj)
+{
+  return SCM_VM_FRAME_STACK_HOLDER (obj);
+}
+
+static scm_sizet
+vm_frame_free (SCM obj)
+{
+  struct scm_vm_frame *p = SCM_VM_FRAME_DATA (obj);
+  scm_gc_free (p, sizeof(struct scm_vm_frame), "vmframe");
+  return 0;
+}
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_p
+{
+  return SCM_BOOL (SCM_VM_FRAME_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_program
+{
+  SCM_VALIDATE_VM_FRAME (1, frame);
+  return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_arguments
+{
+  SCM *fp;
+  int i;
+  struct scm_objcode *bp;
+  SCM ret;
+  
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  fp = SCM_VM_FRAME_FP (frame);
+  bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+  if (!bp->nargs)
+    return SCM_EOL;
+  else if (bp->nrest)
+    ret = fp[bp->nargs - 1];
+  else
+    ret = scm_cons (fp[bp->nargs - 1], SCM_EOL);
+  
+  for (i = bp->nargs - 2; i >= 0; i--)
+    ret = scm_cons (fp[i], ret);
+  
+  return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_source
+{
+  SCM *fp;
+  struct scm_objcode *bp;
+  
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  fp = SCM_VM_FRAME_FP (frame);
+  bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+  return scm_c_program_source (SCM_FRAME_PROGRAM (fp),
+                               SCM_VM_FRAME_IP (frame) - bp->base);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0,
+	    (SCM frame, SCM index),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_local_ref
+{
+  SCM *fp;
+  unsigned int i;
+  struct scm_objcode *bp;
+  
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  fp = SCM_VM_FRAME_FP (frame);
+  bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+  SCM_VALIDATE_UINT_COPY (2, index, i);
+  SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+  return SCM_FRAME_VARIABLE (fp, i);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0,
+	    (SCM frame, SCM index, SCM val),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_local_set_x
+{
+  SCM *fp;
+  unsigned int i;
+  struct scm_objcode *bp;
+  
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  fp = SCM_VM_FRAME_FP (frame);
+  bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp));
+
+  SCM_VALIDATE_UINT_COPY (2, index, i);
+  SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs);
+
+  SCM_FRAME_VARIABLE (fp, i) = val;
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_return_address
+{
+  SCM_VALIDATE_VM_FRAME (1, frame);
+  return scm_from_ulong ((unsigned long)
+			 (SCM_FRAME_RETURN_ADDRESS
+			  (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_mv_return_address
+{
+  SCM_VALIDATE_VM_FRAME (1, frame);
+  return scm_from_ulong ((unsigned long)
+			 (SCM_FRAME_MV_RETURN_ADDRESS
+			  (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_dynamic_link
+{
+  SCM_VALIDATE_VM_FRAME (1, frame);
+  /* fixme: munge fp if holder is a continuation */
+  return scm_from_ulong
+    ((unsigned long)
+     RELOC (frame,
+            SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_external_link
+{
+  SCM_VALIDATE_VM_FRAME (1, frame);
+  return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
+	    (SCM frame),
+	    "")
+#define FUNC_NAME s_scm_vm_frame_stack
+{
+  SCM *top, *bottom, ret = SCM_EOL;
+
+  SCM_VALIDATE_VM_FRAME (1, frame);
+
+  top = SCM_VM_FRAME_SP (frame);
+  bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame));
+  while (bottom <= top)
+    ret = scm_cons (*bottom++, ret);
+
+  return ret;
+}
+#undef FUNC_NAME
+
+extern SCM
+scm_c_vm_frame_prev (SCM frame)
+{
+  SCM *this_fp, *new_fp, *new_sp;
+  this_fp = SCM_VM_FRAME_FP (frame);
+  new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp);
+  if (new_fp) 
+    { new_fp = RELOC (frame, new_fp);
+      new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1;
+      return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame),
+                                  new_fp, new_sp,
+                                  SCM_FRAME_RETURN_ADDRESS (this_fp),
+                                  SCM_VM_FRAME_OFFSET (frame));
+    }
+  else
+    return SCM_BOOL_F;
+}
+
+
+void
+scm_bootstrap_frames (void)
+{
+  scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
+  scm_set_smob_mark (scm_tc16_vm_frame, vm_frame_mark);
+  scm_set_smob_free (scm_tc16_vm_frame, vm_frame_free);
+  scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
+}
+
+void
+scm_init_frames (void)
+{
+  scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/frames.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/frames.h

@@ -0,0 +1,146 @@
+/* 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   |
+   | MV return address|
+   | Dynamic 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_MV_RETURN_ADDRESS(fp)				\
+  (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_DYNAMIC_LINK(fp)				\
+  (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl)		\
+  ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
+#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_vm_frame;
+
+struct scm_vm_frame 
+{
+  SCM stack_holder;
+  SCM *fp;
+  SCM *sp;
+  scm_byte_t *ip;
+  scm_t_ptrdiff offset;
+};
+
+#define SCM_VM_FRAME_P(x)	SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x)
+#define SCM_VM_FRAME_DATA(x)	((struct scm_vm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_STACK_HOLDER(f)	SCM_VM_FRAME_DATA(f)->stack_holder
+#define SCM_VM_FRAME_FP(f)	SCM_VM_FRAME_DATA(f)->fp
+#define SCM_VM_FRAME_SP(f)	SCM_VM_FRAME_DATA(f)->sp
+#define SCM_VM_FRAME_IP(f)	SCM_VM_FRAME_DATA(f)->ip
+#define SCM_VM_FRAME_OFFSET(f)	SCM_VM_FRAME_DATA(f)->offset
+#define SCM_VALIDATE_VM_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
+
+/* FIXME rename scm_byte_t */
+extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+                                scm_byte_t *ip, scm_t_ptrdiff offset);
+extern SCM scm_vm_frame_p (SCM obj);
+extern SCM scm_vm_frame_program (SCM frame);
+extern SCM scm_vm_frame_arguments (SCM frame);
+extern SCM scm_vm_frame_source (SCM frame);
+extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+extern SCM scm_vm_frame_return_address (SCM frame);
+extern SCM scm_vm_frame_mv_return_address (SCM frame);
+extern SCM scm_vm_frame_dynamic_link (SCM frame);
+extern SCM scm_vm_frame_external_link (SCM frame);
+extern SCM scm_vm_frame_stack (SCM frame);
+
+extern SCM scm_c_vm_frame_prev (SCM frame);
+
+extern void scm_bootstrap_frames (void);
+extern void scm_init_frames (void);
+
+#endif /* _SCM_FRAMES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/goops.c

@@ -59,24 +59,32 @@
 
 #define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)
 
-#define DEFVAR(v, val) \
-{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
-	    scm_module_goops); }
-/* Temporary hack until we get the new module system */
-/*fixme* Should optimize by keeping track of the variable object itself */
-#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure,  \
-						 (v), SCM_BOOL_F)))
+/* this file is a mess. in theory, though, we shouldn't have many SCM references
+   -- most of the references should be to vars. */
 
-/* Fixme: Should use already interned symbols */
+static SCM var_slot_unbound = SCM_BOOL_F;
+static SCM var_slot_missing = SCM_BOOL_F;
+static SCM var_compute_cpl = SCM_BOOL_F;
+static SCM var_no_applicable_method = SCM_BOOL_F;
+static SCM var_memoize_method_x = SCM_BOOL_F;
+static SCM var_change_class = SCM_BOOL_F;
+
+SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
+SCM_SYMBOL (sym_slot_missing, "slot-missing");
+SCM_SYMBOL (sym_compute_cpl, "compute-cpl");
+SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method");
+SCM_SYMBOL (sym_memoize_method_x, "memoize-method!");
+SCM_SYMBOL (sym_change_class, "change-class");
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+
+/* FIXME, exports should come from the scm file only */
+#define DEFVAR(v, val)                                          \
+  { scm_module_define (scm_module_goops, (v), (val));           \
+    scm_module_export (scm_module_goops, scm_list_1 ((v)));     \
+  }
 
-#define CALL_GF1(name, a)	(scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
-					     a))
-#define CALL_GF2(name, a, b)	(scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
-					     a, b))
-#define CALL_GF3(name, a, b, c)	(scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
-					     a, b, c))
-#define CALL_GF4(name, a, b, c, d)	(scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
-					     a, b, c, d))
 
 /* Class redefinition protocol:
 
@@ -119,8 +127,6 @@
 static int goops_loaded_p = 0;
 static scm_t_rstate *goops_rstate;
 
-static SCM scm_goops_lookup_closure;
-
 /* These variables are filled in by the object system when loaded. */
 SCM scm_class_boolean, scm_class_char, scm_class_pair;
 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
@@ -346,7 +352,7 @@ static SCM
 compute_cpl (SCM class)
 {
   if (goops_loaded_p)
-    return CALL_GF1 ("compute-cpl", class);
+    return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class);
   else
     {
       SCM supers = SCM_SLOT (class, scm_si_direct_supers);
@@ -588,13 +594,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
 	    {
 	      slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
 	      if (SCM_GOOPS_UNBOUNDP (slot_value))
-		{
-		  SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
-		  set_slot_value (class,
-				  obj,
-				  SCM_CAR (get_n_set),
-				  scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
-		}
+                set_slot_value (class,
+                                obj,
+                                SCM_CAR (get_n_set),
+                                scm_call_0 (tmp));
 	    }
 	}
     }
@@ -1195,7 +1198,7 @@ SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
 #define FUNC_NAME s_scm_assert_bound
 {
   if (SCM_GOOPS_UNBOUNDP (value))
-    return CALL_GF1 ("slot-unbound", obj);
+    return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
   return value;
 }
 #undef FUNC_NAME
@@ -1208,7 +1211,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
 {
   SCM value = SCM_SLOT (obj, scm_to_int (index));
   if (SCM_GOOPS_UNBOUNDP (value))
-    return CALL_GF1 ("slot-unbound", obj);
+    return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj);
   return value;
 }
 #undef FUNC_NAME
@@ -1296,7 +1299,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
 
       code = SCM_CAR (access);
       if (!SCM_CLOSUREP (code))
-	return SCM_SUBRF (code) (obj);
+	return scm_call_1 (code, obj);
       env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
 			     scm_list_1 (obj),
 			     SCM_ENV (code));
@@ -1313,7 +1316,7 @@ get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
   if (scm_is_true (slotdef))
     return get_slot_value (class, obj, slotdef);
   else
-    return CALL_GF3 ("slot-missing", class, obj, slot_name);
+    return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name);
 }
 
 static SCM
@@ -1339,7 +1342,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
 
       code = SCM_CADR (access);
       if (!SCM_CLOSUREP (code))
-	SCM_SUBRF (code) (obj, value);
+	scm_call_2 (code, obj, value);
       else
 	{
 	  env  = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
@@ -1360,7 +1363,7 @@ set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
   if (scm_is_true (slotdef))
     return set_slot_value (class, obj, slotdef, value);
   else
-    return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
+    return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value);
 }
 
 static SCM
@@ -1390,7 +1393,7 @@ SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
 
   res = get_slot_value_using_name (class, obj, slot_name);
   if (SCM_GOOPS_UNBOUNDP (res))
-    return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+    return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
   return res;
 }
 #undef FUNC_NAME
@@ -1453,7 +1456,7 @@ SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
 
   res = get_slot_value_using_name (class, obj, slot_name);
   if (SCM_GOOPS_UNBOUNDP (res))
-    return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+    return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name);
   return res;
 }
 #undef FUNC_NAME
@@ -1742,7 +1745,7 @@ SCM_SYMBOL (scm_sym_change_class, "change-class");
 static SCM
 purgatory (void *args)
 {
-  return scm_apply_0 (GETVAR (scm_sym_change_class),
+  return scm_apply_0 (SCM_VARIABLE_REF (var_change_class),
 		      SCM_PACK ((scm_t_bits) args));
 }
 
@@ -2143,7 +2146,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
     {
       if (find_method_p)
 	return SCM_BOOL_F;
-      CALL_GF2 ("no-applicable-method", gf, save);
+      scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save);
       /* if we are here, it's because no-applicable-method hasn't signaled an error */
       return SCM_BOOL_F;
     }
@@ -2200,8 +2203,13 @@ call_memoize_method (void *a)
   SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
   if (scm_is_true (cmethod))
     return cmethod;
-  /*fixme* Use scm_apply */
-  return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
+
+  if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x)))
+    var_memoize_method_x =
+      scm_permanent_object
+      (scm_module_variable (scm_module_goops, sym_memoize_method_x));
+      
+  return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x);
 }
 
 SCM
@@ -2229,6 +2237,9 @@ scm_memoize_method (SCM x, SCM args)
 SCM_KEYWORD (k_setter,		"setter");
 SCM_KEYWORD (k_specializers,	"specializers");
 SCM_KEYWORD (k_procedure,	"procedure");
+SCM_KEYWORD (k_formals,		"formals");
+SCM_KEYWORD (k_body,		"body");
+SCM_KEYWORD (k_make_procedure,	"make-procedure");
 SCM_KEYWORD (k_dsupers,		"dsupers");
 SCM_KEYWORD (k_slots,		"slots");
 SCM_KEYWORD (k_gf,		"generic-function");
@@ -2292,9 +2303,27 @@ SCM_DEFINE (scm_make, "make",  0, 0, 1,
 	    scm_i_get_keyword (k_procedure,
 			       args,
 			       len - 1,
-			       SCM_EOL,
+			       SCM_BOOL_F,
 			       FUNC_NAME));
 	  SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+	  SCM_SET_SLOT (z, scm_si_formals,
+	    scm_i_get_keyword (k_formals,
+			       args,
+			       len - 1,
+			       SCM_EOL,
+			       FUNC_NAME));
+	  SCM_SET_SLOT (z, scm_si_body,
+	    scm_i_get_keyword (k_body,
+			       args,
+			       len - 1,
+			       SCM_EOL,
+			       FUNC_NAME));
+	  SCM_SET_SLOT (z, scm_si_make_procedure,
+	    scm_i_get_keyword (k_make_procedure,
+			       args,
+			       len - 1,
+			       SCM_BOOL_F,
+			       FUNC_NAME));
 	}
       else
 	{
@@ -2434,10 +2463,14 @@ static void
 create_standard_classes (void)
 {
   SCM slots;
-  SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
+  SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"),
 				 scm_from_locale_symbol ("specializers"),
 				 sym_procedure,
-				 scm_from_locale_symbol ("code-table"));
+				 scm_from_locale_symbol ("code-table"),
+				 scm_from_locale_symbol ("formals"),
+				 scm_from_locale_symbol ("body"),
+				 scm_from_locale_symbol ("make-procedure"),
+                                 SCM_UNDEFINED);
   SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
 					      k_init_keyword,
 					      k_slot_definition));
@@ -2646,7 +2679,7 @@ make_class_from_template (char const *template, char const *type_name, SCM super
 
   /* Only define name if doesn't already exist. */
   if (!SCM_GOOPS_UNBOUNDP (name)
-      && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+      && scm_is_false (scm_module_variable (scm_module_goops, name)))
     DEFVAR (name, class);
   return class;
 }
@@ -2978,8 +3011,23 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
 {
   goops_loaded_p = 1;
   var_compute_applicable_methods =
-    scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
-		 SCM_BOOL_F);
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_compute_applicable_methods));
+  var_slot_unbound =
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_slot_unbound));
+  var_slot_missing =
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_slot_missing));
+  var_compute_cpl =
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_compute_cpl));
+  var_no_applicable_method =
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_no_applicable_method));
+  var_change_class =
+    scm_permanent_object
+    (scm_module_variable (scm_module_goops, sym_change_class));
   setup_extended_primitive_generics ();
   return SCM_UNSPECIFIED;
 }
@@ -2991,12 +3039,10 @@ SCM
 scm_init_goops_builtins (void)
 {
   scm_module_goops = scm_current_module ();
-  scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
 
   /* Not really necessary right now, but who knows...
    */
   scm_permanent_object (scm_module_goops);
-  scm_permanent_object (scm_goops_lookup_closure);
 
   scm_components = scm_permanent_object (scm_make_weak_key_hash_table
 					 (scm_from_int (37)));

libguile/goops.h

@@ -149,9 +149,11 @@ typedef struct scm_t_method {
 
 #define scm_si_generic_function	 0  /* offset of gf    slot in a <method> */
 #define scm_si_specializers	 1  /* offset of spec. slot in a <method> */
-
 #define scm_si_procedure 	 2  /* offset of proc. slot in a <method> */
 #define scm_si_code_table	 3  /* offset of code. slot in a <method> */
+#define scm_si_formals		 4  /* offset of form. slot in a <method> */
+#define scm_si_body		 5  /* offset of body  slot in a <method> */
+#define scm_si_make_procedure	 6  /* offset of makep.slot in a <method> */
 
 /* C interface */
 SCM_API SCM scm_class_boolean;

libguile/init.c

@@ -118,6 +118,7 @@
 #include "libguile/variable.h"
 #include "libguile/vectors.h"
 #include "libguile/version.h"
+#include "libguile/vm-bootstrap.h"
 #include "libguile/vports.h"
 #include "libguile/weaks.h"
 #include "libguile/guardians.h"
@@ -281,7 +282,7 @@ scm_load_startup_files ()
   /* Load Ice-9.  */
   if (!scm_ice_9_already_loaded)
     {
-      scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm"));
+      scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9"));
 
       /* Load the init.scm file.  */
       if (scm_is_true (init_path))
@@ -573,6 +574,8 @@ scm_i_init_guile (SCM_STACKITEM *base)
   scm_init_rw ();
   scm_init_extensions ();
 
+  scm_bootstrap_vm ();
+
   atexit (cleanup_for_exit);
   scm_load_startup_files ();
 }

libguile/instructions.c

@@ -0,0 +1,234 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+
+struct scm_instruction {
+  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 */
+  SCM symname;                  /* filled in later */
+};
+
+#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar)               \
+  do {                                                                \
+    cvar = scm_lookup_instruction_by_name (var);                      \
+    SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P");     \
+  } while (0)
+
+
+static struct scm_instruction*
+fetch_instruction_table ()
+{
+  static struct scm_instruction *table = NULL;
+
+  if (SCM_UNLIKELY (!table))
+    {
+      size_t bytes = scm_op_last * sizeof(struct scm_instruction);
+      int i;
+      table = malloc (bytes);
+      memset (table, 0, bytes);
+#define VM_INSTRUCTION_TO_TABLE 1
+#include <libguile/vm-expand.h>
+#include <libguile/vm-i-system.i>
+#include <libguile/vm-i-scheme.i>
+#include <libguile/vm-i-loader.i>
+#undef VM_INSTRUCTION_TO_TABLE
+      for (i = 0; i < scm_op_last; i++)
+        {
+          table[i].opcode = i;
+          if (table[i].name)
+            table[i].symname = scm_from_locale_symbol (table[i].name);
+          else
+            table[i].symname = SCM_BOOL_F;
+        }
+    }
+  return table;
+}
+
+static struct scm_instruction *
+scm_lookup_instruction_by_name (SCM name)
+{
+  static SCM instructions_by_name = SCM_BOOL_F;
+  struct scm_instruction *table = fetch_instruction_table ();
+  SCM op;
+
+  if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name)))
+    { 
+      int i;
+      instructions_by_name = scm_make_hash_table (SCM_I_MAKINUM (scm_op_last));
+      for (i = 0; i < scm_op_last; i++)
+        if (scm_is_true (table[i].symname))
+          scm_hashq_set_x (instructions_by_name, table[i].symname,
+                           SCM_I_MAKINUM (i));
+      instructions_by_name = scm_permanent_object (instructions_by_name);
+    }
+  
+  op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
+  if (SCM_I_INUMP (op))
+    return &table[SCM_I_INUM (op)];
+
+  return NULL;
+}
+
+
+/* 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 = fetch_instruction_table (); ip->opcode != scm_op_last; ip++)
+    if (ip->name)
+      list = scm_cons (ip->symname, 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_lookup_instruction_by_name (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_length
+{
+  struct scm_instruction *ip;
+  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+  return SCM_I_MAKINUM (ip->len);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_pops
+{
+  struct scm_instruction *ip;
+  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+  return SCM_I_MAKINUM (ip->npop);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_pushes
+{
+  struct scm_instruction *ip;
+  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+  return SCM_I_MAKINUM (ip->npush);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
+	    (SCM inst),
+	    "")
+#define FUNC_NAME s_scm_instruction_to_opcode
+{
+  struct scm_instruction *ip;
+  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
+  return SCM_I_MAKINUM (ip->opcode);
+}
+#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 opcode;
+  SCM ret = SCM_BOOL_F;
+
+  SCM_MAKE_VALIDATE (1, op, I_INUMP);
+  opcode = SCM_I_INUM (op);
+
+  if (opcode < scm_op_last)
+    ret = fetch_instruction_table ()[opcode].symname;
+
+  if (scm_is_false (ret))
+    scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
+
+  return ret;
+}
+#undef FUNC_NAME
+
+void
+scm_bootstrap_instructions (void)
+{
+}
+
+void
+scm_init_instructions (void)
+{
+  scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/instructions.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/instructions.h

@@ -0,0 +1,77 @@
+/* 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>
+
+#define SCM_VM_NUM_INSTRUCTIONS (1<<7)
+#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
+
+enum scm_opcode {
+#define VM_INSTRUCTION_TO_OPCODE 1
+#include <libguile/vm-expand.h>
+#include <libguile/vm-i-system.i>
+#include <libguile/vm-i-scheme.i>
+#include <libguile/vm-i-loader.i>
+#undef VM_INSTRUCTION_TO_OPCODE
+  scm_op_last = SCM_VM_NUM_INSTRUCTIONS
+};
+
+extern SCM scm_instruction_list (void);
+extern SCM scm_instruction_p (SCM obj);
+extern SCM scm_instruction_length (SCM inst);
+extern SCM scm_instruction_pops (SCM inst);
+extern SCM scm_instruction_pushes (SCM inst);
+extern SCM scm_instruction_to_opcode (SCM inst);
+extern SCM scm_opcode_to_instruction (SCM op);
+
+extern void scm_bootstrap_instructions (void);
+extern void scm_init_instructions (void);
+
+#endif /* _SCM_INSTRUCTIONS_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/load.c

@@ -44,6 +44,8 @@
 #include "libguile/load.h"
 #include "libguile/fluids.h"
 
+#include "libguile/vm.h" /* for load-compiled/vm */
+
 #include <sys/types.h>
 #include <sys/stat.h>
 
@@ -172,6 +174,9 @@ static SCM *scm_loc_load_path;
 /* List of extensions we try adding to the filenames.  */
 static SCM *scm_loc_load_extensions;
 
+/* Like %load-extensions, but for compiled files.  */
+static SCM *scm_loc_load_compiled_extensions;
+
 
 SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0, 
             (SCM path, SCM tail),
@@ -206,9 +211,17 @@ scm_init_load_path ()
   SCM path = SCM_EOL;
 
 #ifdef SCM_LIBRARY_DIR
-  path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
-		     scm_from_locale_string (SCM_LIBRARY_DIR),
-		     scm_from_locale_string (SCM_PKGDATA_DIR));
+  env = getenv ("GUILE_SYSTEM_PATH");
+  if (env && strcmp (env, "") == 0)
+    /* special-case interpret system-path=="" as meaning no system path instead
+       of '("") */
+    ; 
+  else if (env)
+    path = scm_parse_path (scm_from_locale_string (env), path);
+  else
+    path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
+                       scm_from_locale_string (SCM_LIBRARY_DIR),
+                       scm_from_locale_string (SCM_PKGDATA_DIR));
 #endif /* SCM_LIBRARY_DIR */
 
   env = getenv ("GUILE_LOAD_PATH");
@@ -291,14 +304,33 @@ stringbuf_cat (struct stringbuf *buf, char *str)
 }
 
   
+static int
+scm_c_string_has_an_ext (char *str, size_t len, SCM extensions)
+{
+  for (; !scm_is_null (extensions); extensions = SCM_CDR (extensions))
+    {
+      char *ext;
+      size_t extlen;
+      int match;
+      ext = scm_to_locale_string (SCM_CAR (extensions));
+      extlen = strlen (ext);
+      match = (len > extlen && str[len - extlen - 1] == '.'
+               && strncmp (str + (len - extlen), ext, extlen) == 0);
+      free (ext);
+      if (match)
+        return 1;
+    }
+  return 0;
+}
+
 /* Search PATH for a directory containing a file named FILENAME.
    The file must be readable, and not a directory.
    If we find one, return its full filename; otherwise, return #f.
    If FILENAME is absolute, return it unchanged.
    If given, EXTENSIONS is a list of strings; for each directory 
    in PATH, we search for FILENAME concatenated with each EXTENSION.  */
-SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
-           (SCM path, SCM filename, SCM extensions),
+SCM_DEFINE (scm_search_path, "search-path", 2, 2, 0,
+            (SCM path, SCM filename, SCM extensions, SCM require_exts),
 	    "Search @var{path} for a directory containing a file named\n"
 	    "@var{filename}. The file must be readable, and not a directory.\n"
 	    "If we find one, return its full filename; otherwise, return\n"
@@ -316,6 +348,9 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
   if (SCM_UNBNDP (extensions))
     extensions = SCM_EOL;
 
+  if (SCM_UNBNDP (require_exts))
+    require_exts = SCM_BOOL_F;
+
   scm_dynwind_begin (0);
 
   filename_chars = scm_to_locale_string (filename);
@@ -334,8 +369,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
   if (filename_len >= 1 && filename_chars[0] == '/')
 #endif
     {
+      SCM res = filename;
+      if (scm_is_true (require_exts) &&
+          !scm_c_string_has_an_ext (filename_chars, filename_len,
+                                    extensions))
+        res = SCM_BOOL_F;
+
       scm_dynwind_end ();
-      return filename;
+      return res;
     }
 
   /* If FILENAME has an extension, don't try to add EXTENSIONS to it.  */
@@ -348,6 +389,15 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
       {
 	if (*endp == '.')
 	  {
+            if (scm_is_true (require_exts) &&
+                !scm_c_string_has_an_ext (filename_chars, filename_len,
+                                          extensions))
+              {
+                /* This filename has an extension, but not one of the right
+                   ones... */
+                scm_dynwind_end ();
+                return SCM_BOOL_F;
+              }
 	    /* This filename already has an extension, so cancel the
                list of extensions.  */
 	    extensions = SCM_EOL;
@@ -453,7 +503,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
     SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
   if (scm_ilength (exts) < 0)
     SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
-  return scm_search_path (path, filename, exts);
+  return scm_search_path (path, filename, exts, SCM_UNDEFINED);
 }
 #undef FUNC_NAME
 
@@ -466,15 +516,51 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
 	    "an error is signalled.")
 #define FUNC_NAME s_scm_primitive_load_path
 {
-  SCM full_filename;
+  SCM full_filename, compiled_filename;
 
   full_filename = scm_sys_search_load_path (filename);
+  compiled_filename = scm_search_path (*scm_loc_load_path,
+                                       filename,
+                                       *scm_loc_load_compiled_extensions,
+                                       SCM_BOOL_T);
 
-  if (scm_is_false (full_filename))
+  if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
     SCM_MISC_ERROR ("Unable to find file ~S in load path",
 		    scm_list_1 (filename));
 
-  return scm_primitive_load (full_filename);
+  if (scm_is_false (compiled_filename))
+    return scm_primitive_load (full_filename);
+
+  if (scm_is_false (full_filename))
+    return scm_load_compiled_with_vm (compiled_filename);
+
+  {
+    char *source, *compiled;
+    struct stat stat_source, stat_compiled;
+
+    source = scm_to_locale_string (full_filename);
+    compiled = scm_to_locale_string (compiled_filename);
+    
+    if (stat (source, &stat_source) == 0
+        && stat (compiled, &stat_compiled) == 0
+        && stat_source.st_mtime <= stat_compiled.st_mtime) 
+      {
+        free (source);
+        free (compiled);
+        return scm_load_compiled_with_vm (compiled_filename);
+      }
+    else
+      {
+        scm_puts (";;; note: source file ", scm_current_error_port ());
+        scm_puts (source, scm_current_error_port ());
+        scm_puts (" newer than compiled ", scm_current_error_port ());
+        scm_puts (compiled, scm_current_error_port ());
+        scm_puts ("\n", scm_current_error_port ());
+        free (source);
+        free (compiled);
+        return scm_primitive_load (full_filename);
+      }
+  }
 }
 #undef FUNC_NAME
 
@@ -514,6 +600,9 @@ scm_init_load ()
     = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
 				      scm_list_2 (scm_from_locale_string (".scm"),
 						  scm_nullstr)));
+  scm_loc_load_compiled_extensions
+    = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions",
+				      scm_list_1 (scm_from_locale_string (".go"))));
   scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
 
   the_reader = scm_make_fluid ();

libguile/load.h

@@ -31,7 +31,7 @@ SCM_API SCM scm_c_primitive_load (const char *filename);
 SCM_API SCM scm_sys_package_data_dir (void);
 SCM_API SCM scm_sys_library_dir (void);
 SCM_API SCM scm_sys_site_dir (void);
-SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts);
+SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts);
 SCM_API SCM scm_sys_search_load_path (SCM filename);
 SCM_API SCM scm_primitive_load_path (SCM filename);
 SCM_API SCM scm_c_primitive_load_path (const char *filename);

libguile/macros.c

@@ -31,6 +31,7 @@
 #include "libguile/deprecation.h"
 
 #include "libguile/validate.h"
+#include "libguile/programs.h"
 #include "libguile/macros.h"
 
 #include "libguile/private-options.h"
@@ -47,7 +48,7 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
       || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
 					macro, port, pstate)))
     {
-      if (!SCM_CLOSUREP (code))
+      if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
 	scm_puts ("#<primitive-", port);
       else
 	scm_puts ("#<", port);
@@ -223,9 +224,15 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
 	    "Return the transformer of the macro @var{m}.")
 #define FUNC_NAME s_scm_macro_transformer
 {
+  SCM data;
+
   SCM_VALIDATE_SMOB (1, m, macro);
-  return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ?
-	  SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F);
+  data = SCM_PACK (SCM_SMOB_DATA (m));
+  
+  if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data))
+    return data;
+  else
+    return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 

libguile/modules.c

@@ -345,6 +345,8 @@ resolve_duplicate_binding (SCM module, SCM sym,
   return result;
 }
 
+SCM scm_pre_modules_obarray;
+
 /* Lookup SYM as an imported variable of MODULE.  */
 static inline SCM
 module_imported_variable (SCM module, SCM sym)
@@ -471,6 +473,9 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
 
   SCM_VALIDATE_SYMBOL (2, sym);
 
+  if (scm_is_false (module))
+    return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
+
   /* 1. Check module obarray */
   var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
   if (SCM_BOUND_THING_P (var))
@@ -624,6 +629,25 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_SYMBOL (sym_sys_module_public_interface, "%module-public-interface");
+
+SCM_DEFINE (scm_module_public_interface, "module-public-interface", 1, 0, 0,
+	    (SCM module),
+	    "Return the public interface of @var{module}.\n\n"
+            "If @var{module} has no public interface, @code{#f} is returned.")
+#define FUNC_NAME s_scm_module_public_interface
+{
+  SCM var;
+
+  SCM_VALIDATE_MODULE (1, module);
+  var = scm_module_local_variable (module, sym_sys_module_public_interface);
+  if (scm_is_true (var))
+    return SCM_VARIABLE_REF (var);
+  else
+    return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
 /* scm_sym2var
  *
  * looks up the variable bound to SYM according to PROC.  PROC should be
@@ -637,8 +661,6 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
  * the scm_pre_modules_obarray (a `eq' hash table).
  */
 
-SCM scm_pre_modules_obarray;
-
 SCM 
 scm_sym2var (SCM sym, SCM proc, SCM definep)
 #define FUNC_NAME "scm_sym2var"

libguile/modules.h

@@ -100,6 +100,7 @@ SCM_API void scm_c_export (const char *name, ...);
 
 SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
 
+SCM_API SCM scm_module_public_interface (SCM module);
 SCM_API SCM scm_module_import_interface (SCM module, SCM sym);
 SCM_API SCM scm_module_lookup_closure (SCM module);
 SCM_API SCM scm_module_transformer (SCM module);

libguile/objcodes.c

@@ -0,0 +1,296 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <sys/mman.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <assert.h>
+
+#include "vm-bootstrap.h"
+#include "programs.h"
+#include "objcodes.h"
+
+/* nb, the length of the header should be a multiple of 8 bytes */
+#define OBJCODE_COOKIE "GOOF-0.5"
+
+
+/*
+ * Objcode type
+ */
+
+scm_t_bits scm_tc16_objcode;
+
+static SCM
+make_objcode_by_mmap (int fd)
+#define FUNC_NAME "make_objcode_by_mmap"
+{
+  int ret;
+  char *addr;
+  struct stat st;
+  SCM sret = SCM_BOOL_F;
+  struct scm_objcode *data;
+
+  ret = fstat (fd, &st);
+  if (ret < 0)
+    SCM_SYSERROR;
+
+  if (st.st_size <= sizeof (struct scm_objcode) + 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;
+
+  data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
+
+  if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
+    scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+		    SCM_LIST2 (scm_from_size_t (st.st_size),
+                               scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+
+  SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+                SCM_PACK (SCM_BOOL_F), fd);
+  SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+
+  /* FIXME: we leak ourselves and the file descriptor. but then again so does
+     dlopen(). */
+  return scm_permanent_object (sret);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+#define FUNC_NAME "make-objcode-slice"
+{
+  struct scm_objcode *data, *parent_data;
+  SCM ret;
+
+  SCM_VALIDATE_OBJCODE (1, parent);
+  parent_data = SCM_OBJCODE_DATA (parent);
+  
+  if (ptr < parent_data->base
+      || ptr >= (parent_data->base + parent_data->len + parent_data->metalen
+                 - sizeof (struct scm_objcode)))
+    scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
+		    SCM_LIST4 (scm_from_ulong ((unsigned long)ptr),
+                               scm_from_ulong ((unsigned long)parent_data->base),
+                               scm_from_uint32 (parent_data->len),
+                               scm_from_uint32 (parent_data->metalen)));
+
+  data = (struct scm_objcode*)ptr;
+  if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
+    abort ();
+
+  SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
+  SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
+  return ret;
+}
+#undef FUNC_NAME
+
+static SCM
+objcode_mark (SCM obj)
+{
+  return SCM_SMOB_OBJECT_2 (obj);
+}
+
+
+/*
+ * Scheme interface
+ */
+
+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_objcode_meta, "objcode-meta", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_meta
+{
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  if (SCM_OBJCODE_META_LEN (objcode) == 0)
+    return SCM_BOOL_F;
+  else
+    return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode)
+                                               + SCM_OBJCODE_LEN (objcode)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
+	    (SCM bytecode),
+	    "")
+#define FUNC_NAME s_scm_bytecode_to_objcode
+{
+  size_t size;
+  ssize_t increment;
+  scm_t_array_handle handle;
+  const scm_t_uint8 *c_bytecode;
+  struct scm_objcode *data;
+  SCM objcode;
+
+  if (scm_is_false (scm_u8vector_p (bytecode)))
+    scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
+
+  c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+  data = (struct scm_objcode*)c_bytecode;
+  SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
+  scm_array_handle_release (&handle);
+
+  SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
+  if (data->len + data->metalen != (size - sizeof (*data)))
+    scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+		    SCM_LIST2 (scm_from_size_t (size),
+                               scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+  assert (increment == 1);
+  SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
+  
+  /* foolishly, we assume that as long as bytecode is around, that c_bytecode
+     will be of the same length; perhaps a bad assumption? */
+
+  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_bytecode, "objcode->bytecode", 1, 0, 0,
+	    (SCM objcode),
+	    "")
+#define FUNC_NAME s_scm_objcode_to_bytecode
+{
+  scm_t_uint8 *u8vector;
+  scm_t_uint32 len;
+
+  SCM_VALIDATE_OBJCODE (1, objcode);
+
+  len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+  /* FIXME:  Is `gc_malloc' ok here? */
+  u8vector = scm_gc_malloc (len, "objcode-u8vector");
+  memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+
+  return scm_take_u8vector (u8vector, len);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
+	    (SCM objcode, SCM port),
+	    "")
+#define FUNC_NAME s_scm_write_objcode
+{
+  SCM_VALIDATE_OBJCODE (1, objcode);
+  SCM_VALIDATE_OUTPUT_PORT (2, port);
+  
+  scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+  scm_c_write (port, SCM_OBJCODE_DATA (objcode),
+               sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_bootstrap_objcodes (void)
+{
+  scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+  scm_set_smob_mark (scm_tc16_objcode, objcode_mark);
+}
+
+/* Before, we used __BYTE_ORDER, but that is not defined on all
+   systems. So punt and use automake, PDP endianness be damned. */
+#ifdef WORDS_BIGENDIAN
+#define SCM_BYTE_ORDER 4321
+#else
+#define SCM_BYTE_ORDER 1234
+#endif
+
+void
+scm_init_objcodes (void)
+{
+  scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/objcodes.x"
+#endif
+
+  scm_c_define ("word-size", scm_from_size_t (sizeof(SCM)));
+  scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER));
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/objcodes.h

@@ -0,0 +1,99 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_OBJCODES_H_
+#define _SCM_OBJCODES_H_
+
+#include <libguile.h>
+
+/* objcode data should be directly mappable to this C structure. */
+struct scm_objcode {
+  scm_t_uint8 nargs;
+  scm_t_uint8 nrest;
+  scm_t_uint8 nlocs;
+  scm_t_uint8 nexts;
+  scm_t_uint32 len;             /* the maximum index of base[] */
+  scm_t_uint32 metalen;         /* well, i lie. this many bytes at the end of
+                                   base[] for metadata */
+  scm_t_uint8 base[0];
+};
+
+#define SCM_F_OBJCODE_IS_MMAP     (1<<0)
+#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE    (1<<2)
+
+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_LEN(x)	(SCM_OBJCODE_DATA (x)->len)
+#define SCM_OBJCODE_META_LEN(x)	(SCM_OBJCODE_DATA (x)->metalen)
+#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x))
+#define SCM_OBJCODE_NARGS(x)	(SCM_OBJCODE_DATA (x)->nargs)
+#define SCM_OBJCODE_NREST(x)	(SCM_OBJCODE_DATA (x)->nrest)
+#define SCM_OBJCODE_NLOCS(x)	(SCM_OBJCODE_DATA (x)->nlocs)
+#define SCM_OBJCODE_NEXTS(x)	(SCM_OBJCODE_DATA (x)->nexts)
+#define SCM_OBJCODE_BASE(x)	(SCM_OBJCODE_DATA (x)->base)
+
+#define SCM_OBJCODE_IS_MMAP(x)	(SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+
+SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
+extern SCM scm_load_objcode (SCM file);
+extern SCM scm_objcode_p (SCM obj);
+extern SCM scm_objcode_meta (SCM objcode);
+extern SCM scm_bytecode_to_objcode (SCM bytecode);
+extern SCM scm_objcode_to_bytecode (SCM objcode);
+extern SCM scm_write_objcode (SCM objcode, SCM port);
+
+extern void scm_bootstrap_objcodes (void);
+extern void scm_init_objcodes (void);
+
+#endif /* _SCM_OBJCODES_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/objects.c

@@ -39,6 +39,8 @@
 #include "libguile/ports.h"
 #include "libguile/strings.h"
 #include "libguile/vectors.h"
+#include "libguile/programs.h"
+#include "libguile/vm.h"
 
 #include "libguile/validate.h"
 #include "libguile/objects.h"
@@ -138,8 +140,9 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args)
 	    z = SCM_CDR (z);
 	  }
 	while (j-- && !scm_is_null (ls));
-      /* Fewer arguments than specifiers => CAR != ENV */
-      if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+      /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */
+      if (!scm_is_pair (z)
+          || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z))))
 	return z;
     next_method:
       i = (i + 1) & mask;
@@ -161,10 +164,15 @@ SCM
 scm_apply_generic (SCM gf, SCM args)
 {
   SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
-  return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
-			SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
-					args,
-					SCM_CMETHOD_ENV (cmethod)));
+  if (SCM_PROGRAM_P (cmethod))
+    return scm_vm_apply (scm_the_vm (), cmethod, args);
+  else if (scm_is_pair (cmethod))
+    return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+                          SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+                                          args,
+                                          SCM_CMETHOD_ENV (cmethod)));
+  else
+    return scm_apply (cmethod, args, SCM_EOL);
 }
 
 SCM

libguile/procs.c

@@ -31,6 +31,9 @@
 
 #include "libguile/validate.h"
 #include "libguile/procs.h"
+#include "libguile/procprop.h"
+#include "libguile/objcodes.h"
+#include "libguile/programs.h"
 
 
 
@@ -138,7 +141,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
 	  obj = SCM_PROCEDURE (obj);
 	  goto again;
 	default:
-	  ;
+          if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0)
+            return SCM_BOOL_T;
+          /* otherwise fall through */
 	}
     }
   return SCM_BOOL_F;
@@ -208,11 +213,25 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
 	    "with the associated setter @var{setter}.")
 #define FUNC_NAME s_scm_make_procedure_with_setter
 {
+  SCM name, ret;
   SCM_VALIDATE_PROC (1, procedure);
   SCM_VALIDATE_PROC (2, setter);
-  return scm_double_cell (scm_tc7_pws,
-			  SCM_UNPACK (procedure),
-			  SCM_UNPACK (setter), 0);
+  ret = scm_double_cell (scm_tc7_pws,
+                         SCM_UNPACK (procedure),
+                         SCM_UNPACK (setter), 0);
+  /* don't use procedure_name, because don't care enough to do a reverse
+     lookup */
+  switch (SCM_TYP7 (procedure)) {
+  case scm_tcs_subrs:
+    name = SCM_SNAME (procedure);
+    break;
+  default:
+    name = scm_procedure_property (procedure, scm_sym_name);
+    break;
+  }
+  if (scm_is_true (name))
+    scm_set_procedure_property_x (ret, scm_sym_name, name);
+  return ret;
 }
 #undef FUNC_NAME
 

libguile/programs.c

@@ -0,0 +1,387 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#if HAVE_CONFIG_H
+#  include <config.h>
+#endif
+
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "instructions.h"
+#include "modules.h"
+#include "programs.h"
+#include "procprop.h" // scm_sym_name
+#include "srcprop.h" // scm_sym_filename
+#include "vm.h"
+
+
+scm_t_bits scm_tc16_program;
+
+static SCM write_program = SCM_BOOL_F;
+
+SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
+	    (SCM objcode, SCM objtable, SCM external),
+	    "")
+#define FUNC_NAME s_scm_make_program
+{
+  SCM_VALIDATE_OBJCODE (1, objcode);
+  if (SCM_UNLIKELY (SCM_UNBNDP (objtable)))
+    objtable = SCM_BOOL_F;
+  else if (scm_is_true (objtable))
+    SCM_VALIDATE_VECTOR (2, objtable);
+  if (SCM_UNLIKELY (SCM_UNBNDP (external)))
+    external = SCM_EOL;
+  else
+    /* FIXME: currently this test is quite expensive (can be 2-3% of total
+       execution time in programs that make many closures). We could remove it,
+       yes, but we'd get much better gains if we used some other method, like
+       just capturing the variables that we need instead of all heap-allocated
+       variables. Dunno. Keeping the check for now, as it's a user-callable
+       function, and inlining the op in the vm's make-closure operation. */
+    SCM_VALIDATE_LIST (3, external);
+
+  SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
+}
+#undef FUNC_NAME
+
+static SCM
+program_mark (SCM obj)
+{
+  if (scm_is_true (SCM_PROGRAM_OBJTABLE (obj)))
+    scm_gc_mark (SCM_PROGRAM_OBJTABLE (obj));
+  if (!scm_is_null (SCM_PROGRAM_EXTERNALS (obj)))
+    scm_gc_mark (SCM_PROGRAM_EXTERNALS (obj));
+  return SCM_PROGRAM_OBJCODE (obj);
+}
+
+static SCM
+program_apply (SCM program, SCM args)
+{
+  return scm_vm_apply (scm_the_vm (), program, args);
+}
+
+static SCM
+program_apply_0 (SCM program)
+{
+  return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+}
+
+static SCM
+program_apply_1 (SCM program, SCM a)
+{
+  return scm_c_vm_run (scm_the_vm (), program, &a, 1);
+}
+
+static SCM
+program_apply_2 (SCM program, SCM a, SCM b)
+{
+  SCM args[2];
+  args[0] = a;
+  args[1] = b;
+  return scm_c_vm_run (scm_the_vm (), program, args, 2);
+}
+
+static int
+program_print (SCM program, SCM port, scm_print_state *pstate)
+{
+  static int print_error = 0;
+
+  if (SCM_FALSEP (write_program) && scm_module_system_booted_p)
+    write_program = scm_module_local_variable
+      (scm_c_resolve_module ("system vm program"),
+       scm_from_locale_symbol ("write-program"));
+  
+  if (SCM_FALSEP (write_program) || print_error)
+    return scm_smob_print (program, port, pstate);
+
+  print_error = 1;
+  scm_call_2 (SCM_VARIABLE_REF (write_program), program, port);
+  print_error = 0;
+  return 1;
+}
+
+
+/*
+ * 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_objcode *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_objects, "program-objects", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_objects
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return SCM_PROGRAM_OBJTABLE (program);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_module
+{
+  SCM objs;
+  SCM_VALIDATE_PROGRAM (1, program);
+  objs = SCM_PROGRAM_OBJTABLE (program);
+  return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_meta
+{
+  SCM metaobj;
+  
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
+  if (scm_is_true (metaobj))
+    return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
+  else
+    return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_bindings
+{
+  SCM meta;
+  
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  meta = scm_program_meta (program);
+  if (scm_is_false (meta))
+    return SCM_BOOL_F;
+  
+  return scm_car (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_sources
+{
+  SCM meta, sources, ret, filename;
+  
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  meta = scm_program_meta (program);
+  if (scm_is_false (meta))
+    return SCM_EOL;
+  
+  filename = SCM_BOOL_F;
+  ret = SCM_EOL;
+  for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources);
+       sources = scm_cdr (sources))
+    {
+      SCM x = scm_car (sources);
+      if (scm_is_pair (x))
+        {
+          if (scm_is_number (scm_car (x)))
+            {
+              SCM addr = scm_car (x);
+              ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)),
+                               ret);
+            }
+          else if (scm_is_eq (scm_car (x), scm_sym_filename))
+            filename = scm_cdr (x);
+        }
+    }
+  return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_properties
+{
+  SCM meta;
+  
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  meta = scm_program_meta (program);
+  if (scm_is_false (meta))
+    return SCM_EOL;
+  
+  return scm_cddr (scm_call_0 (meta));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0,
+	    (SCM program),
+	    "")
+#define FUNC_NAME s_scm_program_name
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return scm_assq_ref (scm_program_properties (program), scm_sym_name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0,
+	    (SCM program, SCM ip),
+	    "")
+#define FUNC_NAME s_scm_program_source
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+  return scm_c_program_source (program, scm_to_size_t (ip));
+}
+#undef FUNC_NAME
+    
+extern SCM
+scm_c_program_source (SCM program, size_t ip)
+{
+  SCM sources, source = SCM_BOOL_F;
+
+  for (sources = scm_program_sources (program);
+       !scm_is_null (sources)
+         && scm_to_size_t (scm_caar (sources)) <= ip;
+       sources = scm_cdr (sources))
+    source = scm_car (sources);
+  
+  return source; /* (addr . (filename . (line . column))) */
+}
+
+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_EXTERNALS (program);
+}
+#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_EXTERNALS (program) = external;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0,
+	    (SCM program),
+	    "Return a @var{program}'s object code.")
+#define FUNC_NAME s_scm_program_objcode
+{
+  SCM_VALIDATE_PROGRAM (1, program);
+
+  return SCM_PROGRAM_OBJCODE (program);
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_bootstrap_programs (void)
+{
+  scm_tc16_program = scm_make_smob_type ("program", 0);
+  scm_set_smob_mark (scm_tc16_program, program_mark);
+  scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_0 = program_apply_0;
+  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
+  scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
+  scm_set_smob_print (scm_tc16_program, program_print);
+}
+
+void
+scm_init_programs (void)
+{
+  scm_bootstrap_vm ();
+  
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/programs.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/programs.h

@@ -0,0 +1,94 @@
+/* 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>
+#include <libguile/objcodes.h>
+
+/*
+ * Programs
+ */
+
+typedef unsigned char scm_byte_t;
+
+extern scm_t_bits scm_tc16_program;
+
+#define SCM_F_PROGRAM_IS_BOOT (1<<0)
+
+#define SCM_PROGRAM_P(x)	(SCM_SMOB_PREDICATE (scm_tc16_program, x))
+#define SCM_PROGRAM_OBJCODE(x)	(SCM_SMOB_OBJECT (x))
+#define SCM_PROGRAM_OBJTABLE(x)	(SCM_SMOB_OBJECT_2 (x))
+#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_DATA(x)	(SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
+#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
+#define SCM_PROGRAM_IS_BOOT(x)	(SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
+
+extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+
+extern SCM scm_program_p (SCM obj);
+extern SCM scm_program_base (SCM program);
+extern SCM scm_program_arity (SCM program);
+extern SCM scm_program_meta (SCM program);
+extern SCM scm_program_bindings (SCM program);
+extern SCM scm_program_sources (SCM program);
+extern SCM scm_program_source (SCM program, SCM ip);
+extern SCM scm_program_properties (SCM program);
+extern SCM scm_program_name (SCM program);
+extern SCM scm_program_objects (SCM program);
+extern SCM scm_program_module (SCM program);
+extern SCM scm_program_external (SCM program);
+extern SCM scm_program_external_set_x (SCM program, SCM external);
+extern SCM scm_program_objcode (SCM program);
+
+extern SCM scm_c_program_source (SCM program, size_t ip);
+
+extern void scm_bootstrap_programs (void);
+extern void scm_init_programs (void);
+
+#endif /* _SCM_PROGRAMS_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/stacks.c

@@ -32,6 +32,8 @@
 #include "libguile/modules.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
+#include "libguile/vm.h" /* to capture vm stacks */
+#include "libguile/frames.h" /* vm frames */
 
 #include "libguile/validate.h"
 #include "libguile/stacks.h"
@@ -123,19 +125,17 @@
 #define RELOC_FRAME(ptr, offset) \
   ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
 
-
 /* Count number of debug info frames on a stack, beginning with
  * DFRAME.  OFFSET is used for relocation of pointers when the stack
  * is read from a continuation.
  */
-static scm_t_bits
-stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
-	     SCM *id, int *maxp)
+static long
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe,
+	     SCM *id)
 {
   long n;
-  long max_depth = SCM_BACKTRACE_MAXDEPTH;
   for (n = 0;
-       dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+       dframe && !SCM_VOIDFRAMEP (*dframe);
        dframe = RELOC_FRAME (dframe->prev, offset))
     {
       if (SCM_EVALFRAMEP (*dframe))
@@ -148,15 +148,39 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
 	  if ((((info - vect) & 1) == 0)
 	      && SCM_OVERFLOWP (*dframe)
 	      && !SCM_UNBNDP (info[1].a.proc))
-	    ++n;
+            ++n;
 	}
+      else if (SCM_APPLYFRAMEP (*dframe))
+        {
+          scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+          if (SCM_PROGRAM_P (vect[0].a.proc))
+            {
+              if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc))
+                /* Programs can end up in the debug stack via deval; but we just
+                   ignore those, because we know that the debugging VM engine
+                   pushes one dframe per invocation, with the boot program as
+                   the proc, so we only count those. */
+                continue;
+              /* count vmframe back to previous boot frame */
+              for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe))
+                {
+                  if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+                    ++n;
+                  else
+                    { /* skip boot frame, cut out of the vm backtrace */
+                      vmframe = scm_c_vm_frame_prev (vmframe);
+                      break;
+                    }
+                }
+            }
+          else
+            ++n; /* increment for non-program apply frame */
+        }
       else
 	++n;
     }
   if (dframe && SCM_VOIDFRAMEP (*dframe))
     *id = RELOC_INFO(dframe->vect, offset)[0].id;
-  else if (dframe)
-    *maxp = 1;
   return n;
 }
 
@@ -234,7 +258,7 @@ do { \
 
 static scm_t_bits
 read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
-	     long n, scm_t_info_frame *iframes)
+	     SCM vmframe, long n, scm_t_info_frame *iframes)
 {
   scm_t_info_frame *iframe = iframes;
   scm_t_debug_info *info, *vect;
@@ -293,10 +317,39 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
 	      NEXT_FRAME (iframe, n, quit);
 	    }
 	}
+      else if (SCM_PROGRAM_P (iframe->proc))
+        {
+          if (!SCM_PROGRAM_IS_BOOT (iframe->proc))
+            /* Programs can end up in the debug stack via deval; but we just
+               ignore those, because we know that the debugging VM engine
+               pushes one dframe per invocation, with the boot program as
+               the proc, so we only count those. */
+            continue;
+          for (; scm_is_true (vmframe);
+               vmframe = scm_c_vm_frame_prev (vmframe))
+            {
+              if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe)))
+                { /* skip boot frame, back to interpreted frames */
+                  vmframe = scm_c_vm_frame_prev (vmframe);
+                  break;
+                }
+              else 
+                {
+                  /* Oh dear, oh dear, oh dear. */
+                  iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC;
+                  iframe->source = scm_vm_frame_source (vmframe);
+                  iframe->proc = scm_vm_frame_program (vmframe);
+                  iframe->args = scm_vm_frame_arguments (vmframe);
+                  ++iframe;
+                  if (--n == 0)
+                    goto quit;
+                }
+            }
+        }
       else
-	{
-	  NEXT_FRAME (iframe, n, quit);
-	}
+        {
+          NEXT_FRAME (iframe, n, quit);
+        }
     quit:
       if (iframe > iframes)
 	(iframe - 1) -> flags |= SCM_FRAMEF_REAL;
@@ -428,6 +481,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   int maxp;
   scm_t_debug_frame *dframe;
   scm_t_info_frame *iframe;
+  SCM vmframe;
   long offset = 0;
   SCM stack, id;
   SCM inner_cut, outer_cut;
@@ -436,17 +490,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
      scm_make_stack was given.  */
   if (scm_is_eq (obj, SCM_BOOL_T))
     {
+      struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ());
       dframe = scm_i_last_debug_frame ();
+      vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0);
     }
   else if (SCM_DEBUGOBJP (obj))
     {
       dframe = SCM_DEBUGOBJ_FRAME (obj);
+      vmframe = SCM_BOOL_F;
+    }
+  else if (SCM_VM_FRAME_P (obj))
+    {
+      dframe = NULL;
+      vmframe = obj;
     }
   else if (SCM_CONTINUATIONP (obj))
     {
       scm_t_contregs *cont = SCM_CONTREGS (obj);
       offset = cont->offset;
       dframe = RELOC_FRAME (cont->dframe, offset);
+      if (!scm_is_null (cont->vm_conts))
+        { SCM vm_cont;
+          struct scm_vm_cont *data;
+          vm_cont = scm_cdr (scm_car (cont->vm_conts));
+          data = SCM_VM_CONT_DATA (vm_cont);
+          vmframe = scm_c_make_vm_frame (vm_cont,
+                                         data->fp + data->reloc,
+                                         data->sp + data->reloc,
+                                         data->ip,
+                                         data->reloc);
+        } else 
+          vmframe = SCM_BOOL_F;
     }
   else
     {
@@ -459,7 +533,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
      (SCM_BACKTRACE_MAXDEPTH). */
   id = SCM_BOOL_F;
   maxp = 0;
-  n = stack_depth (dframe, offset, &id, &maxp);
+  n = stack_depth (dframe, offset, vmframe, &id);
+  /* FIXME: redo maxp? */
   size = n * SCM_FRAME_N_SLOTS;
 
   /* Make the stack object. */
@@ -467,10 +542,15 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
   SCM_STACK (stack) -> id = id;
   iframe = &SCM_STACK (stack) -> tail[0];
   SCM_STACK (stack) -> frames = iframe;
+  SCM_STACK (stack) -> length = n;
 
   /* Translate the current chain of stack frames into debugging information. */
-  n = read_frames (dframe, offset, n, iframe);
-  SCM_STACK (stack) -> length = n;
+  n = read_frames (dframe, offset, vmframe, n, iframe);
+  if (n != SCM_STACK (stack)->length)
+    {
+      scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ());
+      SCM_STACK (stack)->length = n;
+    }
 
   /* Narrow the stack according to the arguments given to scm_make_stack. */
   SCM_VALIDATE_REST_ARGUMENT (args);
@@ -497,12 +577,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
       n = SCM_STACK (stack) -> length;
     }
   
+  if (n > 0 && maxp)
+    iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+
   if (n > 0)
-    {
-      if (maxp)
-	iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
-      return stack;
-    }
+    return stack;
   else
     return SCM_BOOL_F;
 }

libguile/symbols.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public
@@ -154,31 +154,40 @@ lookup_interned_symbol (const char *name, size_t len,
   return result;
 }
 
+/* Intern SYMBOL, an uninterned symbol.  */
+static void
+intern_symbol (SCM symbol)
+{
+  SCM slot, cell;
+  unsigned long hash;
+
+  hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (symbols);
+  slot = SCM_HASHTABLE_BUCKET (symbols, hash);
+  cell = scm_cons (symbol, SCM_UNDEFINED);
+
+  SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
+  SCM_HASHTABLE_INCREMENT (symbols);
+
+  if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
+    scm_i_rehash (symbols, scm_i_hash_symbol, 0, "intern_symbol");
+}
+
 static SCM
 scm_i_c_mem2symbol (const char *name, size_t len)
 {
   SCM symbol;
   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
-  size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
 
   symbol = lookup_interned_symbol (name, len, raw_hash);
-  if (symbol != SCM_BOOL_F)
-    return symbol;
+  if (scm_is_false (symbol))
+    {
+      /* The symbol was not found, create it.  */
+      symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
+				    scm_cons (SCM_BOOL_F, SCM_EOL));
+      intern_symbol (symbol);
+    }
 
-  {
-    /* The symbol was not found - create it. */
-    SCM symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
-				      scm_cons (SCM_BOOL_F, SCM_EOL));
-
-    SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash);
-    SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED);
-    SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
-    SCM_HASHTABLE_INCREMENT (symbols);
-    if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
-      scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol");
-
-    return symbol;
-  }
+  return symbol;
 }
 
 static SCM
@@ -188,26 +197,17 @@ scm_i_mem2symbol (SCM str)
   const char *name = scm_i_string_chars (str);
   size_t len = scm_i_string_length (str);
   size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
-  size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
 
   symbol = lookup_interned_symbol (name, len, raw_hash);
-  if (symbol != SCM_BOOL_F)
-    return symbol;
+  if (scm_is_false (symbol))
+    {
+      /* The symbol was not found, create it.  */
+      symbol = scm_i_make_symbol (str, 0, raw_hash,
+				  scm_cons (SCM_BOOL_F, SCM_EOL));
+      intern_symbol (symbol);
+    }
 
-  {
-    /* The symbol was not found - create it. */
-    SCM symbol = scm_i_make_symbol (str, 0, raw_hash,
-				    scm_cons (SCM_BOOL_F, SCM_EOL));
-
-    SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash);
-    SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED);
-    SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
-    SCM_HASHTABLE_INCREMENT (symbols);
-    if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
-      scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol");
-
-    return symbol;
-  }
+  return symbol;
 }
 
 
@@ -448,14 +448,14 @@ scm_take_locale_symboln (char *sym, size_t len)
 
   raw_hash = scm_string_hash ((unsigned char *)sym, len);
   res = lookup_interned_symbol (sym, len, raw_hash);
-  if (res != SCM_BOOL_F)
+  if (scm_is_false (res))
     {
-      free (sym);
-      return res;
+      res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
+				 scm_cons (SCM_BOOL_F, SCM_EOL));
+      intern_symbol (res);
     }
-
-  res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
-			     scm_cons (SCM_BOOL_F, SCM_EOL));
+  else
+    free (sym);
 
   return res;
 }

libguile/threads.c

@@ -499,6 +499,7 @@ guilify_self_2 (SCM parent)
 
   t->continuation_root = scm_cons (t->handle, SCM_EOL);
   t->continuation_base = t->base;
+  t->vm = SCM_BOOL_F;
 
   if (scm_is_true (parent))
     t->dynamic_state = scm_make_dynamic_state (parent);

libguile/threads.h

@@ -107,6 +107,7 @@ typedef struct scm_i_thread {
   SCM_STACKITEM *continuation_base;
 
   /* For keeping track of the stack and registers. */
+  SCM vm;
   SCM_STACKITEM *base;
   SCM_STACKITEM *top;
   jmp_buf regs;

libguile/throw.c

@@ -41,6 +41,7 @@
 #include "libguile/throw.h"
 #include "libguile/init.h"
 #include "libguile/strings.h"
+#include "libguile/vm.h"
 
 #include "libguile/private-options.h"
 
@@ -169,8 +170,17 @@ scm_c_catch (SCM tag,
   struct jmp_buf_and_retval jbr;
   SCM jmpbuf;
   SCM answer;
+  SCM vm;
+  SCM *sp = NULL, *fp = NULL; /* to reset the vm */
   struct pre_unwind_data pre_unwind;
 
+  vm = scm_the_vm ();
+  if (SCM_NFALSEP (vm))
+    {
+      sp = SCM_VM_DATA (vm)->sp;
+      fp = SCM_VM_DATA (vm)->fp;
+    }
+
   jmpbuf = make_jmpbuf ();
   answer = SCM_EOL;
   scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
@@ -199,6 +209,30 @@ scm_c_catch (SCM tag,
       throw_tag = jbr.throw_tag;
       jbr.throw_tag = SCM_EOL;
       jbr.retval = SCM_EOL;
+      if (SCM_NFALSEP (vm))
+        {
+          SCM_VM_DATA (vm)->sp = sp;
+          SCM_VM_DATA (vm)->fp = fp;
+#ifdef VM_ENABLE_STACK_NULLING
+          /* see vm.c -- you'll have to enable this manually */
+          memset (sp + 1, 0,
+                  (SCM_VM_DATA (vm)->stack_size
+                   - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
+#endif
+        }
+      else if (SCM_NFALSEP ((vm = scm_the_vm ())))
+        {
+          /* oof, it's possible this catch was called before the vm was
+             booted... yick. anyway, try to reset the vm stack. */
+          SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1;
+          SCM_VM_DATA (vm)->fp = NULL;
+#ifdef VM_ENABLE_STACK_NULLING
+          /* see vm.c -- you'll have to enable this manually */
+          memset (SCM_VM_DATA (vm)->stack_base, 0,
+                  SCM_VM_DATA (vm)->stack_size * sizeof(SCM));
+#endif
+        }
+          
       answer = handler (handler_data, throw_tag, throw_args);
     }
   else

libguile/validate.h

@@ -378,7 +378,7 @@
 
 #define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \
   do { \
-    SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \
+    SCM_ASSERT (scm_is_vector (v) && len == scm_c_vector_length (v), v, pos, FUNC_NAME); \
   } while (0)
 
 

libguile/vm-bootstrap.h

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

libguile/vm-engine.c

@@ -0,0 +1,283 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+/* This file is included in vm.c multiple times */
+
+#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
+#define VM_USE_HOOKS		0	/* Various hooks */
+#define VM_USE_CLOCK		0	/* Bogoclock */
+#define VM_CHECK_EXTERNAL	1	/* Check external link */
+#define VM_CHECK_OBJECT         1       /* Check object table */
+#define VM_PUSH_DEBUG_FRAMES    0       /* Push frames onto the evaluator debug stack */
+#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
+#define VM_USE_HOOKS		1
+#define VM_USE_CLOCK		1
+#define VM_CHECK_EXTERNAL	1
+#define VM_CHECK_OBJECT         1
+#define VM_PUSH_DEBUG_FRAMES    1
+#else
+#error unknown debug engine VM_ENGINE
+#endif
+
+#include "vm-engine.h"
+
+
+static SCM
+VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
+{
+  /* 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_objcode *bp = NULL;	/* program base pointer */
+  SCM external = SCM_EOL;		/* external environment */
+  SCM *objects = NULL;			/* constant objects */
+  size_t object_count = 0;              /* length of OBJECTS */
+  SCM *stack_base = vp->stack_base;	/* stack base address */
+  SCM *stack_limit = vp->stack_limit;	/* stack limit address */
+
+  /* Internal variables */
+  int nvalues = 0;
+  long start_time = scm_c_get_internal_run_time ();
+  SCM finish_args;                      /* used both for returns: both in error
+                                           and normal situations */
+#if VM_USE_HOOKS
+  SCM hook_args = SCM_EOL;
+#endif
+
+#ifdef HAVE_LABELS_AS_VALUES
+  static void **jump_table = NULL;
+#endif
+  
+#if VM_PUSH_DEBUG_FRAMES
+  scm_t_debug_frame debug;
+  scm_t_debug_info debug_vect_body;
+  debug.status = SCM_VOIDFRAME;
+#endif
+
+#ifdef HAVE_LABELS_AS_VALUES
+  if (SCM_UNLIKELY (!jump_table))
+    {
+      int i;
+      jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*));
+      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+        jump_table[i] = &&vm_error_bad_instruction;
+#define VM_INSTRUCTION_TO_LABEL 1
+#include <libguile/vm-expand.h>
+#include <libguile/vm-i-system.i>
+#include <libguile/vm-i-scheme.i>
+#include <libguile/vm-i-loader.i>
+#undef VM_INSTRUCTION_TO_LABEL
+    }
+#endif
+
+  /* Initialization */
+  {
+    SCM prog = program;
+
+    /* Boot program */
+    program = vm_make_boot_program (nargs);
+
+#if VM_PUSH_DEBUG_FRAMES
+    debug.prev = scm_i_last_debug_frame ();
+    debug.status = SCM_APPLYFRAME;
+    debug.vect = &debug_vect_body;
+    debug.vect[0].a.proc = program; /* the boot program */
+    debug.vect[0].a.args = SCM_EOL;
+    scm_i_set_last_debug_frame (&debug);
+#endif
+
+    /* Initial frame */
+    CACHE_REGISTER ();
+    CACHE_PROGRAM ();
+    PUSH (program);
+    NEW_FRAME ();
+
+    /* Initial arguments */
+    PUSH (prog);
+    if (SCM_UNLIKELY (sp + nargs >= stack_limit))
+      goto vm_error_too_many_args;
+    while (nargs--)
+      PUSH (*argv++);
+  }
+
+  /* Let's go! */
+  BOOT_HOOK ();
+  NEXT;
+
+#ifndef HAVE_LABELS_AS_VALUES
+ vm_start:
+  switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) {
+#endif
+
+#include "vm-expand.h"
+#include "vm-i-system.c"
+#include "vm-i-scheme.c"
+#include "vm-i-loader.c"
+
+#ifndef HAVE_LABELS_AS_VALUES
+  default:
+    goto vm_error_bad_instruction;
+  }
+#endif
+
+  
+ vm_done:
+  SYNC_ALL ();
+#if VM_PUSH_DEBUG_FRAMES
+  scm_i_set_last_debug_frame (debug.prev);
+#endif
+  return finish_args;
+
+  /* Errors */
+  {
+    SCM err_msg;
+
+  vm_error_bad_instruction:
+    err_msg  = scm_from_locale_string ("VM: Bad instruction: ~A");
+    finish_args = SCM_LIST1 (scm_from_uchar (ip[-1]));
+    goto vm_error;
+
+  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");
+    finish_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_too_many_args:
+    err_msg  = scm_from_locale_string ("VM: Too many arguments");
+    finish_args = SCM_LIST1 (scm_from_int (nargs));
+    goto vm_error;
+
+  vm_error_wrong_num_args:
+    /* nargs and program are valid */
+    SYNC_ALL ();
+    scm_wrong_num_args (program);
+    /* shouldn't get here */
+    goto vm_error;
+
+  vm_error_wrong_type_apply:
+    err_msg  = scm_from_locale_string ("VM: Wrong type to apply: ~S "
+				       "[IP offset: ~a]");
+    finish_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");
+    finish_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_stack_underflow:
+    err_msg  = scm_from_locale_string ("VM: Stack underflow");
+    finish_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_improper_list:
+    err_msg  = scm_from_locale_string ("VM: Attempt to unroll an improper list: tail is ~A");
+    goto vm_error;
+
+  vm_error_not_a_pair:
+    SYNC_ALL ();
+    scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair");
+    /* shouldn't get here */
+    goto vm_error;
+
+  vm_error_no_values:
+    err_msg  = scm_from_locale_string ("VM: 0-valued return");
+    finish_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_not_enough_values:
+    err_msg  = scm_from_locale_string ("VM: Not enough values for mv-bind");
+    finish_args = SCM_EOL;
+    goto vm_error;
+
+  vm_error_no_such_module:
+    err_msg  = scm_from_locale_string ("VM: No such module: ~A");
+    goto vm_error;
+
+#if VM_CHECK_IP
+  vm_error_invalid_address:
+    err_msg  = scm_from_locale_string ("VM: Invalid program address");
+    finish_args = SCM_EOL;
+    goto vm_error;
+#endif
+
+#if VM_CHECK_EXTERNAL
+  vm_error_external:
+    err_msg  = scm_from_locale_string ("VM: Invalid external access");
+    finish_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");
+    finish_args = SCM_EOL;
+    goto vm_error;
+#endif
+
+  vm_error:
+    SYNC_ALL ();
+
+    scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, finish_args), 1);
+  }
+
+  abort (); /* never reached */
+}
+
+#undef VM_USE_HOOKS
+#undef VM_USE_CLOCK
+#undef VM_CHECK_EXTERNAL
+#undef VM_CHECK_OBJECT
+#undef VM_PUSH_DEBUG_FRAMES
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/vm-engine.h

@@ -0,0 +1,433 @@
+/* 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 */
+
+
+/*
+ * 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__
+/* gcc on lenny actually crashes if we allocate these variables in registers.
+   hopefully this is the only one of these. */
+#if !(__GNUC__==4 && __GNUC_MINOR__==1 && __GNUC_PATCHLEVEL__==2)
+#define IP_REG asm("%esi")
+#define SP_REG asm("%edi")
+#define FP_REG
+#endif
+#endif
+#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
+#define IP_REG asm("26")
+#define SP_REG asm("27")
+#define FP_REG asm("28")
+#endif
+#ifdef __hppa__
+#define IP_REG asm("%r18")
+#define SP_REG asm("%r17")
+#define FP_REG asm("%r16")
+#endif
+#ifdef __mc68000__
+#define IP_REG asm("a5")
+#define SP_REG asm("a4")
+#define FP_REG
+#endif
+#ifdef __arm__
+#define IP_REG asm("r9")
+#define SP_REG asm("r8")
+#define FP_REG asm("r7")
+#endif
+#endif
+
+#ifndef IP_REG
+#define IP_REG
+#endif
+#ifndef SP_REG
+#define SP_REG
+#endif
+#ifndef FP_REG
+#define FP_REG
+#endif
+
+
+/*
+ * Cache/Sync
+ */
+
+#ifdef VM_ENABLE_ASSERTIONS
+# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort()
+#else
+# define ASSERT(condition)
+#endif
+
+
+#define CACHE_REGISTER()			\
+{						\
+  ip = vp->ip;					\
+  sp = vp->sp;					\
+  fp = vp->fp;					\
+  stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \
+}
+
+#define SYNC_REGISTER()				\
+{						\
+  vp->ip = ip;					\
+  vp->sp = sp;					\
+  vp->fp = fp;					\
+}
+
+#ifdef VM_ENABLE_PARANOID_ASSERTIONS
+#define CHECK_IP() \
+  do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#else
+#define CHECK_IP()
+#endif
+
+/* Get a local copy of the program's "object table" (i.e. the vector of
+   external bindings that are referenced by the program), initialized by
+   `load-program'.  */
+/* XXX:  We could instead use the "simple vector macros", thus not having to
+   call `scm_vector_writable_elements ()' and the likes.  */
+#define CACHE_PROGRAM()							\
+{									\
+  if (bp != SCM_PROGRAM_DATA (program)) {                               \
+    bp = SCM_PROGRAM_DATA (program);					\
+    if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) {             \
+      objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program));    \
+      object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
+    } else {                                                            \
+      objects = NULL;                                                   \
+      object_count = 0;                                                 \
+    }                                                                   \
+  }                                                                     \
+}
+
+#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_UNLIKELY (!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 (SCM_UNLIKELY ((_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_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\
+    {						\
+      SYNC_REGISTER ();				\
+      vm_dispatch_hook (vp, 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
+ */
+
+#ifdef VM_ENABLE_STACK_NULLING
+# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]);
+# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1)
+# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; }
+/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation
+   inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for
+   that continuation doesn't have a chance to run. It's not important on a
+   semantic level, but it does mess up our stack nulling -- so this macro is to
+   fix that. */
+# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp);
+#else
+# define CHECK_STACK_LEAKN(_n)
+# define CHECK_STACK_LEAK()
+# define NULLSTACK(_n)
+# define NULLSTACK_FOR_NONLOCAL_EXIT()
+#endif
+
+#define CHECK_OVERFLOW()			\
+  if (sp > stack_limit)				\
+    goto vm_error_stack_overflow
+
+#define CHECK_UNDERFLOW()                       \
+  if (sp < stack_base)                          \
+    goto vm_error_stack_underflow;
+
+#define PUSH(x)	do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0)
+#define DROP()	do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0)
+#define DROPN(_n)	do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_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, x;				\
+  for (i = n; i; i--)                           \
+    {                                           \
+      POP (x);                                  \
+      CONS (l, x, l);                           \
+    }                                           \
+  PUSH (l);					\
+} while (0)
+
+/* The opposite: push all of the elements in L onto the list. */
+#define PUSH_LIST(l, NILP)			\
+do						\
+{						\
+  for (; scm_is_pair (l); l = SCM_CDR (l))      \
+    PUSH (SCM_CAR (l));                         \
+  if (SCM_UNLIKELY (!NILP (l))) {               \
+    finish_args = scm_list_1 (l);               \
+    goto vm_error_improper_list;                \
+  }                                             \
+} while (0)
+
+
+#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)
+
+#define POP_CONS_MARK()				\
+do {						\
+  SCM o, l;					\
+  POP (l);                                      \
+  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 { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } 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 () & SCM_VM_INSTRUCTION_MASK]
+#else
+#define NEXT_JUMP()		goto vm_start
+#endif
+
+#define NEXT					\
+{						\
+  CLOCK (1);					\
+  NEXT_HOOK ();					\
+  CHECK_STACK_LEAK ();                          \
+  NEXT_JUMP ();					\
+}
+
+
+/*
+ * Stack frame
+ */
+
+#define INIT_ARGS()				\
+{						\
+  if (SCM_UNLIKELY (bp->nrest))                 \
+    {						\
+      int n = nargs - (bp->nargs - 1);		\
+      if (n < 0)				\
+	goto vm_error_wrong_num_args;		\
+      /* NB, can cause GC while setting up the  \
+         stack frame */                         \
+      POP_LIST (n);				\
+    }						\
+  else						\
+    {						\
+      if (SCM_UNLIKELY (nargs != bp->nargs))    \
+	goto vm_error_wrong_num_args;		\
+    }						\
+}
+
+/* See frames.h for the layout of stack frames */
+/* When this is called, bp points to the new program data,
+   and the arguments are already on the stack */
+#define NEW_FRAME()				\
+{						\
+  int i;					\
+  SCM *dl, *data;                               \
+  scm_byte_t *ra = ip;                          \
+						\
+  /* Save old registers */                      \
+  ra = ip;                                      \
+  dl = fp;                                      \
+						\
+  /* New registers */                           \
+  fp = sp - bp->nargs + 1;                      \
+  data = SCM_FRAME_DATA_ADDRESS (fp);           \
+  sp = data + 3;                                \
+  CHECK_OVERFLOW ();				\
+  stack_base = sp;				\
+  ip = bp->base;				\
+						\
+  /* Init local variables */			\
+  for (i=bp->nlocs; i; i--)                     \
+    data[-i] = SCM_UNDEFINED;                   \
+						\
+  /* Set frame data */				\
+  data[3] = (SCM)ra;                            \
+  data[2] = 0x0;                                \
+  data[1] = (SCM)dl;                            \
+                                                \
+  /* Postpone initializing external vars,       \
+     because if the CONS causes a GC, we        \
+     want the stack marker to see the data      \
+     array formatted as expected. */            \
+  data[0] = SCM_UNDEFINED;                      \
+  external = SCM_PROGRAM_EXTERNALS (fp[-1]);    \
+  for (i = 0; i < bp->nexts; i++)               \
+    CONS (external, SCM_UNDEFINED, external);   \
+  data[0] = external;                           \
+}
+
+#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/vm-expand.h

@@ -0,0 +1,102 @@
+/* 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_FUNCTION
+#undef VM_DEFINE_LOADER
+#define VM_DEFINE_FUNCTION(code,tag,name,nargs) \
+  VM_DEFINE_INSTRUCTION(code,tag,name,0,nargs,1)
+#define VM_DEFINE_LOADER(code,tag,name)         \
+  VM_DEFINE_INSTRUCTION(code,tag,name,-1,0,1)
+
+#undef VM_DEFINE_INSTRUCTION
+/*
+ * These will go to scm_instruction_table in instructions.c
+ */
+#ifdef VM_INSTRUCTION_TO_TABLE
+#define VM_DEFINE_INSTRUCTION(code_,tag_,name_,len_,npop_,npush_) \
+  table[VM_OPCODE (tag_)].opcode = code_;                          \
+  table[VM_OPCODE (tag_)].name = name_;                            \
+  table[VM_OPCODE (tag_)].len = len_;                              \
+  table[VM_OPCODE (tag_)].npop = npop_;                            \
+  table[VM_OPCODE (tag_)].npush = npush_;
+
+#else
+#ifdef VM_INSTRUCTION_TO_LABEL
+/*
+ * These will go to jump_table in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	jump_table[code] = VM_ADDR (tag);
+
+#else
+#ifdef VM_INSTRUCTION_TO_OPCODE
+/*
+ * These will go to scm_opcode in instructions.h
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	VM_OPCODE (tag) = code,
+
+#else /* Otherwise */
+/*
+ * These are directly included in vm_engine.c
+ */
+#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush)	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:
+*/

libguile/vm-i-loader.c

@@ -0,0 +1,184 @@
+/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
+ * 
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+/* This file is included in vm_engine.c */
+
+VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
+{
+  size_t len;
+
+  FETCH_LENGTH (len);
+  if (SCM_LIKELY (len <= 4))
+    {
+      unsigned int val = 0;
+      while (len-- > 0)
+	val = (val << 8U) + FETCH ();
+      SYNC_REGISTER ();
+      PUSH (scm_from_uint (val));
+      NEXT;
+    }
+  else
+    SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (60, load_integer, "load-integer")
+{
+  size_t len;
+
+  FETCH_LENGTH (len);
+  if (SCM_LIKELY (len <= 4))
+    {
+      int val = 0;
+      while (len-- > 0)
+	val = (val << 8) + FETCH ();
+      SYNC_REGISTER ();
+      PUSH (scm_from_int (val));
+      NEXT;
+    }
+  else
+    SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
+}
+
+VM_DEFINE_LOADER (61, load_number, "load-number")
+{
+  size_t len;
+
+  FETCH_LENGTH (len);
+  SYNC_REGISTER ();
+  PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len),
+			      SCM_UNDEFINED /* radix = 10 */));
+  /* Was: scm_istring2number (ip, len, 10)); */
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (62, load_string, "load-string")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  SYNC_REGISTER ();
+  PUSH (scm_from_locale_stringn ((char *)ip, len));
+  /* Was: scm_makfromstr (ip, len, 0) */
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  SYNC_REGISTER ();
+  PUSH (scm_from_locale_symboln ((char *)ip, len));
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
+{
+  size_t len;
+  FETCH_LENGTH (len);
+  SYNC_REGISTER ();
+  PUSH (scm_from_locale_keywordn ((char *)ip, len));
+  ip += len;
+  NEXT;
+}
+
+VM_DEFINE_LOADER (65, load_program, "load-program")
+{
+  scm_t_uint32 len;
+  SCM objs, objcode;
+
+  POP (objs);
+  SYNC_REGISTER ();
+
+  if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0)))
+    scm_c_vector_set_x (objs, 0, scm_current_module ());
+
+  objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
+  len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
+
+  PUSH (scm_make_program (objcode, objs, SCM_EOL));
+
+  ip += len;
+
+  NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
+{
+  SCM what;
+  POP (what);
+  SYNC_REGISTER ();
+  if (SCM_LIKELY (SCM_SYMBOLP (what)))
+    {
+      PUSH (scm_lookup (what)); /* might longjmp */
+    }
+  else
+    {
+      SCM mod;
+      /* compilation of @ or @@
+         `what' is a three-element list: (MODNAME SYM INTERFACE?)
+         INTERFACE? is #t if we compiled @ or #f if we compiled @@
+      */
+      mod = scm_resolve_module (SCM_CAR (what));
+      if (scm_is_true (SCM_CADDR (what)))
+        mod = scm_module_public_interface (mod);
+      if (SCM_FALSEP (mod))
+        {
+          finish_args = SCM_LIST1 (SCM_CAR (what));
+          goto vm_error_no_such_module;
+        }
+      /* might longjmp */
+      PUSH (scm_module_lookup (mod, SCM_CADR (what)));
+    }
+      
+  NEXT;
+}
+
+VM_DEFINE_LOADER (67, define, "define")
+{
+  SCM sym;
+  size_t len;
+
+  FETCH_LENGTH (len);
+  SYNC_REGISTER ();
+  sym = scm_from_locale_symboln ((char *)ip, len);
+  ip += len;
+
+  SYNC_REGISTER ();
+  PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
+  NEXT;
+}
+
+/*
+(defun renumber-ops ()
+  "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+  (interactive "")
+  (save-excursion
+    (let ((counter 59)) (goto-char (point-min))
+      (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+        (replace-match
+         (number-to-string (setq counter (1+ counter)))
+          t t nil 1)))))
+*/
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/vm-i-scheme.c

@@ -0,0 +1,314 @@
+/* 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
+ */
+
+#define ARGS1(a1)	SCM a1 = sp[0];
+#define ARGS2(a1,a2)	SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1);
+#define ARGS3(a1,a2,a3)	SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2);
+
+#define RETURN(x)	do { *sp = x; NEXT; } while (0)
+
+VM_DEFINE_FUNCTION (80, not, "not", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (!SCM_FALSEP (x)));
+}
+
+VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
+{
+  ARGS2 (x, y);
+  RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
+{
+  ARGS2 (x, y);
+  RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
+}
+
+VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (!SCM_NULLP (x)));
+}
+
+VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_REGISTER ();
+  RETURN (scm_eqv_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
+{
+  ARGS2 (x, y);
+  if (SCM_EQ_P (x, y))
+    RETURN (SCM_BOOL_T);
+  if (SCM_IMP (x) || SCM_IMP (y))
+    RETURN (SCM_BOOL_F);
+  SYNC_REGISTER ();
+  RETURN (scm_equal_p (x, y));
+}
+
+VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (SCM_CONSP (x)));
+}
+
+VM_DEFINE_FUNCTION (89, listp, "list?", 1)
+{
+  ARGS1 (x);
+  RETURN (SCM_BOOL (scm_ilength (x) >= 0));
+}
+
+
+/*
+ * Basic data
+ */
+
+VM_DEFINE_FUNCTION (90, cons, "cons", 2)
+{
+  ARGS2 (x, y);
+  CONS (x, x, y);
+  RETURN (x);
+}
+
+#define VM_VALIDATE_CONS(x)                     \
+  if (SCM_UNLIKELY (!scm_is_pair (x)))          \
+    { finish_args = x;                          \
+      goto vm_error_not_a_pair;                 \
+    }
+  
+VM_DEFINE_FUNCTION (91, car, "car", 1)
+{
+  ARGS1 (x);
+  VM_VALIDATE_CONS (x);
+  RETURN (SCM_CAR (x));
+}
+
+VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
+{
+  ARGS1 (x);
+  VM_VALIDATE_CONS (x);
+  RETURN (SCM_CDR (x));
+}
+
+VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
+{
+  ARGS2 (x, y);
+  VM_VALIDATE_CONS (x);
+  SCM_SETCAR (x, y);
+  RETURN (SCM_UNSPECIFIED);
+}
+
+VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
+{
+  ARGS2 (x, y);
+  VM_VALIDATE_CONS (x);
+  SCM_SETCDR (x, y);
+  RETURN (SCM_UNSPECIFIED);
+}
+
+
+/*
+ * Numeric relational tests
+ */
+
+#undef REL
+#define REL(crel,srel)						\
+{								\
+  ARGS2 (x, y);							\
+  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))			\
+    RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y)));	\
+  SYNC_REGISTER ();                                             \
+  RETURN (srel (x, y));                                         \
+}
+
+VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
+{
+  REL (==, scm_num_eq_p);
+}
+
+VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
+{
+  REL (<, scm_less_p);
+}
+
+VM_DEFINE_FUNCTION (97, le, "le?", 2)
+{
+  REL (<=, scm_leq_p);
+}
+
+VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
+{
+  REL (>, scm_gr_p);
+}
+
+VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
+{
+  REL (>=, scm_geq_p);
+}
+
+
+/*
+ * Numeric functions
+ */
+
+#undef FUNC2
+#define FUNC2(CFUNC,SFUNC)				\
+{							\
+  ARGS2 (x, y);						\
+  if (SCM_I_INUMP (x) && SCM_I_INUMP (y))		\
+    {							\
+      scm_t_bits n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
+      if (SCM_FIXABLE (n))				\
+	RETURN (SCM_I_MAKINUM (n));			\
+    }							\
+  SYNC_REGISTER ();					\
+  RETURN (SFUNC (x, y));				\
+}
+
+VM_DEFINE_FUNCTION (100, add, "add", 2)
+{
+  FUNC2 (+, scm_sum);
+}
+
+VM_DEFINE_FUNCTION (101, sub, "sub", 2)
+{
+  FUNC2 (-, scm_difference);
+}
+
+VM_DEFINE_FUNCTION (102, mul, "mul", 2)
+{
+  ARGS2 (x, y);
+  SYNC_REGISTER ();
+  RETURN (scm_product (x, y));
+}
+
+VM_DEFINE_FUNCTION (103, div, "div", 2)
+{
+  ARGS2 (x, y);
+  SYNC_REGISTER ();
+  RETURN (scm_divide (x, y));
+}
+
+VM_DEFINE_FUNCTION (104, quo, "quo", 2)
+{
+  ARGS2 (x, y);
+  SYNC_REGISTER ();
+  RETURN (scm_quotient (x, y));
+}
+
+VM_DEFINE_FUNCTION (105, rem, "rem", 2)
+{
+  ARGS2 (x, y);
+  SYNC_REGISTER ();
+  RETURN (scm_remainder (x, y));
+}
+
+VM_DEFINE_FUNCTION (106, mod, "mod", 2)
+{
+  ARGS2 (x, y);
+  SYNC_REGISTER ();
+  RETURN (scm_modulo (x, y));
+}
+
+
+/*
+ * GOOPS support
+ */
+VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
+{
+  size_t slot;
+  ARGS2 (instance, idx);
+  slot = SCM_I_INUM (idx);
+  RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+}
+
+VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
+{
+  size_t slot;
+  ARGS3 (instance, idx, val);
+  slot = SCM_I_INUM (idx);
+  SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
+  RETURN (SCM_UNSPECIFIED);
+}
+
+/*
+(defun renumber-ops ()
+  "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
+  (interactive "")
+  (save-excursion
+    (let ((counter 79)) (goto-char (point-min))
+      (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
+        (replace-match
+         (number-to-string (setq counter (1+ counter)))
+          t t nil 1)))))
+*/
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/vm.c

@@ -0,0 +1,682 @@
+/* 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 <alloca.h>
+#include <string.h>
+#include "vm-bootstrap.h"
+#include "frames.h"
+#include "instructions.h"
+#include "objcodes.h"
+#include "programs.h"
+#include "lang.h" /* NULL_OR_NIL_P */
+#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 ());      \
+}
+
+/* The VM has a number of internal assertions that shouldn't normally be
+   necessary, but might be if you think you found a bug in the VM. */
+#define VM_ENABLE_ASSERTIONS
+
+/* We can add a mode that ensures that all stack items above the stack pointer
+   are NULL. This is useful for checking the internal consistency of the VM's
+   assumptions and its operators, but isn't necessary for normal operation. It
+   will ensure that assertions are enabled. Slows down the VM by about 30%. */
+/* NB! If you enable this, search for NULLING in throw.c */
+/* #define VM_ENABLE_STACK_NULLING */
+
+/* #define VM_ENABLE_PARANOID_ASSERTIONS */
+
+#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS)
+#define VM_ENABLE_ASSERTIONS
+#endif
+
+
+/*
+ * VM Continuation
+ */
+
+scm_t_bits scm_tc16_vm_cont;
+
+static void
+vm_mark_stack (SCM *base, scm_t_ptrdiff size, SCM *fp, scm_t_ptrdiff reloc)
+{
+  SCM *sp, *upper, *lower;
+  sp = base + size - 1;
+
+  while (sp > base && fp) 
+    {
+      upper = SCM_FRAME_UPPER_ADDRESS (fp);
+      lower = SCM_FRAME_LOWER_ADDRESS (fp);
+
+      for (; sp >= upper; sp--)
+        if (SCM_NIMP (*sp)) 
+          {
+            if (scm_in_heap_p (*sp))
+              scm_gc_mark (*sp);
+            else
+              fprintf (stderr, "BADNESS: crap on the stack: %p\n", *sp);
+          }
+      
+
+      /* skip ra, mvra */
+      sp -= 2;
+
+      /* update fp from the dynamic link */
+      fp = (SCM*)*sp-- + reloc;
+
+      /* mark from the el down to the lower address */
+      for (; sp >= lower; sp--)
+        if (*sp && SCM_NIMP (*sp))
+          scm_gc_mark (*sp);
+    }
+}
+
+static SCM
+vm_cont_mark (SCM obj)
+{
+  struct scm_vm_cont *p = SCM_VM_CONT_DATA (obj);
+
+  if (p->stack_size)
+    vm_mark_stack (p->stack_base, p->stack_size, p->fp + p->reloc, p->reloc);
+
+  return SCM_BOOL_F;
+}
+
+static scm_sizet
+vm_cont_free (SCM obj)
+{
+  struct scm_vm_cont *p = SCM_VM_CONT_DATA (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;
+}
+
+static SCM
+capture_vm_cont (struct scm_vm *vp)
+{
+  struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont");
+  p->stack_size = vp->sp - vp->stack_base + 1;
+  p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM),
+				 "capture_vm_cont");
+#ifdef VM_ENABLE_STACK_NULLING
+  if (vp->sp >= vp->stack_base)
+    if (!vp->sp[0] || vp->sp[1])
+      abort ();
+  memset (p->stack_base, 0, p->stack_size * sizeof (SCM));
+#endif
+  p->ip = vp->ip;
+  p->sp = vp->sp;
+  p->fp = vp->fp;
+  memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
+  p->reloc = p->stack_base - vp->stack_base;
+  SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+}
+
+static void
+reinstate_vm_cont (struct scm_vm *vp, SCM cont)
+{
+  struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont);
+  if (vp->stack_size < p->stack_size)
+    {
+      /* puts ("FIXME: Need to expand"); */
+      abort ();
+    }
+#ifdef VM_ENABLE_STACK_NULLING
+  {
+    scm_t_ptrdiff nzero = (vp->sp - p->sp);
+    if (nzero > 0)
+      memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM));
+    /* actually nzero should always be negative, because vm_reset_stack will
+       unwind the stack to some point *below* this continuation */
+  }
+#endif
+  vp->ip = p->ip;
+  vp->sp = p->sp;
+  vp->fp = p->fp;
+  memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM));
+}
+
+/* In theory, a number of vm instances can be active in the call trace, and we
+   only want to reify the continuations of those in the current continuation
+   root. I don't see a nice way to do this -- ideally it would involve dynwinds,
+   and previous values of the *the-vm* fluid within the current continuation
+   root. But we don't have access to continuation roots in the dynwind stack.
+   So, just punt for now -- take the current value of *the-vm*.
+
+   While I'm on the topic, ideally we could avoid copying the C stack if the
+   continuation root is inside VM code, and call/cc was invoked within that same
+   call to vm_run; but that's currently not implemented.
+ */
+SCM
+scm_vm_capture_continuations (void)
+{
+  SCM vm = scm_the_vm ();
+  return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL);
+}
+
+void
+scm_vm_reinstate_continuations (SCM conts)
+{
+  for (; conts != SCM_EOL; conts = SCM_CDR (conts))
+    reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts));
+}
+
+static void enfalsen_frame (void *p)
+{ 
+  struct scm_vm *vp = p;
+  vp->trace_frame = SCM_BOOL_F;
+}
+
+static void
+vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args)
+{
+  if (!SCM_FALSEP (vp->trace_frame))
+    return;
+  
+  scm_dynwind_begin (0);
+  // FIXME, stack holder should be the vm
+  vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0);
+  scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY);
+
+  scm_c_run_hook (hook, hook_args);
+
+  scm_dynwind_end ();
+}
+
+
+/*
+ * VM Internal functions
+ */
+
+static SCM sym_vm_run;
+static SCM sym_vm_error;
+static SCM sym_debug;
+
+static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
+{
+  scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
+  memcpy (new_bytes, bytes, len);
+  return scm_take_u8vector (new_bytes, len);
+}
+
+static SCM
+really_make_boot_program (long nargs)
+{
+  scm_byte_t bytes[] = {0, 0, 0, 0,
+                        0, 0, 0, 0,
+                        0, 0, 0, 0,
+                        scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
+  SCM ret;
+  ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
+  if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
+    abort ();
+  bytes[13] = (scm_byte_t)nargs;
+  ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
+                          SCM_BOOL_F, SCM_EOL);
+  SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+  return ret;
+}
+#define NUM_BOOT_PROGS 8
+static SCM
+vm_make_boot_program (long nargs)
+{
+  static SCM programs[NUM_BOOT_PROGS] = { 0, };
+
+  if (SCM_UNLIKELY (!programs[0])) 
+    {
+      int i;
+      for (i = 0; i < NUM_BOOT_PROGS; i++)
+        programs[i] = scm_permanent_object (really_make_boot_program (i));
+    }
+  
+  if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
+    return programs[nargs];
+  else
+    return really_make_boot_program (nargs);
+}
+
+
+/*
+ * VM
+ */
+
+#define VM_DEFAULT_STACK_SIZE	(16 * 1024)
+
+#define VM_NAME   vm_regular_engine
+#define FUNC_NAME "vm-regular-engine"
+#define VM_ENGINE SCM_VM_REGULAR_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef FUNC_NAME
+#undef VM_ENGINE
+
+#define VM_NAME	  vm_debug_engine
+#define FUNC_NAME "vm-debug-engine"
+#define VM_ENGINE SCM_VM_DEBUG_ENGINE
+#include "vm-engine.c"
+#undef VM_NAME
+#undef FUNC_NAME
+#undef VM_ENGINE
+
+static const scm_t_vm_engine vm_engines[] = 
+  { vm_regular_engine, vm_debug_engine };
+
+scm_t_bits scm_tc16_vm;
+
+static SCM
+make_vm (void)
+#define FUNC_NAME "make_vm"
+{
+  int i;
+
+  if (!scm_tc16_vm)
+    return SCM_BOOL_F; /* not booted yet */
+
+  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");
+#ifdef VM_ENABLE_STACK_NULLING
+  memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM));
+#endif
+  vp->stack_limit = vp->stack_base + vp->stack_size - 3;
+  vp->ip    	  = NULL;
+  vp->sp    	  = vp->stack_base - 1;
+  vp->fp    	  = NULL;
+  vp->engine      = SCM_VM_DEBUG_ENGINE;
+  vp->time        = 0;
+  vp->clock       = 0;
+  vp->options     = SCM_EOL;
+  for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+    vp->hooks[i] = SCM_BOOL_F;
+  vp->trace_frame = 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);
+
+#ifdef VM_ENABLE_STACK_NULLING
+  if (vp->sp >= vp->stack_base)
+    if (!vp->sp[0] || vp->sp[1])
+      abort ();
+#endif
+
+  /* mark the stack, precisely */
+  vm_mark_stack (vp->stack_base, vp->sp + 1 - vp->stack_base, vp->fp, 0);
+
+  /* mark other objects  */
+  for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
+    scm_gc_mark (vp->hooks[i]);
+
+  scm_gc_mark (vp->trace_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
+scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
+{
+  struct scm_vm *vp = SCM_VM_DATA (vm);
+  return vm_engines[vp->engine](vp, program, argv, nargs);
+}
+
+SCM
+scm_vm_apply (SCM vm, SCM program, SCM args)
+#define FUNC_NAME "scm_vm_apply"
+{
+  SCM *argv;
+  int i, nargs;
+  
+  SCM_VALIDATE_VM (1, vm);
+  SCM_VALIDATE_PROGRAM (2, program);
+
+  nargs = scm_ilength (args);
+  if (SCM_UNLIKELY (nargs < 0))
+    scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list");
+  
+  argv = alloca(nargs * sizeof(SCM));
+  for (i = 0; i < nargs; i++)
+    {
+      argv[i] = SCM_CAR (args);
+      args = SCM_CDR (args);
+    }
+
+  return scm_c_vm_run (vm, program, argv, nargs);
+}
+#undef FUNC_NAME
+
+/* Scheme interface */
+
+SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_vm_version
+{
+  return scm_from_locale_string (PACKAGE_VERSION);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_the_vm
+{
+  scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+  if (SCM_UNLIKELY (SCM_FALSEP ((t->vm))))
+    t->vm = make_vm ();
+
+  return t->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
+
+SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
+	    (SCM vm),
+	    "")
+#define FUNC_NAME s_scm_vm_trace_frame
+{
+  SCM_VALIDATE_VM (1, vm);
+  return SCM_VM_DATA (vm)->trace_frame;
+}
+#undef FUNC_NAME
+
+
+/*
+ * Initialize
+ */
+
+SCM scm_load_compiled_with_vm (SCM file)
+{
+  SCM program = scm_make_program (scm_load_objcode (file),
+                                  SCM_BOOL_F, SCM_EOL);
+  
+  return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
+}
+
+void
+scm_bootstrap_vm (void)
+{
+  static int strappage = 0;
+  
+  if (strappage)
+    return;
+
+  scm_bootstrap_frames ();
+  scm_bootstrap_instructions ();
+  scm_bootstrap_objcodes ();
+  scm_bootstrap_programs ();
+
+  scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
+  scm_set_smob_mark (scm_tc16_vm_cont, vm_cont_mark);
+  scm_set_smob_free (scm_tc16_vm_cont, vm_cont_free);
+
+  scm_tc16_vm = scm_make_smob_type ("vm", 0);
+  scm_set_smob_mark (scm_tc16_vm, vm_mark);
+  scm_set_smob_free (scm_tc16_vm, vm_free);
+  scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
+
+  scm_c_define ("load-compiled",
+                scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+                                  scm_load_compiled_with_vm));
+
+  sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run"));
+  sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
+  sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
+
+  strappage = 1;
+}
+
+void
+scm_init_vm (void)
+{
+  scm_bootstrap_vm ();
+
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/vm.x"
+#endif
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

libguile/vm.h

@@ -0,0 +1,139 @@
+/* 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>
+#include <libguile/programs.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;
+
+typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int nargs);
+
+#define SCM_VM_REGULAR_ENGINE 0
+#define SCM_VM_DEBUG_ENGINE 1
+#define SCM_VM_NUM_ENGINES 2
+
+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 */
+  int engine;                   /* which vm engine we're using */
+  SCM hooks[SCM_VM_NUM_HOOKS];	/* hooks */
+  SCM options;			/* options */
+  unsigned long time;		/* time spent */
+  unsigned long clock;		/* bogos clock */
+  SCM trace_frame;              /* a frame being traced */
+};
+
+extern SCM scm_the_vm_fluid;
+
+#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_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+extern SCM scm_vm_option_ref (SCM vm, SCM key);
+extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+extern SCM scm_vm_version (void);
+extern SCM scm_the_vm (void);
+extern SCM scm_vm_p (SCM obj);
+extern SCM scm_vm_ip (SCM vm);
+extern SCM scm_vm_sp (SCM vm);
+extern SCM scm_vm_fp (SCM vm);
+extern SCM scm_vm_boot_hook (SCM vm);
+extern SCM scm_vm_halt_hook (SCM vm);
+extern SCM scm_vm_next_hook (SCM vm);
+extern SCM scm_vm_break_hook (SCM vm);
+extern SCM scm_vm_enter_hook (SCM vm);
+extern SCM scm_vm_apply_hook (SCM vm);
+extern SCM scm_vm_exit_hook (SCM vm);
+extern SCM scm_vm_return_hook (SCM vm);
+extern SCM scm_vm_option (SCM vm, SCM key);
+extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+extern SCM scm_vm_stats (SCM vm);
+extern SCM scm_vm_trace_frame (SCM vm);
+
+struct scm_vm_cont {
+  scm_byte_t *ip;
+  SCM *sp;
+  SCM *fp;
+  scm_t_ptrdiff stack_size;
+  SCM *stack_base;
+  scm_t_ptrdiff reloc;
+};
+
+extern 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_DATA(CONT)	((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
+
+extern SCM scm_vm_capture_continuations (void);
+extern void scm_vm_reinstate_continuations (SCM conts);
+
+extern SCM scm_load_compiled_with_vm (SCM file);
+
+extern void scm_init_vm (void);
+
+#endif /* _SCM_VM_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/

m4/labels-as-values.m4

@@ -0,0 +1,22 @@
+dnl check for gcc's "labels as values" feature
+AC_DEFUN([AC_C_LABELS_AS_VALUES],
+[AC_CACHE_CHECK([labels as values], ac_cv_labels_as_values,
+[AC_TRY_COMPILE([
+int foo(int);
+int foo(i)
+int i; { 
+static void *label[] = { &&l1, &&l2 };
+goto *label[i];
+l1: return 1;
+l2: return 2;
+}
+],
+[int i;], 
+ac_cv_labels_as_values=yes,
+ac_cv_labels_as_values=no)])
+if test "$ac_cv_labels_as_values" = yes; then
+AC_DEFINE([HAVE_LABELS_AS_VALUES], [],
+          [Define if compiler supports gcc's "labels as values" (aka computed goto)
+           feature, used to speed up instruction dispatch in the interpreter.])
+fi
+])

module/Makefile.am

@@ -0,0 +1,90 @@
+## Process this file with automake to produce Makefile.in.
+##
+##  	Copyright (C) 2009 Free Software Foundation, Inc.
+##
+##   This file is part of GUILE.
+##
+##   GUILE is free software; you can redistribute it and/or modify
+##   it under the terms of the GNU General Public License as
+##   published by the Free Software Foundation; either version 2, or
+##   (at your option) any later version.
+##
+##   GUILE is distributed in the hope that it will be useful, but
+##   WITHOUT ANY WARRANTY; without even the implied warranty of
+##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+##   GNU General Public License for more details.
+##
+##   You should have received a copy of the GNU General Public
+##   License along with GUILE; see the file COPYING.  If not, write
+##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
+##   Floor, Boston, MA 02110-1301 USA
+
+# Build the compiler and VM support first to avoid stack overflows
+# when building the rest.
+SUBDIRS = . ice-9 srfi oop
+
+# We're at the root of the module hierarchy.
+modpath =
+
+SOURCES =								\
+  system/base/pmatch.scm system/base/syntax.scm				\
+  system/base/compile.scm system/base/language.scm			\
+									\
+  system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm	\
+  system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm	\
+  system/vm/trace.scm system/vm/vm.scm					\
+									\
+  system/xref.scm							\
+									\
+  system/repl/repl.scm system/repl/common.scm				\
+  system/repl/command.scm						\
+									\
+  language/ghil.scm language/glil.scm language/assembly.scm		\
+									\
+  $(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES)			\
+  $(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES)				\
+  $(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES)			\
+  $(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
+
+SCHEME_LANG_SOURCES =						\
+  language/scheme/amatch.scm language/scheme/expand.scm 	\
+  language/scheme/compile-ghil.scm language/scheme/spec.scm	\
+  language/scheme/inline.scm
+
+GHIL_LANG_SOURCES =					\
+  language/ghil/spec.scm language/ghil/compile-glil.scm
+
+GLIL_LANG_SOURCES =						\
+  language/glil/spec.scm language/glil/compile-assembly.scm 	\
+  language/glil/decompile-assembly.scm
+
+ASSEMBLY_LANG_SOURCES =				\
+  language/assembly/spec.scm			\
+  language/assembly/compile-bytecode.scm	\
+  language/assembly/decompile-bytecode.scm	\
+  language/assembly/disassemble.scm
+
+BYTECODE_LANG_SOURCES =				\
+  language/bytecode/spec.scm
+
+OBJCODE_LANG_SOURCES =				\
+  language/objcode/spec.scm
+
+VALUE_LANG_SOURCES =				\
+  language/value/spec.scm
+
+ECMASCRIPT_LANG_SOURCES =			\
+  language/ecmascript/parse-lalr.scm		\
+  language/ecmascript/tokenize.scm		\
+  language/ecmascript/parse.scm			\
+  language/ecmascript/spec.scm			\
+  language/ecmascript/impl.scm			\
+  language/ecmascript/base.scm			\
+  language/ecmascript/function.scm		\
+  language/ecmascript/array.scm			\
+  language/ecmascript/compile-ghil.scm
+
+NOCOMP_SOURCES =				\
+  system/repl/describe.scm
+
+include $(top_srcdir)/am/guilec

module/ice-9/Makefile.am

@@ -24,35 +24,47 @@ AUTOMAKE_OPTIONS = gnu
 SUBDIRS = debugger debugging
 
 # These should be installed and distributed.
-ice9_sources =								\
-	and-let-star.scm boot-9.scm calling.scm common-list.scm		\
+modpath = ice-9
+# Compile psyntax and boot-9 first, so that we get the speed benefit in
+# the rest of the compilation. Also, if there is too much switching back
+# and forth between interpreted and compiled code, we end up using more
+# of the C stack than the interpreter would have; so avoid that by
+# putting these core modules first.
+SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \
+	and-let-star.scm calling.scm common-list.scm			\
 	debug.scm debugger.scm documentation.scm emacs.scm expect.scm	\
 	format.scm getopt-long.scm hcons.scm i18n.scm			\
-	lineio.scm ls.scm mapping.scm					\
-	match.scm networking.scm null.scm optargs.scm poe.scm popen.scm	\
-	posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm		\
+	lineio.scm ls.scm mapping.scm match.scm				\
+	networking.scm null.scm occam-channel.scm optargs.scm poe.scm	\
+	popen.scm posix.scm q.scm r4rs.scm r5rs.scm			\
 	rdelim.scm receive.scm regex.scm runq.scm rw.scm		\
 	safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm	\
 	streams.scm string-fun.scm syncase.scm threads.scm		\
 	buffered-input.scm time.scm history.scm channel.scm		\
-        pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm	\
+        pretty-print.scm ftw.scm gap-buffer.scm				\
 	weak-vector.scm deprecated.scm list.scm serialize.scm		\
-	gds-client.scm gds-server.scm
+	gds-server.scm
 
-subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9
-subpkgdata_DATA = $(ice9_sources)
-TAGS_FILES = $(subpkgdata_DATA)
+# gds-client is tight with the memoizer, so punt on it until it can be
+# made portable.
+#
+# psyntax.scm needs help. fortunately it's only needed when recompiling
+# psyntax-pp.scm.
+NOCOMP_SOURCES = gds-client.scm psyntax.scm
+
+include $(top_srcdir)/am/guilec
 
 ## test.scm is not currently installed.
-EXTRA_DIST = $(ice9_sources) test.scm compile-psyntax.scm ChangeLog-2008
+EXTRA_DIST += test.scm compile-psyntax.scm ChangeLog-2008
+
+TAGS_FILES = $(SOURCES)
 
 # We expect this to never be invoked when there is not already
-# ice-9/psyntax.pp in %load-path, since compile-psyntax.scm depends
-# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'.
+# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
+# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'.
 # In other words, to bootstrap this file, you need to do something like:
-#    GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp
+#    GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm
 include $(top_srcdir)/am/pre-inst-guile
-psyntax.pp: psyntax.ss
+psyntax-pp.scm: psyntax.scm
 	$(preinstguile) -s $(srcdir)/compile-psyntax.scm \
-		$(srcdir)/psyntax.ss $(srcdir)/psyntax.pp
-
+		$(srcdir)/psyntax.scm $(srcdir)/psyntax-pp.scm

module/ice-9/annotate.scm

@@ -0,0 +1,80 @@
+;;;; 	Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; 
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;; 
+
+
+(define-module (ice-9 annotate)
+  :export (<annotation> annotation? annotate deannotate make-annotation
+           annotation-expression annotation-source annotation-stripped
+           set-annotation-stripped!
+           deannotate/source-properties))
+
+(define <annotation>          
+  (make-vtable "prprpw"
+               (lambda (struct port)
+                 (display "#<annotated " port)
+                 (display (struct-ref struct 0) port)
+                 (display ">" port))))
+
+(define (annotation? x)
+  (and (struct? x) (eq? (struct-vtable x) <annotation>)))
+
+(define (make-annotation e s . stripped?)
+  (if (null? stripped?)
+      (make-struct <annotation> 0 e s #f)
+      (apply make-struct <annotation> 0 e s stripped?)))
+
+(define (annotation-expression a)
+  (struct-ref a 0))
+(define (annotation-source a)
+  (struct-ref a 1))
+(define (annotation-stripped a)
+  (struct-ref a 2))
+(define (set-annotation-stripped! a stripped?)
+  (struct-set! a 2 stripped?))
+
+(define (annotate e)
+  (let ((p (if (pair? e) (source-properties e) #f))
+        (out (cond ((and (list? e) (not (null? e)))
+                    (map annotate e))
+                   ((pair? e)
+                    (cons (annotate (car e)) (annotate (cdr e))))
+                   (else e))))
+    (if (pair? p)
+        (make-annotation out p #f)
+        out)))
+                          
+(define (deannotate e)
+  (cond ((list? e)
+         (map deannotate e))
+        ((pair? e)
+         (cons (deannotate (car e)) (deannotate (cdr e))))
+        ((annotation? e) (deannotate (annotation-expression e)))
+        (else e)))
+
+(define (deannotate/source-properties e)
+  (cond ((list? e)
+         (map deannotate/source-properties e))
+        ((pair? e)
+         (cons (deannotate/source-properties (car e))
+               (deannotate/source-properties (cdr e))))
+        ((annotation? e)
+         (let ((e (deannotate/source-properties (annotation-expression e)))
+               (source (annotation-source e)))
+           (if (pair? e)
+               (set-source-properties! e source))
+           e))
+        (else e)))

module/ice-9/boot-9.scm

@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -86,43 +86,39 @@
 
 
 
-;;; {EVAL-CASE}
-;;;
-
-;; (eval-case ((situation*) forms)* (else forms)?)
+;; (eval-when (situation...) form...)
 ;;
-;; Evaluate certain code based on the situation that eval-case is used
-;; in.  The only defined situation right now is `load-toplevel' which
-;; triggers for code evaluated at the top-level, for example from the
-;; REPL or when loading a file.
+;; Evaluate certain code based on the situation that eval-when is used
+;; in. There are three situations defined.
+;;
+;; `load' triggers when a file is loaded via `load', or when a compiled
+;; file is loaded.
+;;
+;; `compile' triggers when an expression is compiled.
+;;
+;; `eval' triggers when code is evaluated interactively, as at the REPL
+;; or via the `compile' or `eval' procedures.
 
-(define eval-case
+;; NB: this macro is only ever expanded by the interpreter. The compiler
+;; notices it and interprets the situations differently.
+(define eval-when
   (procedure->memoizing-macro
    (lambda (exp env)
-     (define (toplevel-env? env)
-       (or (not (pair? env)) (not (pair? (car env)))))
-     (define (syntax)
-       (error "syntax error in eval-case"))
-     (let loop ((clauses (cdr exp)))
-       (cond
-	((null? clauses)
-	 #f)
-	((not (list? (car clauses)))
-	 (syntax))
-	((eq? 'else (caar clauses))
-	 (or (null? (cdr clauses))
-	     (syntax))
-	 (cons 'begin (cdar clauses)))
-	((not (list? (caar clauses)))
-	 (syntax))
-	((and (toplevel-env? env)
-	      (memq 'load-toplevel (caar clauses)))
-	 (cons 'begin (cdar clauses)))
-	(else
-	 (loop (cdr clauses))))))))
+     (let ((situations (cadr exp))
+           (body (cddr exp)))
+       (if (or (memq 'load situations)
+               (memq 'eval situations))
+           `(begin . ,body))))))
 
 
 
+;; Before compiling, make sure any symbols are resolved in the (guile)
+;; module, the primary location of those symbols, rather than in
+;; (guile-user), the default module that we compile in.
+
+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+
 ;;; {Defmacros}
 ;;;
 ;;; Depends on: features, eval-case
@@ -150,19 +146,11 @@
   (let ((defmacro-transformer
 	  (lambda (name parms . body)
 	    (let ((transformer `(lambda ,parms ,@body)))
-	      `(eval-case
-		((load-toplevel)
-		 (define ,name (defmacro:transformer ,transformer)))
-		(else
-		 (error "defmacro can only be used at the top level")))))))
+	      `(eval-when
+                (eval load compile)
+                (define ,name (defmacro:transformer ,transformer)))))))
     (defmacro:transformer defmacro-transformer)))
 
-(define defmacro:syntax-transformer
-  (lambda (f)
-    (procedure->syntax
-	      (lambda (exp env)
-		(copy-tree (apply f (cdr exp)))))))
-
 
 ;; XXX - should the definition of the car really be looked up in the
 ;; current module?
@@ -196,15 +184,15 @@
 
 (defmacro begin-deprecated forms
   (if (include-deprecated-features)
-      (cons begin forms)
-      #f))
+      `(begin ,@forms)
+      (begin)))
 
 
 
 ;;; {R4RS compliance}
 ;;;
 
-(primitive-load-path "ice-9/r4rs.scm")
+(primitive-load-path "ice-9/r4rs")
 
 
 
@@ -327,22 +315,6 @@
 
 
 
-;;; {Environments}
-;;;
-
-(define the-environment
-  (procedure->syntax
-   (lambda (x e)
-     e)))
-
-(define the-root-environment (the-environment))
-
-(define (environment-module env)
-  (let ((closure (and (pair? env) (car (last-pair env)))))
-    (and closure (procedure-property closure 'module))))
-
-
-
 ;;; {Records}
 ;;;
 
@@ -418,14 +390,14 @@
 
 (define (record-constructor rtd . opt)
   (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
-    (local-eval `(lambda ,field-names
-		   (make-struct ',rtd 0 ,@(map (lambda (f)
-						 (if (memq f field-names)
-						     f
-						     #f))
-					       (record-type-fields rtd))))
-		the-root-environment)))
-
+    (primitive-eval
+     `(lambda ,field-names
+        (make-struct ',rtd 0 ,@(map (lambda (f)
+                                      (if (memq f field-names)
+                                          f
+                                          #f))
+                                    (record-type-fields rtd)))))))
+          
 (define (record-predicate rtd)
   (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
 
@@ -437,25 +409,22 @@
 		 #f)))
 
 (define (record-accessor rtd field-name)
-  (let* ((pos (list-index (record-type-fields rtd) field-name)))
+  (let ((pos (list-index (record-type-fields rtd) field-name)))
     (if (not pos)
 	(error 'no-such-field field-name))
-    (local-eval `(lambda (obj)
-                   (if (eq? (struct-vtable obj) ,rtd)
-                       (struct-ref obj ,pos)
-                       (%record-type-error ,rtd obj)))
-		the-root-environment)))
+    (lambda (obj)
+      (if (eq? (struct-vtable obj) rtd)
+          (struct-ref obj pos)
+          (%record-type-error rtd obj)))))
 
 (define (record-modifier rtd field-name)
-  (let* ((pos (list-index (record-type-fields rtd) field-name)))
+  (let ((pos (list-index (record-type-fields rtd) field-name)))
     (if (not pos)
 	(error 'no-such-field field-name))
-    (local-eval `(lambda (obj val)
-                   (if (eq? (struct-vtable obj) ,rtd)
-                       (struct-set! obj ,pos val)
-                       (%record-type-error ,rtd obj)))
-		the-root-environment)))
-
+    (lambda (obj val)
+      (if (eq? (struct-vtable obj) rtd)
+          (struct-set! obj pos val)
+          (%record-type-error rtd obj)))))
 
 (define (record? obj)
   (and (struct? obj) (record-type? (struct-vtable obj))))
@@ -538,10 +507,10 @@
 
 
 (if (provided? 'posix)
-    (primitive-load-path "ice-9/posix.scm"))
+    (primitive-load-path "ice-9/posix"))
 
 (if (provided? 'socket)
-    (primitive-load-path "ice-9/networking.scm"))
+    (primitive-load-path "ice-9/networking"))
 
 ;; For reference, Emacs file-exists-p uses stat in this same way.
 ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
@@ -569,10 +538,7 @@
 	      #f)))))
 
 (define (has-suffix? str suffix)
-  (let ((sufl (string-length suffix))
-	(sl (string-length str)))
-    (and (> sl sufl)
-	 (string=? (substring str (- sl sufl) sl) suffix))))
+  (string-suffix? suffix str))
 
 (define (system-error-errno args)
   (if (eq? (car args) 'system-error)
@@ -768,6 +734,14 @@
 
 
 
+;;; {The interpreter stack}
+;;;
+
+(defmacro start-stack (tag exp)
+  `(%start-stack ,tag (lambda () ,exp)))
+
+
+
 ;;; {Loading by paths}
 ;;;
 
@@ -1306,7 +1280,7 @@
   *unspecified*)
 
 (define module-defer-observers #f)
-(define module-defer-observers-mutex (make-mutex))
+(define module-defer-observers-mutex (make-mutex 'recursive))
 (define module-defer-observers-table (make-hash-table))
 
 (define (module-modified m)
@@ -1695,7 +1669,8 @@
 ;; Add INTERFACE to the list of interfaces used by MODULE.
 ;;
 (define (module-use! module interface)
-  (if (not (eq? module interface))
+  (if (not (or (eq? module interface)
+               (memq interface (module-uses module))))
       (begin
         ;; Newly used modules must be appended rather than consed, so that
         ;; `module-variable' traverses the use list starting from the first
@@ -1803,8 +1778,7 @@
 ;;; The directory of all modules and the standard root module.
 ;;;
 
-(define (module-public-interface m)
-  (module-ref m '%module-public-interface #f))
+;; module-public-interface is defined in C.
 (define (set-module-public-interface! m i)
   (module-define! m '%module-public-interface i))
 (define (set-system-module! m s)
@@ -1815,23 +1789,26 @@
 (set-module-name! the-root-module '(guile))
 (set-module-name! the-scm-module '(guile))
 (set-module-kind! the-scm-module 'interface)
-(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
+(set-system-module! the-root-module #t)
+(set-system-module! the-scm-module #t)
 
 ;; NOTE: This binding is used in libguile/modules.c.
 ;;
 (define (make-modules-in module name)
   (if (null? name)
       module
-      (cond
-       ((module-ref module (car name) #f)
-	=> (lambda (m) (make-modules-in m (cdr name))))
-       (else	(let ((m (make-module 31)))
-		  (set-module-kind! m 'directory)
-		  (set-module-name! m (append (or (module-name module)
-						  '())
-					      (list (car name))))
-		  (module-define! module (car name) m)
-		  (make-modules-in m (cdr name)))))))
+      (make-modules-in
+       (let* ((var (module-local-variable module (car name)))
+              (val (and var (variable-bound? var) (variable-ref var))))
+         (if (module? val)
+             val
+             (let ((m (make-module 31)))
+               (set-module-kind! m 'directory)
+               (set-module-name! m (append (or (module-name module) '())
+                                           (list (car name))))
+               (module-define! module (car name) m)
+               m)))
+       (cdr name))))
 
 (define (beautify-user-module! module)
   (let ((interface (module-public-interface module)))
@@ -1848,25 +1825,28 @@
 
 ;; NOTE: This binding is used in libguile/modules.c.
 ;;
-(define (resolve-module name . maybe-autoload)
-  (let ((full-name (append '(%app modules) name)))
-    (let ((already (nested-ref the-root-module full-name)))
-      (if already
-	  ;; The module already exists...
-	  (if (and (or (null? maybe-autoload) (car maybe-autoload))
-		   (not (module-public-interface already)))
-	      ;; ...but we are told to load and it doesn't contain source, so
-	      (begin
-		(try-load-module name)
-		already)
-	      ;; simply return it.
-	      already)
-	  (begin
-	    ;; Try to autoload it if we are told so
-	    (if (or (null? maybe-autoload) (car maybe-autoload))
-		(try-load-module name))
-	    ;; Get/create it.
-	    (make-modules-in (current-module) full-name))))))
+(define resolve-module
+  (let ((the-root-module the-root-module))
+    (lambda (name . maybe-autoload)
+      (if (equal? name '(guile))
+          the-root-module
+          (let ((full-name (append '(%app modules) name)))
+            (let ((already (nested-ref the-root-module full-name))
+                  (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+              (cond
+               ((and already (module? already)
+                     (or (not autoload) (module-public-interface already)))
+                ;; A hit, a palpable hit.
+                already)
+               (autoload
+                ;; Try to autoload the module, and recurse.
+                (try-load-module name)
+                (resolve-module name #f))
+               (else
+                ;; A module is not bound (but maybe something else is),
+                ;; we're not autoloading -- here's the weird semantics,
+                ;; we create an empty module.
+                (make-modules-in the-root-module full-name)))))))))
 
 ;; Cheat.  These bindings are needed by modules.c, but we don't want
 ;; to move their real definition here because that would be unnatural.
@@ -1877,16 +1857,17 @@
 (define module-export! #f)
 (define default-duplicate-binding-procedures #f)
 
+(define %app (make-module 31))
+(define app %app) ;; for backwards compatability
+
+(local-define '(%app modules) (make-module 31))
+(local-define '(%app modules guile) the-root-module)
+
 ;; This boots the module system.  All bindings needed by modules.c
 ;; must have been defined by now.
 ;;
 (set-current-module the-root-module)
 
-(define %app (make-module 31))
-(define app %app) ;; for backwards compatability
-(local-define '(%app modules) (make-module 31))
-(local-define '(%app modules guile) the-root-module)
-
 ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
 
 (define (try-load-module name)
@@ -2007,98 +1988,98 @@
                          (error "unrecognized define-module argument" arg))))
     (beautify-user-module! module)
     (let loop ((kws kws)
-	       (reversed-interfaces '())
-	       (exports '())
-	       (re-exports '())
-	       (replacements '())
+               (reversed-interfaces '())
+               (exports '())
+               (re-exports '())
+               (replacements '())
                (autoloads '()))
 
       (if (null? kws)
-	  (call-with-deferred-observers
-	   (lambda ()
-	     (module-use-interfaces! module (reverse reversed-interfaces))
-	     (module-export! module exports)
-	     (module-replace! module replacements)
-	     (module-re-export! module re-exports)
+          (call-with-deferred-observers
+           (lambda ()
+             (module-use-interfaces! module (reverse reversed-interfaces))
+             (module-export! module exports)
+             (module-replace! module replacements)
+             (module-re-export! module re-exports)
              (if (not (null? autoloads))
                  (apply module-autoload! module autoloads))))
-	  (case (car kws)
-	    ((#:use-module #:use-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (let* ((interface-args (cadr kws))
-		    (interface (apply resolve-interface interface-args)))
-	       (and (eq? (car kws) #:use-syntax)
-		    (or (symbol? (caar interface-args))
-			(error "invalid module name for use-syntax"
-			       (car interface-args)))
-		    (set-module-transformer!
-		     module
-		     (module-ref interface
-				 (car (last-pair (car interface-args)))
-				 #f)))
-	       (loop (cddr kws)
-		     (cons interface reversed-interfaces)
-		     exports
-		     re-exports
-		     replacements
+          (case (car kws)
+            ((#:use-module #:use-syntax)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (let* ((interface-args (cadr kws))
+                    (interface (apply resolve-interface interface-args)))
+               (and (eq? (car kws) #:use-syntax)
+                    (or (symbol? (caar interface-args))
+                        (error "invalid module name for use-syntax"
+                               (car interface-args)))
+                    (set-module-transformer!
+                     module
+                     (module-ref interface
+                                 (car (last-pair (car interface-args)))
+                                 #f)))
+               (loop (cddr kws)
+                     (cons interface reversed-interfaces)
+                     exports
+                     re-exports
+                     replacements
                      autoloads)))
-	    ((#:autoload)
-	     (or (and (pair? (cdr kws)) (pair? (cddr kws)))
-		 (unrecognized kws))
-	     (loop (cdddr kws)
+            ((#:autoload)
+             (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+                 (unrecognized kws))
+             (loop (cdddr kws)
                    reversed-interfaces
-		   exports
-		   re-exports
-		   replacements
+                   exports
+                   re-exports
+                   replacements
                    (let ((name (cadr kws))
                          (bindings (caddr kws)))
                      (cons* name bindings autoloads))))
-	    ((#:no-backtrace)
-	     (set-system-module! module #t)
-	     (loop (cdr kws) reversed-interfaces exports re-exports
+            ((#:no-backtrace)
+             (set-system-module! module #t)
+             (loop (cdr kws) reversed-interfaces exports re-exports
                    replacements autoloads))
-	    ((#:pure)
-	     (purify-module! module)
-	     (loop (cdr kws) reversed-interfaces exports re-exports
+            ((#:pure)
+             (purify-module! module)
+             (loop (cdr kws) reversed-interfaces exports re-exports
                    replacements autoloads))
-	    ((#:duplicates)
-	     (if (not (pair? (cdr kws)))
-		 (unrecognized kws))
-	     (set-module-duplicates-handlers!
-	      module
-	      (lookup-duplicates-handlers (cadr kws)))
-	     (loop (cddr kws) reversed-interfaces exports re-exports
+            ((#:duplicates)
+             (if (not (pair? (cdr kws)))
+                 (unrecognized kws))
+             (set-module-duplicates-handlers!
+              module
+              (lookup-duplicates-handlers (cadr kws)))
+             (loop (cddr kws) reversed-interfaces exports re-exports
                    replacements autoloads))
-	    ((#:export #:export-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (loop (cddr kws)
-		   reversed-interfaces
-		   (append (cadr kws) exports)
-		   re-exports
-		   replacements
+            ((#:export #:export-syntax)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (loop (cddr kws)
+                   reversed-interfaces
+                   (append (cadr kws) exports)
+                   re-exports
+                   replacements
                    autoloads))
-	    ((#:re-export #:re-export-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (loop (cddr kws)
-		   reversed-interfaces
-		   exports
-		   (append (cadr kws) re-exports)
-		   replacements
+            ((#:re-export #:re-export-syntax)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (loop (cddr kws)
+                   reversed-interfaces
+                   exports
+                   (append (cadr kws) re-exports)
+                   replacements
                    autoloads))
-	    ((#:replace #:replace-syntax)
-	     (or (pair? (cdr kws))
-		 (unrecognized kws))
-	     (loop (cddr kws)
-		   reversed-interfaces
-		   exports
-		   re-exports
-		   (append (cadr kws) replacements)
+            ((#:replace #:replace-syntax)
+             (or (pair? (cdr kws))
+                 (unrecognized kws))
+             (loop (cddr kws)
+                   reversed-interfaces
+                   exports
+                   re-exports
+                   (append (cadr kws) replacements)
                    autoloads))
-	    (else
-	     (unrecognized kws)))))
+            (else
+             (unrecognized kws)))))
     (run-hook module-defined-hook module)
     module))
 
@@ -2147,7 +2128,8 @@ module '(ice-9 q) '(make-q q-length))}."
 
 ;;; {Compiled module}
 
-(define load-compiled #f)
+(if (not (defined? 'load-compiled))
+    (define load-compiled #f))
 
 
 
@@ -2177,14 +2159,20 @@ module '(ice-9 q) '(make-q q-length))}."
 	    (lambda () (autoload-in-progress! dir-hint name))
 	    (lambda ()
 	      (let ((file (in-vicinity dir-hint name)))
-		(cond ((and load-compiled
-			    (%search-load-path (string-append file ".go")))
-		       => (lambda (full)
-			    (load-file load-compiled full)))
-		      ((%search-load-path file)
-		       => (lambda (full)
-			    (with-fluids ((current-reader #f))
-			      (load-file primitive-load full)))))))
+                (let ((compiled (and load-compiled
+                                     (%search-load-path
+                                      (string-append file ".go"))))
+                      (source (%search-load-path file)))
+                  (cond ((and source
+                              (or (not compiled)
+                                  (< (stat:mtime (stat compiled))
+                                     (stat:mtime (stat source)))))
+                         (if compiled
+                             (warn "source file" source "newer than" compiled))
+                         (with-fluids ((current-reader #f))
+                           (load-file primitive-load source)))
+                        (compiled
+                         (load-file load-compiled compiled))))))
 	    (lambda () (set-autoloaded! dir-hint name didit)))
 	   didit))))
 
@@ -2225,23 +2213,11 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; {Run-time options}
 ;;;
 
-(define define-option-interface
+(defmacro define-option-interface (option-group)
   (let* ((option-name car)
 	 (option-value cadr)
 	 (option-documentation caddr)
 
-	 (print-option (lambda (option)
-			 (display (option-name option))
-			 (if (< (string-length
-				 (symbol->string (option-name option)))
-				8)
-			     (display #\tab))
-			 (display #\tab)
-			 (display (option-value option))
-			 (display #\tab)
-			 (display (option-documentation option))
-			 (newline)))
-
 	 ;; Below follow the macros defining the run-time option interfaces.
 
 	 (make-options (lambda (interface)
@@ -2249,8 +2225,19 @@ module '(ice-9 q) '(make-q q-length))}."
 			    (cond ((null? args) (,interface))
 				  ((list? (car args))
 				   (,interface (car args)) (,interface))
-				  (else (for-each ,print-option
-						  (,interface #t)))))))
+				  (else (for-each
+                                         (lambda (option)
+                                           (display (option-name option))
+                                           (if (< (string-length
+                                                   (symbol->string (option-name option)))
+                                                  8)
+                                               (display #\tab))
+                                           (display #\tab)
+                                           (display (option-value option))
+                                           (display #\tab)
+                                           (display (option-documentation option))
+                                           (newline))
+                                         (,interface #t)))))))
 
 	 (make-enable (lambda (interface)
 			`(lambda flags
@@ -2265,22 +2252,19 @@ module '(ice-9 q) '(make-q q-length))}."
 					flags)
 			      (,interface options)
 			      (,interface))))))
-    (procedure->memoizing-macro
-     (lambda (exp env)
-       (let* ((option-group (cadr exp))
-	      (interface (car option-group))
-	      (options/enable/disable (cadr option-group)))
-	 `(begin
-	    (define ,(car options/enable/disable)
-	      ,(make-options interface))
-	    (define ,(cadr options/enable/disable)
-	      ,(make-enable interface))
-	    (define ,(caddr options/enable/disable)
-	      ,(make-disable interface))
-	    (defmacro ,(caaddr option-group) (opt val)
-	      `(,,(car options/enable/disable)
-		(append (,,(car options/enable/disable))
-			(list ',opt ,val))))))))))
+    (let* ((interface (car option-group))
+           (options/enable/disable (cadr option-group)))
+      `(begin
+         (define ,(car options/enable/disable)
+           ,(make-options interface))
+         (define ,(cadr options/enable/disable)
+           ,(make-enable interface))
+         (define ,(caddr options/enable/disable)
+           ,(make-disable interface))
+         (defmacro ,(caaddr option-group) (opt val)
+           `(,',(car options/enable/disable)
+             (append (,',(car options/enable/disable))
+                     (list ',opt ,val))))))))
 
 (define-option-interface
   (eval-options-interface
@@ -2335,12 +2319,12 @@ module '(ice-9 q) '(make-q q-length))}."
 
 (define (set-repl-prompt! v) (set! scm-repl-prompt v))
 
-(define (default-lazy-handler key . args)
-  (save-stack lazy-handler-dispatch)
+(define (default-pre-unwind-handler key . args)
+  (save-stack pre-unwind-handler-dispatch)
   (apply throw key args))
 
-(define (lazy-handler-dispatch key . args)
-  (apply default-lazy-handler key args))
+(define (pre-unwind-handler-dispatch key . args)
+  (apply default-pre-unwind-handler key args))
 
 (define abort-hook (make-hook))
 
@@ -2417,15 +2401,15 @@ module '(ice-9 q) '(make-q q-length))}."
 				 (else
 				  (apply bad-throw key args)))))))
 
-		    ;; Note that having just `lazy-handler-dispatch'
+		    ;; Note that having just `pre-unwind-handler-dispatch'
 		    ;; here is connected with the mechanism that
 		    ;; produces a nice backtrace upon error.  If, for
 		    ;; example, this is replaced with (lambda args
-		    ;; (apply lazy-handler-dispatch args)), the stack
+		    ;; (apply pre-unwind-handler-dispatch args)), the stack
 		    ;; cutting (in save-stack) goes wrong and ends up
 		    ;; saving no stack at all, so there is no
 		    ;; backtrace.
-		    lazy-handler-dispatch)))
+		    pre-unwind-handler-dispatch)))
 
 	(if next (loop next) status)))
     (set! set-batch-mode?! (lambda (arg)
@@ -2536,7 +2520,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; the readline library.
 (define repl-reader
   (lambda (prompt)
-    (display prompt)
+    (display (if (string? prompt) prompt (prompt)))
     (force-output)
     (run-hook before-read-hook)
     ((or (fluid-ref current-reader) read) (current-input-port))))
@@ -2719,25 +2703,11 @@ module '(ice-9 q) '(make-q q-length))}."
 	 (if (symbol? first)
 	     (car rest)
 	     `(lambda ,(cdr first) ,@rest))))
-    `(eval-case
-      ((load-toplevel)
-       (define ,name (defmacro:transformer ,transformer)))
-      (else
-       (error "define-macro can only be used at the top level")))))
+    `(eval-when
+      (eval load compile)
+      (define ,name (defmacro:transformer ,transformer)))))
 
 
-(defmacro define-syntax-macro (first . rest)
-  (let ((name (if (symbol? first) first (car first)))
-	(transformer
-	 (if (symbol? first)
-	     (car rest)
-	     `(lambda ,(cdr first) ,@rest))))
-    `(eval-case
-      ((load-toplevel)
-       (define ,name (defmacro:syntax-transformer ,transformer)))
-      (else
-       (error "define-syntax-macro can only be used at the top level")))))
-
 
 
 ;;; {While}
@@ -2748,32 +2718,25 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; The inner `do' loop avoids re-establishing a catch every iteration,
 ;; that's only necessary if continue is actually used.  A new key is
 ;; generated every time, so break and continue apply to their originating
-;; `while' even when recursing.  `while-helper' is an easy way to keep the
-;; `key' binding away from the cond and body code.
+;; `while' even when recursing.
 ;;
-;; FIXME: This is supposed to have an `unquote' on the `do' the same used
-;; for lambda and not, so as to protect against any user rebinding of that
-;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
-;;
-;;     (use-modules (ice-9 syncase))
-;;     (while #f)
-;;     => ERROR: invalid syntax ()
-;;
-;; This is probably a bug in syncase.
+;; FIXME: This macro is unintentionally unhygienic with respect to let,
+;; make-symbol, do, throw, catch, lambda, and not.
 ;;
 (define-macro (while cond . body)
-  (define (while-helper proc)
-    (do ((key (make-symbol "while-key")))
-	((catch key
-		(lambda ()
-		  (proc (lambda () (throw key #t))
-			(lambda () (throw key #f))))
-		(lambda (key arg) arg)))))
-  `(,while-helper (,lambda (break continue)
-		    (do ()
-			((,not ,cond))
-		      ,@body)
-		    #t)))
+  (let ((keyvar (make-symbol "while-keyvar")))
+    `(let ((,keyvar (make-symbol "while-key")))
+       (do ()
+           ((catch ,keyvar
+                   (lambda ()
+                     (let ((break (lambda () (throw ,keyvar #t)))
+                           (continue (lambda () (throw ,keyvar #f))))
+                       (do ()
+                           ((not ,cond))
+                         ,@body)
+                       #t))
+                   (lambda (key arg)
+                     arg)))))))
 
 
 
@@ -2784,6 +2747,11 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; Return a list of expressions that evaluate to the appropriate
 ;; arguments for resolve-interface according to SPEC.
 
+(eval-when
+ (compile)
+ (if (memq 'prefix (read-options))
+     (error "boot-9 must be compiled with #:kw, not :kw")))
+
 (define (compile-interface-spec spec)
   (define (make-keyarg sym key quote?)
     (cond ((or (memq sym spec)
@@ -2847,14 +2815,12 @@ module '(ice-9 q) '(make-q q-length))}."
 		 (cddr args))))))
 
 (defmacro define-module args
-  `(eval-case
-    ((load-toplevel)
-     (let ((m (process-define-module
-	       (list ,@(compile-define-module-args args)))))
-       (set-current-module m)
-       m))
-    (else
-     (error "define-module can only be used at the top level"))))
+  `(eval-when
+    (eval load compile)
+    (let ((m (process-define-module
+              (list ,@(compile-define-module-args args)))))
+      (set-current-module m)
+      m)))
 
 ;; The guts of the use-modules macro.  Add the interfaces of the named
 ;; modules to the use-list of the current module, in order.
@@ -2872,28 +2838,24 @@ module '(ice-9 q) '(make-q q-length))}."
        (module-use-interfaces! (current-module) interfaces)))))
 
 (defmacro use-modules modules
-  `(eval-case
-    ((load-toplevel)
-     (process-use-modules
-      (list ,@(map (lambda (m)
-		     `(list ,@(compile-interface-spec m)))
-		   modules)))
-     *unspecified*)
-    (else
-     (error "use-modules can only be used at the top level"))))
+  `(eval-when
+    (eval load compile)
+    (process-use-modules
+     (list ,@(map (lambda (m)
+                    `(list ,@(compile-interface-spec m)))
+                  modules)))
+    *unspecified*))
 
 (defmacro use-syntax (spec)
-  `(eval-case
-    ((load-toplevel)
+  `(eval-when
+    (eval load compile)
      ,@(if (pair? spec)
 	   `((process-use-modules (list
 				   (list ,@(compile-interface-spec spec))))
 	     (set-module-transformer! (current-module)
 				      ,(car (last-pair spec))))
 	   `((set-module-transformer! (current-module) ,spec)))
-     *unspecified*)
-    (else
-     (error "use-syntax can only be used at the top level"))))
+     *unspecified*))
 
 ;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
 ;; as soon as guile supports hygienic macros.
@@ -2914,7 +2876,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (let ((name (defined-name (car args))))
       `(begin
 	 (define-private ,@args)
-	 (eval-case ((load-toplevel) (export ,name))))))))
+	 (export ,name))))))
 
 (defmacro defmacro-public args
   (define (syntax)
@@ -2929,7 +2891,7 @@ module '(ice-9 q) '(make-q q-length))}."
    (#t
     (let ((name (defined-name (car args))))
       `(begin
-	 (eval-case ((load-toplevel) (export-syntax ,name)))
+	 (export-syntax ,name)
 	 (defmacro ,@args))))))
 
 ;; Export a local variable
@@ -2967,22 +2929,14 @@ module '(ice-9 q) '(make-q q-length))}."
 	      names)))
 
 (defmacro export names
-  `(eval-case
-    ((load-toplevel)
-     (call-with-deferred-observers
-      (lambda ()
-	(module-export! (current-module) ',names))))
-    (else
-     (error "export can only be used at the top level"))))
+  `(call-with-deferred-observers
+    (lambda ()
+      (module-export! (current-module) ',names))))
 
 (defmacro re-export names
-  `(eval-case
-    ((load-toplevel)
-     (call-with-deferred-observers
-      (lambda ()
-	(module-re-export! (current-module) ',names))))
-    (else
-     (error "re-export can only be used at the top level"))))
+  `(call-with-deferred-observers
+    (lambda ()
+      (module-re-export! (current-module) ',names))))
 
 (defmacro export-syntax names
   `(export ,@names))
@@ -3019,6 +2973,19 @@ module '(ice-9 q) '(make-q q-length))}."
 
 
 
+;;; {Compiler interface}
+;;;
+;;; The full compiler interface can be found in (system). Here we put a
+;;; few useful procedures into the global namespace.
+
+(module-autoload! the-scm-module
+                  '(system base compile)
+                  '(compile
+                    compile-time-environment))
+
+
+
+
 ;;; {Parameters}
 ;;;
 
@@ -3364,6 +3331,8 @@ module '(ice-9 q) '(make-q q-length))}."
     ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
     ;; no effect.
     (let ((old-handlers #f)
+          (start-repl (module-ref (resolve-interface '(system repl repl))
+                                  'start-repl))
 	  (signals (if (provided? 'posix)
 		       `((,SIGINT . "User interrupt")
 			 (,SIGFPE . "Arithmetic error")
@@ -3398,7 +3367,7 @@ module '(ice-9 q) '(make-q q-length))}."
 
 	  ;; the protected thunk.
 	  (lambda ()
-	    (let ((status (scm-style-repl)))
+            (let ((status (start-repl 'scheme)))
 	      (run-hook exit-hook)
 	      status))
 
@@ -3430,7 +3399,7 @@ module '(ice-9 q) '(make-q q-length))}."
    (provided? sym)))
 
 (begin-deprecated
- (primitive-load-path "ice-9/deprecated.scm"))
+ (primitive-load-path "ice-9/deprecated"))
 
 
 

module/ice-9/debugger.scm

@@ -131,16 +131,16 @@ Indicates that the debugger should display an introductory message.
 
 (define (debug-on-error syms)
   "Enable or disable debug on error."
-  (set! lazy-handler-dispatch
+  (set! pre-unwind-handler-dispatch
 	(if syms
 	    (lambda (key . args)
 	      (if (memq key syms)
 		  (begin
-		    (debug-stack (make-stack #t lazy-handler-dispatch)
+		    (debug-stack (make-stack #t pre-unwind-handler-dispatch)
 				 #:with-introduction
 				 #:continuable)
 		    (throw 'abort key)))
-	      (apply default-lazy-handler key args))
-	    default-lazy-handler)))
+	      (apply default-pre-unwind-handler key args))
+	    default-pre-unwind-handler)))
 
 ;;; (ice-9 debugger) ends here.

module/ice-9/debugging/breakpoints.scm

@@ -0,0 +1,415 @@
+;;;; (ice-9 debugging breakpoints) -- practical breakpoints
+
+;;; Copyright (C) 2005 Neil Jerram
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; This module provides a practical interface for setting and
+;;; manipulating breakpoints.
+
+(define-module (ice-9 debugging breakpoints)
+  #:use-module (ice-9 debugger)
+  #:use-module (ice-9 ls)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 regex)
+  #:use-module (oop goops)
+  #:use-module (ice-9 debugging ice-9-debugger-extensions)
+  #:use-module (ice-9 debugging traps)
+  #:use-module (ice-9 debugging trc)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:export (break-in
+	    break-at
+	    default-breakpoint-behaviour
+	    delete-breakpoint
+	    for-each-breakpoint
+	    setup-before-load
+	    setup-after-load
+	    setup-after-read
+	    setup-after-eval))
+
+;; If the running Guile does not provide before- and after- load hooks
+;; itself, install them using the (ice-9 debugging load-hooks) module.
+(or (defined? 'after-load-hook)
+    (begin
+      (use-modules (ice-9 debugging load-hooks))
+      (install-load-hooks)))
+
+;; Getter/setter for default breakpoint behaviour.
+(define default-breakpoint-behaviour
+  (let ((behaviour debug-trap))
+    (make-procedure-with-setter
+     ;; Getter: return current default behaviour.
+     (lambda ()
+       behaviour)
+     ;; Setter: set default behaviour to given procedure.
+     (lambda (new-behaviour)
+       (set! behaviour new-behaviour)))))
+
+;; Base class for breakpoints.  (We don't need to use GOOPS to
+;; represent breakpoints, but it's a nice way to describe a composite
+;; object.)
+(define-class <breakpoint> ()
+  ;; This breakpoint's trap options, which include its behaviour.
+  (trap-options #:init-keyword #:trap-options)
+  ;; All the traps relating to this breakpoint.
+  (traps #:init-value '())
+  ;; Observer.  This is a procedure that is called when the breakpoint
+  ;; trap list changes.
+  (observer #:init-value #f))
+
+;; Noop base class definitions of all the possible setup methods.
+(define-method (setup-before-load (bp <breakpoint>) filename)
+  *unspecified*)
+(define-method (setup-after-load (bp <breakpoint>) filename)
+  *unspecified*)
+(define-method (setup-after-read (bp <breakpoint>) x)
+  *unspecified*)
+(define-method (setup-after-eval (bp <breakpoint>) filename)
+  *unspecified*)
+
+;; Call the breakpoint's observer, if it has one.
+(define-method (call-observer (bp <breakpoint>))
+  (cond ((slot-ref bp 'observer)
+	 =>
+	 (lambda (proc)
+	   (proc)))))
+
+;; Delete a breakpoint.
+(define (delete-breakpoint bp)
+  ;; Remove this breakpoint from the global list.
+  (set! breakpoints (delq! bp breakpoints))
+  ;; Uninstall and discard all its traps.
+  (for-each uninstall-trap (slot-ref bp 'traps))
+  (slot-set! bp 'traps '()))
+
+;; Class for `break-in' breakpoints.
+(define-class <break-in> (<breakpoint>)
+  ;; The name of the procedure to break in.
+  (procedure-name #:init-keyword #:procedure-name)
+  ;; The name of the module or file that the procedure is defined in.
+  ;; A module name is a list of symbols that exactly names the
+  ;; relevant module.  A file name is a string, which can in fact be
+  ;; any substring of the relevant full file name.
+  (module-or-file-name #:init-keyword #:module-or-file-name))
+
+;; Class for `break-at' breakpoints.
+(define-class <break-at> (<breakpoint>)
+  ;; The name of the file to break in.  This is a string, which can in
+  ;; fact be any substring of the relevant full file name.
+  (file-name #:init-keyword #:file-name)
+  ;; Line and column number to break at.
+  (line #:init-keyword #:line)
+  (column #:init-keyword #:column))
+
+;; Global list of non-deleted breakpoints.
+(define breakpoints '())
+
+;; Add to the above list.
+(define-method (add-to-global-breakpoint-list (bp <breakpoint>))
+  (set! breakpoints (append! breakpoints (list bp))))
+
+;; break-in: create a `break-in' breakpoint.
+(define (break-in procedure-name . options)
+  ;; Sort out the optional args.
+  (let* ((module-or-file-name+options
+	  (cond ((and (not (null? options))
+		      (or (string? (car options))
+			  (list? (car options))))
+		 options)
+		(else
+		 (cons (module-name (current-module)) options))))
+	 (module-or-file-name (car module-or-file-name+options))
+	 (trap-options (cdr module-or-file-name+options))
+	 ;; Create the new breakpoint object.
+	 (bp (make <break-in>
+	       #:procedure-name procedure-name
+	       #:module-or-file-name module-or-file-name
+	       #:trap-options (if (memq #:behaviour trap-options)
+				  trap-options
+				  (cons* #:behaviour
+					 (default-breakpoint-behaviour)
+					 trap-options)))))
+    ;; Add it to the global breakpoint list.
+    (add-to-global-breakpoint-list bp)
+    ;; Set the new breakpoint, if possible, in already loaded code.
+    (set-in-existing-code bp)
+    ;; Return the breakpoint object to our caller.
+    bp))
+
+;; break-at: create a `break-at' breakpoint.
+(define (break-at file-name line column . trap-options)
+  ;; Create the new breakpoint object.
+  (let* ((bp (make <break-at>
+	       #:file-name file-name
+	       #:line line
+	       #:column column
+	       #:trap-options (if (memq #:behaviour trap-options)
+				  trap-options
+				  (cons* #:behaviour
+					 (default-breakpoint-behaviour)
+					 trap-options)))))
+    ;; Add it to the global breakpoint list.
+    (add-to-global-breakpoint-list bp)
+    ;; Set the new breakpoint, if possible, in already loaded code.
+    (set-in-existing-code bp)
+    ;; Return the breakpoint object to our caller.
+    bp))
+
+;; Set a `break-in' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-in>))
+  ;; Get the module or file name that was specified for this
+  ;; breakpoint.
+  (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+    ;; Handling is simpler for a module name.
+    (cond ((list? module-or-file-name)
+	   ;; See if the named module exists yet.
+	   (let ((m (module-if-already-loaded module-or-file-name)))
+	     (maybe-break-in-module-proc m bp)))
+	  ((string? module-or-file-name)
+	   ;; Try all loaded modules.
+	   (or-map (lambda (m)
+		     (maybe-break-in-module-proc m bp))
+		   (all-loaded-modules)))
+	  (else
+	   (error "Bad module-or-file-name:" module-or-file-name)))))
+
+(define (make-observer bp trap)
+  (lambda (event)
+    (trap-target-gone bp trap)))
+
+;; Set a `break-at' breakpoint in already loaded code, if possible.
+(define-method (set-in-existing-code (bp <break-at>) . code)
+  ;; Procedure to install a source trap on each expression that we
+  ;; find matching this breakpoint.
+  (define (install-source-trap x)
+    (or (or-map (lambda (trap)
+		  (and (is-a? trap <source-trap>)
+		       (eq? (slot-ref trap 'expression) x)))
+		(slot-ref bp 'traps))
+	(let ((trap (apply make <source-trap>
+			   #:expression x
+			   (slot-ref bp 'trap-options))))
+	  (slot-set! trap 'observer (make-observer bp trap))
+	  (install-trap trap)
+	  (trc 'install-source-trap (object-address trap) (object-address x))
+	  (trap-installed bp trap #t))))
+  ;; Scan the source whash, and install a trap on all code matching
+  ;; this breakpoint.
+  (trc 'set-in-existing-code (length code))
+  (if (null? code)
+      (scan-source-whash (slot-ref bp 'file-name)
+			 (slot-ref bp 'line)
+			 (slot-ref bp 'column)
+			 install-source-trap)
+      (scan-code (car code)
+		 (slot-ref bp 'file-name)
+		 (slot-ref bp 'line)
+		 (slot-ref bp 'column)
+		 install-source-trap)))
+
+;; Temporary implementation of scan-source-whash - this _really_ needs
+;; to be implemented in C.
+(define (scan-source-whash file-name line column proc)
+  ;; Procedure to call for each source expression in the whash.
+  (define (folder x props acc)
+    (if (and (= line (source-property x 'line))
+	     (= column (source-property x 'column))
+	     (let ((fn (source-property x 'filename)))
+	       (trc 'scan-source-whash fn)
+	       (and (string? fn)
+		    (string-contains fn file-name))))
+	(proc x)))
+  ;; Tracing.
+  (trc 'scan-source-whash file-name line column)
+  ;; Apply this procedure to the whash.
+  (hash-fold folder 0 source-whash))
+
+(define (scan-code x file-name line column proc)
+  (trc 'scan-code file-name line column)
+  (if (pair? x)
+      (begin
+	(if (and (eq? line (source-property x 'line))
+		 (eq? column (source-property x 'column))
+		 (let ((fn (source-property x 'filename)))
+		   (trc 'scan-code fn)
+		   (and (string? fn)
+			(string-contains fn file-name))))
+	    (proc x))
+	(scan-code (car x) file-name line column proc)
+	(scan-code (cdr x) file-name line column proc))))
+
+;; If a module named MODULE-NAME has been loaded, return its module
+;; object; otherwise return #f.
+(define (module-if-already-loaded module-name)
+  (nested-ref the-root-module (append '(app modules) module-name)))
+
+;; Construct and return a list of all loaded modules.
+(define (all-loaded-modules)
+  ;; This is the list that accumulates known modules.  It has to be
+  ;; defined outside the following functions, and accumulated using
+  ;; set!, so as to avoid infinite loops - because of the fact that
+  ;; all non-pure modules have a variable `app'.
+  (define known-modules '())
+  ;; Return an alist of submodules of the given PARENT-MODULE-NAME.
+  ;; Each element of the alist is (NAME . MODULE), where NAME is the
+  ;; module's leaf name (i.e. relative to PARENT-MODULE-NAME) and
+  ;; MODULE is the module object.  By a "submodule of a parent
+  ;; module", we mean any module value that is bound to a symbol in
+  ;; the parent module, and which is not an interface module.
+  (define (direct-submodules parent-module-name)
+    (filter (lambda (name+value)
+	      (and (module? (cdr name+value))
+		   (not (eq? (module-kind (cdr name+value)) 'interface))))
+	    (map (lambda (name)
+		   (cons name (local-ref (append parent-module-name
+						 (list name)))))
+		 (cdar (lls parent-module-name)))))
+  ;; Add all submodules (direct and indirect) of the module named
+  ;; PARENT-MODULE-NAME to `known-modules', if not already there.
+  (define (add-submodules-of parent-module-name)
+    (let ((ds (direct-submodules parent-module-name)))
+      (for-each
+       (lambda (name+module)
+         (or (memq (cdr name+module) known-modules)
+             (begin
+               (set! known-modules (cons (cdr name+module) known-modules))
+               (add-submodules-of (append parent-module-name
+                                          (list (car name+module)))))))
+       ds)))
+  ;; Add submodules recursively, starting from the root of all
+  ;; modules.
+  (add-submodules-of '(app modules))
+  ;; Return the result.
+  known-modules)
+
+;; Before-load setup for `break-at' breakpoints.
+(define-method (setup-before-load (bp <break-at>) filename)
+  (let ((trap (apply make <location-trap>
+		     #:file-regexp (regexp-quote (slot-ref bp 'file-name))
+		     #:line (slot-ref bp 'line)
+		     #:column (slot-ref bp 'column)
+		     (slot-ref bp 'trap-options))))
+    (install-trap trap)
+    (trap-installed bp trap #f)
+    (letrec ((uninstaller
+	      (lambda (file-name)
+		(uninstall-trap trap)
+		(remove-hook! after-load-hook uninstaller))))
+      (add-hook! after-load-hook uninstaller))))
+
+;; After-load setup for `break-in' breakpoints.
+(define-method (setup-after-load (bp <break-in>) filename)
+  ;; Get the module that the loaded file created or was loaded into,
+  ;; and the module or file name that were specified for this
+  ;; breakpoint.
+  (let ((m (current-module))
+	(module-or-file-name (slot-ref bp 'module-or-file-name)))
+    ;; Decide whether the breakpoint spec matches this load.
+    (if (or (and (string? module-or-file-name)
+		 (string-contains filename module-or-file-name))
+	    (and (list? module-or-file-name)
+		 (equal? (module-name (current-module)) module-or-file-name)))
+	;; It does, so try to install the breakpoint.
+	(maybe-break-in-module-proc m bp))))
+
+;; After-load setup for `break-at' breakpoints.
+(define-method (setup-after-load (bp <break-at>) filename)
+  (if (string-contains filename (slot-ref bp 'file-name))
+      (set-in-existing-code bp)))
+
+(define (maybe-break-in-module-proc m bp)
+  "If module M defines a procedure matching the specification of
+breakpoint BP, install a trap on it."
+  (let ((proc (module-ref m (slot-ref bp 'procedure-name) #f)))
+    (if (and proc
+	     (procedure? proc)
+	     (let ((module-or-file-name (slot-ref bp 'module-or-file-name)))
+	       (if (string? module-or-file-name)
+		   (source-file-matches (procedure-source proc)
+					module-or-file-name)
+		   #t))
+	     (not (or-map (lambda (trap)
+			    (and (is-a? trap <procedure-trap>)
+				 (eq? (slot-ref trap 'procedure) proc)))
+			  (slot-ref bp 'traps))))
+	;; There is, so install a <procedure-trap> on it.
+	(letrec ((trap (apply make <procedure-trap>
+			      #:procedure proc
+			      (slot-ref bp 'trap-options))))
+	  (slot-set! trap 'observer (make-observer bp trap))
+	  (install-trap trap)
+	  (trap-installed bp trap #t)
+	  ;; Tell caller that we installed a trap.
+	  #t)
+	;; Tell caller that we did not install a trap.
+	#f)))
+
+;; After-read setup for `break-at' breakpoints.
+(define-method (setup-after-read (bp <break-at>) x)
+  (set-in-existing-code bp x))
+
+;; Common code for associating a newly created and installed trap with
+;; a breakpoint object.
+(define (trap-installed bp trap record?)
+  (if record?
+      ;; Remember this trap in the breakpoint object.
+      (slot-set! bp 'traps (append! (slot-ref bp 'traps) (list trap))))
+  ;; Update the breakpoint status.
+  (call-observer bp))
+
+;; Common code for handling when the target of one of a breakpoint's
+;; traps is being GC'd.
+(define (trap-target-gone bp trap)
+  (trc 'trap-target-gone (object-address trap))
+  ;; Remove this trap from the breakpoint's list.
+  (slot-set! bp 'traps (delq! trap (slot-ref bp 'traps)))
+  ;; Update the breakpoint status.
+  (call-observer bp))
+
+(define (source-file-matches source file-name)
+  "Return #t if any of the expressions in SOURCE have a 'filename
+source property that includes FILE-NAME; otherwise return #f."
+  (and (pair? source)
+       (or (let ((source-file-name (source-property source 'filename)))
+	     (and source-file-name
+		  (string? source-file-name)
+		  (string-contains source-file-name file-name)))
+	   (let loop ((source source))
+	     (and (pair? source)
+		  (or (source-file-matches (car source) file-name)
+		      (loop (cdr source))))))))
+
+;; Install load hook functions.
+(add-hook! before-load-hook
+	   (lambda (fn)
+	     (for-each-breakpoint setup-before-load fn)))
+
+(add-hook! after-load-hook
+	   (lambda (fn)
+	     (for-each-breakpoint setup-after-load fn)))
+
+;;; Apply generic function GF to each breakpoint, passing the
+;;; breakpoint object and ARGS as args on each call.
+(define (for-each-breakpoint gf . args)
+  (for-each (lambda (bp)
+	      (apply gf bp args))
+	    breakpoints))
+
+;; Make sure that recording of source positions is enabled.  Without
+;; this break-at breakpoints will obviously not work.
+(read-enable 'positions)
+
+;;; (ice-9 debugging breakpoints) ends here.