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