module/language/elisp/runtime.scm

   1 ;;; Guile Emacs Lisp
   2
   3 ;;; Copyright (C) 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 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language elisp runtime)
  22   #:export (nil-value
  23             t-value
  24             value-slot-module
  25             function-slot-module
  26             elisp-bool
  27             ensure-fluid!
  28             symbol-fluid
  29             set-symbol-fluid!
  30             symbol-value
  31             set-symbol-value!
  32             symbol-function
  33             set-symbol-function!
  34             symbol-bound?
  35             symbol-fbound?
  36             makunbound!
  37             fmakunbound!)
  38   #:export-syntax (defspecial prim))
  39
  40 ;;; This module provides runtime support for the Elisp front-end.
  41
  42 ;;; Values for t and nil. (FIXME remove this abstraction)
  43
  44 (define nil-value #nil)
  45
  46 (define t-value #t)
  47
  48 ;;; Modules for the binding slots.
  49 ;;; Note: Naming those value-slot and/or function-slot clashes with the
  50 ;;; submodules of these names!
  51
  52 (define value-slot-module '(language elisp runtime value-slot))
  53
  54 (define function-slot-module '(language elisp runtime function-slot))
  55
  56 ;;; Routines for access to elisp dynamically bound symbols.  This is
  57 ;;; used for runtime access using functions like symbol-value or set,
  58 ;;; where the symbol accessed might not be known at compile-time.  These
  59 ;;; always access the dynamic binding and can not be used for the
  60 ;;; lexical!
  61
  62 (define (ensure-fluid! module sym)
  63   (let ((intf (resolve-interface module))
  64         (resolved (resolve-module module)))
  65     (if (not (module-defined? intf sym))
  66         (let ((fluid (make-unbound-fluid)))
  67           (module-define! resolved sym fluid)
  68           (module-export! resolved `(,sym))))))
  69
  70 (define (symbol-fluid symbol)
  71   (let ((module (resolve-module value-slot-module)))
  72     (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation
  73     (module-ref module symbol)))
  74
  75 (define (set-symbol-fluid! symbol fluid)
  76   (let ((module (resolve-module value-slot-module)))
  77     (module-define! module symbol fluid)
  78     (module-export! module (list symbol)))
  79   fluid)
  80
  81 (define (symbol-value symbol)
  82   (fluid-ref (symbol-fluid symbol)))
  83
  84 (define (set-symbol-value! symbol value)
  85   (fluid-set! (symbol-fluid symbol) value)
  86   value)
  87
  88 (define (symbol-function symbol)
  89   (let ((module (resolve-module function-slot-module)))
  90     (module-ref module symbol)))
  91
  92 (define (set-symbol-function! symbol value)
  93   (let ((module (resolve-module function-slot-module)))
  94    (module-define! module symbol value)
  95    (module-export! module (list symbol)))
  96   value)
  97
  98 (define (symbol-bound? symbol)
  99   (and
 100    (module-bound? (resolve-interface value-slot-module) symbol)
 101    (let ((var (module-variable (resolve-module value-slot-module)
 102                                symbol)))
 103      (and (variable-bound? var)
 104           (if (fluid? (variable-ref var))
 105               (fluid-bound? (variable-ref var))
 106               #t)))))
 107
 108 (define (symbol-fbound? symbol)
 109   (and
 110    (module-bound? (resolve-interface function-slot-module) symbol)
 111    (variable-bound?
 112     (module-variable (resolve-module function-slot-module)
 113                      symbol))))
 114
 115 (define (makunbound! symbol)
 116   (if (module-bound? (resolve-interface value-slot-module) symbol)
 117       (let ((var (module-variable (resolve-module value-slot-module)
 118                                   symbol)))
 119         (if (and (variable-bound? var) (fluid? (variable-ref var)))
 120             (fluid-unset! (variable-ref var))
 121             (variable-unset! var))))
 122     symbol)
 123
 124 (define (fmakunbound! symbol)
 125   (if (module-bound? (resolve-interface function-slot-module) symbol)
 126       (variable-unset! (module-variable
 127                         (resolve-module function-slot-module)
 128                         symbol)))
 129   symbol)
 130
 131 ;;; Define a predefined macro for use in the function-slot module.
 132
 133 (define (make-id template-id . data)
 134   (let ((append-symbols
 135          (lambda (symbols)
 136            (string->symbol
 137             (apply string-append (map symbol->string symbols))))))
 138     (datum->syntax template-id
 139                    (append-symbols
 140                     (map (lambda (datum)
 141                            ((if (identifier? datum)
 142                                 syntax->datum
 143                                 identity)
 144                             datum))
 145                          data)))))
 146
 147 (define-syntax defspecial
 148   (lambda (x)
 149     (syntax-case x ()
 150       ((_ name args body ...)
 151        (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
 152          #'(define scheme-name
 153              (cons 'special-operator (lambda args body ...))))))))