bug#30094: [wishlist] better support for alternative languages

bug#30094: [wishlist] better support for alternative languages

[Ricardo Wurmus]

Hi Guilers,

since Guile supports alternative language implementations like Wisp it
would be nice if it could interpret files that contain code written in
other languages, without having to specially cater to them.

If GUILE_LOAD_PATH contains a file “foo.wisp” written in Wisp it would
be nice if Guile would automatically read it with the Wisp language.

The same applies to “load”, which only supports Scheme code.

Another idea might be to adopt the “#lang” macro from Racket to inform
Guile about the language that is used in the current file.

--
Ricardo

GPG: BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC
https://elephly.net

bug#30094: proposed code for alt languages

[Matt Wette]

[-- Attachment #1: Type: text/plain, Size: 5935 bytes --]

Hey all,

The attached code implements alternative languages. It is roughly a patch to
(system base compile).  It provides
1) extra procedures lang-from-port and lang-from-file
2) the global %file-extension-map
3) an altered version of compile-file

Behavior:
1) if the first line of the file is `#lang <lang>' then that is used as from
2) if the file-ending matches an entry in the a-list %file-extension-map the ref is used

Matt

In the following, compile.scm and ncompile.scm are trimmed to only contain
the procedure compile-file
mwette$ diff -c compile.scm ncompile.scm
*** compile.scm	Sun Aug 19 14:19:44 2018
--- ncompile.scm	Sun Aug 19 14:20:07 2018
***************
*** 1,10 ****
! (define* (compile-file file #:key
!                        (output-file #f)
!                        (from (current-language))
!                        (to 'bytecode)
!                        (env (default-environment from))
!                        (opts '())
!                        (canonicalization 'relative))
     (with-fluids ((%file-port-name-canonicalization canonicalization))
       (let* ((comp (or output-file (compiled-file-name file)
                        (error "failed to create path for auto-compiled file"
--- 1,10 ----
! (define* (ncompile-file file #:key
! 			(output-file #f)
! 			(from #f)
! 			(to 'bytecode)
! 			(env #f)
! 			(opts '())
! 			(canonicalization 'relative))
     (with-fluids ((%file-port-name-canonicalization canonicalization))
       (let* ((comp (or output-file (compiled-file-name file)
                        (error "failed to create path for auto-compiled file"
***************
*** 16,25 ****
   
         (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)
!       comp)))
--- 16,31 ----
   
         (ensure-directory (dirname comp))
         (call-with-output-file/atomic comp
! 	(lambda (port)
! 	  (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)))


Here is ncompile:;; ncompile v180819b
;; usage:
;;   (ncompile-file "foo.m")
;; first checks for first line of the form
;;   #lang <from-language>
;; then uses file ending ".m" => nx-matlab


(define-module (ncompile)
   #:export (ncompile-file)
   )

(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)
     ("m" . nx-matlab)
     ("js" . ecmascript)))

(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 call-with-output-file/atomic
   (@@ (system base compile) call-with-output-file/atomic))
(define language-printer
   (@ (system base language) language-printer))
(define ensure-language
   (@@ (system base compile) ensure-language))
(define ensure-directory
   (@@ (system base compile) ensure-directory))
(define read-and-compile
   (@@ (system base compile) read-and-compile))
(define compiled-file-name
   (@@ (system base compile) compiled-file-name))
(define default-environment
   (@@ (system base compile) default-environment))

(define* (ncompile-file file #:key
			(output-file #f)
			(from #f)
			(to 'bytecode)
			(env #f)
			(opts '())
			(canonicalization 'relative))
   (with-fluids ((%file-port-name-canonicalization canonicalization))
     (let* ((comp (or output-file (compiled-file-name file)
                      (error "failed to create path for auto-compiled file"
                             file)))
            (in (open-input-file file))
            (enc (file-encoding in)))
       ;; Choose the input encoding deterministically.
       (set-port-encoding! in (or enc "UTF-8"))

       (ensure-directory (dirname comp))
       (call-with-output-file/atomic comp
	(lambda (port)
	  (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)))

;; Local Variables:
;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;; End:
;; --- last line ---




[-- Attachment #2: ncompile.scm --]
[-- Type: text/x-scheme, Size: 3338 bytes --]

;; ncompile v180819b
;; usage:
;;   (ncompile-file "foo.m")
;; first checks for first line of the form
;;   #lang <from-language>
;; then uses file ending ".m" => nx-matlab


(define-module (ncompile)
  #:export (ncompile-file)
  )

(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)
    ("m" . nx-matlab)
    ("js" . ecmascript)))

(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 call-with-output-file/atomic
  (@@ (system base compile) call-with-output-file/atomic))
(define language-printer
  (@ (system base language) language-printer))
(define ensure-language
  (@@ (system base compile) ensure-language))
(define ensure-directory
  (@@ (system base compile) ensure-directory))
(define read-and-compile
  (@@ (system base compile) read-and-compile))
(define compiled-file-name
  (@@ (system base compile) compiled-file-name))
(define default-environment
  (@@ (system base compile) default-environment))

(define* (ncompile-file file #:key
			(output-file #f)
			(from #f)
			(to 'bytecode)
			(env #f)
			(opts '())
			(canonicalization 'relative))
  (with-fluids ((%file-port-name-canonicalization canonicalization))
    (let* ((comp (or output-file (compiled-file-name file)
                     (error "failed to create path for auto-compiled file"
                            file)))
           (in (open-input-file file))
           (enc (file-encoding in)))
      ;; Choose the input encoding deterministically.
      (set-port-encoding! in (or enc "UTF-8"))

      (ensure-directory (dirname comp))
      (call-with-output-file/atomic comp
	(lambda (port)
	  (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)))

;; Local Variables:
;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
;; End:
;; --- last line ---

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)

bug#30094: patch for adding external lang support

[Matt Wette]

There is a left-over simple-format statement which should be removed.

bug#30094: test script

[Matt Wette]

The following test script works with the 2.2.4 patch provided.
elisp tests don't work well but I think that is elisp issue.
This stuff works with my own developed.

;;; load-lang.test -			-*- scheme -*-

(define-module (test-suite test-load-lang)
   #:use-module (test-suite lib))

(define tmp-dir (getcwd))

(define (data-file-name filename)
   (in-vicinity tmp-dir filename))

(with-test-prefix "load/lang"

   (pass-if "using #lang"
     (let ((src-file (data-file-name "load1js")))
       (with-output-to-file src-file
	(lambda ()
	  (display "#lang ecmascript\n")
	  (display "function js_1pl(b) { return 1 + b; }\n")))
       (load src-file)
       (delete-file src-file)
       (= (js_1pl 2) 3)))

   (pass-if "using dot-js"
     (let ((src-file (data-file-name "load2.js")))
       (with-output-to-file src-file
	(lambda ()
	  (display "function js_2pl(b) { return 2 + b; }\n")))
       (load src-file)
       (delete-file src-file)
       (= (js_2pl 2) 4)))

   )

;; --- last line ---

bug#30094: load-lang patch

[Matt Wette]

I am now posting patch for this to github.com mwette guile-contrib 
patch-2.2.4 load.patch .