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