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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5