Commit | Line | Data |
---|---|---|
eb80072d LC |
1 | ;;; Guile Emacs Lisp |
2 | ||
9447207f | 3 | ;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. |
eb80072d LC |
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 | |
344927c3 DK |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language elisp runtime) | |
3f70b2dc | 22 | #:export (nil-value |
f4e5e411 BT |
23 | t-value |
24 | value-slot-module | |
25 | function-slot-module | |
37099846 | 26 | elisp-bool |
f4e5e411 | 27 | ensure-fluid! |
85bc6238 BT |
28 | symbol-fluid |
29 | set-symbol-fluid! | |
30 | symbol-value | |
31 | set-symbol-value! | |
32 | symbol-function | |
33 | set-symbol-function! | |
34 | symbol-bound? | |
35 | symbol-fbound? | |
36 | makunbound! | |
5bdd388c | 37 | fmakunbound!) |
b652e2b9 | 38 | #:export-syntax (defspecial prim)) |
344927c3 | 39 | |
c983a199 | 40 | ;;; This module provides runtime support for the Elisp front-end. |
344927c3 | 41 | |
c983a199 | 42 | ;;; Values for t and nil. (FIXME remove this abstraction) |
1e018f6c | 43 | |
474060a2 | 44 | (define nil-value #nil) |
1e018f6c | 45 | |
abcf4a9e | 46 | (define t-value #t) |
1e018f6c | 47 | |
c983a199 BT |
48 | ;;; Modules for the binding slots. |
49 | ;;; Note: Naming those value-slot and/or function-slot clashes with the | |
50 | ;;; submodules of these names! | |
37099846 DK |
51 | |
52 | (define value-slot-module '(language elisp runtime value-slot)) | |
37099846 | 53 | |
abcf4a9e | 54 | (define function-slot-module '(language elisp runtime function-slot)) |
37099846 | 55 | |
c983a199 BT |
56 | ;;; Routines for access to elisp dynamically bound symbols. This is |
57 | ;;; used for runtime access using functions like symbol-value or set, | |
58 | ;;; where the symbol accessed might not be known at compile-time. These | |
59 | ;;; always access the dynamic binding and can not be used for the | |
60 | ;;; lexical! | |
37099846 DK |
61 | |
62 | (define (ensure-fluid! module sym) | |
63 | (let ((intf (resolve-interface module)) | |
64 | (resolved (resolve-module module))) | |
65 | (if (not (module-defined? intf sym)) | |
e01163b5 | 66 | (let ((fluid (make-unbound-fluid))) |
f4e5e411 BT |
67 | (module-define! resolved sym fluid) |
68 | (module-export! resolved `(,sym)))))) | |
37099846 | 69 | |
85bc6238 BT |
70 | (define (symbol-fluid symbol) |
71 | (let ((module (resolve-module value-slot-module))) | |
72 | (ensure-fluid! value-slot-module symbol) ;++ implicit special proclamation | |
73 | (module-ref module symbol))) | |
37099846 | 74 | |
85bc6238 BT |
75 | (define (set-symbol-fluid! symbol fluid) |
76 | (let ((module (resolve-module value-slot-module))) | |
77 | (module-define! module symbol fluid) | |
78 | (module-export! module (list symbol))) | |
79 | fluid) | |
80 | ||
81 | (define (symbol-value symbol) | |
82 | (fluid-ref (symbol-fluid symbol))) | |
83 | ||
84 | (define (set-symbol-value! symbol value) | |
85 | (fluid-set! (symbol-fluid symbol) value) | |
c6920dc8 | 86 | value) |
37099846 | 87 | |
85bc6238 BT |
88 | (define (symbol-function symbol) |
89 | (let ((module (resolve-module function-slot-module))) | |
90 | (module-ref module symbol))) | |
91 | ||
92 | (define (set-symbol-function! symbol value) | |
93 | (let ((module (resolve-module function-slot-module))) | |
94 | (module-define! module symbol value) | |
95 | (module-export! module (list symbol))) | |
96 | value) | |
7d1a9782 | 97 | |
85bc6238 BT |
98 | (define (symbol-bound? symbol) |
99 | (and | |
100 | (module-bound? (resolve-interface value-slot-module) symbol) | |
101 | (let ((var (module-variable (resolve-module value-slot-module) | |
102 | symbol))) | |
103 | (and (variable-bound? var) | |
104 | (if (fluid? (variable-ref var)) | |
105 | (fluid-bound? (variable-ref var)) | |
106 | #t))))) | |
107 | ||
108 | (define (symbol-fbound? symbol) | |
109 | (and | |
110 | (module-bound? (resolve-interface function-slot-module) symbol) | |
35724ee1 BT |
111 | (variable-bound? |
112 | (module-variable (resolve-module function-slot-module) | |
113 | symbol)))) | |
85bc6238 BT |
114 | |
115 | (define (makunbound! symbol) | |
116 | (if (module-bound? (resolve-interface value-slot-module) symbol) | |
117 | (let ((var (module-variable (resolve-module value-slot-module) | |
118 | symbol))) | |
119 | (if (and (variable-bound? var) (fluid? (variable-ref var))) | |
120 | (fluid-unset! (variable-ref var)) | |
121 | (variable-unset! var)))) | |
122 | symbol) | |
123 | ||
124 | (define (fmakunbound! symbol) | |
125 | (if (module-bound? (resolve-interface function-slot-module) symbol) | |
35724ee1 BT |
126 | (variable-unset! (module-variable |
127 | (resolve-module function-slot-module) | |
128 | symbol))) | |
85bc6238 BT |
129 | symbol) |
130 | ||
9b15703d | 131 | ;;; Define a predefined macro for use in the function-slot module. |
1e018f6c | 132 | |
44ae163d BT |
133 | (define (make-id template-id . data) |
134 | (let ((append-symbols | |
135 | (lambda (symbols) | |
136 | (string->symbol | |
137 | (apply string-append (map symbol->string symbols)))))) | |
138 | (datum->syntax template-id | |
139 | (append-symbols | |
140 | (map (lambda (datum) | |
141 | ((if (identifier? datum) | |
142 | syntax->datum | |
143 | identity) | |
144 | datum)) | |
145 | data))))) | |
146 | ||
44ae163d BT |
147 | (define-syntax defspecial |
148 | (lambda (x) | |
149 | (syntax-case x () | |
150 | ((_ name args body ...) | |
151 | (with-syntax ((scheme-name (make-id #'name 'compile- #'name))) | |
35724ee1 BT |
152 | #'(define scheme-name |
153 | (cons 'special-operator (lambda args body ...)))))))) |