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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

1 rklochkov 3 (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