X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/b3219085d92f6ab67347f251b651a65c3a7b6c1e..aacc689677316ebb1ea45bb8fb22f921ebaf97d5:/module/system/base/compile.scm

diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 1c3320ad2..db05d1790 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -48,7 +48,7 @@
         thunk
         (lambda () #t))))
 
-;; (put 'call-with-output-file/atomic 'scheme-indent-function 1)
+;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
 (define* (call-with-output-file/atomic filename proc #:optional reference)
   (let* ((template (string-append filename ".XXXXXX"))
          (tmp (mkstemp! template)))
@@ -61,6 +61,7 @@
            (close-port tmp)
            (rename-file template filename))
          (lambda args
+           (close-port tmp)
            (delete-file template)))))))
 
 (define (ensure-language x)
@@ -152,7 +153,7 @@
         file)
       comp)))
 
-(define* (compile-and-load file #:key (from 'scheme) (to 'value)
+(define* (compile-and-load file #:key (from (current-language)) (to 'value)
                            (env (current-module)) (opts '())
                            (canonicalization 'relative))
   (with-fluids ((%file-port-name-canonicalization canonicalization))
@@ -181,12 +182,26 @@
   (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))
+    (cond ((null? in) to)
           ((language-joiner lang) lang)
           (else
            (lp (cdr in) (caar in))))))
 
+(define (default-language-joiner lang)
+  (lambda (exps env)
+    (if (and (pair? exps) (null? (cdr exps)))
+        (car exps)
+        (error
+         "Multiple expressions read and compiled, but language has no joiner"
+         lang))))
+
+(define (read-and-parse lang port cenv)
+  (let ((exp ((language-reader lang) port cenv)))
+    (cond
+     ((eof-object? exp) exp)
+     ((language-parser lang) => (lambda (parse) (parse exp)))
+     (else exp))))
+
 (define* (read-and-compile port #:key
                            (from (current-language))
                            (to 'objcode)
@@ -195,13 +210,16 @@
   (let ((from (ensure-language from))
         (to (ensure-language to)))
     (let ((joint (find-language-joint from to)))
-      (with-fluids ((*current-language* from))
+      (parameterize ((current-language from))
         (let lp ((exps '()) (env #f) (cenv env))
-          (let ((x ((language-reader (current-language)) port cenv)))
+          (let ((x (read-and-parse (current-language) port cenv)))
             (cond
              ((eof-object? x)
               (close-port port)
-              (compile ((language-joiner joint) (reverse exps) env)
+              (compile ((or (language-joiner joint)
+                            (default-language-joiner joint))
+                        (reverse exps)
+                        env)
                        #:from joint #:to to
                        ;; env can be false if no expressions were read.
                        #:env (or env (default-environment joint))