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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4 - (hide 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 rklochkov 3 (in-package #:advanced-readtable)
2    
3 rklochkov 4 ;;; 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 rklochkov 3
12 rklochkov 4 (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 rklochkov 3
17    
18    
19    
20 rklochkov 4 ;;;
21     ;;; Prepare readtables
22     ;;;
23 rklochkov 3
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 rklochkov 4 ;;; Internal special variables. Do not export
86 rklochkov 3
87 rklochkov 4 (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 rklochkov 3 (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 rklochkov 4 (mv-or . ,(cdr clauses))))
120 rklochkov 3 `(values nil nil))))
121    
122     (mv-or
123 rklochkov 4 (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 rklochkov 3
131 rklochkov 4 (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 rklochkov 3
139 rklochkov 4 (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 rklochkov 3 (defun read-token-with-colons (stream char)
182     "Reads token, then analize package part if needed"
183     (unread-char char stream)
184 rklochkov 4 (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 rklochkov 3
200 rklochkov 4 (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 rklochkov 3 (defun open-paren-reader (stream char)
210 rklochkov 4 (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
211 rklochkov 3 (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 rklochkov 4 (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