nifty generic compiler infrastructure -- no more hardcoded passes

* module/system/base/language.scm (<language>): Rework so that instead of
  hardcoding passes in the language, we define compilers that translate
  from one language to another. Add `parser' to the language fields, a
  bit of a hack but useful for languages with s-expression external
  representations but with record internal representations.
  (define-language, *compilation-cache*, invalidate-compilation-cache!)
  (compute-compilation-order, lookup-compilation-order): Add an algorithm
  that does a depth-first search for a translation path from a source
  language to a target language, caching the result in a lookup table.

* module/language/scheme/spec.scm:
* module/language/ghil/spec.scm: Update to the new language format.

* module/language/glil/spec.scm: Add a language specification for GLIL,
  with a compiler to objcode. Also there are parsers and printers, for
  repl usage, but for some reason this doesn't work yet.

* module/language/objcode/spec.scm: Define a language specification for
  object code. There is some sleight of hand here, in the "compiler" to
  values; but there is method behind the madness, because this way we
  higher levels can pass environments (a module + externals pair) to
  objcode->program.

* module/language/value/spec.scm: Define a language specification for
  values. There is something intellectually dishonest about this, but it
  does serve its purpose as a foundation for the language hierarchy.

* configure.in:
* module/language/Makefile.am
* module/language/ghil/Makefile.am
* module/language/glil/Makefile.am
* module/language/objcode/Makefile.am
* module/language/value/Makefile.am:
  Autotomfoolery for the ghil, glil, objcode, and value languages.

* module/language/scheme/translate.scm (translate): Import the bits that
  understand `compile-time-environment' here, and pass on the relevant
  portions of the environment to the next compiler pass.

* module/system/base/compile.scm (current-language): New procedure, refs
  the current language fluid, or lazily sets it to scheme.
  (call-once, call-with-output-file/atomic): Refactor these bits to use
  with-throw-handler. No functional change.
  (compile-file, compile-and-load, compile-passes, compile-fold)
  (compile): Refactor the public interface of the compiler to be generic
  and simple. Uses `lookup-compilation-order' to find a path from the
  source language to the target language.

* module/system/base/syntax.scm (define-type): Adapt to changes in
  define-record.
  (define-record): Instead of expecting all slots in the first form,
  expect them in the body, and let the first form hold the options.

* module/system/il/compile.scm (compile): Adapt to the compilation pass
  API (three in and two out).

* module/system/il/ghil.scm (<ghil-var>, <ghil-env>)
  (<ghil-toplevel-env>): Adapt to define-record changes.

* module/system/il/glil.scm (<glil-vars>): Adapt to define-record
  changes.
  (<glil>, print-glil): Add a GLIL record printer that uses unparse.
  (parse-glil, unparse-glil): Update unparse (formerly known as pprint),
  and write a parse function.

* module/system/repl/common.scm (<repl>): Adapt to define-record changes.
  (repl-parse): New function, parses the read form using the current
  language. Something of a hack.
  (repl-compile): Adapt to changes in `compile'.
  (repl-eval): Fix up the does-the-language-have-a-compiler check for
  changes in <language>.

* module/system/repl/repl.scm (start-repl): Parse the form before eval.

* module/system/repl/command.scm (describe): Parse.
  (compile): Be more generic.
  (compile-file): Adapt to changes in compile-file.
  (disassemble, time, profile, trace): Parse.

* module/system/vm/debug.scm:
* module/system/vm/assemble.scm: Adapt to define-record changes.

* module/language/scheme/translate.scm (receive): Fix an important bug
  that gave `receive' letrec semantics instead of let semantics. Whoops!

configure.in

@@ -1557,6 +1557,10 @@ AC_CONFIG_FILES([
   module/system/repl/Makefile
   module/language/Makefile
   module/language/scheme/Makefile
+  module/language/ghil/Makefile
+  module/language/glil/Makefile
+  module/language/objcode/Makefile
+  module/language/value/Makefile
   module/ice-9/Makefile
   module/ice-9/debugger/Makefile
   module/ice-9/debugging/Makefile

module/language/Makefile.am

@@ -1 +1 @@
-SUBDIRS=scheme
+SUBDIRS=scheme ghil glil objcode value

module/language/ghil/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = spec.scm
+modpath = language/ghil
+include $(top_srcdir)/am/guilec

module/language/ghil/spec.scm

@@ -21,14 +21,16 @@
 
 (define-module (language ghil spec)
   #:use-module (system base language)
+  #:use-module (language glil spec)
   #:use-module (system il ghil)
+  #:use-module ((system il compile) #:select ((compile . compile-il)))
   #:export (ghil))
 
 (define (write-ghil exp . port)
   (apply write (unparse-ghil exp) port))
 
-(define (translate x e)
+(define (parse x)
-  (call-with-ghil-environment e '()
+  (call-with-ghil-environment (make-ghil-toplevel-env e) '()
     (lambda (env vars)
       (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
 
@@ -37,5 +39,6 @@
   #:version	"0.3"
   #:reader	read
   #:printer	write-ghil
-  #:translator  translate
+  #:parser      parse
+  #:compilers   `((,glil . ,compile-il))
   )

module/language/glil/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = spec.scm
+modpath = language/glil
+include $(top_srcdir)/am/guilec

module/language/glil/spec.scm

@@ -0,0 +1,48 @@
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language glil spec)
+  #:use-module (system base language)
+  #:use-module (language objcode spec)
+  #:use-module (system il glil)
+  #:use-module (system vm assemble)
+  #:export (glil))
+
+(define (write-glil exp . port)
+  (apply write (unparse-glil exp) port))
+
+(define (translate x)
+  ;; Don't wrap in a thunk -- if you're down in these weeds you can
+  ;; thunk it yourself. We don't know how many locs there will be,
+  ;; anyway.
+  (parse-glil x))
+
+(define (compile x e opts)
+  (values (assemble x e) e))
+
+(define-language glil
+  #:title	"Guile Lowlevel Intermediate Language (GLIL)"
+  #:version	"0.3"
+  #:reader	read
+  #:printer	write-glil
+  #:parser      translate
+  #:compilers   `((,objcode . ,compile))
+  )

module/language/objcode/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = spec.scm
+modpath = language/objcode
+include $(top_srcdir)/am/guilec

module/language/objcode/spec.scm

@@ -0,0 +1,52 @@
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language objcode spec)
+  #:use-module (system base language)
+  #:use-module (language value spec)
+  #:use-module (system vm objcode)
+  #:export (objcode make-objcode-env))
+
+(define (make-objcode-env module externals)
+  (cons module externals))
+
+(define (objcode-env-module env)
+  (if env (car env) (current-module)))
+
+(define (objcode-env-externals env)
+  (if env (cdr env) '()))
+
+(define (objcode->value x e opts)
+  (let ((thunk (objcode->program x (objcode-env-externals e))))
+    (if e
+        (save-module-excursion
+         (lambda ()
+           (set-current-module (objcode-env-module e))
+           (values (thunk) #f)))
+        (values (thunk) #f))))
+
+(define-language objcode
+  #:title	"Guile Object Code"
+  #:version	"0.3"
+  #:reader	#f
+  #:printer	(lambda (x port) (uniform-vector-write (objcode->u8vector x) port))
+  #:compilers   `((,value . ,objcode->value))
+  )

module/language/scheme/spec.scm

@@ -20,8 +20,9 @@
 ;;; Code:
 
 (define-module (language scheme spec)
-  #:use-module (language scheme translate)
   #:use-module (system base language)
+  #:use-module (language scheme translate)
+  #:use-module (language ghil spec)
   #:export (scheme))
 
 ;;;
@@ -45,7 +46,7 @@
   #:version	"0.5"
   #:reader	read
   #:read-file	read-file
-  #:translator	translate
+  #:compilers   `((,ghil . ,translate))
   #:evaluator	(lambda (x module) (primitive-eval x))
   #:printer	write
   )

module/language/scheme/translate.scm

@@ -24,17 +24,52 @@
   #:use-module (system base language)
   #:use-module (system il ghil)
   #:use-module (system il inline)
+  #:use-module (system vm objcode)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
   #:use-module ((ice-9 syncase) #:select (sc-macro))
   #:use-module ((system base compile) #:select (syntax-error))
   #:export (translate translate-1
             *translate-table* define-scheme-translator))
 
 
-(define (translate x e)
+;;; environment := #f
-  (call-with-ghil-environment e '()
+;;;                | MODULE
-    (lambda (env vars)
+;;;                | COMPILE-ENV
-      (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)))))
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+  (cond ((not env) #f)
+        ((module? env) env)
+        ((and (pair? env) (module? (car env))) (car env))
+        (else (error "bad environment" env))))
+
+(define (cenv-ghil-env env)
+  (cond ((not env) (make-ghil-toplevel-env))
+        ((module? env) (make-ghil-toplevel-env))
+        ((pair? env)
+         (ghil-env-dereify (cadr env)))
+        (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+  (cond ((not env) '())
+        ((module? env) '())
+        ((pair? env) (cddr env))
+        (else (error "bad environment" env))))
+
+
+
+
+(define (translate x e opts)
+  (save-module-excursion
+   (lambda ()
+     (and=> (cenv-module e) set-current-module)
+     (call-with-ghil-environment (cenv-ghil-env e) '()
+       (lambda (env vars)
+         (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
+                 (and e
+                      (cons* (cenv-module e)
+                             (ghil-env-parent env)
+                             (cenv-externals e)))))))))
 
 
 ;;;
@@ -375,10 +410,11 @@
    ;; macro would do the trick; but it's good to test the mv-bind
    ;; code.
    (receive (syms rest) (parse-formals formals)
-            (call-with-ghil-bindings e syms
+            (let ((producer (retrans `(lambda () ,producer-exp))))
-                                     (lambda (vars)
+              (call-with-ghil-bindings e syms
-                                       (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
+                (lambda (vars)
-                                                          vars rest (trans-body e l body)))))))
+                  (make-ghil-mv-bind e l producer
+                                     vars rest (trans-body e l body))))))))
 
 (define-scheme-translator values
   ((,x) (retrans x))

module/language/value/Makefile.am

@@ -0,0 +1,3 @@
+SOURCES = spec.scm
+modpath = language/value
+include $(top_srcdir)/am/guilec

module/language/value/spec.scm

@@ -0,0 +1,31 @@
+;;; Guile Lowlevel Intermediate Language
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language value spec)
+  #:use-module (system base language)
+  #:export (value))
+
+(define-language value
+  #:title	"Guile Values"
+  #:version	"0.3"
+  #:reader	#f
+  #:printer	write
+  )

module/oop/goops.scm

@@ -1086,17 +1086,17 @@
                   (if (unbound? x)
                       (slot-unbound obj)
                       x)))
-   *goops-module*))
+   #:env *goops-module*))
 
 (define (make-get index)
   ((@ (system base compile) compile)
    `(lambda (o) (@slot-ref o ,index))
-   *goops-module*))
+   #:env *goops-module*))
 
 (define (make-set index)
   ((@ (system base compile) compile)
    `(lambda (o v) (@slot-set! o ,index v))
-   *goops-module*))
+   #:env *goops-module*))
 
 (define bound-check-get
   (standard-accessor-method make-bound-check-get bound-check-get-methods))

module/oop/goops/compile.scm

@@ -148,7 +148,7 @@
                                                 ,@(improper->proper formals)))
                                          (apply ,next-method-sym args)))))
                               ,@body)))
-                       (slot-ref method 'compile-env))))
+                       #:env (slot-ref method 'compile-env))))
         (list-set! (program-external cmethod) 0
                    (make-next-method (method-generic-function method)
                                      (cdr methods)

module/system/base/compile.scm

@@ -20,23 +20,18 @@
 ;;; Code:
 
 (define-module (system base compile)
-  #:use-syntax (system base syntax)
+  #:use-module (system base syntax)
   #:use-module (system base language)
-  #:use-module ((system il compile) #:select ((compile . compile-il)))
+  #:use-module (language objcode spec)
-  #:use-module (system il ghil)
+  #:use-module (language value spec)
-  #:use-module (system il glil)
+  #:use-module (system vm vm) ;; FIXME: there's a reason for this, can't remember why tho
-  #:use-module (system vm objcode)
-  #:use-module (system vm assemble)
-  #:use-module (system vm vm) ;; for compile-time evaluation
   #:use-module (ice-9 regex)
   #:use-module (ice-9 optargs)
-  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (ice-9 receive)
-  #:export (syntax-error compile-file load-source-file load-file
+  #:export (syntax-error 
             *current-language*
-            compiled-file-name
+            compiled-file-name compile-file compile-and-load
-            compile-time-environment
+            compile compile-time-environment)
-            compile read-file-in compile-in
-            load/compile)
   #:export-syntax (call-with-compile-error-catch))
 
 ;;;
@@ -62,48 +57,47 @@
 ;;;
 
 (define *current-language* (make-fluid))
+(define (current-language)
+  (or (fluid-ref *current-language*)
+      (begin (fluid-set! *current-language* (lookup-language 'scheme))
+             (current-language))))
 
-;; This is basically to avoid mucking with the backtrace.
+(define (call-once thunk)
-(define (call-with-nonlocal-exit-protect thunk on-nonlocal-exit)
+  (let ((entered #f))
-  (let ((success #f) (entered #f))
     (dynamic-wind
         (lambda ()
           (if entered
               (error "thunk may only be entered once: ~a" thunk))
           (set! entered #t))
-        (lambda ()
+        thunk
-          (thunk)
+        (lambda () #t))))
-          (set! success #t))
-        (lambda ()
-          (if (not success)
-              (on-nonlocal-exit))))))
 
 (define (call-with-output-file/atomic filename proc)
   (let* ((template (string-append filename ".XXXXXX"))
          (tmp (mkstemp! template)))
-    (call-with-nonlocal-exit-protect
+    (call-once
      (lambda ()
-       (with-output-to-port tmp
+       (with-throw-handler #t
-         (lambda () (proc (current-output-port))))
+         (lambda ()
-       (rename-file template filename))
+           (with-output-to-port tmp
-     (lambda ()
+             (lambda () (proc (current-output-port))))
-       (delete-file template)))))
+           (rename-file template filename))
+         (lambda args
+           (delete-file template)))))))
 
-(define (compile-file file . opts)
+(define* (compile-file file #:key (to objcode) (opts '()))
   (let ((comp (compiled-file-name file))
-        (lang (fluid-ref *current-language*)))
+        (lang (current-language)))
     (catch 'nothing-at-all
       (lambda ()
 	(call-with-compile-error-catch
 	 (lambda ()
 	   (call-with-output-file/atomic comp
 	     (lambda (port)
-	       (let* ((source (read-file-in file lang))
+               (let ((print (language-printer to)))
-		      (objcode (apply compile-in source (current-module)
+                 (print (compile (read-file-in file lang)
-				      lang opts)))
+                                 #:from lang #:to to #:opts opts)
-		 (if (memq #:c opts)
+                        port))))
-		   (pprint-glil objcode port)
-		   (uniform-vector-write (objcode->u8vector objcode) port)))))
 	   (format #t "wrote `~A'\n" comp))))
       (lambda (key . args)
 	(format #t "ERROR: during compilation of ~A:\n" file)
@@ -113,25 +107,9 @@
 	(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
 	(delete-file comp)))))
 
-; (let ((c-f compile-file))
+(define* (compile-and-load file #:key (to value) (opts '()))
-;   ;; XXX:  Debugging output
+  (let ((lang (current-language)))
-;   (set! compile-file
+    (compile (read-file-in file lang) #:to value #:opts opts)))
-; 	(lambda (file . opts)
-; 	  (format #t "compile-file: ~a ~a~%" file opts)
-; 	  (let ((result (apply c-f (cons file opts))))
-; 	    (format #t "compile-file: returned ~a~%" result)
-; 	    result))))
-
-(define (load-source-file file . opts)
-  (let ((lang (fluid-ref *current-language*)))
-    (let ((source (read-file-in file lang)))
-      (apply compile-in source (current-module) lang opts))))
-
-(define (load-file file . opts)
-  (let ((comp (compiled-file-name file)))
-    (if (file-exists? comp)
-	(load-objcode comp)
-	(apply load-source-file file opts))))
 
 (define (compiled-file-name file)
   (let ((base (basename file))
@@ -151,28 +129,32 @@
               cext))
             (else (lp (cdr exts)))))))
 
-;;; environment := #f
+
-;;;                | MODULE
+;;;
-;;;                | COMPILE-ENV
+;;; Compiler interface
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+;;;
-(define (cenv-module env)
-  (cond ((not env) #f)
-        ((module? env) env)
-        ((and (pair? env) (module? (car env))) (car env))
-        (else (error "bad environment" env))))
 
-(define (cenv-ghil-env env)
+(define (read-file-in file lang)
-  (cond ((not env) (make-ghil-toplevel-env))
+  (call-with-input-file file
-        ((module? env) (make-ghil-toplevel-env))
+    (or (language-read-file lang)
-        ((pair? env)
+        (error "language has no #:read-file" lang))))
-         (ghil-env-dereify (cadr env)))
-        (else (error "bad environment" env))))
 
-(define (cenv-externals env)
+(define (compile-passes from to opts)
-  (cond ((not env) '())
+  (let lp ((langs (or (lookup-compilation-order from to)
-        ((module? env) '())
+                      (error "no way to compile" (language-name from)
-        ((pair? env) (cddr env))
+                             "to" (language-name to))))
-        (else (error "bad environment" env))))
+           (out '()))
+    (if (null? (cdr langs))
+        (reverse! out)
+        (lp (cdr langs)
+            (cons (assq-ref (language-compilers (car langs)) (cadr langs))
+                  out)))))
+
+(define (compile-fold passes exp env opts)
+  (if (null? passes)
+      exp
+      (receive (exp env) ((car passes) exp env opts)
+        (compile-fold (cdr passes) exp env opts))))
 
 (define (compile-time-environment)
   "A special function known to the compiler that, when compiled, will
@@ -181,82 +163,12 @@ time. Useful for supporting some forms of dynamic compilation. Returns
 #f if called from the interpreter."
   #f)
 
-(define* (compile x #:optional env)
+(define* (compile x #:key
-  (let ((thunk (objcode->program
+                  (env #f)
-                (compile-in x env (fluid-ref *current-language*))
+                  (from (current-language))
-                (cenv-externals env))))
+                  (to value)
-    (if (not env)
+                  (opts '()))
-        (thunk)
+  (compile-fold (compile-passes from to opts)
-        (save-module-excursion
+                x
-         (lambda ()
+                env
-           (set-current-module (cenv-module env))
+                opts))
-           (thunk))))))
-
-
-;;;
-;;; Scheme compiler interface
-;;;
-
-(define (read-file-in file lang)
-  (call-with-input-file file (or (language-read-file lang)
-                                 (error "language has no #:read-file" lang))))
-
-;;; FIXME: fold run-pass x (compile-passes lang opts) 
-(define (compile-passes lang opts)
-  (let lp ((passes (list
-                    (language-expander lang)
-                    (language-translator lang)
-                    (lambda (x e) (apply compile-il x e opts))
-                    (lambda (x e) (apply assemble x e opts))))
-           (keys '(#f #:e #:t #:c))
-           (out '()))
-    (if (or (null? keys)
-            (and (car keys) (memq (car keys) opts)))
-        (reverse! out)
-        (lp (cdr passes) (cdr keys)
-            (if (car passes)
-                (cons (car passes) out)
-                out)))))
-
-(define (compile-in x e lang . opts)
-  (save-module-excursion
-   (lambda ()
-     (and=> (cenv-module e) set-current-module)
-     (let ((env (cenv-ghil-env e)))
-       (fold (lambda (pass exp)
-               (pass exp env))
-             x
-             (compile-passes lang opts))))))
-
-;;;
-;;;
-;;;
-
-(define (compile-and-load file . opts)
-  (let ((comp (object-file-name file)))
-    (if (or (not (file-exists? comp))
-	    (> (stat:mtime (stat file)) (stat:mtime (stat comp))))
-	(compile-file file))
-    (load-compiled-file comp)))
-
-(define (load/compile file . opts)
-  (let* ((file (file-full-name file))
-	 (compiled (object-file-name file)))
-    (if (or (not (file-exists? compiled))
-	    (> (stat:mtime (stat file)) (stat:mtime (stat compiled))))
-	(apply compile-file file #f opts))
-    (if (memq #:b opts)
-	(apply vm-trace (the-vm) (load-objcode compiled) opts)
-	((the-vm) (load-objcode compiled)))))
-
-(define (file-full-name filename)
-  (let* ((port (current-load-port))
-	 (oldname (and port (port-filename port))))
-    (if (and oldname
-	     (> (string-length filename) 0)
-	     (not (char=? (string-ref filename 0) #\/))
-	     (not (string=? (dirname oldname) ".")))
-	(string-append (dirname oldname) "/" filename)
-	filename)))
-
-(fluid-set! *current-language* (lookup-language 'scheme))

module/system/base/language.scm

@@ -20,30 +20,56 @@
 ;;; Code:
 
 (define-module (system base language)
-  #:use-syntax (system base syntax)
+  #:use-module (system base syntax)
   #:export (define-language lookup-language make-language
-           language-name language-title language-version language-reader
+            language-name language-title language-version language-reader
-           language-printer language-read-file language-expander
+            language-printer language-parser language-read-file
-           language-translator language-evaluator language-environment))
+            language-compilers language-evaluator
+
+            lookup-compilation-order invalidate-compilation-cache!))
 
 
 ;;;
 ;;; Language class
 ;;;
 
-(define-record (<language> name title version reader printer
+(define-record <language>
-                           (read-file #f)
+  name
-			   (expander #f)
+  title
-			   (translator #f)
+  version
-			   (evaluator #f)
+  reader
-			   (environment #f)
+  printer
-			   ))
+  (parser #f)
+  (read-file #f)
+  (compilers '())
+  (evaluator #f))
 
 (define-macro (define-language name . spec)
-  `(define ,name (make-language #:name ',name ,@spec)))
+  `(begin
+     (invalidate-compilation-cache!)
+     (define ,name (make-language #:name ',name ,@spec))))
 
 (define (lookup-language name)
   (let ((m (resolve-module `(language ,name spec))))
     (if (module-bound? m name)
 	(module-ref m name)
 	(error "no such language" name))))
+
+(define *compilation-cache* '())
+
+(define (invalidate-compilation-cache!)
+  (set! *compilation-cache* '()))
+
+(define (compute-compilation-order from to)
+  (let lp ((from from) (seen '()))
+    (cond ((eq? from to) (reverse! (cons from seen)))
+          ((memq from seen) #f)
+          (else (or-map (lambda (lang) (lp lang (cons from seen)))
+                        (map car (language-compilers from)))))))
+
+(define (lookup-compilation-order from to)
+  (or (assoc-ref *compilation-cache* (cons from to))
+      (let ((order (compute-compilation-order from to)))
+        (set! *compilation-cache*
+              (acons (cons from to) order *compilation-cache*))
+        order)))

module/system/base/syntax.scm

@@ -32,8 +32,11 @@
   (let ((name (if (pair? name) (car name) name))
         (opts (if (pair? name) (cdr name) '())))
     (let ((printer (kw-arg-ref opts #:printer)))
-      `(begin ,@(map (lambda (def) `(define-record ,def
+      `(begin ,@(map (lambda (def)
-                                      ,@(if printer (list printer) '())))
+                       `(define-record ,(if printer
+                                            `(,(car def) ,printer)
+                                            (car def))
+                          ,@(cdr def)))
                      rest)))))
 
 
@@ -44,14 +47,15 @@
 (define (symbol-trim-both sym pred)
   (string->symbol (string-trim-both (symbol->string sym) pred)))
 
-(define-macro (define-record def . printer)
+(define-macro (define-record name-form . slots)
-  (let* ((name (car def)) (slots (cdr def))
+  (let* ((name (if (pair? name-form) (car name-form) name-form))
+         (printer (and (pair? name-form) (cadr name-form)))
          (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
                           slots))
          (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
     `(begin
        (define ,name (make-record-type ,(symbol->string name) ',slot-names
-                                       ,@printer))
+                                       ,@(if printer (list printer) '())))
        (define ,(symbol-append 'make- stem)
          (let ((slots (list ,@(map (lambda (slot)
                                      (if (pair? slot)

module/system/il/compile.scm

@@ -26,9 +26,10 @@
   #:use-module (ice-9 common-list)
   #:export (compile))
 
-(define (compile x e . opts)
+(define (compile x e opts)
   (if (memq #:O opts) (set! x (optimize x)))
-  (codegen x))
+  (values (codegen x)
+          (and e (cons (car e) (cddr e)))))
 
 
 ;;;

module/system/il/ghil.scm

@@ -145,7 +145,7 @@
 ;;; Variables
 ;;;
 
-(define-record (<ghil-var> env name kind (index #f)))
+(define-record <ghil-var> env name kind (index #f))
 
 
 ;;;
@@ -157,8 +157,8 @@
 ;;; Environments
 ;;;
 
-(define-record (<ghil-env> parent (table '()) (variables '())))
+(define-record <ghil-env> parent (table '()) (variables '()))
-(define-record (<ghil-toplevel-env> (table '())))
+(define-record <ghil-toplevel-env> (table '()))
 
 (define (ghil-env-ref env sym)
   (assq-ref (ghil-env-table env) sym))

module/system/il/glil.scm

@@ -20,10 +20,10 @@
 ;;; Code:
 
 (define-module (system il glil)
-  #:use-syntax (system base syntax)
+  #:use-module (system base syntax)
+  #:use-module (system base pmatch)
   #:export
-  (pprint-glil
+  (<glil-vars> make-glil-vars
-   <glil-vars> make-glil-vars
    glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
 
    <glil-asm> make-glil-asm glil-asm?
@@ -70,11 +70,16 @@
    glil-call-inst glil-call-nargs
 
    <glil-mv-call> make-glil-mv-call glil-mv-call?
-   glil-mv-call-nargs glil-mv-call-ra))
+   glil-mv-call-nargs glil-mv-call-ra
 
-(define-record (<glil-vars> nargs nrest nlocs nexts))
+   parse-glil unparse-glil))
 
-(define-type <glil>
+(define-record <glil-vars> nargs nrest nlocs nexts)
+
+(define (print-glil x port)
+  (format port "#<glil ~s>" (unparse-glil x)))
+
+(define-type (<glil> #:printer print-glil)
   ;; Meta operations
   (<glil-asm> vars meta body)
   (<glil-bind> vars)
@@ -97,125 +102,57 @@
   (<glil-mv-call> nargs ra))
 
 
-;;;
+(define (parse-glil x)
-;;; Parser
+  (pmatch x
-;;;
+    ((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body)
+     (make-glil-asm (make-glil-vars nargs nrest nlocs next)
+                    meta (map parse-glil body)))
+    ((bind . ,vars) (make-glil-bind vars))
+    ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
+    ((unbind) (make-glil-unbind))
+    ((source ,loc) (make-glil-source loc))
+    ((void) (make-glil-void))
+    ((const ,obj) (make-glil-const obj))
+    ((argument ,op ,index) (make-glil-argument op index))
+    ((local ,op ,index) (make-glil-local op index))
+    ((external ,op ,depth ,index) (make-glil-external op depth index))
+    ((toplevel ,op ,name) (make-glil-toplevel op name))
+    ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
+    ((module private ,op ,mod ,name) (make-glil-module op mod name #f))
+    ((label ,label) (make-label ,label))
+    ((branch ,inst ,label) (make-glil-branch inst label))
+    ((call ,inst ,nargs) (make-glil-call inst nargs))
+    ((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
+    (else (error "invalid glil" x))))
 
-;;; (define (parse-glil x)
+(define (unparse-glil glil)
-;;;   (match x
-;;;     (('@asm args . body)
-;;;      (let* ((env (make-new-env e))
-;;; 	    (args (parse-args args env)))
-;;;        (make-asm env args (map-parse body env))))
-;;;     (else
-;;;      (error "Invalid assembly code:" x))))
-;;; 
-;;; (define (parse-args x e)
-;;;   (let ((args (cond ((symbol? x) (make-args (list (make-local-var x)) #t))
-;;; 		    ((list? x) (make-args (map make-local-var x) #f))
-;;; 		    (else (let loop ((l x) (v '()))
-;;; 			    (if (pair? l)
-;;; 				(loop (cdr l) (cons (car l) v))
-;;; 				(make-args (map make-local-var
-;;; 						(reverse! (cons l v)))
-;;; 					   #t)))))))
-;;;     (for-each (lambda (v) (env-add! e v)) (args-vars args))
-;;;     args))
-;;; 
-;;; (define (map-parse x e)
-;;;   (map (lambda (x) (parse x e)) x))
-;;; 
-;;; (define (parse x e)
-;;;   (match x
-;;;     ;; (@asm ARGS BODY...)
-;;;     (('@asm args . body)
-;;;      (parse-asm x e))
-;;;     ;; (@bind VARS BODY...)
-;;;     ;; (@block VARS BODY...)
-;;;     (((or '@bind '@block) vars . body)
-;;;      (let* ((offset (env-nvars e))
-;;; 	    (vars (args-vars (parse-args vars e)))
-;;; 	    (block (make-block (car x) offset vars (map-parse body e))))
-;;;        (for-each (lambda (v) (env-remove! e)) vars)
-;;;        block))
-;;;     ;; (void)
-;;;     (('void)
-;;;      (make-void))
-;;;     ;; (const OBJ)
-;;;     (('const obj)
-;;;      (make-const obj))
-;;;     ;; (ref NAME)
-;;;     ;; (set NAME)
-;;;     (((or 'ref 'set) name)
-;;;      (make-access (car x) (env-ref e name)))
-;;;     ;; (label LABEL)
-;;;     (('label label)
-;;;      (make-label label))
-;;;     ;; (br-if LABEL)
-;;;     ;; (jump LABEL)
-;;;     (((or 'br-if 'jump) label)
-;;;      (make-instl (car x) label))
-;;;     ;; (call NARGS)
-;;;     ;; (tail-call NARGS)
-;;;     (((or 'call 'goto/args) n)
-;;;      (make-instn (car x) n))
-;;;     ;; (INST)
-;;;     ((inst)
-;;;      (if (instruction? inst)
-;;; 	 (make-inst inst)
-;;; 	 (error "Unknown instruction:" inst)))))
-
-
-;;;
-;;; Unparser
-;;;
-
-(define (unparse glil)
   (record-case glil
     ;; meta
     ((<glil-asm> vars meta body)
-     `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
+     `(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
-             ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
+            ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
-            ,meta
+           ,meta
-	    ,@(map unparse body)))
+           ,@(map unparse-glil body)))
-    ((<glil-bind> vars) `(@bind ,@vars))
+    ((<glil-bind> vars) `(bind ,@vars))
-    ((<glil-unbind>) `(@unbind))
+    ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
-    ((<glil-source> loc) `(@source ,loc))
+    ((<glil-unbind>) `(unbind))
+    ((<glil-source> loc) `(source ,loc))
     ;; constants
     ((<glil-void>) `(void))
     ((<glil-const> obj) `(const ,obj))
     ;; variables
     ((<glil-argument> op index)
-     `(,(symbol-append 'argument- op) ,index))
+     `(argument ,op ,index))
     ((<glil-local> op index)
-     `(,(symbol-append 'local- op) ,index))
+     `(local ,op ,index))
     ((<glil-external> op depth index)
-     `(,(symbol-append 'external- op) ,depth ,index))
+     `(external ,op ,depth ,index))
     ((<glil-toplevel> op name)
-     `(,(symbol-append 'toplevel- op) ,name))
+     `(toplevel ,op ,name))
     ((<glil-module> op mod name public?)
-     `(,(symbol-append (if public? 'public 'private) '- op) ,mod ,name))
+     `(module ,(if public? 'public 'private) ,op ,mod ,name))
     ;; controls
-    ((<glil-label> label) label)
+    ((<glil-label> label) (label ,label))
-    ((<glil-branch> inst label) `(,inst ,label))
+    ((<glil-branch> inst label) `(branch ,inst ,label))
-    ((<glil-call> inst nargs) `(,inst ,nargs))))
+    ((<glil-call> inst nargs) `(call ,inst ,nargs))
-
+    ((<glil-mv-call> nargs ra) `(mv-call ,nargs ,(unparse-glil ra)))))
-
-;;;
-;;; Printer
-;;;
-
-(define (pprint-glil glil . port)
-  (let ((port (if (pair? port) (car port) (current-output-port))))
-    (let print ((code (unparse glil)) (column 0))
-      (display (make-string column #\space) port)
-      (cond ((and (pair? code) (eq? (car code) '@asm))
-	     (format port "(@asm ~A\n" (cadr code))
-	     (let ((col (+ column 2)))
-	       (let loop ((l (cddr code)))
-		 (print (car l) col)
-		 (if (null? (cdr l))
-		   (display ")" port)
-		   (begin (newline port) (loop (cdr l)))))))
-	    (else (write code port))))
-    (newline port)))

module/system/repl/command.scm

@@ -28,7 +28,6 @@
   #: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)
   #:autoload (system vm debug) (vm-debugger vm-backtrace)
   #:autoload (system vm trace) (vm-trace vm-trace-on vm-trace-off)
@@ -168,7 +167,8 @@ Find bindings/modules/packages."
 (define (describe repl obj)
   "describe OBJ
 Show description/documentation."
-  (display (object-documentation (repl-eval repl obj)))
+  (display (object-documentation
+            (repl-eval repl (repl-parse repl obj))))
   (newline))
 
 (define (option repl . args)
@@ -266,21 +266,20 @@ Generate compiled code.
 
   -O    Enable optimization
   -D    Add debug information"
-  (let ((x (apply repl-compile repl form opts)))
+  (let ((x (apply repl-compile repl (repl-parse repl form) opts)))
-    (cond ((or (memq #:e opts) (memq #:t opts)) (puts x))
+    (cond ((objcode? x) (disassemble-objcode x))
-	  ((memq #:c opts) (pprint-glil x))
+          (else (repl-print repl x)))))
-	  (else (disassemble-objcode x)))))
 
 (define guile:compile-file compile-file)
 (define (compile-file repl file . opts)
   "compile-file FILE
 Compile a file."
-  (apply guile:compile-file (->string file) opts))
+  (guile:compile-file (->string file) #:opts opts))
 
 (define (disassemble repl prog)
   "disassemble PROGRAM
 Disassemble a program."
-  (disassemble-program (repl-eval repl prog)))
+  (disassemble-program (repl-eval repl (repl-parse repl prog))))
 
 (define (disassemble-file repl file)
   "disassemble-file FILE
@@ -298,7 +297,7 @@ Time execution."
   (let* ((vms-start (vm-stats (repl-vm repl)))
 	 (gc-start (gc-run-time))
 	 (tms-start (times))
-	 (result (repl-eval repl form))
+	 (result (repl-eval repl (repl-parse repl form)))
 	 (tms-end (times))
 	 (gc-end (gc-run-time))
 	 (vms-end (vm-stats (repl-vm repl))))
@@ -320,7 +319,7 @@ Time execution."
 Profile execution."
   (apply vm-profile
          (repl-vm repl)
-         (repl-compile repl form)
+         (repl-compile repl (repl-parse repl form))
          opts))
 
 
@@ -346,7 +345,9 @@ Trace execution.
   -l    Display local variables
   -e    Display external variables
   -b    Bytecode level trace"
-  (apply vm-trace (repl-vm repl) (repl-compile repl form) opts))
+  (apply vm-trace (repl-vm repl)
+         (repl-compile repl (repl-parse repl form))
+         opts))
 
 (define (step repl)
   "step FORM

module/system/repl/common.scm

@@ -25,17 +25,17 @@
   #:use-module (system base language)
   #: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-tm-stats repl-gc-stats repl-vm-stats
-           repl-welcome repl-prompt repl-read repl-compile repl-eval
+            repl-welcome repl-prompt repl-read repl-compile repl-eval
-           repl-print repl-option-ref repl-option-set!
+            repl-parse repl-print repl-option-ref repl-option-set!
-           puts ->string user-error))
+            puts ->string user-error))
 
 
 ;;;
 ;;; Repl type
 ;;;
 
-(define-record (<repl> vm language options tm-stats gc-stats vm-stats))
+(define-record <repl> vm language options tm-stats gc-stats vm-stats)
 
 (define repl-default-options
   '((trace . #f)
@@ -65,15 +65,23 @@
   ((language-reader (repl-language repl))))
 
 (define (repl-compile repl form . opts)
-  (apply compile-in form (current-module) (repl-language repl) opts))
+  (let ((to (lookup-language (cond ((memq #:e opts) 'scheme)
+                                   ((memq #:t opts) 'ghil)
+                                   ((memq #:c opts) 'glil)
+                                   (else 'objcode)))))
+    (compile form #:from (repl-language repl) #:to to #:opts opts)))
+
+(define (repl-parse repl form)
+  (let ((parser (language-parser (repl-language repl))))
+    (if parser (parser form) form)))
 
 (define (repl-eval repl form)
   (let ((eval (language-evaluator (repl-language repl))))
     (if (and eval
-             (or (not (language-translator (repl-language repl)))
+             (or (null? (language-compilers (repl-language repl)))
                  (assq-ref (repl-options repl) 'interp)))
-	(eval form (current-module))
+        (eval form (current-module))
-	(vm-load (repl-vm repl) (repl-compile repl form)))))
+        (vm-load (repl-vm repl) (repl-compile repl form '())))))
 
 (define (repl-print repl val)
   (if (not (eq? val *unspecified*))

module/system/repl/repl.scm

@@ -121,7 +121,8 @@
                       (call-with-values (lambda ()
                                           (run-hook before-eval-hook exp)
                                           (start-stack repl-eval
-                                                       (repl-eval repl exp)))
+                                                       (repl-eval repl
+                                                                  (repl-parse repl exp))))
                         (lambda l
                           (for-each (lambda (v)
                                       (run-hook before-print-hook v)

module/system/vm/assemble.scm

@@ -40,13 +40,13 @@
 ;;; Types
 ;;;
 
-(define-record (<vm-asm> venv glil body))
+(define-record <vm-asm> venv glil body)
-(define-record (<venv> parent nexts closure?))
+(define-record <venv> parent nexts closure?)
 ;; key is either a symbol or the list (MODNAME SYM PUBLIC?)
-(define-record (<vlink-now> key))
+(define-record <vlink-now> key)
-(define-record (<vlink-later> key))
+(define-record <vlink-later> key)
-(define-record (<vdefine> name))
+(define-record <vdefine> name)
-(define-record (<bytespec> vars bytes meta objs closure?))
+(define-record <bytespec> vars bytes meta objs closure?)
 
 
 ;;;

module/system/vm/debug.scm

@@ -31,7 +31,7 @@
 ;;; Debugger
 ;;;
 
-(define-record (<debugger> vm chain index))
+(define-record <debugger> vm chain index)
 
 (define (vm-debugger vm)
   (let ((chain (vm-last-frame-chain vm)))

test-suite/tests/compiler.test

@@ -40,15 +40,15 @@
 
     ;; fixme: compiling with #t or module
     (pass-if "recompiling with environment"
-             (equal? ((compile '(lambda () x) env))
+             (equal? ((compile '(lambda () x) #:env env))
                      1))
 
     (pass-if "recompiling with environment/2"
-             (equal? ((compile '(lambda () (set! x (1+ x)) x) env))
+             (equal? ((compile '(lambda () (set! x (1+ x)) x) #:env env))
                      2))
 
     (pass-if "recompiling with environment/3"
-             (equal? ((compile '(lambda () x) env))
+             (equal? ((compile '(lambda () x) #:env env))
                      2))
     )
 
@@ -57,6 +57,6 @@
                    10))
 
   (pass-if "compile environment is a module"
-           (equal? ((compile '(lambda () 10) (current-module)))
+           (equal? ((compile '(lambda () 10) #:env (current-module)))
                    10))
   )

testsuite/run-vm-tests.scm

@@ -22,13 +22,12 @@
 	     (system vm disasm)
 	     (system base compile)
 	     (system base language)
-
+             (language scheme spec)
+             (language objcode spec)
 	     (srfi srfi-1)
 	     (ice-9 r5rs))
 
 
-(define %scheme (lookup-language 'scheme))
-
 (define (fetch-sexp-from-file file)
   (with-input-from-file file
     (lambda ()
@@ -40,7 +39,7 @@
 
 (define (compile-to-objcode sexp)
   "Compile the expression @var{sexp} into a VM program and return it."
-  (compile-in sexp (current-module) %scheme))
+  (compile sexp #:from scheme #:to objcode))
 
 (define (run-vm-program objcode)
   "Run VM program contained into @var{objcode}."