GNU bug report logs - #30094
[wishlist] better support for alternative languages

Previous Next

Full log

View this message in rfc822 format

From: Matt Wette <matt.wette <at> gmail.com>
To: 30094 <at> debbugs.gnu.org
Subject: bug#30094: patch for adding external lang support
Date: Tue, 4 Sep 2018 06:43:39 -0700

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)

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.