bug#30094: proposed code for alt languages

[Matt Wette]

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 ---

ncompile.scm
Description: Text Data