Commit | Line | Data |
---|---|---|
17e90c5e KN |
1 | ;;; Multi-language support |
2 | ||
c245d16a | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011 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 |
246ea9e1 | 25 | language-name language-title 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 |
4288533b AW |
31 | invalidate-compilation-cache! default-environment |
32 | ||
33 | *current-language* current-language)) | |
17e90c5e KN |
34 | |
35 | \f | |
36 | ;;; | |
37 | ;;; Language class | |
38 | ;;; | |
39 | ||
d9d671f7 | 40 | (define-record/keywords <language> |
b0b180d5 AW |
41 | name |
42 | title | |
b0b180d5 AW |
43 | reader |
44 | printer | |
45 | (parser #f) | |
b0b180d5 | 46 | (compilers '()) |
5d6fb8bb | 47 | (decompilers '()) |
b8076ec6 | 48 | (evaluator #f) |
f95f82f8 AW |
49 | (joiner #f) |
50 | (make-default-environment make-fresh-user-module)) | |
17e90c5e KN |
51 | |
52 | (define-macro (define-language name . spec) | |
b0b180d5 AW |
53 | `(begin |
54 | (invalidate-compilation-cache!) | |
55 | (define ,name (make-language #:name ',name ,@spec)))) | |
17e90c5e KN |
56 | |
57 | (define (lookup-language name) | |
58 | (let ((m (resolve-module `(language ,name spec)))) | |
59 | (if (module-bound? m name) | |
60 | (module-ref m name) | |
884d46de | 61 | (error "no such language" name)))) |
b0b180d5 AW |
62 | |
63 | (define *compilation-cache* '()) | |
5d6fb8bb | 64 | (define *decompilation-cache* '()) |
b0b180d5 AW |
65 | |
66 | (define (invalidate-compilation-cache!) | |
5d6fb8bb | 67 | (set! *decompilation-cache* '()) |
b0b180d5 AW |
68 | (set! *compilation-cache* '())) |
69 | ||
5d6fb8bb AW |
70 | (define (compute-translation-order from to language-translators) |
71 | (cond | |
72 | ((not (language? to)) | |
73 | (compute-translation-order from (lookup-language to) language-translators)) | |
74 | (else | |
75 | (let lp ((from from) (seen '())) | |
76 | (cond | |
77 | ((not (language? from)) | |
78 | (lp (lookup-language from) seen)) | |
79 | ((eq? from to) (reverse! seen)) | |
80 | ((memq from seen) #f) | |
81 | (else (or-map (lambda (pair) | |
82 | (lp (car pair) (acons from (cdr pair) seen))) | |
83 | (language-translators from)))))))) | |
b0b180d5 AW |
84 | |
85 | (define (lookup-compilation-order from to) | |
5d6fb8bb AW |
86 | (let ((key (cons from to))) |
87 | (or (assoc-ref *compilation-cache* key) | |
88 | (let ((order (compute-translation-order from to language-compilers))) | |
89 | (set! *compilation-cache* | |
90 | (acons key order *compilation-cache*)) | |
91 | order)))) | |
92 | ||
93 | (define (lookup-decompilation-order from to) | |
94 | (let ((key (cons from to))) | |
95 | (or (assoc-ref *decompilation-cache* key) | |
7b107cce AW |
96 | ;; trickery! |
97 | (let ((order (and=> | |
98 | (compute-translation-order to from language-decompilers) | |
99 | reverse!))) | |
100 | (set! *decompilation-cache* (acons key order *decompilation-cache*)) | |
5d6fb8bb | 101 | order)))) |
f95f82f8 AW |
102 | |
103 | (define (default-environment lang) | |
104 | "Return the default compilation environment for source language LANG." | |
105 | ((language-make-default-environment | |
106 | (if (language? lang) lang (lookup-language lang))))) | |
4288533b AW |
107 | |
108 | \f | |
109 | ||
110 | ;;; | |
111 | ;;; Current language | |
112 | ;;; | |
113 | ||
114 | (define *current-language* (make-fluid)) | |
4288533b AW |
115 | |
116 | (define (current-language) | |
c245d16a | 117 | (or (fluid-ref *current-language*) 'scheme)) |