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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5