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