1;;; Multi-language support 2 3;; Copyright (C) 2001,2005,2008-2011,2013,2020 Free Software Foundation, Inc. 4 5;; This library is free software; you can redistribute it and/or 6;; modify it under the terms of the GNU Lesser General Public 7;; License as published by the Free Software Foundation; either 8;; version 3 of the License, or (at your option) any later version. 9;; 10;; This library is distributed in the hope that it will be useful, 11;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13;; Lesser General Public License for more details. 14;; 15;; You should have received a copy of the GNU Lesser General Public 16;; License along with this library; if not, write to the Free Software 17;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 18;; 02110-1301 USA 19 20;;; Code: 21 22(define-module (system base language) 23 #:use-module (system base syntax) 24 #:export (define-language language? lookup-language make-language 25 language-name language-title language-reader 26 language-printer language-parser 27 language-compilers language-decompilers language-evaluator 28 language-joiner language-for-humans? 29 language-make-default-environment 30 language-lowerer language-analyzer 31 language-compiler-chooser 32 33 lookup-compilation-order lookup-decompilation-order 34 default-environment) 35 36 #:re-export (current-language)) 37 38 39;;; 40;;; Language class 41;;; 42 43(define-record/keywords <language> 44 name 45 title 46 reader 47 printer 48 (parser #f) 49 (compilers '()) 50 (decompilers '()) 51 (evaluator #f) 52 (joiner #f) 53 (for-humans? #t) 54 (make-default-environment make-fresh-user-module) 55 (lowerer #f) 56 (analyzer #f) 57 (compiler-chooser #f)) 58 59(define-syntax-rule (define-language name . spec) 60 (define name (make-language #:name 'name . spec))) 61 62(define (lookup-language name) 63 (let ((m (resolve-module `(language ,name spec)))) 64 (if (module-bound? m name) 65 (module-ref m name) 66 (error "no such language" name)))) 67 68(begin-deprecated 69 (define-public (invalidate-compilation-cache!) 70 (issue-deprecation-warning 71 "invalidate-compilation-cache is deprecated; recompile your modules") 72 (values))) 73 74(define (compute-translation-order from to language-translators) 75 (cond 76 ((not (language? to)) 77 (compute-translation-order from (lookup-language to) language-translators)) 78 (else 79 (let lp ((from from) (seen '())) 80 (cond 81 ((not (language? from)) 82 (lp (lookup-language from) seen)) 83 ((eq? from to) (reverse! seen)) 84 ((memq from seen) #f) 85 (else (or-map (lambda (pair) 86 (lp (car pair) (acons from (cdr pair) seen))) 87 (language-translators from)))))))) 88 89(define (lookup-compilation-order from to) 90 (compute-translation-order from to language-compilers)) 91 92(define (lookup-decompilation-order from to) 93 (and=> (compute-translation-order to from language-decompilers) 94 reverse!)) 95 96(define (default-environment lang) 97 "Return the default compilation environment for source language LANG." 98 ((language-make-default-environment 99 (if (language? lang) lang (lookup-language lang))))) 100 101 102 103;;; 104;;; Current language 105;;; 106 107;; Deprecated; use current-language instead. 108(begin-deprecated 109 (define-public *current-language* (parameter-fluid current-language))) 110