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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4 - (show annotations)
Sat Dec 8 06:20:09 2012 UTC (16 months, 1 week ago) by rklochkov
File size: 13553 byte(s)
Added package:(...) abd package::(...) clauses
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 (multiple-value-bind (symbol status)
172 (find-symbol token package)
173 (unintern token)
174 (when (and (= colons 1) (not (eq status :external)))
175 (cerror "Use anyway"
176 "Symbol ~A not external" symbol))
177 symbol))))
178
179
180
181 (defun read-token-with-colons (stream char)
182 "Reads token, then analize package part if needed"
183 (unread-char char stream)
184 (when *read-suppress*
185 (let ((*readtable* (copy-readtable nil)))
186 (read stream))
187 (return-from read-token-with-colons))
188 (let* ((token (read-token stream))
189 ;; We have read something.
190 ;; It may represent either symbol or package designator.
191 ;; Looking after it: do we have a colon?
192 (colons (count-colons stream))
193 (object (read-after-colon stream token colons)))
194
195 (when (or *disable-symbol-readmacro*
196 (not (symbolp object))
197 (eql char #\|))
198 (return-from read-token-with-colons object))
199
200 (let ((object (process-symbol-readmacro object stream)))
201 (when *car-list*
202 (setf *car-list* nil
203 *extra-symbol-finders*
204 (append (extra-finders object) *extra-symbol-finders*)))
205 object)))
206
207 (let ((default-open-paren-reader
208 (get-macro-character #\( (copy-readtable nil))))
209 (defun open-paren-reader (stream char)
210 (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
211 (funcall default-open-paren-reader stream char))))
212
213
214
215 (defun (setf package-finders) (value &optional (package *package*))
216 (setf (gethash (find-package package) *per-package-finders*) value))
217
218 (defun package-finders (&optional (package *package*))
219 (gethash (find-package package) *per-package-finders*))
220
221 (defun (setf symbol-finders) (value &optional (package *package*))
222 (setf (gethash (find-package package) *package-symbol-finders*) value))
223
224 (defun symbol-finders (&optional (package *package*))
225 (gethash (find-package package) *package-symbol-finders*))
226
227 (defun (setf extra-finders) (value symbol)
228 (setf (gethash symbol *extra-finders*) value))
229
230 (defun extra-finders (symbol)
231 (gethash symbol *extra-finders*))
232
233 (defun push-import-prefix (prefix &optional (package *package*))
234 "Enables using package name omitting prefix.
235 For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
236 You may use them as
237 (push-import-prefix :com.clearly-useful)
238 (iterator-protocol:do-iterator ...)
239 (reducers:r/map #'1+ data)
240 and so on.
241 Package prefix is enabled per package so it is safe to use it in your package.
242
243 If there is package, which name coincides with shortcut, package name has priority.
244
245 So, if you make
246 (defpackage :reducers ...)
247
248 after that reducers:... will refer to new package, not com.clearly-useful.reducers.
249 "
250 (push (lambda (name package)
251 (declare (ignore package))
252 (or (cl:find-package name)
253 (cl:find-package (concatenate 'string prefix "." name))))
254 (package-finders package)))
255
256 (defun push-local-nickname (long-package nick
257 &optional (current-package *package*))
258 "Enables package nickname in CURRENT-PACKAGE.
259 For example, you found COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST package and want to use
260 it. But don't want to USE-PACKAGE them, because some exported symbols from it are clashing
261 with yours.
262
263 You may do it right:
264 (push-local-nickname :com.informatimago.common-lisp.cesarum.list :ilist)
265 (ilist:circular-length l)
266
267 Local-nicknames are local, so you may use it freely.
268
269 Local-nickname shadows any package, which name is NICK, so if package A wants
270 package LIB version 1, and package B wants package LIB version 2, one can simply
271 rename LIB version 1 to LIB1 and make
272 (push-local-nickname :lib1 :lib :a)
273 "
274 (let ((dpackage (find-package long-package)))
275 (push (lambda (name package)
276 (declare (ignore package))
277 (when (string= name (string nick)) dpackage))
278 (package-finders current-package))))
279
280 (defun push-local-package (symbol local-package)
281 "Sets local-package for a symbol. Many macroses use the own clauses.
282 For example, ITERATE uses FOR, COLLECT and so on.
283 If you don't want to USE-PACKAGE iterate, this function will help.
284 (push-local-package 'iter:iter :iterate)
285 (iter:iter (for i from 1 to 10) (collect i))
286
287 Caution: this function enables package substitution in all cases,
288 where SYMBOL is the car of a list.
289 For example, this will be error:
290 (let (iter:iter for) (list iter:iter for))
291 , because first for is in ITERATE package, but second -- is not.
292 "
293 (let ((dpackage (find-package local-package)))
294 (push (lambda (name package)
295 (declare (ignore package))
296 (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
297 (when (eq status :external) symbol)))
298 (extra-finders symbol))))
299
300 ;;;
301 ;;; Readtable analysis and change
302 ;;;
303
304 (defmacro with-case (case &body body)
305 (let ((save (gensym)))
306 `(let ((,save (readtable-case *readtable*)))
307 (setf (readtable-case *readtable*) ,case)
308 (unwind-protect
309 (progn ,@body)
310 (setf (readtable-case *readtable*) ,save)))))
311
312 (defun does-not-terminate-token-p (c)
313 (ignore-errors
314 (let ((str (format nil "a~Ab" c)))
315 (string= str (symbol-name
316 (with-case :preserve
317 (read-from-string (format nil "#:~A" str))))))))
318
319
320 (defun whitespace-p (c)
321 (ignore-errors
322 (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
323
324 (defun multiple-escape-p (c)
325 (ignore-errors
326 (string= "qQ" (symbol-name
327 (with-case :upcase
328 (read-from-string (format nil "#:~AqQ~A" c c)))))))
329
330 (defun single-escape-p (c)
331 (ignore-errors
332 (string= (symbol-name '#:\ ) (symbol-name
333 (read-from-string (format nil "#:~A'" c))))))
334
335
336
337 (defun macro-char-p (c)
338 "If C is macro-char, return GET-MACRO-CHARACTER"
339 #+allegro (unless
340 (eql (get-macro-character c) #'excl::read-token)
341 (get-macro-character c))
342 #-allegro (get-macro-character c))
343
344 (defun fill-char-table ()
345 "Returns simple-vector with character syntax classes"
346 (let ((*readtable* (copy-readtable nil))
347 (char-table (make-array 127)))
348 (dotimes (i (length char-table))
349 (let ((c (code-char i)))
350 (setf
351 (svref char-table i)
352 (cond
353 ((eql c #\:) :colon)
354 ((macro-char-p c) :macro)
355 ((does-not-terminate-token-p c) :does-not-terminate-token)
356 ((whitespace-p c) :whitespace)
357 ((multiple-escape-p c) :multiple-escape)
358 ((single-escape-p c) :single-escape)))))
359 char-table))
360
361 (let (initialized)
362 (defun activate (&optional force)
363 "Inits *advanced-readtable* and *colon-readtable*."
364 (when (or force (not initialized))
365 (setq initialized t)
366 (let ((char-table (fill-char-table)))
367 (dotimes (i (length char-table))
368 (let ((b (svref char-table i))
369 (c (code-char i)))
370 (unless (char= #\# c)
371 (when (member b '(:does-not-terminate-token
372 :multiple-escape :single-escape))
373 ;; will make it non-terminating macro character
374 ;; = potentially beginning of the package-name
375 (set-macro-character c #'read-token-with-colons
376 t *advanced-readtable*))))))
377
378 (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
379 (set-macro-character #\( #'open-paren-reader))
380 (setf *readtable* *advanced-readtable*)))
381
382 (defun ! () (activate))

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5