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   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-8)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-26)
  26   #:export (make-bindings
  27             with-lexical-bindings
  28             with-dynamic-bindings
  29             with-function-bindings
  30             get-lexical-binding
  31             get-function-binding))
  32
  33 ;;; This module defines routines to handle analysis of symbol bindings
  34 ;;; used during elisp compilation.  This data allows to collect the
  35 ;;; symbols, for which globals need to be created, or mark certain
  36 ;;; symbols as lexically bound.
  37 ;;;
  38 ;;; The lexical bindings of symbols are stored in a hash-table that
  39 ;;; associates symbols to fluids; those fluids are used in the
  40 ;;; with-lexical-binding and with-dynamic-binding routines to associate
  41 ;;; symbols to different bindings over a dynamic extent.
  42
  43 ;;; Record type used to hold the data necessary.
  44
  45 (define-record-type bindings
  46   (%make-bindings lexical-bindings function-bindings)
  47   bindings?
  48   (lexical-bindings lexical-bindings)
  49   (function-bindings function-bindings))
  50
  51 ;;; Construct an 'empty' instance of the bindings data structure to be
  52 ;;; used at the start of a fresh compilation.
  53
  54 (define (make-bindings)
  55   (%make-bindings (make-hash-table) (make-hash-table)))
  56
  57 ;;; Get the current lexical binding (gensym it should refer to in the
  58 ;;; current scope) for a symbol or #f if it is dynamically bound.
  59
  60 (define (get-lexical-binding bindings sym)
  61   (let* ((lex (lexical-bindings bindings))
  62          (slot (hash-ref lex sym #f)))
  63     (if slot
  64         (fluid-ref slot)
  65         #f)))
  66
  67 (define (get-function-binding bindings symbol)
  68   (and=> (hash-ref (function-bindings bindings) symbol)
  69          fluid-ref))
  70
  71 ;;; Establish a binding or mark a symbol as dynamically bound for the
  72 ;;; extent of calling proc.
  73
  74 (define (with-symbol-bindings bindings syms targets proc)
  75   (if (or (not (list? syms))
  76           (not (and-map symbol? syms)))
  77       (error "can't bind non-symbols" syms))
  78   (let ((lex (lexical-bindings bindings)))
  79     (for-each (lambda (sym)
  80                 (if (not (hash-ref lex sym))
  81                     (hash-set! lex sym (make-fluid))))
  82               syms)
  83     (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
  84                   targets
  85                   proc)))
  86
  87 (define (with-lexical-bindings bindings syms targets proc)
  88   (if (or (not (list? targets))
  89           (not (and-map symbol? targets)))
  90       (error "invalid targets for lexical binding" targets)
  91       (with-symbol-bindings bindings syms targets proc)))
  92
  93 (define (with-dynamic-bindings bindings syms proc)
  94   (with-symbol-bindings bindings
  95                         syms
  96                         (map (lambda (el) #f) syms)
  97                         proc))
  98
  99 (define (with-function-bindings bindings symbols gensyms thunk)
 100   (let ((fb (function-bindings bindings)))
 101     (for-each (lambda (symbol)
 102                 (if (not (hash-ref fb symbol))
 103                     (hash-set! fb symbol (make-fluid))))
 104               symbols)
 105     (with-fluids* (map (cut hash-ref fb <>) symbols)
 106                   gensyms
 107                   thunk)))