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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 14 - (show annotations)
Fri Jan 25 14:09:35 2013 UTC (14 months, 2 weeks ago) by rklochkov
File size: 19717 byte(s)
Version 0.2
1 (in-package #:advanced-readtable)
2
3 ;;;; 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
12 (defvar *per-package-finders* (make-hash-table :test 'eq)
13 "Hash package -> list of handlers. Each handler is a cons (key . function)
14 function = (lambda (name package) ...) -> package")
15
16 (defvar *package-finders* nil
17 "List of handlers. Each handler is a cons (key . function)
18 function = (lambda (name package) ...) -> package")
19
20 (defvar *global-nicknames* nil
21 "Placeholder for global nicknames, when not null, it is an alias hash")
22
23 ;;;
24 ;;; Prepare readtables
25 ;;;
26
27 (defvar *colon-readtable* (copy-readtable nil)
28 "Support readtable with colon as whitespace")
29 (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
30
31 ;;;
32 ;;; Readtable handlers
33 ;;;
34
35 (|CL|:defpackage #:advanced-readtable.junk)
36
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 (or (funcall (cdr (car handlers-list)) name package)
43 (try-funcall (cdr handlers-list) name package))))
44
45 (defun find-package (name &optional (current-package *package*))
46 "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 (declare (type package current-package))
51 (if (typep name 'package) name
52 (let ((sname (string name)))
53 (or
54 (cl:find-package name)
55 (try-funcall (package-finders current-package)
56 sname current-package)
57 (try-funcall *package-finders* sname current-package)))))
58
59 (defvar *package-symbol-finders* (make-hash-table :test 'eq)
60 "Hash package -> list of handlers. Each handler is a cons (key . function)
61 function = (lambda (name package) ...) -> symbol")
62
63 (defvar *symbol-finders* nil
64 "List of handlers. Each handler is a cons (key . function)
65 function = (lambda (name package) ...) -> symbol")
66
67 (defvar *extra-finders* (make-hash-table :test 'eq)
68 "Hash symbol -> list of handlers. Each handler is a cons (key . function)
69 function = (lambda (name package) ...) -> symbol
70 These will be used before CL:FIND-SYMBOL")
71
72 (defvar *symbol-readmacros* (make-hash-table :test 'eq))
73
74 (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 ;;; Internal special variables. Do not export
95
96 (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 (funcall (cdr (car handlers-list)) name package)
116 (if symbol
117 (values symbol status)
118 (try-funcall (cdr handlers-list) name package)))))
119
120 (defun find-symbol (name &optional dpackage)
121 "We try to find symbol
122 1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
123 2. By CL-FIND-SYMBOL, when package explicitly given
124 3. By packages added with package:(...)
125 4. By per-package finders
126 5. By global finders
127 6. By CL-FIND-SYMBOL"
128 (declare (type string name))
129 ; (when (string= name "NIL")
130 ; (return-from find-symbol (cl:find-symbol name (or dpackage *package*))))
131 (let ((package (if dpackage (find-package dpackage) *package*)))
132 (macrolet ((mv-or (&rest clauses)
133 (if clauses
134 `(multiple-value-bind (symbol status) ,(car clauses)
135 (if status (values symbol status)
136 (mv-or . ,(cdr clauses))))
137 `(values nil nil))))
138 (mv-or
139 (try-mv-funcall *extra-symbol-finders* name package)
140 (when dpackage (cl:find-symbol name package))
141 (unless dpackage (try-local-packages *local-packages* name))
142 (try-mv-funcall (symbol-finders package) name package)
143 (try-mv-funcall *symbol-finders* name package)
144 (unless dpackage (cl:find-symbol name package))))))
145
146 (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 (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 (or (collect-dots stream)
163 (read-preserving-whitespace stream nil))))
164
165 (defun count-colons (stream)
166 "
167 DO: Reads colons from STREAM
168 RETURN: number of the colons"
169 (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
174 (defun read-after-colon (stream maybe-package colons)
175 "Read symbol package:sym or list package:(...)"
176 (declare (type stream stream)
177 (type integer colons))
178 (check-type colons (integer 0 2))
179 (when (= colons 0) ; no colon: this is a symbol or an atom
180 (return-from read-after-colon
181 (if (symbolp maybe-package)
182 (prog1
183 (let ((name (symbol-name maybe-package)))
184 (or (find-symbol name) (intern name)))
185 (unintern maybe-package))
186 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 (check-type token symbol)
203 (multiple-value-bind (symbol status)
204 (find-symbol (symbol-name token) package)
205 (unless status
206 (if (= colons 1) (error "No external symbol ~S in ~S"
207 (symbol-name token) package)
208 (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 (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 (defun read-token-with-colons (stream char)
219 "Reads token, then analize package part if needed"
220 (unread-char char stream)
221 (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
237 (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 (defun open-paren-reader (stream char)
247 (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
248 (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 (defmacro set-handler (handler-list key function)
269 "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 (let ((key-var (gensym "key")))
281 `(let ((,key-var ,key))
282 (unless (assoc ,key-var ,handler-list :test #'equal)
283 (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 `(set-handler ,handler-list ,key
289 (lambda (,name package)
290 (declare (ignore package)) . ,handler-body)))
291
292 (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 (%set-handler (package-finders package) `(:prefix ,prefix) name
310 (cl:find-package (concatenate 'string (string prefix) "." name))))
311
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 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 (push-local-nickname :lib1 :lib :a)
329 (push-local-nickname :lib2 :lib :b)
330
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 "
337 (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
348 (defun push-local-package (symbol local-package)
349 "Sets local-package for a symbol. Many macroses use there own clauses.
350 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 (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
363 (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
364 (when (eq status :external) symbol)))))
365
366 ;;; 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 ;;;
440 ;;; Readtable analysis and change
441 ;;;
442 (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
451 (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
458 (defun whitespace-p (c)
459 (ignore-errors
460 (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
461
462 (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
468 (defun single-escape-p (c)
469 (ignore-errors
470 (string= (symbol-name '#:\ ) (symbol-name
471 (read-from-string
472 (format nil "#:~A'" c))))))
473
474 (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
481 (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
494 (defun chars-to-process ()
495 (let ((*readtable* (copy-readtable nil)))
496 (nconc
497 (loop :for i :from 1 :to 127
498 :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
503 (defun make-named-rt ()
504 `(,(cl:find-symbol "DEFREADTABLE" "NAMED-READTABLES") :advanced
505 (:merge :standard)
506 ,@(loop :for c :in (chars-to-process)
507 :collect `(:macro-char ,c #'read-token-with-colons t))
508 (:macro-char #\( #'open-paren-reader nil))))
509
510 (macrolet ((def-advanced-readtable ()
511 (make-named-rt)))
512 (when (cl:find-package "NAMED-READTABLES")
513 (def-advanced-readtable)))
514
515 (defun activate ()
516 (dolist (c (chars-to-process))
517 (set-macro-character c #'read-token-with-colons t))
518 (set-macro-character #\( #'open-paren-reader t))
519
520 (defun ! () (activate))

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5