Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Multi-language support |
2 | ||
5c27902e | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
17e90c5e | 4 | |
5c27902e AW |
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. | |
17e90c5e | 9 | ;; |
5c27902e | 10 | ;; This library is distributed in the hope that it will be useful, |
17e90c5e | 11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
5c27902e AW |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;; Lesser General Public License for more details. | |
17e90c5e | 14 | ;; |
5c27902e AW |
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 | |
17e90c5e KN |
19 | |
20 | ;;; Code: | |
21 | ||
22 | (define-module (system base language) | |
b0b180d5 | 23 | #:use-module (system base syntax) |
7b107cce | 24 | #:export (define-language language? lookup-language make-language |
b0b180d5 | 25 | language-name language-title language-version language-reader |
81fd3152 | 26 | language-printer language-parser |
5d6fb8bb | 27 | language-compilers language-decompilers language-evaluator |
f95f82f8 | 28 | language-joiner language-make-default-environment |
b0b180d5 | 29 | |
5d6fb8bb | 30 | lookup-compilation-order lookup-decompilation-order |
f95f82f8 | 31 | invalidate-compilation-cache! default-environment)) |
17e90c5e KN |
32 | |
33 | \f | |
34 | ;;; | |
35 | ;;; Language class | |
36 | ;;; | |
37 | ||
d9d671f7 | 38 | (define-record/keywords <language> |
b0b180d5 AW |
39 | name |
40 | title | |
41 | version | |
42 | reader | |
43 | printer | |
44 | (parser #f) | |
b0b180d5 | 45 | (compilers '()) |
5d6fb8bb | 46 | (decompilers '()) |
b8076ec6 | 47 | (evaluator #f) |
f95f82f8 AW |
48 | (joiner #f) |
49 | (make-default-environment make-fresh-user-module)) | |
17e90c5e KN |
50 | |
51 | (define-macro (define-language name . spec) | |
b0b180d5 AW |
52 | `(begin |
53 | (invalidate-compilation-cache!) | |
54 | (define ,name (make-language #:name ',name ,@spec)))) | |
17e90c5e KN |
55 | |
56 | (define (lookup-language name) | |
57 | (let ((m (resolve-module `(language ,name spec)))) | |
58 | (if (module-bound? m name) | |
59 | (module-ref m name) | |
884d46de | 60 | (error "no such language" name)))) |
b0b180d5 AW |
61 | |
62 | (define *compilation-cache* '()) | |
5d6fb8bb | 63 | (define *decompilation-cache* '()) |
b0b180d5 AW |
64 | |
65 | (define (invalidate-compilation-cache!) | |
5d6fb8bb | 66 | (set! *decompilation-cache* '()) |
b0b180d5 AW |
67 | (set! *compilation-cache* '())) |
68 | ||
5d6fb8bb AW |
69 | (define (compute-translation-order from to language-translators) |
70 | (cond | |
71 | ((not (language? to)) | |
72 | (compute-translation-order from (lookup-language to) language-translators)) | |
73 | (else | |
74 | (let lp ((from from) (seen '())) | |
75 | (cond | |
76 | ((not (language? from)) | |
77 | (lp (lookup-language from) seen)) | |
78 | ((eq? from to) (reverse! seen)) | |
79 | ((memq from seen) #f) | |
80 | (else (or-map (lambda (pair) | |
81 | (lp (car pair) (acons from (cdr pair) seen))) | |
82 | (language-translators from)))))))) | |
b0b180d5 AW |
83 | |
84 | (define (lookup-compilation-order from to) | |
5d6fb8bb AW |
85 | (let ((key (cons from to))) |
86 | (or (assoc-ref *compilation-cache* key) | |
87 | (let ((order (compute-translation-order from to language-compilers))) | |
88 | (set! *compilation-cache* | |
89 | (acons key order *compilation-cache*)) | |
90 | order)))) | |
91 | ||
92 | (define (lookup-decompilation-order from to) | |
93 | (let ((key (cons from to))) | |
94 | (or (assoc-ref *decompilation-cache* key) | |
7b107cce AW |
95 | ;; trickery! |
96 | (let ((order (and=> | |
97 | (compute-translation-order to from language-decompilers) | |
98 | reverse!))) | |
99 | (set! *decompilation-cache* (acons key order *decompilation-cache*)) | |
5d6fb8bb | 100 | order)))) |
f95f82f8 AW |
101 | |
102 | (define (default-environment lang) | |
103 | "Return the default compilation environment for source language LANG." | |
104 | ((language-make-default-environment | |
105 | (if (language? lang) lang (lookup-language lang))))) |