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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Sat Nov 10 03:49:04 2012 UTC (17 months ago) by rklochkov
File size: 11769 byte(s)
Added documentation
Added local package for clauses (macro-symbol ...)

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

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5