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   #:use-module (ice-9 format)
  23   #:use-module ((system base compile)
  24                 #:select (compile))
  25   #:export (nil-value
  26             t-value
  27             value-slot-module
  28             function-slot-module
  29             elisp-bool
  30             ensure-dynamic!
  31             symbol-name
  32             symbol-value
  33             set-symbol-value!
  34             symbol-function
  35             set-symbol-function!
  36             symbol-plist
  37             set-symbol-plist!
  38             symbol-bound?
  39             symbol-fbound?
  40             bind-symbol
  41             makunbound!
  42             fmakunbound!
  43             symbol-desc
  44             proclaim-special!
  45             special?
  46             emacs!
  47             unbound
  48             lexical-binding?
  49             set-lexical-binding-mode
  50             log!
  51             eval-elisp
  52             local-eval-elisp
  53             make-lisp-string
  54             lisp-string?)
  55   #:export-syntax (defspecial prim))
  56
  57 ;;; This module provides runtime support for the Elisp front-end.
  58
  59 ;;; Values for t and nil. (FIXME remove this abstraction)
  60
  61 (define nil-value #nil)
  62
  63 (define t-value #t)
  64
  65 (define make-lisp-string identity)
  66 (define lisp-string? string?)
  67
  68 ;;; Modules for the binding slots.
  69 ;;; Note: Naming those value-slot and/or function-slot clashes with the
  70 ;;; submodules of these names!
  71
  72 (define value-slot-module (resolve-module '(elisp-symbols)))
  73
  74 (define function-slot-module (resolve-module '(elisp-functions)))
  75
  76 (define plist-slot-module (resolve-module '(elisp-plists)))
  77
  78 (define nil_ 'nil)
  79 (define t_ 't)
  80
  81 ;;; Routines for access to elisp dynamically bound symbols.  This is
  82 ;;; used for runtime access using functions like symbol-value or set,
  83 ;;; where the symbol accessed might not be known at compile-time.  These
  84 ;;; always access the dynamic binding and can not be used for the
  85 ;;; lexical!
  86
  87 (define lexical-binding #t)
  88
  89 (define (lexical-binding?)
  90   lexical-binding)
  91
  92 (define (set-lexical-binding-mode x)
  93   (set! lexical-binding x))
  94
  95 (define unbound (make-symbol "unbound"))
  96
  97 (define dynamic? vector?)
  98 (define (make-dynamic)
  99   (vector #f 4 0 0 unbound))
 100 (define (dynamic-ref x)
 101   (vector-ref x 4))
 102 (define (dynamic-set! x v)
 103   (vector-set! x 4 v))
 104 (define (dynamic-unset! x)
 105   (vector-set! x 4 unbound))
 106 (define (dynamic-bound? x)
 107   (not (eq? (vector-ref x 4) unbound)))
 108 (define (dynamic-bind x v thunk)
 109   (let ((old (vector-ref x 4)))
 110    (dynamic-wind
 111      (lambda () (vector-set! x 4 v))
 112      thunk
 113      (lambda () (vector-set! x 4 old)))))
 114
 115 (define-inlinable (ensure-present! module sym thunk)
 116   (or (module-local-variable module sym)
 117       (let ((variable (make-variable (thunk))))
 118         (module-add! module sym variable)
 119         variable)))
 120
 121 (define-inlinable (ensure-desc! module sym)
 122   (ensure-present! module
 123                    sym
 124                    (lambda ()
 125                      (let ((x (make-dynamic)))
 126                        (vector-set! x 0 sym)
 127                        x))))
 128
 129 (define-inlinable (schemify symbol)
 130   (case symbol
 131     ((#nil) nil_)
 132     ((#t) t_)
 133     (else symbol)))
 134
 135 (define (symbol-name symbol)
 136   (symbol->string (schemify symbol)))
 137
 138 (define (symbol-desc symbol)
 139   (let ((symbol (schemify symbol)))
 140     (let ((module value-slot-module))
 141       (variable-ref (ensure-desc! module symbol)))))
 142
 143 (define (ensure-dynamic! sym)
 144   (vector-set! (symbol-desc sym) 3 1))
 145
 146 (define (symbol-dynamic symbol)
 147   (ensure-dynamic! symbol)
 148   (symbol-desc symbol))
 149
 150 (define (symbol-value symbol)
 151   (dynamic-ref (symbol-desc symbol)))
 152
 153 (define (set-symbol-value! symbol value)
 154   (dynamic-set! (symbol-desc symbol) value)
 155   value)
 156
 157 (define (symbol-function symbol)
 158   (set! symbol (schemify symbol))
 159   (ensure-present! function-slot-module symbol (lambda () #nil))
 160   (let ((module function-slot-module))
 161     (module-ref module symbol)))
 162
 163 (define (set-symbol-function! symbol value)
 164   (set! symbol (schemify symbol))
 165   (ensure-present! function-slot-module symbol (lambda () #nil))
 166   (let ((module function-slot-module))
 167    (module-define! module symbol value)
 168    (module-export! module (list symbol)))
 169   value)
 170
 171 (define (symbol-plist symbol)
 172   (set! symbol (schemify symbol))
 173   (ensure-present! plist-slot-module symbol (lambda () #nil))
 174   (let ((module plist-slot-module))
 175     (module-ref module symbol)))
 176
 177 (define (set-symbol-plist! symbol value)
 178   (set! symbol (schemify symbol))
 179   (ensure-present! plist-slot-module symbol (lambda () #nil))
 180   (let ((module plist-slot-module))
 181    (module-define! module symbol value)
 182    (module-export! module (list symbol)))
 183   value)
 184
 185 (define (symbol-bound? symbol)
 186   (set! symbol (schemify symbol))
 187   (and
 188    (module-bound? value-slot-module symbol)
 189    (let ((var (module-variable value-slot-module
 190                                symbol)))
 191      (and (variable-bound? var)
 192           (if (dynamic? (variable-ref var))
 193               (dynamic-bound? (variable-ref var))
 194               #t)))))
 195
 196 (define (symbol-fbound? symbol)
 197   (set! symbol (schemify symbol))
 198   (and
 199    (module-bound? function-slot-module symbol)
 200    (variable-bound?
 201     (module-variable function-slot-module symbol))
 202    (variable-ref (module-variable function-slot-module symbol))))
 203
 204 (define (bind-symbol symbol value thunk)
 205   (dynamic-bind (symbol-desc symbol) value thunk))
 206
 207 (define (makunbound! symbol)
 208   (if (module-bound? value-slot-module symbol)
 209       (let ((var (module-variable value-slot-module
 210                                   symbol)))
 211         (if (and (variable-bound? var) (dynamic? (variable-ref var)))
 212             (dynamic-unset! (variable-ref var))
 213             (variable-unset! var))))
 214     symbol)
 215
 216 (define (fmakunbound! symbol)
 217   (if (module-bound? function-slot-module symbol)
 218       (variable-unset! (module-variable function-slot-module symbol)))
 219   symbol)
 220
 221 (define (special? sym)
 222   (eqv? (vector-ref (symbol-desc sym) 3) 1))
 223
 224 (define (proclaim-special! sym)
 225   (vector-set! (symbol-desc sym) 3 1)
 226   #nil)
 227
 228 (define (emacs! ref set boundp bind)
 229   (set! symbol-value ref)
 230   (set! set-symbol-value! set)
 231   (set! symbol-bound? boundp)
 232   (set! bind-symbol bind)
 233   (set! lexical-binding? (lambda () (symbol-value 'lexical-binding)))
 234   (set! set-lexical-binding-mode (lambda (x) (set-symbol-value! 'lexical-binding x))))
 235
 236 (define (eval-elisp form)
 237   (compile form #:from 'elisp #:to 'value))
 238
 239 (set-symbol-value! nil_ #nil)
 240 (set-symbol-value! t_ #t)
 241
 242 (define (make-string s) s)
 243
 244 ;;; Define a predefined macro for use in the function-slot module.
 245
 246 (define (make-id template-id . data)
 247   (let ((append-symbols
 248          (lambda (symbols)
 249            (string->symbol
 250             (apply string-append (map symbol->string symbols))))))
 251     (datum->syntax template-id
 252                    (append-symbols
 253                     (map (lambda (datum)
 254                            ((if (identifier? datum)
 255                                 syntax->datum
 256                                 identity)
 257                             datum))
 258                          data)))))
 259
 260 (define-syntax defspecial
 261   (lambda (x)
 262     (syntax-case x ()
 263       ((_ name args body ...)
 264        (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
 265          #'(define scheme-name
 266              (cons 'special-operator (lambda args body ...))))))))