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

Diff of /src.lisp

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

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

Legend:
Removed from v.2  
changed lines
  Added in v.3

  ViewVC Help
Powered by ViewVC 1.1.5