1 ;;; Multi-language support
3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
5 ;; This program is free software; you can redistribute it and/or modify
6 ;; it under the terms of the GNU General Public License as published by
7 ;; the Free Software Foundation; either version 2, or (at your option)
10 ;; This program 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
13 ;; GNU General Public License for more details.
15 ;; You should have received a copy of the GNU General Public License
16 ;; along with this program; see the file COPYING. If not, write to
17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;; Boston, MA 02111-1307, USA.
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-version language-reader
26 language-printer language-parser language-read-file
27 language-compilers language-decompilers language-evaluator
29 lookup-compilation-order lookup-decompilation-order
30 invalidate-compilation-cache!))
37 (define-record/keywords <language>
49 (define-macro (define-language name . spec)
51 (invalidate-compilation-cache!)
52 (define ,name (make-language #:name ',name ,@spec))))
54 (define (lookup-language name)
55 (let ((m (resolve-module `(language ,name spec))))
56 (if (module-bound? m name)
58 (error "no such language" name))))
60 (define *compilation-cache* '())
61 (define *decompilation-cache* '())
63 (define (invalidate-compilation-cache!)
64 (set! *decompilation-cache* '())
65 (set! *compilation-cache* '()))
67 (define (compute-translation-order from to language-translators)
70 (compute-translation-order from (lookup-language to) language-translators))
72 (let lp ((from from) (seen '()))
74 ((not (language? from))
75 (lp (lookup-language from) seen))
76 ((eq? from to) (reverse! seen))
78 (else (or-map (lambda (pair)
79 (lp (car pair) (acons from (cdr pair) seen)))
80 (language-translators from))))))))
82 (define (lookup-compilation-order from to)
83 (let ((key (cons from to)))
84 (or (assoc-ref *compilation-cache* key)
85 (let ((order (compute-translation-order from to language-compilers)))
86 (set! *compilation-cache*
87 (acons key order *compilation-cache*))
90 (define (lookup-decompilation-order from to)
91 (let ((key (cons from to)))
92 (or (assoc-ref *decompilation-cache* key)
95 (compute-translation-order to from language-decompilers)
97 (set! *decompilation-cache* (acons key order *decompilation-cache*))