big reorg of scheme modules -- e.g. programs.c -> (system vm program)

This reorganization kills the ugly module-export-all hacks in
bootstrap.scm and core.scm. In fact, it gets rid of core.scm entirely,
breaking out its functionality into separate files.

* module/system/vm/trace.scm:
* module/system/vm/profile.scm:
* module/system/vm/disasm.scm:
* module/system/vm/debug.scm:
* module/system/vm/conv.scm:
* module/system/vm/assemble.scm:
* module/system/repl/repl.scm:
* module/system/repl/common.scm:
* module/system/base/compile.scm:
* module/system/repl/command.scm: Update for changes, and fix a bug in
  procedure-documentation.

* module/system/vm/bootstrap.scm: Just call scm_bootstrap_vm, which
  handles setting load-compiled for us.

* module/system/vm/core.scm: Removed, functionality folded into other
  modules.

* module/system/vm/frame.scm: Export the C frame procedures here; also
  move scheme functions from core.scm here.

* module/system/vm/instruction.scm: New file, exports procedures from
  instructions.c.

* module/system/vm/objcode.scm: New file, exports procedures from
  objcodes.c.

* module/system/vm/program.scm: New file, exports procedures from
  programs.c, and some scheme functions originally from core.scm.

* module/system/vm/vm.scm: New file, from vm.c and core.scm.

* src/Makefile.am (libguile_vm_la_SOURCES): Add bootstrap.h.

* src/bootstrap.h: New file, prototypes scm_bootstrap_vm (), which the
  scm_init_* functions call.

* src/frames.h:
* src/frames.c (scm_init_frames):
* src/frames.c (scm_bootstrap_frames):

* src/vm.h:
* src/instructions.h:
* src/instructions.c (scm_init_instructions):
* src/instructions.c (scm_bootstrap_instructions):
* src/objcodes.h:
* src/objcodes.c (scm_bootstrap_objcodes):
* src/objcodes.c (scm_init_objcodes):
* src/programs.h:
* src/programs.c (scm_bootstrap_programs):
* src/programs.c (scm_init_programs):
* src/vm.c (scm_bootstrap_vm):
* src/vm.c (scm_init_vm): Call scm_bootstrap_vm() before doing anything
  in an init function. Bootstrap_vm will call bootstrap_instructions(),
  etc to initialize types, then set load-compiled to point to
  load-compiled/vm.

* src/vm.c (scm_load_compiled_with_vm): Code to load .go files, if
  they're present.

29 files changed, 421 insertions, 241 deletions

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 0cc8f1c22..8a08c5a25 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -24,8 +24,8 @@
   :use-module (system base language)
   :use-module (system il compile)
   :use-module (system il glil)
-  :use-module ((system vm core)
-	       :select (the-vm vm-load objcode->u8vector load-objcode))
+  :use-module (system vm objcode)
+  :use-module (system vm vm) ;; for compile-time evaluation
   :use-module (system vm assemble)
   :use-module (ice-9 regex)
   :export (syntax-error compile-file load-source-file load-file
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index fecea4458..f3bccec76 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -24,7 +24,9 @@
   :use-module (system base pmatch)
   :use-module (system base compile)
   :use-module (system repl common)
-  :use-module (system vm core)
+  :use-module (system vm objcode)
+  :use-module (system vm program)
+  :use-module (system vm vm)
   :autoload (system base language) (lookup-language)
   :autoload (system il glil) (pprint-glil)
   :autoload (system vm disasm) (disassemble-program disassemble-objcode)
@@ -61,7 +63,7 @@
     (lambda (p)
       (if (program? p)
           (program-documentation p)
-          (procedure-documentation p)))))
+          (old-definition p)))))
 
 (define *command-module* (current-module))
 (define (command-name c) (car c))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index cbc8bc48e..c142cc177 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -23,7 +23,7 @@
   :use-syntax (system base syntax)
   :use-module (system base compile)
   :use-module (system base language)
-  :use-module (system vm core)
+  :use-module (system vm vm)
   :export (<repl> make-repl repl-vm repl-language repl-options
                   repl-tm-stats repl-gc-stats repl-vm-stats
            repl-welcome repl-prompt repl-read repl-compile repl-eval
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 5f1a63160..f00f9289c 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -26,7 +26,7 @@
   :use-module (system base language)
   :use-module (system repl common)
   :use-module (system repl command)
-  :use-module (system vm core)
+  :use-module (system vm vm)
   :use-module (system vm debug)
   :use-module (ice-9 rdelim)
   :export (start-repl))
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 897a386af..d121dc52f 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -22,10 +22,9 @@
 (define-module (system vm assemble)
   :use-syntax (system base syntax)
   :use-module (system il glil)
-  :use-module ((system vm core)
-	       :select (instruction? instruction-pops
-		        make-binding
-			bytecode->objcode))
+  :use-module (system vm instruction)
+  :use-module (system vm objcode)
+  :use-module ((system vm program) :select (make-binding))
   :use-module (system vm conv)
   :use-module (ice-9 regex)
   :use-module (ice-9 common-list)
diff --git a/module/system/vm/bootstrap.scm b/module/system/vm/bootstrap.scm
index 785bcad67..6ecd83554 100644
--- a/module/system/vm/bootstrap.scm
+++ b/module/system/vm/bootstrap.scm
@@ -25,15 +25,7 @@
 ;;; Core procedures
 ;;;
 
-(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
-
-(module-export! (current-module)
-		(delq! '%module-public-interface
-		       (hash-fold (lambda (k v d) (cons k d)) '()
-				  (module-obarray (current-module)))))
-
-;; `load-compiled' is referred to by `boot-9.scm' and used by `use-modules'
-;; and friends.
-(set! load-compiled
-      (lambda (file)
-        ((the-vm) (objcode->program (load-objcode file)))))
+;; Calling this updates boot-9.scm's `load-compiled' to point to to
+;; scm_load_compiled_with_vm, so future module loads will read .go files
+;; if they are present.
+(dynamic-call "scm_bootstrap_vm" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/conv.scm b/module/system/vm/conv.scm
index 89993f6a3..ebe72b4fe 100644
--- a/module/system/vm/conv.scm
+++ b/module/system/vm/conv.scm
@@ -20,9 +20,7 @@
 ;;; Code:
 
 (define-module (system vm conv)
-  :use-module ((system vm core)
-	       :select (instruction? instruction-length
-			instruction->opcode opcode->instruction))
+  :use-module (system vm instruction)
   :use-module (system base pmatch)
   :use-module (ice-9 regex)
   :use-module (srfi srfi-4)
diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
deleted file mode 100644
index 32e2d6b07..000000000
--- a/module/system/vm/core.scm
+++ /dev/null
@@ -1,185 +0,0 @@
-;;; Guile VM core
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;; 
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;; GNU General Public License for more details.
-;; 
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING.  If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (system vm core)
-  :use-module (system vm bootstrap)
-  :export (arity:nargs arity:nrest arity:nlocs arity:nexts
-           make-binding binding:name binding:extp binding:index
-           program-bindings program-sources
-           program-properties program-property program-documentation
-           frame-arguments frame-local-variables frame-external-variables
-           frame-environment
-           frame-variable-exists? frame-variable-ref frame-variable-set!
-           frame-object-name
-           vm-fetch-locals vm-fetch-externals vm-return-value
-           vms:time vms:clock vm-load))
-
-;;;
-;;; Core procedures
-;;;
-
-;; FIXME
-(module-re-export! (current-module)
-                   (hash-fold (lambda (k v d) (cons k d)) '()
-                              (module-obarray
-                               (resolve-interface '(system vm bootstrap)))))
-
-
-;;;
-;;; Programs
-;;;
-
-(define arity:nargs car)
-(define arity:nrest cadr)
-(define arity:nlocs caddr)
-(define arity:nexts cadddr)
-
-(define (make-binding name extp index)
-  (list name extp index))
-
-(define binding:name car)
-(define binding:extp cadr)
-(define binding:index caddr)
-
-(define (program-bindings prog)
-  (cond ((program-meta prog) => car)
-	(else '())))
-
-(define (program-sources prog)
-  (cond ((program-meta prog) => cadr)
-	(else '())))
-
-(define (program-properties prog)
-  (or (and=> (program-meta prog) cddr)
-      '()))
-
-(define (program-property prog prop)
-  (assq-ref (program-properties proc) prop))
-
-(define (program-documentation prog)
-  (assq-ref (program-properties proc) 'documentation))
-
-
-
-;;;
-;;; Frames
-;;;
-
-(define (frame-arguments frame)
-  (let* ((prog (frame-program frame))
-	 (arity (program-arity prog)))
-    (do ((n (+ (arity:nargs arity) -1) (1- n))
-	 (l '() (cons (frame-local-ref frame n) l)))
-	((< n 0) l))))
-
-(define (frame-local-variables frame)
-  (let* ((prog (frame-program frame))
-	 (arity (program-arity prog)))
-    (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
-	 (l '() (cons (frame-local-ref frame n) l)))
-	((< n 0) l))))
-
-(define (frame-external-variables frame)
-  (frame-external-link frame))
-
-(define (frame-external-ref frame index)
-  (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
-  (list-set! (frame-external-link frame) index val))
-
-(define (frame-binding-ref frame binding)
-  (if (binding:extp binding)
-    (frame-external-ref frame (binding:index binding))
-    (frame-local-ref frame (binding:index binding))))
-
-(define (frame-binding-set! frame binding val)
-  (if (binding:extp binding)
-    (frame-external-set! frame (binding:index binding) val)
-    (frame-local-set! frame (binding:index binding) val)))
-
-(define (frame-bindings frame addr)
-  (do ((bs (program-bindings (frame-program frame)) (cdr bs))
-       (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
-      ((or (null? bs) (> (caar bs) addr))
-       (apply append ls))))
-
-(define (frame-lookup-binding frame addr sym)
-  (do ((bs (frame-bindings frame addr) (cdr bs)))
-      ((or (null? bs) (eq? sym (binding:name (car bs))))
-       (and (pair? bs) (car bs)))))
-
-(define (frame-object-binding frame addr obj)
-  (do ((bs (frame-bindings frame addr) (cdr bs)))
-      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
-       (and (pair? bs) (car bs)))))
-
-(define (frame-environment frame addr)
-  (map (lambda (binding)
-	 (cons (binding:name binding) (frame-binding-ref frame binding)))
-       (frame-bindings frame addr)))
-
-(define (frame-variable-exists? frame addr sym)
-  (if (frame-lookup-binding frame addr sym) #t #f))
-
-(define (frame-variable-ref frame addr sym)
-  (cond ((frame-lookup-binding frame addr sym) =>
-	 (lambda (binding) (frame-binding-ref frame binding)))
-	(else (error "Unknown variable:" sym))))
-
-(define (frame-variable-set! frame addr sym val)
-  (cond ((frame-lookup-binding frame addr sym) =>
-	 (lambda (binding) (frame-binding-set! frame binding val)))
-	(else (error "Unknown variable:" sym))))
-
-(define (frame-object-name frame addr obj)
-  (cond ((frame-object-binding frame addr obj) => binding:name)
-	(else #f)))
-
-
-;;;
-;;; Current status
-;;;
-
-(define (vm-fetch-locals vm)
-  (frame-local-variables (vm-this-frame vm)))
-
-(define (vm-fetch-externals vm)
-  (frame-external-variables (vm-this-frame vm)))
-
-(define (vm-return-value vm)
-  (car (vm-fetch-stack vm)))
-
-
-;;;
-;;; Statistics
-;;;
-
-(define (vms:time stat) (vector-ref stat 0))
-(define (vms:clock stat) (vector-ref stat 1))
-
-
-;;;
-;;; Loader
-;;;
-
-(define (vm-load vm objcode)
-  (vm (objcode->program objcode)))
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index cf72df3b7..4d23d7c54 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -21,8 +21,7 @@
 
 (define-module (system vm debug)
   :use-syntax (system base syntax)
-;;  :use-module ((system vm core)
-;;	       :select (vm-last-frame-chain vm-backtrace))
+  :use-module (system vm vm)
   :use-module (system vm frame)
   :use-module (ice-9 format)
   :export (vm-debugger vm-backtrace))
diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 60f2d2542..92c91bf35 100644
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -21,7 +21,8 @@
 
 (define-module (system vm disasm)
   :use-module (system base pmatch)
-  :use-module (system vm core)
+  :use-module (system vm objcode)
+  :use-module (system vm program)
   :use-module (system vm conv)
   :use-module (ice-9 regex)
   :use-module (ice-9 format)
@@ -102,6 +103,7 @@
       (let ((info (object->string (car l))))
 	(print-info n info #f)))))
 
+;; FIXME: update for recent meta changes
 (define (disassemble-meta meta)
   (display "Meta info:\n\n")
   (for-each (lambda (data)
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 29a612b44..7a09a6275 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -20,12 +20,19 @@
 ;;; Code:
 
 (define-module (system vm frame)
-  :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:))
+  :use-module (system vm program)
   :export (frame-number frame-address
-           vm-current-frame-chain vm-last-frame-chain
-           print-frame print-frame-call))
+           print-frame print-frame-call
+           frame-arguments frame-local-variables frame-external-variables
+           frame-environment
+           frame-variable-exists? frame-variable-ref frame-variable-set!
+           frame-object-name
+           frame-local-ref frame-external-link frame-local-set!
+           frame-return-address frame-program
+           frame-dynamic-link frame?))
+
+(dynamic-call "scm_init_frames" (dynamic-link "libguile-vm"))
 
-
 ;;;
 ;;; Frame chain
 ;;;
@@ -33,21 +40,15 @@
 (define frame-number (make-object-property))
 (define frame-address (make-object-property))
 
-(define (vm-current-frame-chain vm)
-  (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm)))
-
-(define (vm-last-frame-chain vm)
-  (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm)))
-
 (define (make-frame-chain frame addr)
-  (let* ((link (vm:frame-dynamic-link frame))
+  (let* ((link (frame-dynamic-link frame))
 	 (chain (if (eq? link #t)
 		  '()
 		  (cons frame (make-frame-chain
-			       link (vm:frame-return-address frame))))))
+			       link (frame-return-address frame))))))
     (set! (frame-number frame) (length chain))
     (set! (frame-address frame)
-	  (- addr (program-base (vm:frame-program frame))))
+	  (- addr (program-base (frame-program frame))))
     chain))
 
 
@@ -56,7 +57,7 @@
 ;;;
 
 (define (print-frame frame)
-  (format #t "#~A " (vm:frame-number frame))
+  (format #t "#~A " (frame-number frame))
   (print-frame-call frame)
   (newline))
 
@@ -72,12 +73,88 @@
 			 (else (vector (abbrev (vector-ref x 0)) '...))))
 	  (else x)))
   (write (abbrev (cons (program-name frame)
-		       (vm:frame-arguments frame)))))
+		       (frame-arguments frame)))))
 
 (define (program-name frame)
-  (let ((prog (vm:frame-program frame))
-	(link (vm:frame-dynamic-link frame)))
+  (let ((prog (frame-program frame))
+	(link (frame-dynamic-link frame)))
     (or (object-property prog 'name)
-	(vm:frame-object-name link (1- (vm:frame-address link)) prog)
+	(frame-object-name link (1- (frame-address link)) prog)
 	(hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
 		   prog (module-obarray (current-module))))))
+
+
+;;;
+;;; Frames
+;;;
+
+(define (frame-arguments frame)
+  (let* ((prog (frame-program frame))
+	 (arity (program-arity prog)))
+    (do ((n (+ (arity:nargs arity) -1) (1- n))
+	 (l '() (cons (frame-local-ref frame n) l)))
+	((< n 0) l))))
+
+(define (frame-local-variables frame)
+  (let* ((prog (frame-program frame))
+	 (arity (program-arity prog)))
+    (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
+	 (l '() (cons (frame-local-ref frame n) l)))
+	((< n 0) l))))
+
+(define (frame-external-variables frame)
+  (frame-external-link frame))
+
+(define (frame-external-ref frame index)
+  (list-ref (frame-external-link frame) index))
+
+(define (frame-external-set! frame index val)
+  (list-set! (frame-external-link frame) index val))
+
+(define (frame-binding-ref frame binding)
+  (if (binding:extp binding)
+    (frame-external-ref frame (binding:index binding))
+    (frame-local-ref frame (binding:index binding))))
+
+(define (frame-binding-set! frame binding val)
+  (if (binding:extp binding)
+    (frame-external-set! frame (binding:index binding) val)
+    (frame-local-set! frame (binding:index binding) val)))
+
+(define (frame-bindings frame addr)
+  (do ((bs (program-bindings (frame-program frame)) (cdr bs))
+       (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls))))
+      ((or (null? bs) (> (caar bs) addr))
+       (apply append ls))))
+
+(define (frame-lookup-binding frame addr sym)
+  (do ((bs (frame-bindings frame addr) (cdr bs)))
+      ((or (null? bs) (eq? sym (binding:name (car bs))))
+       (and (pair? bs) (car bs)))))
+
+(define (frame-object-binding frame addr obj)
+  (do ((bs (frame-bindings frame addr) (cdr bs)))
+      ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
+       (and (pair? bs) (car bs)))))
+
+(define (frame-environment frame addr)
+  (map (lambda (binding)
+	 (cons (binding:name binding) (frame-binding-ref frame binding)))
+       (frame-bindings frame addr)))
+
+(define (frame-variable-exists? frame addr sym)
+  (if (frame-lookup-binding frame addr sym) #t #f))
+
+(define (frame-variable-ref frame addr sym)
+  (cond ((frame-lookup-binding frame addr sym) =>
+	 (lambda (binding) (frame-binding-ref frame binding)))
+	(else (error "Unknown variable:" sym))))
+
+(define (frame-variable-set! frame addr sym val)
+  (cond ((frame-lookup-binding frame addr sym) =>
+	 (lambda (binding) (frame-binding-set! frame binding val)))
+	(else (error "Unknown variable:" sym))))
+
+(define (frame-object-name frame addr obj)
+  (cond ((frame-object-binding frame addr obj) => binding:name)
+	(else #f)))
diff --git a/module/system/vm/instruction.scm b/module/system/vm/instruction.scm
new file mode 100644
index 000000000..e8b325a7f
--- /dev/null
+++ b/module/system/vm/instruction.scm
@@ -0,0 +1,28 @@
+;;; Guile VM instructions
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm instruction)
+  :export (instruction-list
+           instruction? instruction-length
+           instruction-pops instruction-pushes
+           instruction->opcode opcode->instruction))
+
+(dynamic-call "scm_init_instructions" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/objcode.scm b/module/system/vm/objcode.scm
new file mode 100644
index 000000000..a814d5b85
--- /dev/null
+++ b/module/system/vm/objcode.scm
@@ -0,0 +1,26 @@
+;;; Guile VM object code
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm objcode)
+  :export (objcode->u8vector objcode? objcode->program  bytecode->objcode
+           load-objcode))
+
+(dynamic-call "scm_init_objcodes" (dynamic-link "libguile-vm"))
diff --git a/module/system/vm/profile.scm b/module/system/vm/profile.scm
index cfc53fee0..fcbe0e0ba 100644
--- a/module/system/vm/profile.scm
+++ b/module/system/vm/profile.scm
@@ -20,7 +20,7 @@
 ;;; Code:
 
 (define-module (system vm profile)
-  :use-module (system vm core)
+  :use-module (system vm vm)
   :use-module (ice-9 format)
   :export (vm-profile))
 
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
new file mode 100644
index 000000000..3c08542a6
--- /dev/null
+++ b/module/system/vm/program.scm
@@ -0,0 +1,63 @@
+;;; Guile VM program functions
+
+;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+
+;;; Code:
+
+(define-module (system vm program)
+  :export (arity:nargs arity:nrest arity:nlocs arity:nexts
+           make-binding binding:name binding:extp binding:index
+           program-bindings program-sources
+           program-properties program-property program-documentation
+           
+           program-arity program-external-set! program-meta
+           program-bytecode program? program-objects
+           program-base program-external))
+
+(dynamic-call "scm_init_programs" (dynamic-link "libguile-vm"))
+
+(define arity:nargs car)
+(define arity:nrest cadr)
+(define arity:nlocs caddr)
+(define arity:nexts cadddr)
+
+(define (make-binding name extp index)
+  (list name extp index))
+
+(define binding:name car)
+(define binding:extp cadr)
+(define binding:index caddr)
+
+(define (program-bindings prog)
+  (cond ((program-meta prog) => car)
+	(else '())))
+
+(define (program-sources prog)
+  (cond ((program-meta prog) => cadr)
+	(else '())))
+
+(define (program-properties prog)
+  (or (and=> (program-meta prog) cddr)
+      '()))
+
+(define (program-property prog prop)
+  (assq-ref (program-properties proc) prop))
+
+(define (program-documentation prog)
+  (assq-ref (program-properties proc) 'documentation))
+
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 0b028277f..0a0dc38ea 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -21,7 +21,7 @@
 
 (define-module (system vm trace)
   :use-syntax (system base syntax)
-  :use-module (system vm core)
+  :use-module (system vm vm)
   :use-module (system vm frame)
   :use-module (ice-9 format)
   :export (vm-trace vm-trace-on vm-trace-off))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
new file mode 100644
index 000000000..5fd719ca5
--- /dev/null
+++ b/module/system/vm/vm.scm
@@ -0,0 +1,62 @@
+;;; Guile VM core
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (system vm vm)
+  :use-module (system vm frame)
+  :use-module (system vm objcode)
+  :export (vm? the-vm make-vm vm-version
+           vm:ip vm:sp vm:fp
+
+           vm-load vm-return-value
+
+           vm-option set-vm-option! vm-version
+
+           vm-fetch-locals vm-fetch-externals
+           vm-last-frame vm-this-frame vm-fetch-stack
+           vm-current-frame-chain vm-last-frame-chain
+
+           vm-stats vms:time vms:clock
+
+           vm-next-hook vm-apply-hook vm-boot-hook vm-return-hook
+           vm-break-hook vm-exit-hook vm-halt-hook vm-enter-hook))
+
+(dynamic-call "scm_init_vm" (dynamic-link "libguile-vm"))
+
+(define (vm-current-frame-chain vm)
+  (make-frame-chain (vm-this-frame vm) (vm:ip vm)))
+
+(define (vm-last-frame-chain vm)
+  (make-frame-chain (vm-last-frame vm) (vm:ip vm)))
+
+(define (vm-fetch-locals vm)
+  (frame-local-variables (vm-this-frame vm)))
+
+(define (vm-fetch-externals vm)
+  (frame-external-variables (vm-this-frame vm)))
+
+(define (vm-return-value vm)
+  (car (vm-fetch-stack vm)))
+
+(define (vms:time stat) (vector-ref stat 0))
+(define (vms:clock stat) (vector-ref stat 1))
+
+(define (vm-load vm objcode)
+  (vm (objcode->program objcode)))
diff --git a/src/Makefile.am b/src/Makefile.am
index 0cc2617e8..32de942fa 100644
--- a/src/Makefile.am
+++ b/src/Makefile.am
@@ -9,6 +9,7 @@ CFLAGS:=$(filter-out -Wmissing-prototypes,$(CFLAGS))
 
 lib_LTLIBRARIES = libguile-vm.la
 libguile_vm_la_SOURCES =						\
+	bootstrap.h 							\
 	envs.c frames.c instructions.c objcodes.c programs.c vm.c	\
 	envs.h frames.h instructions.h objcodes.h programs.h vm.h	\
 	vm_engine.h vm_expand.h
diff --git a/src/bootstrap.h b/src/bootstrap.h
new file mode 100644
index 000000000..beecf0fc2
--- /dev/null
+++ b/src/bootstrap.h
@@ -0,0 +1,53 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
+ * Boston, MA 02111-1307 USA
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  */
+
+#ifndef _SCM_VM_BOOTSTRAP_H_
+#define _SCM_VM_BOOTSTRAP_H_
+
+extern void scm_bootstrap_vm (void);
+
+#endif /* _SCM_VM_BOOTSTRAP_H_ */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/
diff --git a/src/frames.c b/src/frames.c
index c25c9f677..a3c9b9705 100644
--- a/src/frames.c
+++ b/src/frames.c
@@ -44,6 +44,7 @@
 #endif
 
 #include <string.h>
+#include "bootstrap.h"
 #include "frames.h"
 
 
@@ -172,11 +173,17 @@ SCM_DEFINE (scm_frame_external_link, "frame-external-link", 1, 0, 0,
 
 
 void
-scm_init_frames (void)
+scm_bootstrap_frames (void)
 {
   scm_tc16_heap_frame = scm_make_smob_type ("frame", 0);
   scm_set_smob_mark (scm_tc16_heap_frame, heap_frame_mark);
   scm_set_smob_free (scm_tc16_heap_frame, heap_frame_free);
+}
+
+void
+scm_init_frames (void)
+{
+  scm_bootstrap_vm ();
 
 #ifndef SCM_MAGIC_SNARFER
 #include "frames.x"
diff --git a/src/frames.h b/src/frames.h
index 3803ffdc2..b0ac0c79a 100644
--- a/src/frames.h
+++ b/src/frames.h
@@ -105,6 +105,7 @@ extern scm_t_bits scm_tc16_heap_frame;
 #define SCM_VALIDATE_HEAP_FRAME(p,x)	SCM_MAKE_VALIDATE (p, x, HEAP_FRAME_P)
 
 extern SCM scm_c_make_heap_frame (SCM *fp);
+extern void scm_bootstrap_frames (void);
 extern void scm_init_frames (void);
 
 #endif /* _SCM_FRAMES_H_ */
diff --git a/src/instructions.c b/src/instructions.c
index 2ed70f381..f7ec70182 100644
--- a/src/instructions.c
+++ b/src/instructions.c
@@ -44,6 +44,7 @@
 #endif
 
 #include <string.h>
+#include "bootstrap.h"
 #include "instructions.h"
 
 struct scm_instruction scm_instruction_table[] = {
@@ -159,8 +160,15 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
 #undef FUNC_NAME
 
 void
+scm_bootstrap_instructions (void)
+{
+}
+
+void
 scm_init_instructions (void)
 {
+  scm_bootstrap_vm ();
+
 #ifndef SCM_MAGIC_SNARFER
 #include "instructions.x"
 #endif
diff --git a/src/instructions.h b/src/instructions.h
index 71b3f511f..d3f183761 100644
--- a/src/instructions.h
+++ b/src/instructions.h
@@ -79,6 +79,7 @@ struct scm_instruction {
 extern struct scm_instruction scm_instruction_table[];
 extern struct scm_instruction *scm_lookup_instruction (SCM name);
 
+extern void scm_bootstrap_instructions (void);
 extern void scm_init_instructions (void);
 
 #endif /* _SCM_INSTRUCTIONS_H_ */
diff --git a/src/objcodes.c b/src/objcodes.c
index 4306d3f47..603a0873c 100644
--- a/src/objcodes.c
+++ b/src/objcodes.c
@@ -51,6 +51,7 @@
 #include <sys/types.h>
 #include <assert.h>
 
+#include "bootstrap.h"
 #include "programs.h"
 #include "objcodes.h"
 
@@ -277,10 +278,16 @@ SCM_DEFINE (scm_objcode_to_program, "objcode->program", 1, 0, 0,
 
 
 void
-scm_init_objcodes (void)
+scm_bootstrap_objcodes (void)
 {
   scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
   scm_set_smob_free (scm_tc16_objcode, objcode_free);
+}
+
+void
+scm_init_objcodes (void)
+{
+  scm_bootstrap_vm ();
 
 #ifndef SCM_MAGIC_SNARFER
 #include "objcodes.x"
diff --git a/src/objcodes.h b/src/objcodes.h
index ee3b0956e..9acdbcc0f 100644
--- a/src/objcodes.h
+++ b/src/objcodes.h
@@ -60,6 +60,10 @@ extern scm_t_bits scm_tc16_objcode;
 #define SCM_OBJCODE_BASE(x)	(SCM_OBJCODE_DATA (x)->base)
 #define SCM_OBJCODE_FD(x)	(SCM_OBJCODE_DATA (x)->fd)
 
+extern SCM scm_load_objcode (SCM file);
+extern SCM scm_objcode_to_program (SCM objcode);
+
+extern void scm_bootstrap_objcodes (void);
 extern void scm_init_objcodes (void);
 
 #endif /* _SCM_OBJCODES_H_ */
diff --git a/src/programs.c b/src/programs.c
index 388b8cad6..9f0bde738 100644
--- a/src/programs.c
+++ b/src/programs.c
@@ -44,6 +44,7 @@
 #endif
 
 #include <string.h>
+#include "bootstrap.h"
 #include "instructions.h"
 #include "programs.h"
 #include "vm.h"
@@ -227,7 +228,7 @@ SCM_DEFINE (scm_program_bytecode, "program-bytecode", 1, 0, 0,
 
 
 void
-scm_init_programs (void)
+scm_bootstrap_programs (void)
 {
   zero_vector = scm_permanent_object (scm_c_make_vector (0, SCM_BOOL_F));
 
@@ -235,7 +236,13 @@ scm_init_programs (void)
   scm_set_smob_mark (scm_tc16_program, program_mark);
   scm_set_smob_free (scm_tc16_program, program_free);
   scm_set_smob_apply (scm_tc16_program, program_apply, 0, 0, 1);
+}
 
+void
+scm_init_programs (void)
+{
+  scm_bootstrap_vm ();
+  
 #ifndef SCM_MAGIC_SNARFER
 #include "programs.x"
 #endif
diff --git a/src/programs.h b/src/programs.h
index 238fae939..8bc3f8ad5 100644
--- a/src/programs.h
+++ b/src/programs.h
@@ -72,6 +72,7 @@ extern scm_t_bits scm_tc16_program;
 extern SCM scm_c_make_program (void *addr, size_t size, SCM holder);
 extern SCM scm_c_make_closure (SCM program, SCM external);
 
+extern void scm_bootstrap_programs (void);
 extern void scm_init_programs (void);
 
 #endif /* _SCM_PROGRAMS_H_ */
diff --git a/src/vm.c b/src/vm.c
index d9535ba48..53457287d 100644
--- a/src/vm.c
+++ b/src/vm.c
@@ -561,13 +561,25 @@ SCM_DEFINE (scm_vm_fetch_stack, "vm-fetch-stack", 1, 0, 0,
  * Initialize
  */
 
+SCM scm_load_compiled_with_vm (SCM file)
+{
+  SCM program = scm_objcode_to_program (scm_load_objcode (file));
+  
+  return vm_run (the_vm, program, SCM_EOL);
+}
+
 void
-scm_init_vm (void)
+scm_bootstrap_vm (void)
 {
-  scm_init_frames ();
-  scm_init_instructions ();
-  scm_init_objcodes ();
-  scm_init_programs ();
+  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);
@@ -580,6 +592,19 @@ scm_init_vm (void)
 
   the_vm = scm_permanent_object (make_vm ());
 
+  /* a bit heavy-handed, this */
+  scm_variable_set_x (scm_c_lookup ("load-compiled"),
+                      scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+                                        scm_load_compiled_with_vm));
+
+  strappage = 1;
+}
+
+void
+scm_init_vm (void)
+{
+  scm_bootstrap_vm ();
+
 #ifndef SCM_MAGIC_SNARFER
 #include "vm.x"
 #endif
diff --git a/src/vm.h b/src/vm.h
index e3cdc25ef..ef3022916 100644
--- a/src/vm.h
+++ b/src/vm.h
@@ -79,6 +79,8 @@ extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
 extern SCM scm_vm_option_ref (SCM vm, SCM key);
 extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
 
+extern SCM scm_load_compiled_with_vm (SCM file);
+
 extern void scm_init_vm (void);
 
 #endif /* _SCM_VM_H_ */