bug#30094: patch for adding external lang support

[Matt Wette]

Here is a patch against 2.2.4.  It compiled and passed "make check".
Still to go: some test-suite scripts.


--- module/system/base/compile.scm-orig 2016-08-01 04:32:31.000000000 -0700
+++ module/system/base/compile.scm      2018-09-04 06:27:53.056330281 -0700
@@ -28,6 +28,7 @@
   #:use-module (ice-9 receive)
   #:export (compiled-file-name
             compile-file
+           add-extension
             compile-and-load
             read-and-compile
             compile
@@ -132,11 +133,65 @@
          (and (false-if-exception (ensure-directory (dirname f)))
               f))))
 
+;; --- new ---------------------------
+
+(define (lang-from-port port)
+
+  (define (release chl)
+    (let loop ((chl chl))
+      (unless (null? chl)
+       (unread-char (car chl) port)
+       (loop (cdr chl))))
+    #f)
+
+  (define (return chl)
+    (string->symbol (reverse-list->string chl)))
+       
+  (let loop ((cl '()) (st 0) (kl '(#\# #\l #\a #\n #\g)) (ch (read-char port)))
+    (case st
+      ((0) (cond                       ; read `#lang'
+           ((eof-object? ch) (release cl))
+           ((null? kl) (loop cl 1 kl ch))
+           ((char=? ch (car kl))
+            (loop (cons ch cl) st (cdr kl) (read-char port)))
+           (else (release (cons ch cl)))))
+      ((1) (cond                       ; skip spaces
+           ((eof-object? ch) (release cl))
+           ((char=? ch #\space) (loop (cons ch cl) st kl (read-char port)))
+           (else (loop cl 2 '() ch))))
+      ((2) (cond                       ; collect lang name
+           ((eof-object? ch) (return kl))
+           ((char=? ch #\newline) (return kl))
+           ((char-whitespace? ch) (loop cl 3 kl ch))
+           (else (loop cl st (cons ch kl) (read-char port)))))
+      ((3) (cond
+           ((eof-object? ch) (return kl))
+           ((char=? ch #\newline) (return kl))
+           (else (loop cl st kl (read-char port))))))))
+
+(define %file-extension-map
+  '(("scm" . scheme)
+    ("el" . elisp)
+    ("js" . ecmascript)))
+
+(define (add-extension tag lang)
+  (unless (and (string? tag) (symbol? lang))
+    (error "expecting string symbol"))
+  (set! %file-extension-map (acons tag lang %file-extension-map)))
+
+(define* (lang-from-file file)
+  (let* ((ix (string-rindex file #\.))
+       (ext (and ix (substring file (1+ ix)))))
+    (and ext (assoc-ref %file-extension-map ext))))
+
+
+;; -----------------------------------
+
 (define* (compile-file file #:key
                        (output-file #f)
-                       (from (current-language))
+                       (from #f)
                        (to 'bytecode)
-                       (env (default-environment from))
+                       (env #f)
                        (opts '())
                        (canonicalization 'relative))
   (with-fluids ((%file-port-name-canonicalization canonicalization))
@@ -151,11 +206,17 @@
       (ensure-directory (dirname comp))
       (call-with-output-file/atomic comp
         (lambda (port)
-          ((language-printer (ensure-language to))
-           (read-and-compile in #:env env #:from from #:to to #:opts
-                             (cons* #:to-file? #t opts))
-           port))
-        file)
+         (let* ((from (or from
+                          (lang-from-port in)
+                          (lang-from-file file)
+                          (current-language)))
+                (env (or env (default-environment from))))
+           (simple-format (current-error-port) "compiling from lang ~A\n" from)
+           ((language-printer (ensure-language to))
+            (read-and-compile in #:env env #:from from #:to to #:opts
+                              (cons* #:to-file? #t opts))
+            port)))
+       file)
       comp)))
 
 (define* (compile-and-load file #:key (from (current-language)) (to 'value)