module/system/base/language.scm

   1 ;;; Multi-language support
   2
   3 ;; Copyright (C) 2001, 2009, 2010, 2011 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-make-default-environment
  29
  30             lookup-compilation-order lookup-decompilation-order
  31             invalidate-compilation-cache! default-environment
  32
  33             *current-language* current-language))
  34
  35 \f
  36 ;;;
  37 ;;; Language class
  38 ;;;
  39
  40 (define-record/keywords <language>
  41   name
  42   title
  43   reader
  44   printer
  45   (parser #f)
  46   (compilers '())
  47   (decompilers '())
  48   (evaluator #f)
  49   (joiner #f)
  50   (make-default-environment make-fresh-user-module))
  51
  52 (define-macro (define-language name . spec)
  53   `(begin
  54      (invalidate-compilation-cache!)
  55      (define ,name (make-language #:name ',name ,@spec))))
  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)
  61         (error "no such language" name))))
  62
  63 (define *compilation-cache* '())
  64 (define *decompilation-cache* '())
  65
  66 (define (invalidate-compilation-cache!)
  67   (set! *decompilation-cache* '())
  68   (set! *compilation-cache* '()))
  69
  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))))))))
  84
  85 (define (lookup-compilation-order from to)
  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)
  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*))
 101           order))))
 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)))))
 107
 108 \f
 109
 110 ;;;
 111 ;;; Current language
 112 ;;;
 113
 114 (define *current-language* (make-fluid))
 115
 116 (define (current-language)
 117   (or (fluid-ref *current-language*) 'scheme))