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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 15 - (hide annotations)
Sat Jan 26 19:59:30 2013 UTC (14 months, 2 weeks ago) by rklochkov
File size: 19521 byte(s)
Refactored. Beta release. Now strong depends on named-readtables

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 14 "Hash package -> list of handlers. Each handler is a cons (key . function)
14     function = (lambda (name package) ...) -> package")
15    
16 rklochkov 4 (defvar *package-finders* nil
17 rklochkov 6 "List of handlers. Each handler is a cons (key . function)
18     function = (lambda (name package) ...) -> package")
19 rklochkov 3
20 rklochkov 14 (defvar *global-nicknames* nil
21     "Placeholder for global nicknames, when not null, it is an alias hash")
22    
23 rklochkov 4 ;;;
24     ;;; Prepare readtables
25     ;;;
26 rklochkov 3
27     (defvar *colon-readtable* (copy-readtable nil)
28     "Support readtable with colon as whitespace")
29 rklochkov 14 (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
30 rklochkov 3
31     ;;;
32     ;;; Readtable handlers
33     ;;;
34    
35 rklochkov 14 (|CL|:defpackage #:advanced-readtable.junk)
36 rklochkov 3
37     (defun try-funcall (handlers-list name package)
38     (declare (type list handlers-list)
39     (type string name)
40     (type (or null package) package))
41     (when handlers-list
42 rklochkov 6 (or (funcall (cdr (car handlers-list)) name package)
43 rklochkov 3 (try-funcall (cdr handlers-list) name package))))
44    
45     (defun find-package (name &optional (current-package *package*))
46 rklochkov 6 "We try to find package.
47     1. By full name with CL:FIND-PACKAGE.
48     2. By per-package handlers. Here we wil try local-nicknames and so on.
49     3. By global handlers. Here we may use, for example, hierarchical packages."
50 rklochkov 14 (declare (type package current-package))
51 rklochkov 3 (if (typep name 'package) name
52     (let ((sname (string name)))
53 rklochkov 6 (or
54     (cl:find-package name)
55 rklochkov 14 (try-funcall (package-finders current-package)
56     sname current-package)
57 rklochkov 6 (try-funcall *package-finders* sname current-package)))))
58 rklochkov 3
59     (defvar *package-symbol-finders* (make-hash-table :test 'eq)
60 rklochkov 14 "Hash package -> list of handlers. Each handler is a cons (key . function)
61     function = (lambda (name package) ...) -> symbol")
62    
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 14
67 rklochkov 3 (defvar *extra-finders* (make-hash-table :test 'eq)
68 rklochkov 6 "Hash symbol -> list of handlers. Each handler is a cons (key . function)
69     function = (lambda (name package) ...) -> symbol
70 rklochkov 3 These will be used before CL:FIND-SYMBOL")
71    
72     (defvar *symbol-readmacros* (make-hash-table :test 'eq))
73 rklochkov 14
74 rklochkov 3 (defvar *disable-symbol-readmacro* nil
75     "Disables processing of symbol-readmacro.")
76    
77     (defun def-symbol-readmacro (symbol func)
78     (setf (gethash symbol *symbol-readmacros*) func))
79    
80     (defun set-macro-symbol (symbol func)
81     "Syntax is like set-macro-character,
82     except that FUNC is binded to SYMBOL, not character"
83     (setf (gethash symbol *symbol-readmacros*) func))
84    
85     (defun get-macro-symbol (symbol)
86     "Syntax is like get-macro-character.
87     Returns function, assigned by set-macro-symbol"
88     (gethash symbol *symbol-readmacros*))
89    
90     (defun process-symbol-readmacro (symbol stream)
91     (let ((func (gethash symbol *symbol-readmacros*)))
92     (if func (funcall func stream symbol) symbol)))
93    
94 rklochkov 4 ;;; Internal special variables. Do not export
95 rklochkov 3
96 rklochkov 4 (defvar *extra-symbol-finders* nil
97     "List of handlers: handlers for symbol, car of list")
98     (defvar *car-list* nil "Boolean: iff reader in list and car is not read")
99     (defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
100    
101     (defun try-local-packages (packages name)
102     (when packages
103     (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
104     (if symbol
105     (values symbol status)
106     (try-local-packages (cdr packages) name)))))
107    
108     (defun try-mv-funcall (handlers-list name package)
109     "Returns symbol, status"
110     (declare (type list handlers-list)
111     (type string name)
112     (type (or null package) package))
113     (when handlers-list
114     (multiple-value-bind (symbol status)
115 rklochkov 6 (funcall (cdr (car handlers-list)) name package)
116 rklochkov 4 (if symbol
117     (values symbol status)
118     (try-funcall (cdr handlers-list) name package)))))
119    
120 rklochkov 3 (defun find-symbol (name &optional dpackage)
121 rklochkov 6 "We try to find symbol
122 rklochkov 9 1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
123     2. By CL-FIND-SYMBOL, when package explicitly given
124 rklochkov 6 3. By packages added with package:(...)
125     4. By per-package finders
126 rklochkov 9 5. By global finders
127     6. By CL-FIND-SYMBOL"
128 rklochkov 3 (declare (type string name))
129 rklochkov 14 ; (when (string= name "NIL")
130     ; (return-from find-symbol (cl:find-symbol name (or dpackage *package*))))
131 rklochkov 6 (let ((package (if dpackage (find-package dpackage) *package*)))
132 rklochkov 3 (macrolet ((mv-or (&rest clauses)
133     (if clauses
134     `(multiple-value-bind (symbol status) ,(car clauses)
135 rklochkov 14 (if status (values symbol status)
136 rklochkov 4 (mv-or . ,(cdr clauses))))
137 rklochkov 14 `(values nil nil))))
138 rklochkov 3 (mv-or
139 rklochkov 4 (try-mv-funcall *extra-symbol-finders* name package)
140 rklochkov 9 (when dpackage (cl:find-symbol name package))
141 rklochkov 6 (unless dpackage (try-local-packages *local-packages* name))
142     (try-mv-funcall (symbol-finders package) name package)
143 rklochkov 9 (try-mv-funcall *symbol-finders* name package)
144     (unless dpackage (cl:find-symbol name package))))))
145 rklochkov 3
146 rklochkov 14 (defun collect-dots (stream)
147     (do ((n 0 (1+ n))
148     (c (read-char stream nil) (read-char stream nil)))
149     ((or (null c) (char/= c #\.))
150     (when c
151     (unread-char c stream))
152     (if (and (plusp n) (member c '(nil #\Space #\) #\( #\Tab #\Newline #\:)))
153     (intern (make-string n :initial-element #\.))
154     (dotimes (foo n) (unread-char #\. stream))))))
155    
156 rklochkov 4 (defun read-token (stream)
157     "
158     DO: Reads from STREAM a symbol or number up to whitespace or colon
159     RETURN: symbols name or numbers value"
160     (let ((*readtable* *colon-readtable*)
161     (*package* (cl:find-package '#:advanced-readtable.junk)))
162 rklochkov 14 (or (collect-dots stream)
163     (read-preserving-whitespace stream nil))))
164 rklochkov 3
165 rklochkov 4 (defun count-colons (stream)
166     "
167     DO: Reads colons from STREAM
168     RETURN: number of the colons"
169 rklochkov 14 (do ((n 0 (1+ n))
170     (c (read-char stream nil) (read-char stream nil)))
171     ((or (null c) (char/= c #\:))
172     (when c (unread-char c stream)) n)))
173 rklochkov 4
174     (defun read-after-colon (stream maybe-package colons)
175     "Read symbol package:sym or list package:(...)"
176 rklochkov 11 (declare (type stream stream)
177 rklochkov 14 (type integer colons))
178 rklochkov 12 (check-type colons (integer 0 2))
179 rklochkov 9 (when (= colons 0) ; no colon: this is a symbol or an atom
180 rklochkov 4 (return-from read-after-colon
181     (if (symbolp maybe-package)
182 rklochkov 10 (prog1
183     (let ((name (symbol-name maybe-package)))
184     (or (find-symbol name) (intern name)))
185     (unintern maybe-package))
186 rklochkov 4 maybe-package)))
187    
188     (let ((package (find-package maybe-package)))
189     (assert package (package) "No package ~a" maybe-package)
190     (unintern maybe-package)
191     (when (eql (peek-char t stream) #\()
192     ;; package:(...) or package::(...)
193     (ecase colons
194     (1 (let ((*local-packages* (cons package *local-packages*)))
195     (return-from read-after-colon
196     (read stream nil))))
197     (2 (let ((*package* package))
198     (return-from read-after-colon
199     (read stream nil))))))
200    
201     (let ((token (read-token stream)))
202 rklochkov 5 (check-type token symbol)
203 rklochkov 4 (multiple-value-bind (symbol status)
204 rklochkov 5 (find-symbol (symbol-name token) package)
205 rklochkov 12 (unless status
206     (if (= colons 1) (error "No external symbol ~S in ~S"
207     (symbol-name token) package)
208 rklochkov 14 (progn
209     (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
210     (symbol-name token) package)
211     (setf symbol (intern (symbol-name token) package)))))
212 rklochkov 4 (unintern token)
213     (when (and (= colons 1) (not (eq status :external)))
214     (cerror "Use anyway"
215     "Symbol ~A not external" symbol))
216     symbol))))
217    
218 rklochkov 3 (defun read-token-with-colons (stream char)
219     "Reads token, then analize package part if needed"
220     (unread-char char stream)
221 rklochkov 4 (when *read-suppress*
222     (let ((*readtable* (copy-readtable nil)))
223     (read stream))
224     (return-from read-token-with-colons))
225     (let* ((token (read-token stream))
226     ;; We have read something.
227     ;; It may represent either symbol or package designator.
228     ;; Looking after it: do we have a colon?
229     (colons (count-colons stream))
230     (object (read-after-colon stream token colons)))
231    
232     (when (or *disable-symbol-readmacro*
233     (not (symbolp object))
234     (eql char #\|))
235     (return-from read-token-with-colons object))
236 rklochkov 3
237 rklochkov 4 (let ((object (process-symbol-readmacro object stream)))
238     (when *car-list*
239     (setf *car-list* nil
240     *extra-symbol-finders*
241     (append (extra-finders object) *extra-symbol-finders*)))
242     object)))
243    
244     (let ((default-open-paren-reader
245     (get-macro-character #\( (copy-readtable nil))))
246 rklochkov 3 (defun open-paren-reader (stream char)
247 rklochkov 4 (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
248 rklochkov 3 (funcall default-open-paren-reader stream char))))
249    
250     (defun (setf package-finders) (value &optional (package *package*))
251     (setf (gethash (find-package package) *per-package-finders*) value))
252    
253     (defun package-finders (&optional (package *package*))
254     (gethash (find-package package) *per-package-finders*))
255    
256     (defun (setf symbol-finders) (value &optional (package *package*))
257     (setf (gethash (find-package package) *package-symbol-finders*) value))
258    
259     (defun symbol-finders (&optional (package *package*))
260     (gethash (find-package package) *package-symbol-finders*))
261    
262     (defun (setf extra-finders) (value symbol)
263     (setf (gethash symbol *extra-finders*) value))
264    
265     (defun extra-finders (symbol)
266     (gethash symbol *extra-finders*))
267    
268 rklochkov 6 (defmacro set-handler (handler-list key function)
269 rklochkov 9 "This is middle-level public API for changing handlers for
270     find-symbol and find-package. There are five lists:
271     *package-finders* -- global for find-package
272     *symbol-finders* -- global for find-symbol
273     (package-finders package) -- per-package for find-package
274     (symbol-finders package) -- per-package for find-symbol
275     (extra-finders symbol) -- per-symbol for (symbol ....) package substitution
276    
277     Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds
278     new handler if it is not already there.
279     "
280 rklochkov 6 (let ((key-var (gensym "key")))
281     `(let ((,key-var ,key))
282 rklochkov 8 (unless (assoc ,key-var ,handler-list :test #'equal)
283 rklochkov 6 (push (cons ,key-var ,function)
284     ,handler-list)))))
285    
286     (defmacro %set-handler (handler-list key name &body handler-body)
287     "Local macros for push-* functions. No gensyms intended."
288 rklochkov 7 `(set-handler ,handler-list ,key
289     (lambda (,name package)
290     (declare (ignore package)) . ,handler-body)))
291 rklochkov 6
292 rklochkov 3 (defun push-import-prefix (prefix &optional (package *package*))
293     "Enables using package name omitting prefix.
294     For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
295     You may use them as
296     (push-import-prefix :com.clearly-useful)
297     (iterator-protocol:do-iterator ...)
298     (reducers:r/map #'1+ data)
299     and so on.
300     Package prefix is enabled per package so it is safe to use it in your package.
301    
302     If there is package, which name coincides with shortcut, package name has priority.
303    
304     So, if you make
305     (defpackage :reducers ...)
306    
307     after that reducers:... will refer to new package, not com.clearly-useful.reducers.
308     "
309 rklochkov 8 (%set-handler (package-finders package) `(:prefix ,prefix) name
310 rklochkov 10 (cl:find-package (concatenate 'string (string prefix) "." name))))
311 rklochkov 3
312     (defun push-local-nickname (long-package nick
313     &optional (current-package *package*))
314     "Enables package nickname in CURRENT-PACKAGE.
315     For example, you found COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST package and want to use
316     it. But don't want to USE-PACKAGE them, because some exported symbols from it are clashing
317     with yours.
318    
319     You may do it right:
320     (push-local-nickname :com.informatimago.common-lisp.cesarum.list :ilist)
321     (ilist:circular-length l)
322    
323     Local-nicknames are local, so you may use it freely.
324    
325 rklochkov 9 If package A wants package LIB version 1, and package B wants package
326     LIB version 2, one can simply rename LIB version 1 to LIB1 and rename LIB
327     version 2 to LIB2 and make
328 rklochkov 3 (push-local-nickname :lib1 :lib :a)
329 rklochkov 9 (push-local-nickname :lib2 :lib :b)
330 rklochkov 14
331     If enabled global-nicknames via enable-global-nicknames,
332     then also created alias in current package.
333    
334     For example,
335     (push-local-nickname :lib1 :lib :a), states, that package A.LIB is eq to LIB1.
336 rklochkov 3 "
337 rklochkov 14 (let ((dpackage (find-package long-package))
338     (s-nick (string nick)))
339     (%set-handler (package-finders current-package)
340     `(:nick ,(string long-package) ,s-nick) name
341     (when (string= name s-nick) dpackage))
342     (when *global-nicknames*
343     (setf (gethash (concatenate 'string
344     (package-name current-package)
345     "." s-nick) *global-nicknames*)
346     dpackage))))
347 rklochkov 3
348     (defun push-local-package (symbol local-package)
349 rklochkov 6 "Sets local-package for a symbol. Many macroses use there own clauses.
350 rklochkov 3 For example, ITERATE uses FOR, COLLECT and so on.
351     If you don't want to USE-PACKAGE iterate, this function will help.
352     (push-local-package 'iter:iter :iterate)
353     (iter:iter (for i from 1 to 10) (collect i))
354    
355     Caution: this function enables package substitution in all cases,
356     where SYMBOL is the car of a list.
357     For example, this will be error:
358     (let (iter:iter for) (list iter:iter for))
359     , because first for is in ITERATE package, but second -- is not.
360     "
361     (let ((dpackage (find-package local-package)))
362 rklochkov 8 (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
363 rklochkov 7 (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
364     (when (eq status :external) symbol)))))
365 rklochkov 4
366 rklochkov 14 ;;; TODO: process nicknames in hierarchy
367     ;;; ex: cl-user.test == common-lisp-user.test
368     ;;; cl-user.test.a == common-lisp-user.test.a
369    
370     (defun normalize-package (name)
371     "Returns nil if already normalized.
372     Replace first section of hierarchy with proper name"
373     (let ((pos (position #\. name)))
374     (when pos
375     (if (= pos 0) ; .subpackage
376     (concatenate 'string (package-name *package*) name)
377     (let* ((base (subseq name 0 pos))
378     (p (find-package base)))
379     (when (and p (string/= (package-name p) base))
380     (concatenate 'string (package-name p) "."
381     (subseq name (1+ pos)))))))))
382    
383     (flet ((parent (name)
384     (let ((pos (position #\. name :from-end t)))
385     (if pos (subseq name 0 pos) "")))
386     (relative-to (parent name)
387     (cond
388     ((string= parent "") name)
389     ((string= name "") parent)
390     (t (concatenate 'string parent "." name)))))
391     (defun hierarchy-find-package (name package)
392     (if (char= (char name 0) #\.)
393     (do ((i 1 (1+ i))
394     (p (package-name package) (parent p)))
395     ((or (= i (length name)) (char/= (char name i) #\.))
396     (find-package (relative-to p (subseq name i)))))
397     (let ((normalized (normalize-package name)))
398     (when normalized
399     (find-package normalized package))))))
400    
401     (defun correct-package (designator)
402     (let ((p (find-package designator)))
403     (if p (package-name p) designator)))
404    
405     (defmacro in-package (designator)
406     `(|CL|:in-package ,(correct-package (string designator))))
407    
408     (defmacro defpackage (package &rest options)
409     (let ((normalized (normalize-package (string package)))
410     (options
411     (mapcar (lambda (option)
412     (cons (car option)
413     (case (car option)
414     (:use (mapcar #'correct-package (cdr option)))
415     ((:import-from :shadowing-import-from)
416     (cons (correct-package (second option))
417     (cddr option)))
418     (t (cdr option)))))
419     options)))
420     `(|CL|:defpackage ,(or normalized package) . ,options)))
421    
422     (defun substitute-symbol (stream symbol)
423     (declare (ignore stream))
424     (find-symbol (symbol-name symbol) #.*package*))
425    
426     (defun enable-hierarchy-packages ()
427     (set-handler *package-finders* :hierarchy #'hierarchy-find-package)
428     (set-macro-symbol '|CL|:in-package #'substitute-symbol)
429     (set-macro-symbol '|CL|:defpackage #'substitute-symbol))
430    
431     (defun enable-global-nicknames ()
432     (setf *global-nicknames* (make-hash-table :test 'equal))
433     (%set-handler *package-finders* :global-nicknames name
434     (gethash name *global-nicknames*)))
435    
436     (enable-hierarchy-packages)
437     (enable-global-nicknames)
438    
439 rklochkov 4 ;;;
440     ;;; Readtable analysis and change
441     ;;;
442 rklochkov 14 (eval-when (:compile-toplevel :load-toplevel :execute)
443     (defmacro with-case (case &body body)
444     (let ((save (gensym)))
445     `(let ((,save (readtable-case *readtable*)))
446     (setf (readtable-case *readtable*) ,case)
447     (unwind-protect
448     (progn ,@body)
449     (setf (readtable-case *readtable*) ,save)))))
450 rklochkov 4
451 rklochkov 14 (defun does-not-terminate-token-p (c)
452     (ignore-errors
453     (let ((str (format nil "a~Ab" c)))
454     (string= str (symbol-name
455     (with-case :preserve
456     (read-from-string (format nil "#:~A" str))))))))
457 rklochkov 4
458 rklochkov 14 (defun whitespace-p (c)
459     (ignore-errors
460     (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
461 rklochkov 4
462 rklochkov 14 (defun multiple-escape-p (c)
463     (ignore-errors
464     (string= "qQ" (symbol-name
465     (with-case :upcase
466     (read-from-string (format nil "#:~AqQ~A" c c)))))))
467 rklochkov 4
468 rklochkov 14 (defun single-escape-p (c)
469     (ignore-errors
470     (string= (symbol-name '#:\ ) (symbol-name
471     (read-from-string
472     (format nil "#:~A'" c))))))
473 rklochkov 4
474 rklochkov 14 (defun macro-char-p (c)
475     "If C is macro-char, return GET-MACRO-CHARACTER"
476     #+allegro (unless
477     (eql (get-macro-character c) #'excl::read-token)
478     (get-macro-character c))
479     #-allegro (get-macro-character c))
480 rklochkov 4
481 rklochkov 14 (defun to-process (c)
482     (cond
483     ((eql c #\:) nil)
484     ((macro-char-p c) nil)
485     ((does-not-terminate-token-p c) t)
486     ((whitespace-p c) nil)
487     ((multiple-escape-p c) t)
488     ((single-escape-p c) t)
489     (t nil)))
490    
491     (defparameter +additional-chars+ ""
492     "Fill this, if you need extra characters for packages to begin with")
493 rklochkov 4
494 rklochkov 14 (defun chars-to-process ()
495     (let ((*readtable* (copy-readtable nil)))
496     (nconc
497 rklochkov 15 (loop :for i :from 0 :to 127
498 rklochkov 14 :for c = (code-char i)
499     :when (to-process c) :collect c)
500     (loop :for c :across +additional-chars+
501     :when (to-process c) :collect c))))
502 rklochkov 4
503 rklochkov 14 (defun make-named-rt ()
504 rklochkov 15 `(defreadtable :advanced
505 rklochkov 14 (:merge :standard)
506 rklochkov 15 ,@(mapcar (lambda (c) (list :macro-char c #'read-token-with-colons t))
507     (chars-to-process))
508 rklochkov 14 (:macro-char #\( #'open-paren-reader nil))))
509 rklochkov 4
510 rklochkov 14 (macrolet ((def-advanced-readtable ()
511     (make-named-rt)))
512 rklochkov 15 (def-advanced-readtable))
513 rklochkov 4
514 rklochkov 14 (defun activate ()
515 rklochkov 15 (in-readtable :advanced))
516 rklochkov 4
517     (defun ! () (activate))

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5