/[advanced-readtable]/src.lisp
ViewVC logotype

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 5 - (show annotations)
Sat Dec 8 18:04:29 2012 UTC (16 months, 2 weeks ago) by rklochkov
File size: 13599 byte(s)
Fixed bug: (cl:+ 2 2) hadn't parsed.
1 (in-package #:advanced-readtable)
2
3 ;;; Advanced-readtable
4 ;;;
5 ;;; per-package aliases for packages
6 ;;; per-package shortcuts for package hierarchies
7 ;;; extendable find-package and find-symbol
8 ;;; local use pcakage in form package:(here form where package used)
9 ;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern
10 ;;; package::symbol1 and package::symbol2
11
12 (defvar *per-package-finders* (make-hash-table :test 'eq)
13 "Hash package -> list of handlers")
14 (defvar *package-finders* nil
15 "List of handlers (lambda (name package) ...) -> package")
16
17
18
19
20 ;;;
21 ;;; Prepare readtables
22 ;;;
23
24
25
26 (defvar *advanced-readtable* (copy-readtable nil))
27 (defvar *colon-readtable* (copy-readtable nil)
28 "Support readtable with colon as whitespace")
29
30 ;;;
31 ;;; Readtable handlers
32 ;;;
33
34 (defpackage #:advanced-readtable.junk)
35
36
37
38 (defun try-funcall (handlers-list name package)
39 (declare (type list handlers-list)
40 (type string name)
41 (type (or null package) package))
42 (when handlers-list
43 (or (funcall (car handlers-list) name package)
44 (try-funcall (cdr handlers-list) name package))))
45
46 (defun find-package (name &optional (current-package *package*))
47 (declare (type (or null package) current-package))
48 (if (typep name 'package) name
49 (let ((sname (string name)))
50 (or
51 (when current-package
52 (try-funcall (package-finders current-package) sname current-package))
53 (try-funcall *package-finders* sname current-package)
54 (cl:find-package name)))))
55
56 (defvar *package-symbol-finders* (make-hash-table :test 'eq)
57 "Hash package -> list of handlers")
58 (defvar *symbol-finders* nil
59 "List of handlers (lambda (name package) ...) -> symbol")
60 (defvar *extra-finders* (make-hash-table :test 'eq)
61 "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol
62 These will be used before CL:FIND-SYMBOL")
63
64 (defvar *symbol-readmacros* (make-hash-table :test 'eq))
65 (defvar *disable-symbol-readmacro* nil
66 "Disables processing of symbol-readmacro.")
67
68 (defun def-symbol-readmacro (symbol func)
69 (setf (gethash symbol *symbol-readmacros*) func))
70
71 (defun set-macro-symbol (symbol func)
72 "Syntax is like set-macro-character,
73 except that FUNC is binded to SYMBOL, not character"
74 (setf (gethash symbol *symbol-readmacros*) func))
75
76 (defun get-macro-symbol (symbol)
77 "Syntax is like get-macro-character.
78 Returns function, assigned by set-macro-symbol"
79 (gethash symbol *symbol-readmacros*))
80
81 (defun process-symbol-readmacro (symbol stream)
82 (let ((func (gethash symbol *symbol-readmacros*)))
83 (if func (funcall func stream symbol) symbol)))
84
85 ;;; Internal special variables. Do not export
86
87 (defvar *extra-symbol-finders* nil
88 "List of handlers: handlers for symbol, car of list")
89 (defvar *car-list* nil "Boolean: iff reader in list and car is not read")
90 (defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
91
92 (defun try-local-packages (packages name)
93 (when packages
94 (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
95 (if symbol
96 (values symbol status)
97 (try-local-packages (cdr packages) name)))))
98
99 (defun try-mv-funcall (handlers-list name package)
100 "Returns symbol, status"
101 (declare (type list handlers-list)
102 (type string name)
103 (type (or null package) package))
104 (when handlers-list
105 (multiple-value-bind (symbol status)
106 (funcall (car handlers-list) name package)
107 (if symbol
108 (values symbol status)
109 (try-funcall (cdr handlers-list) name package)))))
110
111
112 (defun find-symbol (name &optional dpackage)
113 (declare (type string name))
114 (let ((package (find-package dpackage)))
115 (macrolet ((mv-or (&rest clauses)
116 (if clauses
117 `(multiple-value-bind (symbol status) ,(car clauses)
118 (if symbol (values symbol status)
119 (mv-or . ,(cdr clauses))))
120 `(values nil nil))))
121
122 (mv-or
123 (try-mv-funcall *extra-symbol-finders* name package)
124 (unless package (try-local-packages *local-packages* name))
125 (when package (try-mv-funcall (symbol-finders package) name package))
126 (try-mv-funcall *symbol-finders* name package)
127 (if package
128 (cl:find-symbol name package)
129 (cl:find-symbol name))))))
130
131 (defun read-token (stream)
132 "
133 DO: Reads from STREAM a symbol or number up to whitespace or colon
134 RETURN: symbols name or numbers value"
135 (let ((*readtable* *colon-readtable*)
136 (*package* (cl:find-package '#:advanced-readtable.junk)))
137 (read-preserving-whitespace stream nil)))
138
139 (defun count-colons (stream)
140 "
141 DO: Reads colons from STREAM
142 RETURN: number of the colons"
143 (let ((c (read-char stream nil)))
144 (if (eql c #\:)
145 (+ 1 (count-colons stream))
146 (progn (unread-char c stream) 0))))
147
148 (defun read-after-colon (stream maybe-package colons)
149 "Read symbol package:sym or list package:(...)"
150 (when (= colons 0)
151 (return-from read-after-colon
152 (if (symbolp maybe-package)
153 (let ((name (symbol-name maybe-package)))
154 (or (find-symbol name)(intern name)))
155 maybe-package)))
156
157 (let ((package (find-package maybe-package)))
158 (assert package (package) "No package ~a" maybe-package)
159 (unintern maybe-package)
160 (when (eql (peek-char t stream) #\()
161 ;; package:(...) or package::(...)
162 (ecase colons
163 (1 (let ((*local-packages* (cons package *local-packages*)))
164 (return-from read-after-colon
165 (read stream nil))))
166 (2 (let ((*package* package))
167 (return-from read-after-colon
168 (read stream nil))))))
169
170 (let ((token (read-token stream)))
171 (check-type token symbol)
172 (multiple-value-bind (symbol status)
173 (find-symbol (symbol-name token) package)
174 (unintern token)
175 (when (and (= colons 1) (not (eq status :external)))
176 (cerror "Use anyway"
177 "Symbol ~A not external" symbol))
178 symbol))))
179
180
181
182 (defun read-token-with-colons (stream char)
183 "Reads token, then analize package part if needed"
184 (unread-char char stream)
185 (when *read-suppress*
186 (let ((*readtable* (copy-readtable nil)))
187 (read stream))
188 (return-from read-token-with-colons))
189 (let* ((token (read-token stream))
190 ;; We have read something.
191 ;; It may represent either symbol or package designator.
192 ;; Looking after it: do we have a colon?
193 (colons (count-colons stream))
194 (object (read-after-colon stream token colons)))
195
196 (when (or *disable-symbol-readmacro*
197 (not (symbolp object))
198 (eql char #\|))
199 (return-from read-token-with-colons object))
200
201 (let ((object (process-symbol-readmacro object stream)))
202 (when *car-list*
203 (setf *car-list* nil
204 *extra-symbol-finders*
205 (append (extra-finders object) *extra-symbol-finders*)))
206 object)))
207
208 (let ((default-open-paren-reader
209 (get-macro-character #\( (copy-readtable nil))))
210 (defun open-paren-reader (stream char)
211 (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
212 (funcall default-open-paren-reader stream char))))
213
214
215
216 (defun (setf package-finders) (value &optional (package *package*))
217 (setf (gethash (find-package package) *per-package-finders*) value))
218
219 (defun package-finders (&optional (package *package*))
220 (gethash (find-package package) *per-package-finders*))
221
222 (defun (setf symbol-finders) (value &optional (package *package*))
223 (setf (gethash (find-package package) *package-symbol-finders*) value))
224
225 (defun symbol-finders (&optional (package *package*))
226 (gethash (find-package package) *package-symbol-finders*))
227
228 (defun (setf extra-finders) (value symbol)
229 (setf (gethash symbol *extra-finders*) value))
230
231 (defun extra-finders (symbol)
232 (gethash symbol *extra-finders*))
233
234 (defun push-import-prefix (prefix &optional (package *package*))
235 "Enables using package name omitting prefix.
236 For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
237 You may use them as
238 (push-import-prefix :com.clearly-useful)
239 (iterator-protocol:do-iterator ...)
240 (reducers:r/map #'1+ data)
241 and so on.
242 Package prefix is enabled per package so it is safe to use it in your package.
243
244 If there is package, which name coincides with shortcut, package name has priority.
245
246 So, if you make
247 (defpackage :reducers ...)
248
249 after that reducers:... will refer to new package, not com.clearly-useful.reducers.
250 "
251 (push (lambda (name package)
252 (declare (ignore package))
253 (or (cl:find-package name)
254 (cl:find-package (concatenate 'string prefix "." name))))
255 (package-finders package)))
256
257 (defun push-local-nickname (long-package nick
258 &optional (current-package *package*))
259 "Enables package nickname in CURRENT-PACKAGE.
260 For example, you found COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST package and want to use
261 it. But don't want to USE-PACKAGE them, because some exported symbols from it are clashing
262 with yours.
263
264 You may do it right:
265 (push-local-nickname :com.informatimago.common-lisp.cesarum.list :ilist)
266 (ilist:circular-length l)
267
268 Local-nicknames are local, so you may use it freely.
269
270 Local-nickname shadows any package, which name is NICK, so if package A wants
271 package LIB version 1, and package B wants package LIB version 2, one can simply
272 rename LIB version 1 to LIB1 and make
273 (push-local-nickname :lib1 :lib :a)
274 "
275 (let ((dpackage (find-package long-package)))
276 (push (lambda (name package)
277 (declare (ignore package))
278 (when (string= name (string nick)) dpackage))
279 (package-finders current-package))))
280
281 (defun push-local-package (symbol local-package)
282 "Sets local-package for a symbol. Many macroses use the own clauses.
283 For example, ITERATE uses FOR, COLLECT and so on.
284 If you don't want to USE-PACKAGE iterate, this function will help.
285 (push-local-package 'iter:iter :iterate)
286 (iter:iter (for i from 1 to 10) (collect i))
287
288 Caution: this function enables package substitution in all cases,
289 where SYMBOL is the car of a list.
290 For example, this will be error:
291 (let (iter:iter for) (list iter:iter for))
292 , because first for is in ITERATE package, but second -- is not.
293 "
294 (let ((dpackage (find-package local-package)))
295 (push (lambda (name package)
296 (declare (ignore package))
297 (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
298 (when (eq status :external) symbol)))
299 (extra-finders symbol))))
300
301 ;;;
302 ;;; Readtable analysis and change
303 ;;;
304
305 (defmacro with-case (case &body body)
306 (let ((save (gensym)))
307 `(let ((,save (readtable-case *readtable*)))
308 (setf (readtable-case *readtable*) ,case)
309 (unwind-protect
310 (progn ,@body)
311 (setf (readtable-case *readtable*) ,save)))))
312
313 (defun does-not-terminate-token-p (c)
314 (ignore-errors
315 (let ((str (format nil "a~Ab" c)))
316 (string= str (symbol-name
317 (with-case :preserve
318 (read-from-string (format nil "#:~A" str))))))))
319
320
321 (defun whitespace-p (c)
322 (ignore-errors
323 (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
324
325 (defun multiple-escape-p (c)
326 (ignore-errors
327 (string= "qQ" (symbol-name
328 (with-case :upcase
329 (read-from-string (format nil "#:~AqQ~A" c c)))))))
330
331 (defun single-escape-p (c)
332 (ignore-errors
333 (string= (symbol-name '#:\ ) (symbol-name
334 (read-from-string (format nil "#:~A'" c))))))
335
336
337
338 (defun macro-char-p (c)
339 "If C is macro-char, return GET-MACRO-CHARACTER"
340 #+allegro (unless
341 (eql (get-macro-character c) #'excl::read-token)
342 (get-macro-character c))
343 #-allegro (get-macro-character c))
344
345 (defun fill-char-table ()
346 "Returns simple-vector with character syntax classes"
347 (let ((*readtable* (copy-readtable nil))
348 (char-table (make-array 127)))
349 (dotimes (i (length char-table))
350 (let ((c (code-char i)))
351 (setf
352 (svref char-table i)
353 (cond
354 ((eql c #\:) :colon)
355 ((macro-char-p c) :macro)
356 ((does-not-terminate-token-p c) :does-not-terminate-token)
357 ((whitespace-p c) :whitespace)
358 ((multiple-escape-p c) :multiple-escape)
359 ((single-escape-p c) :single-escape)))))
360 char-table))
361
362 (let (initialized)
363 (defun activate (&optional force)
364 "Inits *advanced-readtable* and *colon-readtable*."
365 (when (or force (not initialized))
366 (setq initialized t)
367 (let ((char-table (fill-char-table)))
368 (dotimes (i (length char-table))
369 (let ((b (svref char-table i))
370 (c (code-char i)))
371 (unless (char= #\# c)
372 (when (member b '(:does-not-terminate-token
373 :multiple-escape :single-escape))
374 ;; will make it non-terminating macro character
375 ;; = potentially beginning of the package-name
376 (set-macro-character c #'read-token-with-colons
377 t *advanced-readtable*))))))
378
379 (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
380 (set-macro-character #\( #'open-paren-reader))
381 (setf *readtable* *advanced-readtable*)))
382
383 (defun ! () (activate))

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5