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

Diff of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1  
changed lines
  Added in v.5

  ViewVC Help
Powered by ViewVC 1.1.5