support expression-by-expression compilation

* module/language/ghil.scm (unparse-ghil): Fix unparsing of quasiquoted
  expressions.

* module/language/ghil/spec.scm (join): Define a joiner for GHIL.

* module/language/scheme/compile-ghil.scm (cenv-ghil-env): Expand the
  definition of a CENV so it can have an actual ghil-env, if available.
  (compile-ghil): Return the actual ghil env in the cenv.

* module/system/base/compile.scm (compile-file): Rewrite. `output-file'
  is now a keyword argument, along with the new kwargs `env' and `from'.
  We now allow exceptions to propagate up, and instead of printing the
  output file to the console, we return a string corresponding to its
  location.
  (compile-and-load): Use read-and-compile.
  (compile-fold): Thread around the cenv as well. Return all three
  values.
  (find-language-joint, read-and-compile): New exciting helpers. The idea
  is that compiling a file should be semantically equivalent to compiling
  each expression in it, one by one. Compilation can have side effects,
  e.g. affecting the current language or the current reader. So what we
  do is find a point in the compilation path at which different
  expressions of a given language can be joined into one. Expressions
  from the source language are compiled to the joint language, then
  joined and compiled to the target.
  (compile): Just return the first value from compile-fold.

* module/system/base/language.scm (language-joiner): New optional field.

* scripts/compile: Rework for changes to compile-file.

module/language/ghil.scm

@@ -432,7 +432,10 @@
     ((<ghil-quote> env loc obj)
      `(,'quote ,obj))
     ((<ghil-quasiquote> env loc exp)
-     `(,'quasiquote ,(map unparse-ghil exp)))
+     `(,'quasiquote ,(let lp ((x exp))
+                       (cond ((struct? x) (unparse-ghil x))
+                             ((pair? x) (cons (lp (car x)) (lp (cdr x))))
+                             (else x)))))
     ((<ghil-unquote> env loc exp)
      `(,'unquote ,(unparse-ghil exp)))
     ((<ghil-unquote-splicing> env loc exp)

module/language/ghil/spec.scm

@@ -34,11 +34,30 @@
     (lambda (env vars)
       (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
 
+(define (join exps env)
+  (if (or-map (lambda (x)
+                (or (not (ghil-lambda? x))
+                    (ghil-lambda-rest x)
+                    (memq 'argument
+                          (map ghil-var-kind
+                               (ghil-env-variables (ghil-lambda-env x))))))
+              exps)
+      (error "GHIL expressions to join must be thunks"))
+
+  (let ((env (make-ghil-env env '()
+                            (apply append
+                                   (map ghil-env-variables
+                                        (map ghil-lambda-env exps))))))
+    (make-ghil-lambda env #f '() #f '()
+                      (make-ghil-begin env #f
+                                       (map ghil-lambda-body exps)))))
+
 (define-language ghil
   #:title	"Guile High Intermediate Language (GHIL)"
   #:version	"0.3"
   #:reader	read
   #:printer	write-ghil
   #:parser      parse
+  #:joiner      join
   #:compilers   `((glil . ,compile-glil))
   )

module/language/scheme/compile-ghil.scm

@@ -36,7 +36,7 @@
 ;;; environment := #f
 ;;;                | MODULE
 ;;;                | COMPILE-ENV
-;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+;;; compile-env := (MODULE LEXICALS|GHIL-ENV . EXTERNALS)
 (define (cenv-module env)
   (cond ((not env) #f)
         ((module? env) env)
@@ -47,7 +47,9 @@
   (cond ((not env) (make-ghil-toplevel-env))
         ((module? env) (make-ghil-toplevel-env))
         ((pair? env)
-         (ghil-env-dereify (cadr env)))
+         (if (struct? (cadr env))
+             (cadr env)
+             (ghil-env-dereify (cadr env))))
         (else (error "bad environment" env))))
 
 (define (cenv-externals env)
@@ -68,13 +70,11 @@
      (call-with-ghil-environment (cenv-ghil-env e) '()
        (lambda (env vars)
          (let ((x (make-ghil-lambda env #f vars #f '()
-                                    (translate-1 env #f x))))
+                                    (translate-1 env #f x)))
-           (values x
+               (cenv (make-cenv (current-module)
-                   (and e
+                                (ghil-env-parent env)
-                        (cons* (cenv-module e)
+                                (if e (cenv-externals e) '()))))
-                               (ghil-env-parent env)
+           (values x cenv cenv)))))))
-                               (cenv-externals e)))
-                   (make-cenv (current-module) '() '()))))))))
 
 
 ;;;

module/system/base/compile.scm

@@ -92,33 +92,24 @@
       x
       (lookup-language x)))
 
-(define* (compile-file file #:optional output-file
+(define* (compile-file file #:key
-		            #:key (to 'objcode) (opts '()))
+                       (output-file #f)
+                       (env #f)
+                       (from (current-language))
+                       (to 'objcode)
+                       (opts '()))
   (let ((comp (or output-file (compiled-file-name file)))
-        (lang (ensure-language (current-language)))
+        (in (open-input-file file)))
-        (to (ensure-language to)))
+    (call-with-output-file/atomic comp
-    (catch 'nothing-at-all
+      (lambda (port)
-      (lambda ()
+        ((language-printer (ensure-language to))
-	(call-with-compile-error-catch
+         (read-and-compile in #:env env #:from from #:to to #:opts opts)
-	 (lambda ()
+         port)))
-	   (call-with-output-file/atomic comp
+    comp))
-	     (lambda (port)
-               (let ((print (language-printer to)))
-                 (print (compile (read-file-in file lang)
-                                 #:from lang #:to to #:opts opts)
-                        port))))
-	   (format #t "wrote `~A'\n" comp))))
-      (lambda (key . args)
-	(format #t "ERROR: during compilation of ~A:\n" file)
-	(display "ERROR: ")
-	(apply format #t (cadr args) (caddr args))
-	(newline)
-	(format #t "ERROR: ~A ~A ~A\n" key (car args) (cadddr args))
-	(delete-file comp)))))
 
 (define* (compile-and-load file #:key (to 'value) (opts '()))
-  (let ((lang (ensure-language (current-language))))
+  (read-and-compile (open-input-port file)
-    (compile (read-file-in file lang) #:to 'value #:opts opts)))
+                    #:from lang #:to to #:opts opts))
 
 (define (compiled-file-name file)
   (let ((base (basename file))
@@ -155,10 +146,11 @@
            (error "no way to compile" from "to" to))))
 
 (define (compile-fold passes exp env opts)
-  (if (null? passes)
+  (let lp ((passes passes) (x exp) (e env) (cenv env) (first? #t))
-      exp
+    (if (null? passes)
-      (receive (exp env cenv) ((car passes) exp env opts)
+        (values x e cenv)
-        (compile-fold (cdr passes) exp env opts))))
+        (receive (x e new-cenv) ((car passes) x e opts)
+          (lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
 
 (define (compile-time-environment)
   "A special function known to the compiler that, when compiled, will
@@ -167,15 +159,46 @@ time. Useful for supporting some forms of dynamic compilation. Returns
 #f if called from the interpreter."
   #f)
 
+(define (find-language-joint from to)
+  (let lp ((in (reverse (or (lookup-compilation-order from to)
+                            (error "no way to compile" from "to" to))))
+           (lang to))
+    (cond ((null? in)
+           (error "don't know how to join expressions" from to))
+          ((language-joiner lang) lang)
+          (else
+           (lp (cdr in) (caar in))))))
+
+(define* (read-and-compile port #:key
+                           (env #f)
+                           (from (current-language))
+                           (to 'objcode)
+                           (opts '()))
+  (let ((from (ensure-language from))
+        (to (ensure-language to)))
+    (let ((joint (find-language-joint from to)))
+      (with-fluids ((*current-language* from))
+        (let lp ((exps '()) (env #f) (cenv env))
+          (let ((x ((language-reader (current-language)) port)))
+            (cond
+             ((eof-object? x)
+              (compile ((language-joiner joint) (reverse exps) env)
+                       #:from joint #:to to #:env env #:opts opts))
+             (else
+              ;; compile-fold instead of compile so we get the env too
+              (receive (jexp jenv jcenv)
+                  (compile-fold (compile-passes (current-language) joint opts)
+                                x cenv opts)
+                (lp (cons jexp exps) jenv jcenv))))))))))
+
 (define* (compile x #:key
                   (env #f)
                   (from (current-language))
                   (to 'value)
                   (opts '()))
-  (compile-fold (compile-passes from to opts)
+  (receive (exp env cenv)
-                x
+      (compile-fold (compile-passes from to opts) x env opts)
-                env
+    exp))
-                opts))
 
 
 ;;;

module/system/base/language.scm

@@ -25,6 +25,7 @@
             language-name language-title language-version language-reader
             language-printer language-parser language-read-file
             language-compilers language-decompilers language-evaluator
+            language-joiner
 
             lookup-compilation-order lookup-decompilation-order
             invalidate-compilation-cache!))
@@ -44,7 +45,8 @@
   (read-file #f)
   (compilers '())
   (decompilers '())
-  (evaluator #f))
+  (evaluator #f)
+  (joiner #f))
 
 (define-macro (define-language name . spec)
   `(begin

scripts/compile

@@ -28,9 +28,7 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@"
 
 ;; Usage: compile [ARGS]
 ;;
-;; PROGRAM does something.
+;; A command-line interface to the Guile compiler.
-;;
-;; TODO: Write it!
 
 ;;; Code:
 
@@ -67,15 +65,16 @@ exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@"
 	(option '(#\O "optimize") #f #f
 		(lambda (opt name arg result)
 		  (alist-cons 'optimize? #t result)))
-	(option '(#\e "expand-only") #f #f
+	(option '(#\f "from") #t #f
 		(lambda (opt name arg result)
-		  (alist-cons 'expand-only? #t result)))
+                  (if (assoc-ref result 'from)
-	(option '(#\t "translate-only") #f #f
+                      (fail "`--from' option cannot be specified more than once")
+                      (alist-cons 'from (string->symbol arg) result))))
+	(option '(#\t "to") #t #f
 		(lambda (opt name arg result)
-		  (alist-cons 'translate-only? #t result)))
+                  (if (assoc-ref result 'to)
-	(option '(#\c "compile-only") #f #f
+                      (fail "`--to' option cannot be specified more than once")
-		(lambda (opt name arg result)
+                      (alist-cons 'to (string->symbol arg) result))))))
-		  (alist-cons 'compile-only? #t result)))))
 
 (define (parse-args args)
   "Parse argument list @var{args} and return an alist with all the relevant
@@ -97,46 +96,44 @@ options."
 (define (compile args)
   (let* ((options         (parse-args (cdr args)))
          (help?           (assoc-ref options 'help?))
-         (optimize?       (assoc-ref options 'optimize?))
+         (compile-opts    (if (assoc-ref options 'optimize?) '(#:O) '()))
-         (expand-only?    (assoc-ref options 'expand-only?))
+         (from            (or (assoc-ref options 'from) 'scheme))
-         (translate-only? (assoc-ref options 'translate-only?))
+         (to              (or (assoc-ref options 'to) 'objcode))
-         (compile-only?   (assoc-ref options 'compile-only?))
 	 (input-files     (assoc-ref options 'input-files))
 	 (output-file     (assoc-ref options 'output-file))
 	 (load-path       (assoc-ref options 'load-path)))
     (if (or help? (null? input-files))
         (begin
           (format #t "Usage: compile [OPTION] FILE...
-Compile each Guile Scheme source file FILE into a Guile object.
+Compile each Guile source file FILE into a Guile object.
 
   -h, --help           print this help message
 
   -L, --load-path=DIR  add DIR to the front of the module load path
   -o, --output=OFILE   write output to OFILE
 
-  -O, --optimize       turn on optimizations
+  -f, --from=LANG      specify a source language other than `scheme'
-  -e, --expand-only    only go through the code expansion stage
+  -t, --to=LANG        specify a target language other than `objcode'
-  -t, --translate-only stop after the translation to GHIL
-  -c, --compile-only   stop after the compilation to GLIL
 
 Report bugs to <guile-user@gnu.org>.~%")
           (exit 0)))
 
     (set! %load-path (append load-path %load-path))
 
-    (let ((compile-opts (append (if optimize? '(#:O) '())
+    (if (and output-file
-                                (if expand-only? '(#:e) '())
+             (or (null? input-files)
-                                (if translate-only? '(#:t) '())
+                 (not (null? (cdr input-files)))))
-                                (if compile-only? '(#:c) '()))))
+        (fail "`-o' option can only be specified "
-      (if output-file
+              "when compiling a single file"))
-	  (if (and (not (null? input-files))
+
-		   (null? (cdr input-files)))
+    (for-each (lambda (file)
-	      (compile-file (car input-files) output-file)
+                (format #t "wrote `~A'\n"
-	      (fail "`-o' option can only be specified "
+                        (compile-file file
-		    "when compiling a single file"))
+                                      #:output-file output-file
-	  (for-each (lambda (file)
+                                      #:from from
-		      (apply compile-file file compile-opts))
+                                      #:to to
-		    input-files)))))
+                                      #:opts compile-opts)))
+              input-files)))
 
 ;;; Local Variables:
 ;;; coding: latin-1