module/language/elisp/bindings.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 bindings)
  22   #:export (make-bindings
  23             mark-global-needed!
  24             map-globals-needed
  25             with-lexical-bindings
  26             with-dynamic-bindings
  27             get-lexical-binding))
  28
  29 ;;; This module defines routines to handle analysis of symbol bindings
  30 ;;; used during elisp compilation.  This data allows to collect the
  31 ;;; symbols, for which globals need to be created, or mark certain
  32 ;;; symbols as lexically bound.
  33 ;;;
  34 ;;; Needed globals are stored in an association-list that stores a list
  35 ;;; of symbols for each module they are needed in.
  36 ;;;
  37 ;;; The lexical bindings of symbols are stored in a hash-table that
  38 ;;; associates symbols to fluids; those fluids are used in the
  39 ;;; with-lexical-binding and with-dynamic-binding routines to associate
  40 ;;; symbols to different bindings over a dynamic extent.
  41
  42 ;;; Record type used to hold the data necessary.
  43
  44 (define bindings-type
  45   (make-record-type 'bindings '(needed-globals lexical-bindings)))
  46
  47 ;;; Construct an 'empty' instance of the bindings data structure to be
  48 ;;; used at the start of a fresh compilation.
  49
  50 (define (make-bindings)
  51   ((record-constructor bindings-type) '() (make-hash-table)))
  52
  53 ;;; Mark that a given symbol is needed as global in the specified
  54 ;;; slot-module.
  55
  56 (define (mark-global-needed! bindings sym module)
  57   (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
  58                       bindings))
  59          (old-in-module (or (assoc-ref old-needed module) '()))
  60          (new-in-module (if (memq sym old-in-module)
  61                             old-in-module
  62                             (cons sym old-in-module)))
  63          (new-needed (assoc-set! old-needed module new-in-module)))
  64     ((record-modifier bindings-type 'needed-globals)
  65      bindings
  66      new-needed)))
  67
  68 ;;; Cycle through all globals needed in order to generate the code for
  69 ;;; their creation or some other analysis.
  70
  71 (define (map-globals-needed bindings proc)
  72   (let ((needed ((record-accessor bindings-type 'needed-globals)
  73                  bindings)))
  74     (let iterate-modules ((mod-tail needed)
  75                           (mod-result '()))
  76       (if (null? mod-tail)
  77           mod-result
  78           (iterate-modules
  79            (cdr mod-tail)
  80            (let* ((aentry (car mod-tail))
  81                   (module (car aentry))
  82                   (symbols (cdr aentry)))
  83              (let iterate-symbols ((sym-tail symbols)
  84                                    (sym-result mod-result))
  85                (if (null? sym-tail)
  86                    sym-result
  87                    (iterate-symbols (cdr sym-tail)
  88                                     (cons (proc module (car sym-tail))
  89                                           sym-result))))))))))
  90
  91 ;;; Get the current lexical binding (gensym it should refer to in the
  92 ;;; current scope) for a symbol or #f if it is dynamically bound.
  93
  94 (define (get-lexical-binding bindings sym)
  95   (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
  96                bindings))
  97          (slot (hash-ref lex sym #f)))
  98     (if slot
  99         (fluid-ref slot)
 100         #f)))
 101
 102 ;;; Establish a binding or mark a symbol as dynamically bound for the
 103 ;;; extent of calling proc.
 104
 105 (define (with-symbol-bindings bindings syms targets proc)
 106   (if (or (not (list? syms))
 107           (not (and-map symbol? syms)))
 108       (error "can't bind non-symbols" syms))
 109   (let ((lex ((record-accessor bindings-type 'lexical-bindings)
 110               bindings)))
 111     (for-each (lambda (sym)
 112                 (if (not (hash-ref lex sym))
 113                     (hash-set! lex sym (make-fluid))))
 114               syms)
 115     (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
 116                   targets
 117                   proc)))
 118
 119 (define (with-lexical-bindings bindings syms targets proc)
 120   (if (or (not (list? targets))
 121           (not (and-map symbol? targets)))
 122       (error "invalid targets for lexical binding" targets)
 123       (with-symbol-bindings bindings syms targets proc)))
 124
 125 (define (with-dynamic-bindings bindings syms proc)
 126   (with-symbol-bindings bindings
 127                         syms
 128                         (map (lambda (el) #f) syms)
 129                         proc))