From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Matt Wette Newsgroups: gmane.lisp.guile.bugs Subject: bug#30094: patch for adding external lang support Date: Tue, 4 Sep 2018 06:43:39 -0700 Message-ID: <8cd59533-5fdb-7ae0-f37b-bc9117044161@gmail.com> References: <876086wvan.fsf@elephly.net> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=utf-8; format=flowed Content-Transfer-Encoding: 7bit X-Trace: blaine.gmane.org 1536068526 10905 195.159.176.226 (4 Sep 2018 13:42:06 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Tue, 4 Sep 2018 13:42:06 +0000 (UTC) User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.9.1 To: 30094@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Tue Sep 04 15:42:01 2018 Return-path: Envelope-to: guile-bugs@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fxBaj-0002fx-Jv for guile-bugs@m.gmane.org; Tue, 04 Sep 2018 15:42:01 +0200 Original-Received: from localhost ([::1]:51048 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fxBcp-0007FG-SC for guile-bugs@m.gmane.org; Tue, 04 Sep 2018 09:44:11 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:41494) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fxBcl-0007BL-8z for bug-guile@gnu.org; Tue, 04 Sep 2018 09:44:08 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fxBch-0003UI-7C for bug-guile@gnu.org; Tue, 04 Sep 2018 09:44:07 -0400 Original-Received: from debbugs.gnu.org ([208.118.235.43]:40172) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fxBcg-0003U8-UY for bug-guile@gnu.org; Tue, 04 Sep 2018 09:44:03 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fxBcf-0007DZ-Uq for bug-guile@gnu.org; Tue, 04 Sep 2018 09:44:02 -0400 X-Loop: help-debbugs@gnu.org In-Reply-To: <876086wvan.fsf@elephly.net> Resent-From: Matt Wette Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Tue, 04 Sep 2018 13:44:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 30094 X-GNU-PR-Package: guile X-GNU-PR-Keywords: Original-Received: via spool by 30094-submit@debbugs.gnu.org id=B30094.153606862927720 (code B ref 30094); Tue, 04 Sep 2018 13:44:01 +0000 Original-Received: (at 30094) by debbugs.gnu.org; 4 Sep 2018 13:43:49 +0000 Original-Received: from localhost ([127.0.0.1]:45190 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fxBcT-0007D2-1n for submit@debbugs.gnu.org; Tue, 04 Sep 2018 09:43:49 -0400 Original-Received: from mail-pf1-f169.google.com ([209.85.210.169]:41561) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1fxBcQ-0007Ck-Tk for 30094@debbugs.gnu.org; Tue, 04 Sep 2018 09:43:47 -0400 Original-Received: by mail-pf1-f169.google.com with SMTP id h79-v6so1719220pfk.8 for <30094@debbugs.gnu.org>; Tue, 04 Sep 2018 06:43:46 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=to:from:subject:message-id:date:user-agent:mime-version :content-transfer-encoding:content-language; bh=RSrWGS77gNAke35vwY1Osh7/JftPc/FDiXAzJu83OEI=; b=DMs2JRKW1U3434kYHFZb9SH9b7XZiz7cBCiv1IIgYnaTJkMgl3JKOAJYtpuvVRBCzX wkVAjZZxLWghiIPt0sES05mJ9OK3aO4EEPnP1REiCRXPD7EOmbLnyzX64vDa8myV4RVp WnXFUZCGpIMYUDNd7baw3YGXdylusgjNJWmR4vw9tTgUFrJkdBAvZUtvvUuH+Xwezo0s 0GLpNZC30xgUCjmyJswuUG9tTL+nWCwAJQPYnJim75OTos2Iz6+bsz8RM8vKgqdWmytQ W+k0ANhaztPPkm3go1ZBjBZOgzq8Ov+956pYdyYiqyg9ZvtKXbdpOoyCaXPN+vv6QVQg NO1Q== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:to:from:subject:message-id:date:user-agent :mime-version:content-transfer-encoding:content-language; bh=RSrWGS77gNAke35vwY1Osh7/JftPc/FDiXAzJu83OEI=; b=pfjwh9sdbGlKcPTku9UU1g1qhZQWssapgmej5EibBMWyM2Ela61GKydbOQ3Jo91ArE DqtMHv07ft/DGhjVGTEyJUQFGeuslJyJBTQrICUk9OsuKDjjrYUVOfPJh8ynDqRA7INS U8FfY9sFD+BsS8Lh2bU1qv60IITaL1yVhq6Kks4gK8bQHItRuOfVaRsgKjFrU3LRaFWc jWRpa2Zqd854Pz/zhgDRUWcO9Rg9n9VuhT3eFQhNcyJXWAa/+Bn2F8xH6YNDMYJzIrek 6bx1MYI0ZD9NHCffQRQ197uG9YIhbOctzxWSa5LVHvGeq1dUVKRXKmbtXwlg9ZwZ7g2O DffQ== X-Gm-Message-State: APzg51Dh6Uf37pMAX57R0WP0lWPIHd872Aga9PFNeizslr0tl6QFulST AnE2z24Y+ZBuMcMbxbLZk8MqLBMq X-Google-Smtp-Source: ANB0VdaWZgj6AdMpt1TeKkZ7LCsMKV0cNp522bQTgDwzgkQCRe7Xu2BVxSBezqEFlTk3Xre66fBf/w== X-Received: by 2002:a63:5fc8:: with SMTP id t191-v6mr31422456pgb.183.1536068620484; Tue, 04 Sep 2018 06:43:40 -0700 (PDT) Original-Received: from [192.168.2.183] (216-165-229-229.championbroadband.com. [216.165.229.229]) by smtp.gmail.com with ESMTPSA id l84-v6sm51823989pfg.3.2018.09.04.06.43.39 for <30094@debbugs.gnu.org> (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Tue, 04 Sep 2018 06:43:40 -0700 (PDT) Content-Language: en-US X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane.org@gnu.org Original-Sender: "bug-guile" Xref: news.gmane.org gmane.lisp.guile.bugs:9146 Archived-At: 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)