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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5