|
0
|
1 ;; Customizable, Common Lisp like reader for Emacs Lisp.
|
|
|
2 ;;
|
|
|
3 ;; Copyright (C) 1993 by Guido Bosch <Guido.Bosch@loria.fr>
|
|
|
4
|
|
4
|
5 ;; This file is part of XEmacs
|
|
0
|
6
|
|
4
|
7 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
8 ;; under the terms of the GNU General Public License as published by
|
|
|
9 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
10 ;; any later version.
|
|
0
|
11
|
|
4
|
12 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
15 ;; General Public License for more details.
|
|
0
|
16
|
|
|
17 ;; You should have received a copy of the GNU General Public License
|
|
4
|
18 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
19 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
20 ;; 02111-1307, USA.
|
|
0
|
21
|
|
4
|
22 ;;; Synched up with: Not in FSF
|
|
|
23
|
|
|
24 ;;; Commentary:
|
|
|
25
|
|
0
|
26 ;; Please send bugs and comments to the author.
|
|
|
27 ;;
|
|
|
28 ;; <DISCLAIMER>
|
|
|
29 ;; This program is still under development. Neither the author nor
|
|
|
30 ;; his employer accepts responsibility to anyone for the consequences of
|
|
|
31 ;; using it or for whether it serves any particular purpose or works
|
|
|
32 ;; at all.
|
|
|
33
|
|
|
34
|
|
|
35 ;; Introduction
|
|
|
36 ;; ------------
|
|
|
37 ;;
|
|
|
38 ;; This package replaces the standard Emacs Lisp reader (implemented
|
|
|
39 ;; as a set of built-in Lisp function in C) by a flexible and
|
|
|
40 ;; customizable Common Lisp like one (implemented entirely in Emacs
|
|
|
41 ;; Lisp). During reading of Emacs Lisp source files, it is about 40%
|
|
|
42 ;; slower than the built-in reader, but there is no difference in
|
|
|
43 ;; loading byte compiled files - they dont contain any syntactic sugar
|
|
|
44 ;; and are loaded with the built in subroutine `load'.
|
|
|
45 ;;
|
|
|
46 ;; The user level functions for defining read tables, character and
|
|
|
47 ;; dispatch macros are implemented according to the Commom Lisp
|
|
|
48 ;; specification by Steel's (2nd edition), but the read macro functions
|
|
|
49 ;; themselves are implemented in a slightly different way, because the
|
|
|
50 ;; basic character reading is done in an Emacs buffer, and not by
|
|
|
51 ;; using the primitive functions `read-char' and `unread-char', as real
|
|
|
52 ;; CL does. To get 100% compatibility with CL, the above functions
|
|
|
53 ;; (or their equivalents) must be implemented as subroutines.
|
|
|
54 ;;
|
|
|
55 ;; Another difference with real CL reading is that basic tokens (symbols
|
|
|
56 ;; numbers, strings, and a few more) are still read by the original
|
|
|
57 ;; built-in reader. This is necessary to get reasonable performance.
|
|
|
58 ;; As a consquence, the read syntax of basic tokens can't be
|
|
|
59 ;; customized.
|
|
|
60
|
|
|
61 ;; Most of the built-in reader syntax has been replaced by lisp
|
|
|
62 ;; character macros: parentheses and brackets, simple and double
|
|
|
63 ;; quotes, semicolon comments and the dot. In addition to that, the
|
|
|
64 ;; following new syntax features are provided:
|
|
|
65
|
|
|
66 ;; Backquote-Comma-Atsign Macro: `(,el ,@list)
|
|
|
67 ;;
|
|
|
68 ;; (the clumsy Emacs Lisp syntax (` ((, el) (,@ list))) is also
|
|
|
69 ;; supported, but with one restriction: the blank behind the quote
|
|
|
70 ;; characters is mandatory when using the old syntax. The cl reader
|
|
|
71 ;; needs it as a landmark to distinguish between old and new syntax.
|
|
|
72 ;; An example:
|
|
|
73 ;;
|
|
|
74 ;; With blanks, both readers read the same:
|
|
|
75 ;; (` (, (head)) (,@ (tail))) -std-read-> (` (, (head)) (,@ (tail)))
|
|
|
76 ;; (` (, (head)) (,@ (tail))) -cl-read-> (` (, (head)) (,@ (tail)))
|
|
|
77 ;;
|
|
|
78 ;; Without blanks, the form is interpreted differently by the two readers:
|
|
|
79 ;; (`(,(head)) (,@(tail))) -std-read-> (` (, (head)) (,@ (tail)))
|
|
|
80 ;; (`(,(head)) (,@(tail))) -cl-read-> ((` ((, ((head)))) ((,@ ((tail)))))
|
|
|
81 ;;
|
|
|
82 ;;
|
|
|
83 ;; Dispatch Character Macro" `#'
|
|
|
84 ;;
|
|
|
85 ;; #'<function> function quoting
|
|
|
86 ;; #\<charcter> character syntax
|
|
|
87 ;; #.<form> read time evaluation
|
|
|
88 ;; #p<path>, #P<path> paths
|
|
|
89 ;; #+<feature>, #-<feature> conditional reading
|
|
|
90 ;; #<n>=, #<n># tags for shared structure reading
|
|
|
91 ;;
|
|
|
92 ;; Other read macros can be added easily (see the definition of the
|
|
|
93 ;; above ones in this file, using the functions `set-macro-character'
|
|
|
94 ;; and `set-dispatch-macro-character')
|
|
|
95 ;;
|
|
|
96 ;; The Cl reader is mostly downward compatile, (exception: backquote
|
|
|
97 ;; comma macro, see above). E.g., this file, which is written entirely
|
|
|
98 ;; in the standard Emacs Lisp syntax, can be read and compiled with the
|
|
|
99 ;; cl-reader activated (see Examples below).
|
|
|
100
|
|
|
101 ;; This also works with package.el for Common Lisp packages.
|
|
|
102
|
|
|
103
|
|
|
104 ;; Requirements
|
|
|
105 ;; ------------
|
|
|
106 ;; The package runs on Emacs 18 and Emacs 19 (FSF and Lucid) It is
|
|
|
107 ;; built on top of Dave Gillespie's cl.el package (version 2.02 or
|
|
|
108 ;; later). The old one (from Ceazar Quiroz, still shiped with some
|
|
|
109 ;; Emacs 19 disributions) will not do.
|
|
|
110
|
|
|
111 ;; Usage
|
|
|
112 ;; -----
|
|
|
113 ;; The package is implemented as a kind of minor mode to the
|
|
|
114 ;; emacs-lisp-mode. As most of the Emacs Lisp files are still written
|
|
|
115 ;; in the standard Emacs Lisp syntax, the cl reader is only activated
|
|
|
116 ;; on elisp files whose property lines contain the following entry:
|
|
|
117 ;;
|
|
|
118 ;; -*- Read-Syntax: Common-Lisp -*-
|
|
|
119 ;;
|
|
|
120 ;; Note that both property name ("Read-Syntax") and value
|
|
|
121 ;; ("Common-Lisp") are not case sensitive. There can also be other
|
|
|
122 ;; properties in this line:
|
|
|
123 ;;
|
|
|
124 ;; -*- Mode: Emacs-Lisp; Read-Syntax: Common-Lisp -*-
|
|
|
125
|
|
|
126 ;; Installation
|
|
|
127 ;; ------------
|
|
|
128 ;; Save this file in a directory where Emacs will find it, then
|
|
|
129 ;; byte compile it (M-x byte-compile-file).
|
|
|
130 ;;
|
|
|
131 ;; A permanent installation of the package can be done in two ways:
|
|
|
132 ;;
|
|
|
133 ;; 1.) If you want to have the package always loaded, put this in your
|
|
|
134 ;; .emacs, or in just the files that require it:
|
|
|
135 ;;
|
|
|
136 ;; (require 'cl-read)
|
|
|
137 ;;
|
|
|
138 ;; 2.) To load the cl-read package automatically when visiting an elisp
|
|
|
139 ;; file that needs it, it has to be installed using the
|
|
|
140 ;; emacs-lisp-mode-hook. In this case, put the following function
|
|
|
141 ;; definition and add-hook form in your .emacs:
|
|
|
142 ;;
|
|
|
143 ;; (defun cl-reader-autoinstall-function ()
|
|
|
144 ;; "Activates the Common Lisp style reader for emacs-lisp-mode buffers,
|
|
|
145 ;; if the property line has a local variable setting like this:
|
|
|
146 ;; \;\; -*- Read-Syntax: Common-Lisp -*-"
|
|
|
147 ;;
|
|
|
148 ;; (or (boundp 'local-variable-hack-done)
|
|
|
149 ;; (let (local-variable-hack-done
|
|
|
150 ;; (case-fold-search t))
|
|
|
151 ;; (hack-local-variables-prop-line 't)
|
|
|
152 ;; (cond
|
|
|
153 ;; ((and (boundp 'read-syntax)
|
|
|
154 ;; read-syntax
|
|
|
155 ;; (string-match "^common-lisp$" (symbol-name read-syntax)))
|
|
|
156 ;; (require 'cl-read)
|
|
|
157 ;; (make-local-variable 'cl-read-active)
|
|
|
158 ;; (setq cl-read-active 't))))))
|
|
|
159 ;;
|
|
|
160 ;; (add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function)
|
|
|
161 ;;
|
|
|
162 ;; The `cl-reader-autoinstall-function' function tests for the
|
|
|
163 ;; presence of the correct Read-Syntax property in the first line of
|
|
|
164 ;; the file and loads the cl-read package if necessary. cl-read
|
|
|
165 ;; replaces the following standard elisp functions:
|
|
|
166 ;;
|
|
|
167 ;; - read
|
|
|
168 ;; - read-from-string
|
|
|
169 ;; - eval-current-buffer
|
|
|
170 ;; - eval-buffer
|
|
|
171 ;; - eval-region
|
|
|
172 ;; - eval-expression (to call reader explicitly)
|
|
|
173 ;;
|
|
|
174 ;; There may be other built-in functions that need to be replaced
|
|
|
175 ;; (e.g. load). The behavior of the new reader function depends on
|
|
|
176 ;; the value of the buffer local variable `cl-read-active': if it is
|
|
|
177 ;; nil, they just call the original functions, otherwise they call the
|
|
|
178 ;; cl reader. If the cl reader is active in a buffer, this is
|
|
|
179 ;; indicated in the modeline by the string "CL" (minor mode like).
|
|
|
180 ;;
|
|
|
181
|
|
|
182 ;; Examples:
|
|
|
183 ;; ---------
|
|
|
184 ;; After having installed the package as described above, the
|
|
|
185 ;; following forms can be evaluated (M-C-x) with the cl reader being
|
|
|
186 ;; active. (make sure that the mode line displays "(Emacs-Lisp CL)")
|
|
|
187 ;;
|
|
|
188 ;; (setq whitespaces '(#\space #\newline #\tab))
|
|
|
189 ;; (setq more-whitespaces `(#\page ,@whitespaces #\linefeed))
|
|
|
190 ;; (setq whitespace-strings (mapcar #'char-to-string more-whitespaces))
|
|
|
191 ;;
|
|
|
192 ;; (setq shared-struct '(#1=[hello world] #1# #1#))
|
|
|
193 ;; (progn (setq cirlist '#1=(a b . #1#)) 't)
|
|
|
194 ;;
|
|
|
195 ;; This file, though written in standard Emacs Lisp syntax, can also be
|
|
|
196 ;; compiled with the cl reader active: Type M-x byte-compile-file
|
|
|
197
|
|
|
198 ;; TO DO List:
|
|
|
199 ;; -----------
|
|
|
200 ;; - Provide a replacement for load so that uncompiled cl syntax
|
|
|
201 ;; source file can be loaded, too. For now prohibit loading un-bytecompiled.
|
|
|
202 ;; - Do we really need the (require 'cl) dependency? Yes.
|
|
|
203 ;; - More read macros: #S for structs, #A for array, #X for hex, #nR for radix
|
|
|
204 ;; - Refine the error signaling mechanism.
|
|
|
205 ;; - invalid-cl-read-syntax is now defined. what else?
|
|
|
206
|
|
|
207
|
|
|
208 ; Change History
|
|
|
209 ;
|
|
|
210 ; $Log: cl-read.el,v $
|
|
4
|
211 ; Revision 1.1.1.3 1996/12/18 03:54:28 steve
|
|
|
212 ; XEmacs 19.15-b3
|
|
0
|
213 ;
|
|
|
214 ; Revision 1.19 94/03/21 19:59:24 liberte
|
|
|
215 ; Add invalid-cl-read-syntax error symbol.
|
|
|
216 ; Add reader::read-sexp and reader::read-sexp-func to allow customization
|
|
|
217 ; based on the results of reading.
|
|
|
218 ; Remove more dependencies on cl-package.
|
|
|
219 ; Remove reader::eval-current-buffer, eval-buffer, and eval-region,
|
|
|
220 ; and use elisp-eval-region package instead.
|
|
|
221 ;
|
|
|
222 ; Revision 1.18 94/03/04 23:42:24 liberte
|
|
|
223 ; Fix typos in comments.
|
|
|
224 ;
|
|
|
225 ; Revision 1.17 93/11/24 12:04:09 bosch
|
|
|
226 ; cl-packages dependency removed. `reader::read-constituent' and
|
|
|
227 ; corresponding variables moved to cl-packages.el.
|
|
|
228 ; Multi-line comment #| ... |# dispatch character read macro added.
|
|
|
229 ;
|
|
|
230 ; Revision 1.16 1993/11/23 10:21:02 bosch
|
|
|
231 ; Patches from Daniel LaLiberte integrated.
|
|
|
232 ;
|
|
|
233 ; Revision 1.15 1993/11/18 21:21:10 bosch
|
|
|
234 ; `reader::symbol-regexp1' modified.
|
|
|
235 ;
|
|
|
236 ; Revision 1.14 1993/11/17 19:06:32 bosch
|
|
|
237 ; More characters added to `reader::symbol-characters'.
|
|
|
238 ; `reader::read-constituent' modified.
|
|
|
239 ; defpackage form added.
|
|
|
240 ;
|
|
|
241 ; Revision 1.13 1993/11/16 13:06:41 bosch
|
|
|
242 ; - Symbol reading for CL package convention implemented.
|
|
|
243 ; Variables `reader::symbol-characters', `reader::symbol-regexp1' and
|
|
|
244 ; `reader::symbol-regexp2' and functions `reader::lookup-symbol' and
|
|
|
245 ; `reader::read-constituent' added.
|
|
|
246 ; - Prefix for internal symbols is now "reader::" (Common Lisp
|
|
|
247 ; compatible).
|
|
|
248 ; - Dispatch character macro #: for reading uninterned symbols added.
|
|
|
249 ;
|
|
|
250 ; Revision 1.12 1993/11/07 19:29:07 bosch
|
|
|
251 ; Minor bug fix.
|
|
|
252 ;
|
|
|
253 ; Revision 1.11 1993/11/07 19:23:59 bosch
|
|
|
254 ; Comment added. Character read macro #\<char> rewritten. Now reads
|
|
|
255 ; e.g. #\meta-control-x. Needs to be checked.
|
|
|
256 ; fix in `reader::restore-shared-structure'. `cl-reader-autoinstall-function' improved.
|
|
|
257 ;
|
|
|
258 ; Revision 1.10 1993/11/06 18:35:35 bosch
|
|
|
259 ; Included Daniel LaLiberte's Patches.
|
|
|
260 ; Efficiency of `reader::restore-shared-structure' improved.
|
|
|
261 ; Implementation notes for shared structure reading added.
|
|
|
262 ;
|
|
|
263 ; Revision 1.9 1993/09/08 07:44:54 bosch
|
|
|
264 ; Comment modified.
|
|
|
265 ;
|
|
|
266 ; Revision 1.8 1993/08/10 13:43:34 bosch
|
|
|
267 ; Hook function `cl-reader-autoinstall-function' for automatic installation added.
|
|
|
268 ; Buffer local variable `cl-read-active' added: together with the above
|
|
|
269 ; hook it allows the file specific activation of the cl reader.
|
|
|
270 ;
|
|
|
271 ; Revision 1.7 1993/08/10 10:35:21 bosch
|
|
|
272 ; Functions `read*' and `read-from-string*' renamed into `reader::read'
|
|
|
273 ; and `reader::read-from-string'. Whitespace character skipping after
|
|
|
274 ; recursive reader calls removed (Emacs 19 should not need this).
|
|
|
275 ; Functions `cl-reader-install' and `cl-reader-uninstall' updated.
|
|
|
276 ; Introduction text and function comments added.
|
|
|
277 ;
|
|
|
278 ; Revision 1.6 1993/08/09 15:36:05 bosch Function `read*' now nearly
|
|
|
279 ; elisp compatible (no functions as streams, yet -- I don't think I
|
|
|
280 ; will ever implement this, it would be far too slow). Elisp
|
|
|
281 ; compatible function `read-from-string*' added. Replacements for
|
|
|
282 ; `eval-current-buffer', `eval-buffer' and `eval-region' added.
|
|
|
283 ; Renamed feature `cl-dg' in `cl', as Dave Gillespie's cl.el package
|
|
|
284 ; is rather stable now. Function `cl-reader-install' and
|
|
|
285 ; `cl-reader-uninstall' modified.
|
|
|
286 ;
|
|
|
287 ; Revision 1.5 1993/08/09 10:23:35 bosch
|
|
|
288 ; Functions `copy-readtable' and `set-syntax-from-character' added.
|
|
|
289 ; Variable `reader::internal-standard-readtable' added. Standard
|
|
|
290 ; readtable initialization modified. Whitespace skipping placed back
|
|
|
291 ; inside the read loop.
|
|
|
292 ;
|
|
|
293 ; Revision 1.4 1993/05/14 13:00:48 bosch
|
|
|
294 ; Included patches from Daniel LaLiberte.
|
|
|
295 ;
|
|
|
296 ; Revision 1.3 1993/05/11 09:57:39 bosch
|
|
|
297 ; `read*' renamed in `reader::read-from-buffer'. `read*' now can read
|
|
|
298 ; from strings.
|
|
|
299 ;
|
|
|
300 ; Revision 1.2 1993/05/09 16:30:50 bosch
|
|
|
301 ; (require 'cl-read) added.
|
|
|
302 ; Calling of `{before,after}-read-hook' modified.
|
|
|
303 ;
|
|
|
304 ; Revision 1.1 1993/03/29 19:37:21 bosch
|
|
|
305 ; Initial revision
|
|
|
306 ;
|
|
|
307 ;
|
|
|
308
|
|
4
|
309 ;;; Code:
|
|
0
|
310
|
|
4
|
311 (require 'cl)
|
|
|
312 ;; Thou shalt evaluate a defadvice only once, or thou shalt surely lose. -sb
|
|
|
313 (require 'advise-eval-region)
|
|
|
314
|
|
|
315 ;; load before compiling
|
|
|
316 ;; This is ugly, but apparently the only way to do it :-( -sb
|
|
0
|
317 (provide 'cl-read)
|
|
|
318 (require 'cl-read)
|
|
|
319
|
|
|
320 ;; bootstrapping with cl-packages
|
|
|
321 ;; defpackage and in-package are ignored until cl-read is installed.
|
|
|
322 '(defpackage reader
|
|
|
323 (:nicknames "rd")
|
|
|
324 (:use el)
|
|
|
325 (:export
|
|
|
326 cl-read-active
|
|
|
327 copy-readtable
|
|
|
328 set-macro-character
|
|
|
329 get-macro-character
|
|
|
330 set-syntax-from-character
|
|
|
331 make-dispatch-macro-character
|
|
|
332 set-dispatch-macro-character
|
|
|
333 get-dispatch-macro-character
|
|
|
334 before-read-hook
|
|
|
335 after-read-hook
|
|
|
336 cl-reader-install
|
|
|
337 cl-reader-uninstall
|
|
|
338 read-syntax
|
|
|
339 cl-reader-autoinstall-function))
|
|
|
340
|
|
|
341 '(in-package reader)
|
|
|
342
|
|
|
343
|
|
|
344 (autoload 'compiled-function-p "bytecomp")
|
|
|
345
|
|
|
346 ;; This makes cl-read behave as a kind of minor mode:
|
|
|
347
|
|
|
348 (make-variable-buffer-local 'cl-read-active)
|
|
|
349 (defvar cl-read-active nil
|
|
|
350 "Buffer local variable that enables Common Lisp style syntax reading.")
|
|
|
351 (setq-default cl-read-active nil)
|
|
|
352
|
|
|
353 (or (assq 'cl-read-active minor-mode-alist)
|
|
|
354 (setq minor-mode-alist
|
|
|
355 (cons '(cl-read-active " CL") minor-mode-alist)))
|
|
|
356
|
|
|
357 ;; Define a new error symbol: invalid-cl-read-syntax
|
|
|
358 ;; XEmacs change
|
|
|
359 (define-error 'invalid-cl-read-syntax "Invalid CL read syntax"
|
|
|
360 'invalid-read-syntax)
|
|
|
361
|
|
|
362 (defun reader::error (msg &rest args)
|
|
|
363 (signal 'invalid-cl-read-syntax (list (apply 'format msg args))))
|
|
|
364
|
|
|
365
|
|
|
366 ;; The readtable
|
|
|
367
|
|
|
368 (defvar reader::readtable-size 256
|
|
|
369 "The size of a readtable."
|
|
|
370 ;; Actually, the readtable is a vector of size (1+
|
|
|
371 ;; reader::readtable-size), because the last element contains the
|
|
|
372 ;; symbol `readtable', used for defining `readtablep.
|
|
|
373 )
|
|
|
374
|
|
|
375 ;; An entry of the readtable must have one of the following forms:
|
|
|
376 ;;
|
|
|
377 ;; 1. A symbol, one of {illegal, constituent, whitespace}. It means
|
|
|
378 ;; the character's reader class.
|
|
|
379 ;;
|
|
|
380 ;; 2. A function (i.e., a symbol with a function definition, a byte
|
|
|
381 ;; compiled function or an uncompiled lambda expression). It means the
|
|
|
382 ;; character is a macro character.
|
|
|
383 ;;
|
|
|
384 ;; 3. A vector of length `reader::readtable-size'. Elements of this vector
|
|
|
385 ;; may be `nil' or a function (see 2.). It means the charater is a
|
|
|
386 ;; dispatch character, and the vector its dispatch fucntion table.
|
|
|
387
|
|
|
388 (defvar *readtable*)
|
|
|
389 (defvar reader::internal-standard-readtable)
|
|
|
390
|
|
|
391 (defun* copy-readtable
|
|
|
392 (&optional (from-readtable *readtable*)
|
|
|
393 (to-readtable
|
|
|
394 (make-vector (1+ reader::readtable-size) 'illegal)))
|
|
|
395 "Return a copy of FROM-READTABLE \(default: *readtable*\). If the
|
|
|
396 FROM-READTABLE argument is provided as `nil', make a copy of a
|
|
|
397 standard \(CL-like\) readtable. If TO-READTABLE is provided, modify and
|
|
|
398 return it, otherwise create a new readtable object."
|
|
|
399
|
|
|
400 (if (null from-readtable)
|
|
|
401 (setq from-readtable reader::internal-standard-readtable))
|
|
|
402
|
|
|
403 (loop for i to reader::readtable-size
|
|
|
404 as from-syntax = (aref from-readtable i)
|
|
|
405 do (setf (aref to-readtable i)
|
|
|
406 (if (vectorp from-syntax)
|
|
|
407 (copy-sequence from-syntax)
|
|
|
408 from-syntax))
|
|
|
409 finally return to-readtable))
|
|
|
410
|
|
|
411
|
|
|
412 (defmacro reader::get-readtable-entry (char readtable)
|
|
|
413 (` (aref (, readtable) (, char))))
|
|
|
414
|
|
|
415 (defun set-macro-character
|
|
|
416 (char function &optional readtable)
|
|
|
417 "Makes CHAR to be a macro character with FUNCTION as handler.
|
|
|
418 When CHAR is seen by reader::read-from-buffer, it calls FUNCTION.
|
|
|
419 Returns always t. Optional argument READTABLE is the readtable to set
|
|
|
420 the macro character in (default: *readtable*)."
|
|
|
421 (or readtable (setq readtable *readtable*))
|
|
|
422 (or (reader::functionp function)
|
|
|
423 (reader::error "Not valid character macro function: %s" function))
|
|
|
424 (setf (reader::get-readtable-entry char readtable) function)
|
|
|
425 t)
|
|
|
426
|
|
|
427
|
|
|
428 (put 'set-macro-character 'edebug-form-spec
|
|
|
429 '(&define sexp function-form &optional sexp))
|
|
|
430 (put 'set-macro-character 'lisp-indent-function 1)
|
|
|
431
|
|
|
432 (defun get-macro-character (char &optional readtable)
|
|
|
433 "Return the function associated with the character CHAR.
|
|
|
434 Optional READTABLE defaults to *readtable*. If char isn't a macro
|
|
|
435 character in READTABLE, return nil."
|
|
|
436 (or readtable (setq readtable *readtable*))
|
|
|
437 (let ((entry (reader::get-readtable-entry char readtable)))
|
|
|
438 (if (reader::functionp entry)
|
|
|
439 entry)))
|
|
|
440
|
|
|
441 (defun set-syntax-from-character
|
|
|
442 (to-char from-char &optional to-readtable from-readtable)
|
|
|
443 "Make the syntax of TO-CHAR be the same as the syntax of FROM-CHAR.
|
|
|
444 Optional TO-READTABLE and FROM-READTABLE are the corresponding tables
|
|
|
445 to use. TO-READTABLE defaults to the current readtable
|
|
|
446 \(*readtable*\), and FROM-READTABLE to nil, meaning to use the
|
|
|
447 syntaxes from the standard Lisp Readtable."
|
|
|
448 (or to-readtable (setq to-readtable *readtable*))
|
|
|
449 (or from-readtable
|
|
|
450 (setq from-readtable reader::internal-standard-readtable))
|
|
|
451 (let ((from-syntax
|
|
|
452 (reader::get-readtable-entry from-char from-readtable)))
|
|
|
453 (if (vectorp from-syntax)
|
|
|
454 ;; dispatch macro character table
|
|
|
455 (setq from-syntax (copy-sequence from-syntax)))
|
|
|
456 (setf (reader::get-readtable-entry to-char to-readtable)
|
|
|
457 from-syntax))
|
|
|
458 t)
|
|
|
459
|
|
|
460
|
|
|
461 ;; Dispatch macro character
|
|
|
462 (defun make-dispatch-macro-character (char &optional readtable)
|
|
|
463 "Let CHAR be a dispatch macro character in READTABLE (default: *readtable*)."
|
|
|
464 (or readtable (setq readtable *readtable*))
|
|
|
465 (setf (reader::get-readtable-entry char readtable)
|
|
|
466 ;; create a dispatch character table
|
|
|
467 (make-vector reader::readtable-size nil)))
|
|
|
468
|
|
|
469
|
|
|
470 (defun set-dispatch-macro-character
|
|
|
471 (disp-char sub-char function &optional readtable)
|
|
|
472 "Make reading CHAR1 followed by CHAR2 be handled by FUNCTION.
|
|
|
473 Optional argument READTABLE (default: *readtable*). CHAR1 must first be
|
|
|
474 made a dispatch char with `make-dispatch-macro-character'."
|
|
|
475 (or readtable (setq readtable *readtable*))
|
|
|
476 (let ((disp-table (reader::get-readtable-entry disp-char readtable)))
|
|
|
477 ;; check whether disp-char is a valid dispatch character
|
|
|
478 (or (vectorp disp-table)
|
|
|
479 (reader::error "`%c' not a dispatch macro character." disp-char))
|
|
|
480 ;; check whether function is a valid function
|
|
|
481 (or (reader::functionp function)
|
|
|
482 (reader::error "Not valid dispatch character macro function: %s"
|
|
|
483 function))
|
|
|
484 (setf (aref disp-table sub-char) function)))
|
|
|
485
|
|
|
486 (put 'set-dispatch-macro-character 'edebug-form-spec
|
|
|
487 '(&define sexp sexp function-form &optional sexp))
|
|
|
488 (put 'set-dispatch-macro-character 'lisp-indent-function 2)
|
|
|
489
|
|
|
490
|
|
|
491 (defun get-dispatch-macro-character
|
|
|
492 (disp-char sub-char &optional readtable)
|
|
|
493 "Return the macro character function for SUB-CHAR unser DISP-CHAR.
|
|
|
494 Optional READTABLE defaults to *readtable*.
|
|
|
495 Returns nil if there is no such function."
|
|
|
496 (or readtable (setq readtable *readtable*))
|
|
|
497 (let ((disp-table (reader::get-readtable-entry disp-char readtable)))
|
|
|
498 (and (vectorp disp-table)
|
|
|
499 (reader::functionp (aref disp-table sub-char))
|
|
|
500 (aref disp-table sub-char))))
|
|
|
501
|
|
|
502
|
|
|
503 (defun reader::functionp (function)
|
|
|
504 ;; Check whether FUNCTION is a valid function object to be used
|
|
|
505 ;; as (dispatch) macro character function.
|
|
|
506 (or (and (symbolp function) (fboundp function))
|
|
|
507 (compiled-function-p function)
|
|
|
508 (and (consp function) (eq (first function) 'lambda))))
|
|
|
509
|
|
|
510
|
|
|
511 ;; The basic reader loop
|
|
|
512
|
|
|
513 ;; shared and circular structure reading
|
|
|
514 (defvar reader::shared-structure-references nil)
|
|
|
515 (defvar reader::shared-structure-labels nil)
|
|
|
516
|
|
|
517 (defun reader::read-sexp-func (point func)
|
|
|
518 ;; This function is called to read a sexp at POINT by calling FUNC.
|
|
|
519 ;; reader::read-sexp-func is here to be advised, e.g. by Edebug,
|
|
|
520 ;; to do something before or after reading.
|
|
|
521 (funcall func))
|
|
|
522
|
|
|
523 (defmacro reader::read-sexp (point &rest body)
|
|
|
524 ;; Called to return a sexp starting at POINT. BODY creates the sexp result
|
|
|
525 ;; and should leave point after the sexp. The body is wrapped in
|
|
|
526 ;; a lambda expression and passed to reader::read-sexp-func.
|
|
|
527 (` (reader::read-sexp-func (, point) (function (lambda () (,@ body))))))
|
|
|
528
|
|
|
529 (put 'reader::read-sexp 'edebug-form-spec '(form body))
|
|
|
530 (put 'reader::read-sexp 'lisp-indent-function 2)
|
|
|
531 (put 'reader::read-sexp 'lisp-indent-hook 1) ;; Emacs 18
|
|
|
532
|
|
|
533
|
|
|
534 (defconst before-read-hook nil)
|
|
|
535 (defconst after-read-hook nil)
|
|
|
536
|
|
|
537 ;; Set the hooks to `read-char' in order to step through the reader. e.g.
|
|
|
538 ;; (add-hook 'before-read-hook '(lambda () (message "before") (read-char)))
|
|
|
539 ;; (add-hook 'after-read-hook '(lambda () (message "after") (read-char)))
|
|
|
540
|
|
|
541 (defmacro reader::encapsulate-recursive-call (reader-call)
|
|
|
542 ;; Encapsulate READER-CALL, a form that contains a recursive call to
|
|
|
543 ;; the reader, for usage inside the main reader loop. The macro
|
|
|
544 ;; wraps two hooks around READER-CALL: `before-read-hook' and
|
|
|
545 ;; `after-read-hook'.
|
|
|
546 ;;
|
|
|
547 ;; If READER-CALL returns normally, the macro exits immediately from
|
|
|
548 ;; the surrounding loop with the value of READER-CALL as result. If
|
|
|
549 ;; it exits non-locally (with tag `reader-ignore'), it just returns
|
|
|
550 ;; the value of READER-CALL, in which case the surrounding reader
|
|
|
551 ;; loop continues its execution.
|
|
|
552 ;;
|
|
|
553 ;; In both cases, `before-read-hook' and `after-read-hook' are
|
|
|
554 ;; called before and after executing READER-CALL.
|
|
|
555 ;; Are there any other uses for these hooks? Edebug doesn't need them.
|
|
|
556 (` (prog2
|
|
|
557 (run-hooks 'before-read-hook)
|
|
|
558 ;; this catch allows to ignore the return, in the case that
|
|
|
559 ;; reader::read-from-buffer should continue looping (e.g.
|
|
|
560 ;; skipping over comments)
|
|
|
561 (catch 'reader-ignore
|
|
|
562 ;; this only works inside a block (e.g., in a loop):
|
|
|
563 ;; go outside
|
|
|
564 (return
|
|
|
565 (prog1
|
|
|
566 (, reader-call)
|
|
2
|
567 ;; this occurrence of the after hook fires if the
|
|
0
|
568 ;; reader-call returns normally ...
|
|
|
569 (run-hooks 'after-read-hook))))
|
|
|
570 ;; ... and that one if it was thrown to the tag 'reader-ignore
|
|
|
571 (run-hooks 'after-read-hook))))
|
|
|
572
|
|
|
573 (put 'reader::encapsulate-recursive-call 'edebug-form-spec '(form))
|
|
|
574 (put 'reader::encapsulate-recursive-call 'lisp-indent-function 0)
|
|
|
575
|
|
|
576 (defun reader::read-from-buffer (&optional stream reader::recursive-p)
|
|
|
577 (or (bufferp stream)
|
|
|
578 (reader::error "Sorry, can only read on buffers"))
|
|
|
579 (if (not reader::recursive-p)
|
|
|
580 ;; set up environment for shared structure reading
|
|
|
581 (let (reader::shared-structure-references
|
|
|
582 reader::shared-structure-labels
|
|
|
583 tmp-sexp)
|
|
|
584 ;; the reader returns an unshared sexpr, possibly containing
|
|
|
585 ;; symbolic references
|
|
|
586 (setq tmp-sexp (reader::read-from-buffer stream 't))
|
|
|
587 (if ;; sexpr actually contained shared structures
|
|
|
588 reader::shared-structure-references
|
|
|
589 (reader::restore-shared-structure tmp-sexp)
|
|
|
590 ;; it did not, so don't bother about restoring
|
|
|
591 tmp-sexp))
|
|
|
592
|
|
|
593 (loop for char = (following-char)
|
|
|
594 for entry = (reader::get-readtable-entry char *readtable*)
|
|
|
595 if (eobp) do (reader::error "End of file during reading")
|
|
|
596 do
|
|
|
597 (cond
|
|
|
598
|
|
|
599 ((eq entry 'illegal)
|
|
|
600 (reader::error "`%c' has illegal character syntax" char))
|
|
|
601
|
|
|
602 ;; skipping whitespace characters must be done inside this
|
|
|
603 ;; loop as character macro subroutines may return without
|
|
|
604 ;; leaving the loop using (throw 'reader-ignore ...)
|
|
|
605 ((eq entry 'whitespace)
|
|
|
606 (forward-char 1)
|
|
|
607 ;; skip all whitespace
|
|
|
608 (while (eq 'whitespace
|
|
|
609 (reader::get-readtable-entry
|
|
|
610 (following-char) *readtable*))
|
|
|
611 (forward-char 1)))
|
|
|
612
|
|
|
613 ;; for every token starting with a constituent character
|
|
|
614 ;; call the built-in reader (symbols, numbers, strings,
|
|
|
615 ;; characters with ?<char> syntax)
|
|
|
616 ((eq entry 'constituent)
|
|
|
617 (reader::encapsulate-recursive-call
|
|
|
618 (reader::read-constituent stream)))
|
|
|
619
|
|
|
620 ((vectorp entry)
|
|
|
621 ;; Dispatch macro character. The dispatch macro character
|
|
|
622 ;; function is contained in the vector `entry', at the
|
|
|
623 ;; place indicated by <sub-char>, the first non-digit
|
|
|
624 ;; character following the <disp-char>:
|
|
|
625 ;; <disp-char><digit>*<sub-char>
|
|
|
626 (reader::encapsulate-recursive-call
|
|
|
627 (loop initially do (forward-char 1)
|
|
|
628 for sub-char = (prog1 (following-char)
|
|
|
629 (forward-char 1))
|
|
|
630 while (memq sub-char
|
|
|
631 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))
|
|
|
632 collect sub-char into digit-args
|
|
|
633 finally
|
|
|
634 (return
|
|
|
635 (funcall
|
|
|
636 ;; no test is done here whether a non-nil
|
|
|
637 ;; contents is a correct dispatch character
|
|
|
638 ;; function to apply.
|
|
|
639 (or (aref entry sub-char)
|
|
|
640 (reader::error
|
|
|
641 "Undefined subsequent dispatch character `%c'"
|
|
|
642 sub-char))
|
|
|
643 stream
|
|
|
644 sub-char
|
|
|
645 (string-to-int
|
|
|
646 (apply 'concat
|
|
|
647 (mapcar
|
|
|
648 'char-to-string digit-args))))))))
|
|
|
649
|
|
|
650 (t
|
|
|
651 ;; must be a macro character. In this case, `entry' is
|
|
|
652 ;; the function to be called
|
|
|
653 (reader::encapsulate-recursive-call
|
|
|
654 (progn
|
|
|
655 (forward-char 1)
|
|
|
656 (funcall entry stream char))))))))
|
|
|
657
|
|
|
658
|
|
|
659 ;; Constituent reader fix for Emacs 18
|
|
|
660 (if (string-match "^19" emacs-version)
|
|
|
661 (defun reader::read-constituent (stream)
|
|
|
662 (reader::read-sexp (point)
|
|
|
663 (reader::original-read stream)))
|
|
|
664
|
|
|
665 (defun reader::read-constituent (stream)
|
|
|
666 (reader::read-sexp (point)
|
|
|
667 (prog1 (reader::original-read stream)
|
|
|
668 ;; For Emacs 18, backing up is necessary because the `read' function
|
|
|
669 ;; reads one character too far after reading a symbol or number.
|
|
|
670 ;; This doesnt apply to reading chars (e.g. ?n).
|
|
|
671 ;; This still loses for escaped chars.
|
|
|
672 (if (not (eq (reader::get-readtable-entry
|
|
|
673 (preceding-char) *readtable*) 'constituent))
|
|
|
674 (forward-char -1))))))
|
|
|
675
|
|
|
676
|
|
|
677 ;; Make the default current CL readtable
|
|
|
678
|
|
|
679 (defconst *readtable*
|
|
|
680 (loop with raw-readtable =
|
|
|
681 (make-vector (1+ reader::readtable-size) 'illegal)
|
|
|
682 initially do (setf (aref raw-readtable reader::readtable-size)
|
|
|
683 'readtable)
|
|
|
684 for entry in
|
|
|
685 '((constituent ?! ?@ ?$ ?% ?& ?* ?_ ?- ?+ ?= ?/ ?\\ ?0 ?1 ?2
|
|
|
686 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?: ?~ ?> ?< ?a ?b
|
|
|
687 ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p
|
|
|
688 ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D
|
|
|
689 ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R
|
|
|
690 ?S ?T ?U ?V ?W ?X ?Y ?Z)
|
|
|
691 (whitespace ? ?\t ?\n ?\r ?\f)
|
|
|
692
|
|
|
693 ;; The following CL character classes are only useful for
|
|
|
694 ;; token parsing. We don't need them, as token parsing is
|
|
|
695 ;; left to the built-in reader.
|
|
|
696 ;; (single-escape ?\\)
|
|
|
697 ;; (multiple-escape ?|)
|
|
|
698 )
|
|
|
699 do
|
|
|
700 (loop for char in (rest entry)
|
|
|
701 do (setf (reader::get-readtable-entry char raw-readtable)
|
|
|
702 (first entry)))
|
|
|
703 finally return raw-readtable)
|
|
|
704 "The current readtable.")
|
|
|
705
|
|
|
706
|
|
|
707 ;; Variables used non-locally in the standard readmacros
|
|
|
708 (defvar reader::context)
|
|
|
709 (defvar reader::stack)
|
|
|
710 (defvar reader::recursive-p)
|
|
|
711
|
|
|
712
|
|
|
713 ;;;; Read macro character definitions
|
|
|
714
|
|
|
715 ;;; Hint for modifying, testing and debugging new read macros: All the
|
|
|
716 ;;; read macros and dispatch character macros below are defined in
|
|
|
717 ;;; the `*readtable*'. Modifications or
|
|
|
718 ;;; instrumenting with edebug are effective immediately without having to
|
|
|
719 ;;; copy the internal readtable to the standard *readtable*. However,
|
|
|
720 ;;; if you wish to modify reader::internal-standard-readtable, then
|
|
|
721 ;;; you must recopy *readtable*.
|
|
|
722
|
|
|
723 ;; Chars and strings
|
|
|
724
|
|
|
725 ;; This is defined to distinguish chars from constituents
|
|
|
726 ;; since chars are read by the standard reader without reading too far.
|
|
|
727 (set-macro-character ?\?
|
|
|
728 (function
|
|
|
729 (lambda (stream char)
|
|
|
730 (forward-char -1)
|
|
|
731 (reader::read-sexp (point)
|
|
|
732 (reader::original-read stream)))))
|
|
|
733
|
|
|
734 ;; ?\M-\C-a
|
|
|
735
|
|
|
736 ;; This is defined to distinguish strings from constituents
|
|
|
737 ;; since backing up after reading a string is simpler.
|
|
|
738 (set-macro-character ?\"
|
|
|
739 (function
|
|
|
740 (lambda (stream char)
|
|
|
741 (forward-char -1)
|
|
|
742 (reader::read-sexp (point)
|
|
|
743 (prog1 (reader::original-read stream)
|
|
|
744 ;; This is not needed with Emacs 19, but it is OK. See above.
|
|
|
745 (if (/= (preceding-char) ?\")
|
|
|
746 (forward-char -1)))))))
|
|
|
747
|
|
|
748 ;; Lists and dotted pairs
|
|
|
749 (set-macro-character ?\(
|
|
|
750 (function
|
|
|
751 (lambda (stream char)
|
|
|
752 (reader::read-sexp (1- (point))
|
|
|
753 (catch 'read-list
|
|
|
754 (let ((reader::context 'list) reader::stack )
|
|
|
755 ;; read list elements up to a `.'
|
|
|
756 (catch 'dotted-pair
|
|
|
757 (while t
|
|
|
758 (setq reader::stack (cons (reader::read-from-buffer stream 't)
|
|
|
759 reader::stack))))
|
|
|
760 ;; In dotted pair. Read one more element
|
|
|
761 (setq reader::stack (cons (reader::read-from-buffer stream 't)
|
|
|
762 reader::stack)
|
|
|
763 ;; signal it to the closing paren
|
|
|
764 reader::context 'dotted-pair)
|
|
|
765 ;; Next char *must* be the closing paren that throws read-list
|
|
|
766 (reader::read-from-buffer stream 't)
|
|
|
767 ;; otherwise an error is signalled
|
|
|
768 (reader::error "Illegal dotted pair read syntax")))))))
|
|
|
769
|
|
|
770 (set-macro-character ?\)
|
|
|
771 (function
|
|
|
772 (lambda (stream char)
|
|
|
773 (cond ((eq reader::context 'list)
|
|
|
774 (throw 'read-list (nreverse reader::stack)))
|
|
|
775 ((eq reader::context 'dotted-pair)
|
|
|
776 (throw 'read-list (nconc (nreverse (cdr reader::stack))
|
|
|
777 (car reader::stack))))
|
|
|
778 (t
|
|
|
779 (reader::error "`)' doesn't end a list"))))))
|
|
|
780
|
|
|
781 (set-macro-character ?\.
|
|
|
782 (function
|
|
|
783 (lambda (stream char)
|
|
|
784 (and (eq reader::context 'dotted-pair)
|
|
|
785 (reader::error "No more than one `.' allowed in list"))
|
|
|
786 (throw 'dotted-pair nil))))
|
|
|
787
|
|
|
788 ;; '(#\a . #\b)
|
|
|
789 ;; '(a . (b . c))
|
|
|
790
|
|
|
791 ;; Vectors: [a b]
|
|
|
792 (set-macro-character ?\[
|
|
|
793 (function
|
|
|
794 (lambda (stream char)
|
|
|
795 (reader::read-sexp (1- (point))
|
|
|
796 (let ((reader::context 'vector))
|
|
|
797 (catch 'read-vector
|
|
|
798 (let ((reader::context 'vector)
|
|
|
799 reader::stack)
|
|
|
800 (while t (push (reader::read-from-buffer stream 't)
|
|
|
801 reader::stack)))))))))
|
|
|
802
|
|
|
803 (set-macro-character ?\]
|
|
|
804 (function
|
|
|
805 (lambda (stream char)
|
|
|
806 (if (eq reader::context 'vector)
|
|
|
807 (throw 'read-vector (apply 'vector (nreverse reader::stack)))
|
|
|
808 (reader::error "`]' doesn't end a vector")))))
|
|
|
809
|
|
|
810 ;; Quote and backquote/comma macro
|
|
|
811 (set-macro-character ?\'
|
|
|
812 (function
|
|
|
813 (lambda (stream char)
|
|
|
814 (reader::read-sexp (1- (point))
|
|
|
815 (list (reader::read-sexp (point) 'quote)
|
|
|
816 (reader::read-from-buffer stream 't))))))
|
|
|
817
|
|
|
818 (set-macro-character ?\`
|
|
|
819 (function
|
|
|
820 (lambda (stream char)
|
|
|
821 (if (= (following-char) ?\ )
|
|
|
822 ;; old backquote syntax. This is ambigous, because
|
|
|
823 ;; (`(sexp)) is a valid form in both syntaxes, but
|
|
|
824 ;; unfortunately not the same.
|
|
|
825 ;; old syntax: read -> (` (sexp))
|
|
|
826 ;; new syntax: read -> ((` (sexp)))
|
|
|
827 (reader::read-sexp (1- (point)) '\`)
|
|
|
828 (reader::read-sexp (1- (point))
|
|
|
829 (list (reader::read-sexp (point) '\`)
|
|
|
830 (reader::read-from-buffer stream 't)))))))
|
|
|
831
|
|
|
832 (set-macro-character ?\,
|
|
|
833 (function
|
|
|
834 (lambda (stream char)
|
|
|
835 (cond ((eq (following-char) ?\ )
|
|
|
836 ;; old syntax
|
|
|
837 (reader::read-sexp (point) '\,))
|
|
|
838 ((eq (following-char) ?\@)
|
|
|
839 (forward-char 1)
|
|
|
840 (cond ((eq (following-char) ?\ )
|
|
|
841 (reader::read-sexp (point) '\,\@))
|
|
|
842 (t
|
|
|
843 (reader::read-sexp (- (point) 2)
|
|
|
844 (list
|
|
|
845 (reader::read-sexp (point) '\,\@)
|
|
|
846 (reader::read-from-buffer stream 't))))))
|
|
|
847 (t
|
|
|
848 (reader::read-sexp (1- (point))
|
|
|
849 (list
|
|
|
850 (reader::read-sexp (1- (point)) '\,)
|
|
|
851 (reader::read-from-buffer stream 't))))))))
|
|
|
852
|
|
|
853 ;; 'a
|
|
|
854 ;; '(a b c)
|
|
|
855 ;; (let ((a 10) (b '(20 30))) `(,a ,@b c))
|
|
|
856 ;; the old syntax is also supported:
|
|
|
857 ;; (let ((a 10) (b '(20 30))) (` ((, a) (,@ b) c)))
|
|
|
858
|
|
|
859 ;; Single line character comment: ;
|
|
|
860 (set-macro-character ?\;
|
|
|
861 (function
|
|
|
862 (lambda (stream char)
|
|
|
863 (skip-chars-forward "^\n\r")
|
|
|
864 (throw 'reader-ignore nil))))
|
|
|
865
|
|
|
866
|
|
|
867
|
|
|
868 ;; Dispatch character character #
|
|
|
869 (make-dispatch-macro-character ?\#)
|
|
|
870
|
|
|
871 (defsubst reader::check-0-infix (n)
|
|
|
872 (or (= n 0)
|
|
|
873 (reader::error "Numeric infix argument not allowed: %d" n)))
|
|
|
874
|
|
|
875
|
|
|
876 (defalias 'search-forward-regexp 're-search-forward)
|
|
|
877
|
|
|
878 ;; nested multi-line comments #| ... |#
|
|
|
879 (set-dispatch-macro-character ?\# ?\|
|
|
|
880 (function
|
|
|
881 (lambda (stream char n)
|
|
|
882 (reader::check-0-infix n)
|
|
|
883 (let ((counter 0))
|
|
|
884 (while (search-forward-regexp "#|\\||#" nil t)
|
|
|
885 (if (string-equal
|
|
|
886 (buffer-substring
|
|
|
887 (match-beginning 0) (match-end 0))
|
|
|
888 "|#")
|
|
|
889 (cond ((> counter 0)
|
|
|
890 (decf counter))
|
|
|
891 ((= counter 0)
|
|
|
892 ;; stop here
|
|
|
893 (goto-char (match-end 0))
|
|
|
894 (throw 'reader-ignore nil))
|
|
|
895 ('t
|
|
|
896 (reader::error "Unmatching closing multicomment")))
|
|
|
897 (incf counter)))
|
|
|
898 (reader::error "Unmatching opening multicomment")))))
|
|
|
899
|
|
|
900 ;; From cl-packages.el
|
|
|
901 (defconst reader::symbol-characters "[A-Za-z0-9-_!@$%^&*+=|~{}<>/]")
|
|
|
902 (defconst reader::symbol-regexp2
|
|
|
903 (format "\\(%s+\\)" reader::symbol-characters))
|
|
|
904
|
|
|
905 (set-dispatch-macro-character ?\# ?\:
|
|
|
906 (function
|
|
|
907 (lambda (stream char n)
|
|
|
908 (reader::check-0-infix n)
|
|
|
909 (or (looking-at reader::symbol-regexp2)
|
|
|
910 (reader::error "Invalid symbol read syntax"))
|
|
|
911 (goto-char (match-end 0))
|
|
|
912 (make-symbol
|
|
|
913 (buffer-substring (match-beginning 0) (match-end 0))))))
|
|
|
914
|
|
|
915 ;; Function quoting: #'<function>
|
|
|
916 (set-dispatch-macro-character ?\# ?\'
|
|
|
917 (function
|
|
|
918 (lambda (stream char n)
|
|
|
919 (reader::check-0-infix n)
|
|
|
920 ;; Probably should test if cl is required by current buffer.
|
|
|
921 ;; Currently, cl will always be a feature because cl-read requires it.
|
|
|
922 (reader::read-sexp (- (point) 2)
|
|
|
923 (list
|
|
|
924 (reader::read-sexp (point) (if (featurep 'cl) 'function* 'function))
|
|
|
925 (reader::read-from-buffer stream 't))))))
|
|
|
926
|
|
|
927 ;; Character syntax: #\<char>
|
|
|
928 ;; Not yet implemented: #\Control-a #\M-C-a etc.
|
|
|
929 ;; This definition is not used - the next one is more general.
|
|
|
930 '(set-dispatch-macro-character ?# ?\\
|
|
|
931 (function
|
|
|
932 (lambda (stream char n)
|
|
|
933 (reader::check-0-infix n)
|
|
|
934 (let ((next (following-char))
|
|
|
935 name)
|
|
|
936 (if (not (and (<= ?a next) (<= next ?z)))
|
|
|
937 (progn (forward-char 1) next)
|
|
|
938 (setq next (reader::read-from-buffer stream t))
|
|
|
939 (cond ((symbolp next) (setq name (symbol-name next)))
|
|
|
940 ((integerp next) (setq name (int-to-string next))))
|
|
|
941 (if (= 1 (length name))
|
|
|
942 (string-to-char name)
|
|
|
943 (case next
|
|
|
944 (linefeed ?\n)
|
|
|
945 (newline ?\r)
|
|
|
946 (space ?\ )
|
|
|
947 (rubout ?\b)
|
|
|
948 (page ?\f)
|
|
|
949 (tab ?\t)
|
|
|
950 (return ?\C-m)
|
|
|
951 (t
|
|
|
952 (reader::error "Unknown character specification `%s'"
|
|
|
953 next))))))))
|
|
|
954 )
|
|
|
955
|
|
|
956 (defvar reader::special-character-name-table
|
|
|
957 '(("linefeed" . ?\n)
|
|
|
958 ("newline" . ?\r)
|
|
|
959 ("space" . ?\ )
|
|
|
960 ("rubout" . ?\b)
|
|
|
961 ("page" . ?\f)
|
|
|
962 ("tab" . ?\t)
|
|
|
963 ("return" . ?\C-m)))
|
|
|
964
|
|
|
965 (set-dispatch-macro-character ?# ?\\
|
|
|
966 (function
|
|
|
967 (lambda (stream char n)
|
|
|
968 (reader::check-0-infix n)
|
|
|
969 (forward-char -1)
|
|
|
970 ;; We should read in a special package to avoid creating symbols.
|
|
|
971 (let ((symbol (reader::read-from-buffer stream t))
|
|
|
972 (case-fold-search t)
|
|
|
973 name modifier character char-base)
|
|
|
974 (setq name (symbol-name symbol))
|
|
|
975 (if (string-match "^\\(meta-\\|m-\\|control-\\|c-\\)+" name)
|
|
|
976 (setq modifier (substring name
|
|
|
977 (match-beginning 1)
|
|
|
978 (match-end 1))
|
|
|
979 character (substring name (match-end 1)))
|
|
|
980 (setq character name))
|
|
|
981 (setq char-base
|
|
|
982 (cond ((= (length character) 1)
|
|
|
983 (string-to-char character))
|
|
|
984 ('t
|
|
|
985 (cdr (assoc character
|
|
|
986 reader::special-character-name-table)))))
|
|
|
987 (or char-base
|
|
|
988 (reader::error
|
|
|
989 "Unknown character specification `%s'" character))
|
|
|
990
|
|
|
991 (and modifier
|
|
|
992 (progn
|
|
|
993 (and (string-match "control-\\|c-" modifier)
|
|
|
994 (decf char-base 32))
|
|
|
995 (and (string-match "meta-\\|m-" modifier)
|
|
|
996 (incf char-base 128))))
|
|
|
997 char-base))))
|
|
|
998
|
|
|
999 ;; '(#\meta-space #\tab #\# #\> #\< #\a #\A #\return #\space)
|
|
|
1000 ;; (eq #\m-tab ?\M-\t)
|
|
|
1001 ;; (eq #\c-m-x #\m-c-x)
|
|
|
1002 ;; (eq #\Meta-Control-return #\M-C-return)
|
|
|
1003 ;; (eq #\m-m-c-c-x #\m-c-x)
|
|
|
1004 ;; #\C-space #\C-@ ?\C-@
|
|
|
1005
|
|
|
1006
|
|
|
1007
|
|
|
1008 ;; Read and load time evaluation: #.<form>
|
|
|
1009 ;; Not yet implemented: #,<form>
|
|
|
1010 (set-dispatch-macro-character ?\# ?\.
|
|
|
1011 (function
|
|
|
1012 (lambda (reader::stream reader::char reader::n)
|
|
|
1013 (reader::check-0-infix reader::n)
|
|
|
1014 ;; This eval will see all internal vars of reader,
|
|
|
1015 ;; e.g. stream, reader::recursive-p. Anything that might be bound.
|
|
|
1016 ;; We must use `read' here rather than read-from-buffer with 'recursive-p
|
|
|
1017 ;; because the expression must not have unresolved #n#s in it anyway.
|
|
|
1018 ;; Otherwise the top-level expression must be completely read before
|
|
|
1019 ;; any embedded evaluation(s) occur(s). CLtL2 does not specify this.
|
|
|
1020 ;; Also, call `read' so that it may be customized, by e.g. Edebug
|
|
|
1021 (eval (read reader::stream)))))
|
|
|
1022 ;; '(#.(current-buffer) #.(get-buffer "*scratch*"))
|
|
|
1023
|
|
|
1024 ;; Path names (kind of): #p<string>, #P<string>,
|
|
|
1025 (set-dispatch-macro-character ?\# ?\P
|
|
|
1026 (function
|
|
|
1027 (lambda (stream char n)
|
|
|
1028 (reader::check-0-infix n)
|
|
|
1029 (let ((string (reader::read-from-buffer stream 't)))
|
|
|
1030 (or (stringp string)
|
|
|
1031 (reader::error "Pathname must be a string: %s" string))
|
|
|
1032 (expand-file-name string)))))
|
|
|
1033
|
|
|
1034 (set-dispatch-macro-character ?\# ?\p
|
|
|
1035 (get-dispatch-macro-character ?\# ?\P))
|
|
|
1036
|
|
|
1037 ;; #P"~/.emacs"
|
|
|
1038 ;; #p"~root/home"
|
|
|
1039
|
|
|
1040 ;; Feature reading: #+<feature>, #-<feature>
|
|
|
1041 ;; Not yet implemented: #+<boolean expression>, #-<boolean expression>
|
|
|
1042
|
|
|
1043
|
|
|
1044 (defsubst reader::read-feature (stream char n flag)
|
|
|
1045 (reader::check-0-infix n)
|
|
|
1046 (let (;; Use the original reader to only read the feature.
|
|
|
1047 ;; This is not exactly correct without *read-suppress*.
|
|
|
1048 ;; Also Emacs 18 read goes one too far,
|
|
|
1049 ;; so we assume there is a space after the feature.
|
|
|
1050 (feature (reader::original-read stream))
|
|
|
1051 (object (reader::read-from-buffer stream 't)))
|
|
|
1052 (if (eq (featurep feature) flag)
|
|
|
1053 object
|
|
|
1054 ;; Ignore it.
|
|
|
1055 (throw 'reader-ignore nil))))
|
|
|
1056
|
|
|
1057 (set-dispatch-macro-character ?\# ?\+
|
|
|
1058 (function
|
|
|
1059 (lambda (stream char n)
|
|
|
1060 (reader::read-feature stream char n t))))
|
|
|
1061
|
|
|
1062 (set-dispatch-macro-character ?\# ?\-
|
|
|
1063 (function
|
|
|
1064 (lambda (stream char n)
|
|
|
1065 (reader::read-feature stream char n nil))))
|
|
|
1066
|
|
|
1067 ;; (#+cl loop #+cl do #-cl while #-cl t (body))
|
|
|
1068
|
|
|
1069
|
|
|
1070
|
|
|
1071
|
|
|
1072 ;; Shared structure reading: #<n>=, #<n>#
|
|
|
1073
|
|
|
1074 ;; Reading of sexpression with shared and circular structure read
|
|
|
1075 ;; syntax is done in two steps:
|
|
|
1076 ;;
|
|
|
1077 ;; 1. Create an sexpr with unshared structures, just as the ordinary
|
|
|
1078 ;; read macros do, with two exceptions:
|
|
|
1079 ;; - each label (#<n>=) creates, as a side effect, a symbolic
|
|
|
1080 ;; reference for the sexpr that follows it
|
|
|
1081 ;; - each reference (#<n>#) is replaced by the corresponding
|
|
|
1082 ;; symbolic reference.
|
|
|
1083 ;;
|
|
|
1084 ;; 2. This non-cyclic and unshared lisp structure is given to the
|
|
|
1085 ;; function `reader::restore-shared-structure' (see
|
|
|
1086 ;; `reader::read-from-buffer'), which simply replaces
|
|
|
1087 ;; destructively all symbolic references by the lisp structures the
|
|
|
1088 ;; references point at.
|
|
|
1089 ;;
|
|
|
1090 ;; A symbolic reference is an uninterned symbol whose name is obtained
|
|
|
1091 ;; from the label/reference number using the function `int-to-string':
|
|
|
1092 ;;
|
|
|
1093 ;; There are two non-locally used variables (bound in
|
|
|
1094 ;; `reader::read-from-buffer') which control shared structure reading:
|
|
|
1095 ;; `reader::shared-structure-labels':
|
|
|
1096 ;; A list of integers that correspond to the label numbers <n> in
|
|
|
1097 ;; the string currently read. This is used to avoid multiple
|
|
|
1098 ;; definitions of the same label.
|
|
|
1099 ;; `reader::shared-structure-references':
|
|
|
1100 ;; The list of symbolic references that will be used as temporary
|
|
|
1101 ;; placeholders for the shared objects introduced by a reference
|
|
|
1102 ;; with the same number identification.
|
|
|
1103
|
|
|
1104 (set-dispatch-macro-character ?\# ?\=
|
|
|
1105 (function
|
|
|
1106 (lambda (stream char n)
|
|
|
1107 (and (= n 0) (reader::error "0 not allowed as label"))
|
|
|
1108 ;; check for multiple definition of the same label
|
|
|
1109 (if (memq n reader::shared-structure-labels)
|
|
|
1110 (reader::error "Label defined twice")
|
|
|
1111 (push n reader::shared-structure-labels))
|
|
|
1112 ;; create an uninterned symbol as symbolic reference for the label
|
|
|
1113 (let* ((string (int-to-string n))
|
|
|
1114 (ref (or (find string reader::shared-structure-references
|
|
|
1115 :test 'string=)
|
|
|
1116 (first
|
|
|
1117 (push (make-symbol string)
|
|
|
1118 reader::shared-structure-references)))))
|
|
|
1119 ;; the link between the symbolic reference and the lisp
|
|
|
1120 ;; structure it points at is done using the symbol value cell
|
|
|
1121 ;; of the reference symbol.
|
|
|
1122 (setf (symbol-value ref)
|
|
|
1123 ;; this is also the return value
|
|
|
1124 (reader::read-from-buffer stream 't))))))
|
|
|
1125
|
|
|
1126
|
|
|
1127 (set-dispatch-macro-character ?\# ?\#
|
|
|
1128 (function
|
|
|
1129 (lambda (stream char n)
|
|
|
1130 (and (= n 0) (reader::error "0 not allowed as label"))
|
|
|
1131 ;; use the non-local variable `reader::recursive-p' (from the reader
|
|
|
1132 ;; main loop) to detect labels at the top level of an sexpr.
|
|
|
1133 (if (not reader::recursive-p)
|
|
|
1134 (reader::error "References at top level not allowed"))
|
|
|
1135 (let* ((string (int-to-string n))
|
|
|
1136 (ref (or (find string reader::shared-structure-references
|
|
|
1137 :test 'string=)
|
|
|
1138 (first
|
|
|
1139 (push (make-symbol string)
|
|
|
1140 reader::shared-structure-references)))))
|
|
|
1141 ;; the value of reading a #n# form is a reference symbol
|
|
|
1142 ;; whose symbol value is or will be the shared structure.
|
|
|
1143 ;; `reader::restore-shared-structure' then replaces the symbol by
|
|
|
1144 ;; its value.
|
|
|
1145 ref))))
|
|
|
1146
|
|
|
1147 (defun reader::restore-shared-structure (obj)
|
|
|
1148 ;; traverses recursively OBJ and replaces all symbolic references by
|
|
|
1149 ;; the objects they point at. Remember that a symbolic reference is
|
|
|
1150 ;; an uninterned symbol whose value is the object it points at.
|
|
|
1151 (cond
|
|
|
1152 ((consp obj)
|
|
|
1153 (loop for rest on obj
|
|
|
1154 as lastcdr = rest
|
|
|
1155 do
|
|
|
1156 (if;; substructure is a symbolic reference
|
|
|
1157 (memq (car rest) reader::shared-structure-references)
|
|
|
1158 ;; replace it by its symbol value, i.e. the associated object
|
|
|
1159 (setf (car rest) (symbol-value (car rest)))
|
|
|
1160 (reader::restore-shared-structure (car rest)))
|
|
|
1161 finally
|
|
|
1162 (if (memq (cdr lastcdr) reader::shared-structure-references)
|
|
|
1163 (setf (cdr lastcdr) (symbol-value (cdr lastcdr)))
|
|
|
1164 (reader::restore-shared-structure (cdr lastcdr)))))
|
|
|
1165 ((vectorp obj)
|
|
|
1166 (loop for i below (length obj)
|
|
|
1167 do
|
|
|
1168 (if;; substructure is a symbolic reference
|
|
|
1169 (memq (aref obj i) reader::shared-structure-references)
|
|
|
1170 ;; replace it by its symbol value, i.e. the associated object
|
|
|
1171 (setf (aref obj i) (symbol-value (aref obj i)))
|
|
|
1172 (reader::restore-shared-structure (aref obj i))))))
|
|
|
1173 obj)
|
|
|
1174
|
|
|
1175
|
|
|
1176 ;; #1=(a b #3=[#2=c])
|
|
|
1177 ;; (#1=[#\return #\a] #1# #1#)
|
|
|
1178 ;; (#1=[a b c] #1# #1#)
|
|
|
1179 ;; #1=(a b . #1#)
|
|
|
1180
|
|
|
1181 ;; Creation and initialization of an internal standard readtable.
|
|
|
1182 ;; Do this after all the macros and dispatch chars above have been defined.
|
|
|
1183
|
|
|
1184 (defconst reader::internal-standard-readtable (copy-readtable)
|
|
|
1185 "The original (CL-like) standard readtable. If you ever modify this
|
|
|
1186 readtable, you won't be able to recover a standard readtable using
|
|
|
1187 \(copy-readtable nil\)")
|
|
|
1188
|
|
|
1189
|
|
|
1190 ;; Replace built-in functions that call the built-in reader
|
|
|
1191 ;;
|
|
|
1192 ;; The following functions are replaced here:
|
|
|
1193 ;;
|
|
|
1194 ;; read by reader::read
|
|
|
1195 ;; read-from-string by reader::read-from-string
|
|
|
1196 ;;
|
|
|
1197 ;; eval-expression by reader::eval-expression
|
|
|
1198 ;; Why replace eval-expression? Not needed for Lucid Emacs since the
|
|
|
1199 ;; reader for arguments is also written in Lisp, and so may be overridden.
|
|
|
1200 ;;
|
|
|
1201 ;; eval-current-buffer by reader::eval-current-buffer
|
|
|
1202 ;; eval-buffer by reader::eval-buffer
|
|
|
1203 ;; original-eval-region by reader::original-eval-region
|
|
|
1204
|
|
|
1205
|
|
|
1206 ;; Temporary read buffer used for reading from strings
|
|
|
1207 (defconst reader::tmp-buffer
|
|
|
1208 (get-buffer-create " *CL Read*"))
|
|
|
1209
|
|
|
1210 ;; Save a pointer to the original read function
|
|
|
1211 (or (fboundp 'reader::original-read)
|
|
|
1212 (fset 'reader::original-read (symbol-function 'read)))
|
|
|
1213
|
|
|
1214 (defun reader::read (&optional stream reader::recursive-p)
|
|
|
1215 "Read one Lisp expression as text from STREAM, return as Lisp object.
|
|
|
1216 If STREAM is nil, use the value of `standard-input' \(which see\).
|
|
|
1217 STREAM or the value of `standard-input' may be:
|
|
|
1218 a buffer \(read from point and advance it\)
|
|
|
1219 a marker \(read from where it points and advance it\)
|
|
|
1220 a string \(takes text from string, starting at the beginning\)
|
|
|
1221 t \(read text line using minibuffer and use it\).
|
|
|
1222
|
|
|
1223 This is the cl-read replacement of the standard elisp function
|
|
|
1224 `read'. The only incompatibility is that functions as stream arguments
|
|
|
1225 are not supported."
|
|
|
1226 (if (not cl-read-active)
|
|
|
1227 (reader::original-read stream)
|
|
|
1228 (if (null stream) ; read from standard-input
|
|
|
1229 (setq stream standard-input))
|
|
|
1230
|
|
|
1231 (if (eq stream 't) ; read from minibuffer
|
|
|
1232 (setq stream (read-from-minibuffer "Common Lisp Expression: ")))
|
|
|
1233
|
|
|
1234 (cond
|
|
|
1235
|
|
|
1236 ((bufferp stream) ; read from buffer
|
|
|
1237 (reader::read-from-buffer stream reader::recursive-p))
|
|
|
1238
|
|
|
1239 ((markerp stream) ; read from marker
|
|
|
1240 (save-excursion
|
|
|
1241 (set-buffer (marker-buffer stream))
|
|
|
1242 (goto-char (marker-position stream))
|
|
|
1243 (reader::read-from-buffer (current-buffer) reader::recursive-p)))
|
|
|
1244
|
|
|
1245 ((stringp stream) ; read from string
|
|
|
1246 (save-excursion
|
|
|
1247 (set-buffer reader::tmp-buffer)
|
|
|
1248 (auto-save-mode -1)
|
|
|
1249 (erase-buffer)
|
|
|
1250 (insert stream)
|
|
|
1251 (goto-char (point-min))
|
|
|
1252 (reader::read-from-buffer reader::tmp-buffer reader::recursive-p)))
|
|
|
1253 (t
|
|
|
1254 (reader::error "Not a valid stream: %s" stream)))))
|
|
|
1255
|
|
|
1256 ;; read-from-string
|
|
|
1257 ;; save a pointer to the original `read-from-string' function
|
|
|
1258 (or (fboundp 'reader::original-read-from-string)
|
|
|
1259 (fset 'reader::original-read-from-string
|
|
|
1260 (symbol-function 'read-from-string)))
|
|
|
1261
|
|
|
1262 (defun reader::read-from-string (string &optional start end)
|
|
|
1263 "Read one Lisp expression which is represented as text by STRING.
|
|
|
1264 Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).
|
|
|
1265 START and END optionally delimit a substring of STRING from which to read;
|
|
|
1266 they default to 0 and (length STRING) respectively.
|
|
|
1267
|
|
|
1268 This is the cl-read replacement of the standard elisp function
|
|
|
1269 `read-from-string'. It uses the reader macros in *readtable* if
|
|
|
1270 `cl-read-active' is non-nil in the current buffer."
|
|
|
1271
|
|
|
1272 ;; Does it really make sense to have read-from-string depend on
|
|
|
1273 ;; what the current buffer happens to be? Yes, so code that
|
|
|
1274 ;; has nothing to do with cl-read uses original reader.
|
|
|
1275 (if (not cl-read-active)
|
|
|
1276 (reader::original-read-from-string string start end)
|
|
|
1277 (or start (setq start 0))
|
|
|
1278 (or end (setq end (length string)))
|
|
|
1279 (save-excursion
|
|
|
1280 (set-buffer reader::tmp-buffer)
|
|
|
1281 (auto-save-mode -1)
|
|
|
1282 (erase-buffer)
|
|
|
1283 (insert (substring string 0 end))
|
|
|
1284 (goto-char (1+ start))
|
|
|
1285 (cons
|
|
|
1286 (reader::read-from-buffer reader::tmp-buffer nil)
|
|
|
1287 (1- (point))))))
|
|
|
1288
|
|
|
1289 ;; (read-from-string "abc (car 'a) bc" 4)
|
|
|
1290 ;; (reader::read-from-string "abc (car 'a) bc" 4)
|
|
|
1291 ;; (read-from-string "abc (car 'a) bc" 2 11)
|
|
|
1292 ;; (reader::read-from-string "abc (car 'a) bc" 2 11)
|
|
|
1293 ;; (reader::read-from-string "`(car ,first ,@rest)")
|
|
|
1294 ;; (read-from-string ";`(car ,first ,@rest)")
|
|
|
1295 ;; (reader::read-from-string ";`(car ,first ,@rest)")
|
|
|
1296
|
|
|
1297 ;; We should replace eval-expression, too, so that it reads (and
|
|
|
1298 ;; evals) in the current buffer. Alternatively, this could be fixed
|
|
|
1299 ;; in C. In Lemacs 19.6 and later, this function is already written
|
|
|
1300 ;; in lisp, and based on more primitive read functions we already
|
|
|
1301 ;; replaced. The reading happens during the interactive parameter
|
|
|
1302 ;; retrieval, which is written in lisp, too. So this replacement of
|
|
|
1303 ;; eval-expresssion is only required fro (FSF) Emacs 18 (and 19?).
|
|
|
1304
|
|
|
1305 (or (fboundp 'reader::original-eval-expression)
|
|
|
1306 (fset 'reader::original-eval-expression
|
|
|
1307 (symbol-function 'eval-expression)))
|
|
|
1308
|
|
|
1309 (defun reader::eval-expression (reader::expression)
|
|
|
1310 "Evaluate EXPRESSION and print value in minibuffer.
|
|
|
1311 Value is also consed on to front of variable `values'."
|
|
|
1312 (interactive
|
|
|
1313 (list
|
|
|
1314 (car (read-from-string
|
|
|
1315 (read-from-minibuffer
|
|
|
1316 "Eval: " nil
|
|
|
1317 ;;read-expression-map ;; not for emacs 18
|
|
|
1318 nil ;; use default map
|
|
|
1319 nil ;; don't do read with minibuffer current.
|
|
|
1320 ;; 'edebug-expression-history ;; not for emacs 18
|
|
|
1321 )))))
|
|
|
1322 (setq values (cons (eval reader::expression) values))
|
|
|
1323 (prin1 (car values) t))
|
|
|
1324
|
|
|
1325 (require 'eval-reg "eval-reg")
|
|
4
|
1326 ; (require 'advice)
|
|
0
|
1327
|
|
|
1328
|
|
|
1329 ;; installing/uninstalling the cl reader
|
|
|
1330 ;; These two should always be used in pairs, or just install once and
|
|
|
1331 ;; never uninstall.
|
|
|
1332 (defun cl-reader-install ()
|
|
|
1333 (interactive)
|
|
|
1334 (fset 'read 'reader::read)
|
|
|
1335 (fset 'read-from-string 'reader::read-from-string)
|
|
|
1336 (fset 'eval-expression 'reader::eval-expression)
|
|
|
1337 (elisp-eval-region-install))
|
|
|
1338
|
|
|
1339 (defun cl-reader-uninstall ()
|
|
|
1340 (interactive)
|
|
|
1341 (fset 'read
|
|
|
1342 (symbol-function 'reader::original-read))
|
|
|
1343 (fset 'read-from-string
|
|
|
1344 (symbol-function 'reader::original-read-from-string))
|
|
|
1345 (fset 'eval-expression
|
|
|
1346 (symbol-function 'reader::original-eval-expression))
|
|
|
1347 (elisp-eval-region-uninstall))
|
|
|
1348
|
|
|
1349 ;; Globally installing the cl-read replacement functions is safe, even
|
|
|
1350 ;; for buffers without cl read syntax. The buffer local variable
|
|
|
1351 ;; `cl-read-active' controls whether the replacement funtions of this
|
|
|
1352 ;; package or the original ones are actually called.
|
|
|
1353 (cl-reader-install)
|
|
|
1354 (cl-reader-uninstall)
|
|
|
1355
|
|
|
1356 (add-hook 'emacs-lisp-mode-hook 'cl-reader-autoinstall-function)
|
|
|
1357
|
|
|
1358 '(defvar read-syntax)
|
|
|
1359
|
|
|
1360 '(defun cl-reader-autoinstall-function ()
|
|
|
1361 "Activates the Common Lisp style reader for emacs-lisp-mode buffers,
|
|
|
1362 if the property line has a local variable setting like this:
|
|
|
1363 \;\; -*- Read-Syntax: Common-Lisp -*-"
|
|
|
1364 ;; this is a hack to avoid recursion in the case that the prop line
|
|
|
1365 ;; containes "Mode: emacs-lisp" entry
|
|
|
1366 (or (boundp 'local-variable-hack-done)
|
|
|
1367 (let (local-variable-hack-done
|
|
|
1368 (case-fold-search t))
|
|
|
1369 ;; Usually `hack-local-variables-prop-line' is called only after
|
|
|
1370 ;; installation of the major mode. But we need to know about the
|
|
|
1371 ;; local variables before that, so we call the local variable hack
|
|
|
1372 ;; explicitly here:
|
|
|
1373 (hack-local-variables-prop-line 't)
|
|
|
1374 ;; But hack-local-variables-prop-line not defined in emacs 18.
|
|
|
1375 (cond
|
|
|
1376 ((and (boundp 'read-syntax)
|
|
|
1377 read-syntax
|
|
|
1378 (string-match "^common-lisp$" (symbol-name read-syntax)))
|
|
|
1379 (require 'cl-read)
|
|
|
1380 (make-local-variable 'cl-read-active)
|
|
|
1381 (setq cl-read-active 't))))))
|
|
|
1382
|
|
|
1383 ;; Emacs 18 doesnt have hack-local-variables-prop-line. So use this instead.
|
|
|
1384 (defun cl-reader-autoinstall-function ()
|
|
|
1385 (save-excursion
|
|
|
1386 (goto-char (point-min))
|
|
|
1387 (let ((case-fold-search t))
|
|
|
1388 (cond ((re-search-forward
|
|
|
1389 "read-syntax: *common-lisp"
|
|
|
1390 (save-excursion
|
|
|
1391 (end-of-line)
|
|
|
1392 (point))
|
|
|
1393 t)
|
|
|
1394 (require 'cl-read)
|
|
|
1395 (make-local-variable 'cl-read-active)
|
|
|
1396 (setq cl-read-active t))))))
|
|
|
1397
|
|
|
1398
|
|
|
1399 (run-hooks 'cl-read-load-hooks)
|
|
4
|
1400
|
|
|
1401 ;; cl-read.el ends here
|
