From d79d908ef0c421798b79bd72403b2a8fd196173c Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 20 May 2008 11:33:28 +0200
Subject: [PATCH] guile-vm is completely self-compiling now!

* module/language/scheme/translate.scm (*the-compile-toplevel-symbol*):
  Reset to compile-toplevel, which requires a patch to guile.

* module/system/base/compile.scm (compile-file): Some foo so that we load
  up the scheme language before call-with-output-file. Fixes compilation
  of (language scheme) modules.

* module/system/base/language.scm (define-language): Don't unquote in
  make-language; refer to it by name instead, and export it.

* module/system/repl/Makefile.am (vm_DATA): Don't compile describe.scm,
  because we really can't deal with goops yet.

* module/system/repl/repl.scm (compile-toplevel): If we're compiling, put
  in a stub definition of start-stack, which is closely tied to the
  interpreter.

* src/vm_loader.c (load-program): Fix a very tricky corruption bug!
---
 module/language/scheme/translate.scm | 2 +-
 module/system/base/compile.scm       | 7 ++++---
 module/system/base/language.scm      | 4 ++--
 module/system/repl/Makefile.am       | 5 +++--
 module/system/repl/repl.scm          | 5 +++++
 src/vm_loader.c                      | 9 +++++----
 6 files changed, 20 insertions(+), 12 deletions(-)

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index bb16ce91a..4aaefdc54 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -127,7 +127,7 @@
                 (else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
   `(list ,@(map make1 body)))
 
-(define *the-compile-toplevel-symbol* 'load-toplevel)
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
 
 (define primitive-syntax-table
   (make-pmatch-transformers
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index b48ed9fb2..e73c09274 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -58,16 +58,17 @@
 (define (scheme) (lookup-language 'scheme))
 
 (define (compile-file file . opts)
-  (let ((comp (compiled-file-name file)))
+  (let ((comp (compiled-file-name file))
+        (scheme (scheme)))
     (catch 'nothing-at-all
       (lambda ()
 	(call-with-compile-error-catch
 	 (lambda ()
 	   (call-with-output-file comp
 	     (lambda (port)
-	       (let* ((source (read-file-in file (scheme)))
+	       (let* ((source (read-file-in file scheme))
 		      (objcode (apply compile-in source (current-module)
-				      (scheme) opts)))
+				      scheme opts)))
 		 (if (memq :c opts)
 		   (pprint-glil objcode port)
 		   (uniform-vector-write (objcode->u8vector objcode) port)))))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 87ca077fa..47c408f67 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -21,7 +21,7 @@
 
 (define-module (system base language)
   :use-syntax (system base syntax)
-  :export (define-language lookup-language
+  :export (define-language lookup-language make-language
            language-name language-title language-version language-reader
            language-printer language-read-file language-expander
            language-translator language-evaluator language-environment))
@@ -39,7 +39,7 @@
 			   ))
 
 (define-macro (define-language name . spec)
-  `(define ,name (,make-language :name ',name ,@spec)))
+  `(define ,name (make-language :name ',name ,@spec)))
 
 (define (lookup-language name)
   (let ((m (resolve-module `(language ,name spec))))
diff --git a/module/system/repl/Makefile.am b/module/system/repl/Makefile.am
index f54b3864a..d5a9f68fb 100644
--- a/module/system/repl/Makefile.am
+++ b/module/system/repl/Makefile.am
@@ -1,8 +1,9 @@
-SOURCES = repl.scm common.scm command.scm describe.scm
+NOCOMP_SOURCES = describe.scm
+SOURCES = repl.scm common.scm command.scm
 GOBJECTS = $(SOURCES:%.scm=%.go)
 
 vmdir = $(guiledir)/system/repl
-vm_DATA = $(SOURCES) $(GOBJECTS)
+vm_DATA = $(SOURCES) $(NOCOMP_SOURCES) $(GOBJECTS)
 
 CLEANFILES = $(GOBJECTS)
 
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 29146221a..5f04ef215 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -85,6 +85,11 @@
     (else
      (apply bad-throw args))))
 
+(eval-case
+ ((compile-toplevel)
+  (define-macro (start-stack tag expr)
+    expr)))
+
 (define (start-repl lang)
   (let ((repl (make-repl lang)))
     (repl-welcome repl)
diff --git a/src/vm_loader.c b/src/vm_loader.c
index 6ad230ab7..f91627856 100644
--- a/src/vm_loader.c
+++ b/src/vm_loader.c
@@ -165,11 +165,12 @@ VM_DEFINE_LOADER (load_program, "load-program")
   else
     {
       /* Other cases */
+      /* x is #f, and already popped off */
+      p->nargs = SCM_I_INUM (sp[-3]);
+      p->nrest = SCM_I_INUM (sp[-2]);
+      p->nlocs = SCM_I_INUM (sp[-1]);
+      p->nexts = SCM_I_INUM (sp[0]);
       sp -= 4;
-      p->nargs = SCM_I_INUM (sp[0]);
-      p->nrest = SCM_I_INUM (sp[1]);
-      p->nlocs = SCM_I_INUM (sp[2]);
-      p->nexts = SCM_I_INUM (sp[3]);
     }
 
   PUSH (prog);
-- 
2.20.1