From: Matt Wette <matt.wette@gmail.com>
To: 30094@debbugs.gnu.org
Subject: bug#30094: patch for adding external lang support
Date: Tue, 4 Sep 2018 06:43:39 -0700 [thread overview]
Message-ID: <8cd59533-5fdb-7ae0-f37b-bc9117044161@gmail.com> (raw)
In-Reply-To: <876086wvan.fsf@elephly.net>
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)
next prev parent reply other threads:[~2018-09-04 13:43 UTC|newest]
Thread overview: 6+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-12 22:45 bug#30094: [wishlist] better support for alternative languages Ricardo Wurmus
2018-08-19 21:24 ` bug#30094: proposed code for alt languages Matt Wette
2018-09-04 13:43 ` Matt Wette [this message]
2018-09-04 14:00 ` bug#30094: patch for adding external lang support Matt Wette
2018-09-05 1:35 ` bug#30094: test script Matt Wette
2018-09-23 17:29 ` bug#30094: load-lang patch Matt Wette
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8cd59533-5fdb-7ae0-f37b-bc9117044161@gmail.com \
--to=matt.wette@gmail.com \
--cc=30094@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).