module/language/elisp/runtime.scm

   1 ;;; Guile Emacs Lisp
   2
   3 ;;; Copyright (C) 2009, 2010 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    (let* ((var (module-variable (resolve-module function-slot-module)
 112                                 symbol)))
 113      (and (variable-bound? var)
 114           (if (fluid? (variable-ref var))
 115               (fluid-bound? (variable-ref var))
 116               #t)))))
 117
 118 (define (makunbound! symbol)
 119   (if (module-bound? (resolve-interface value-slot-module) symbol)
 120       (let ((var (module-variable (resolve-module value-slot-module)
 121                                   symbol)))
 122         (if (and (variable-bound? var) (fluid? (variable-ref var)))
 123             (fluid-unset! (variable-ref var))
 124             (variable-unset! var))))
 125     symbol)
 126
 127 (define (fmakunbound! symbol)
 128   (if (module-bound? (resolve-interface function-slot-module) symbol)
 129       (let ((var (module-variable
 130                   (resolve-module function-slot-module)
 131                   symbol)))
 132         (if (and (variable-bound? var) (fluid? (variable-ref var)))
 133             (fluid-unset! (variable-ref var))
 134             (variable-unset! var))))
 135   symbol)
 136
 137 ;;; Define a predefined macro for use in the function-slot module.
 138
 139 (define (make-id template-id . data)
 140   (let ((append-symbols
 141          (lambda (symbols)
 142            (string->symbol
 143             (apply string-append (map symbol->string symbols))))))
 144     (datum->syntax template-id
 145                    (append-symbols
 146                     (map (lambda (datum)
 147                            ((if (identifier? datum)
 148                                 syntax->datum
 149                                 identity)
 150                             datum))
 151                          data)))))
 152
 153 (define-syntax defspecial
 154   (lambda (x)
 155     (syntax-case x ()
 156       ((_ name args body ...)
 157        (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
 158          #'(begin
 159              (define scheme-name (make-fluid))
 160              (fluid-set! scheme-name
 161                          (cons 'special-operator
 162                                (lambda args body ...)))))))))