allow specification of languages by name; add decompilers to languages

* module/system/base/language.scm (lookup-decompilation-order): New
  function, like its compiling cousin, but backwards.
  (compute-translation-order): Rework so that languages can be specified
  either by name or by identity. Return a list of language - procedure
  pairs, without the "to" language in the list, instead of a list of
  languages.
  (invalidate-compilation-cache!): Invalidate the decompilation cache
  too.
  (<language>): Add a decompiler field.

* module/system/base/compile.scm (compile-passes): Much simpler now that
  lookup-compilation-order gives us the procedures directly.

* module/language/*/spec.scm: Specify compilers by name, so that we can
  avoid unnecessary module loads, and so that when we specify
  decompilers, we can avoid cycles.

module/language/assembly/spec.scm

@@ -21,7 +21,6 @@
 
 (define-module (language assembly spec)
   #:use-module (system base language)
-  #:use-module (language bytecode spec)
   #:use-module (language assembly compile-bytecode)
   #:export (assembly))
 
@@ -31,5 +30,5 @@
   #:reader	read
   #:printer	write
   #:parser      read ;; fixme: make a verifier?
-  #:compilers   `((,bytecode . ,compile-bytecode))
+  #:compilers   `((bytecode . ,compile-bytecode))
   )

module/language/bytecode/spec.scm

@@ -21,7 +21,6 @@
 
 (define-module (language bytecode spec)
   #:use-module (system base language)
-  #:use-module (language objcode spec)
   #:use-module (system vm objcode)
   #:export (bytecode))
 
@@ -33,5 +32,5 @@
   #:version	"0.3"
   #:reader	read
   #:printer	write
-  #:compilers   `((,objcode . ,compile-objcode))
+  #:compilers   `((objcode . ,compile-objcode))
   )

module/language/ghil/spec.scm

@@ -21,7 +21,6 @@
 
 (define-module (language ghil spec)
   #:use-module (system base language)
-  #:use-module (language glil spec)
   #:use-module (language glil)
   #:use-module (language ghil)
   #:use-module (language ghil compile-glil)
@@ -41,5 +40,5 @@
   #:reader	read
   #:printer	write-ghil
   #:parser      parse
-  #:compilers   `((,glil . ,compile-glil))
+  #:compilers   `((glil . ,compile-glil))
   )

module/language/glil/spec.scm

@@ -21,7 +21,6 @@
 
 (define-module (language glil spec)
   #:use-module (system base language)
-  #:use-module (language assembly spec)
   #:use-module (language glil)
   #:use-module (language glil compile-assembly)
   #:export (glil))
@@ -38,5 +37,5 @@
   #:reader	read
   #:printer	write-glil
   #:parser      parse-glil
-  #:compilers   `((,assembly . ,compile-asm))
+  #:compilers   `((assembly . ,compile-asm))
   )

module/language/objcode/spec.scm

@@ -21,7 +21,6 @@
 
 (define-module (language objcode spec)
   #:use-module (system base language)
-  #:use-module (language value spec)
   #:use-module (system vm objcode)
   #:use-module (system vm program)
   #:export (objcode make-objcode-env))
@@ -49,5 +48,5 @@
   #:version	"0.3"
   #:reader	#f
   #:printer	write-objcode
-  #:compilers   `((,value . ,objcode->value))
+  #:compilers   `((value . ,objcode->value))
   )

module/language/scheme/spec.scm

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

module/system/base/compile.scm

@@ -140,15 +140,9 @@
         (error "language has no #:read-file" lang))))
 
 (define (compile-passes from to opts)
-  (let lp ((langs (or (lookup-compilation-order from to)
-                      (error "no way to compile" (language-name from)
-                             "to" (language-name to))))
-           (out '()))
-    (if (null? (cdr langs))
-        (reverse! out)
-        (lp (cdr langs)
-            (cons (assq-ref (language-compilers (car langs)) (cadr langs))
-                  out)))))
+  (map cdr
+       (or (lookup-compilation-order from to)
+           (error "no way to compile" from "to" to))))
 
 (define (compile-fold passes exp env opts)
   (if (null? passes)

module/system/base/language.scm

@@ -24,9 +24,10 @@
   #:export (define-language lookup-language make-language
             language-name language-title language-version language-reader
             language-printer language-parser language-read-file
-            language-compilers language-evaluator
+            language-compilers language-decompilers language-evaluator
 
-            lookup-compilation-order invalidate-compilation-cache!))
+            lookup-compilation-order lookup-decompilation-order
+            invalidate-compilation-cache!))
 
 
 ;;;
@@ -42,6 +43,7 @@
   (parser #f)
   (read-file #f)
   (compilers '())
+  (decompilers '())
   (evaluator #f))
 
 (define-macro (define-language name . spec)
@@ -56,20 +58,39 @@
 	(error "no such language" name))))
 
 (define *compilation-cache* '())
+(define *decompilation-cache* '())
 
 (define (invalidate-compilation-cache!)
+  (set! *decompilation-cache* '())
   (set! *compilation-cache* '()))
 
-(define (compute-compilation-order from to)
+(define (compute-translation-order from to language-translators)
+  (cond
+   ((not (language? to))
+    (compute-translation-order from (lookup-language to) language-translators))
+   (else
     (let lp ((from from) (seen '()))
-    (cond ((eq? from to) (reverse! (cons from seen)))
+      (cond
+       ((not (language? from))
+        (lp (lookup-language from) seen))
+       ((eq? from to) (reverse! seen))
        ((memq from seen) #f)
-          (else (or-map (lambda (lang) (lp lang (cons from seen)))
-                        (map car (language-compilers from)))))))
+       (else (or-map (lambda (pair)
+                       (lp (car pair) (acons from (cdr pair) seen)))
+                     (language-translators from))))))))
 
 (define (lookup-compilation-order from to)
-  (or (assoc-ref *compilation-cache* (cons from to))
-      (let ((order (compute-compilation-order from to)))
+  (let ((key (cons from to)))
+    (or (assoc-ref *compilation-cache* key)
+        (let ((order (compute-translation-order from to language-compilers)))
           (set! *compilation-cache*
-              (acons (cons from to) order *compilation-cache*))
-        order)))
+                (acons key order *compilation-cache*))
+          order))))
+
+(define (lookup-decompilation-order from to)
+  (let ((key (cons from to)))
+    (or (assoc-ref *decompilation-cache* key)
+        (let ((order (compute-translation-order from to language-decompilers)))
+          (set! *decompilation-cache*
+                (acons key order *decompilation-cache*))
+          order))))