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)