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