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

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

  ViewVC Help
Powered by ViewVC 1.1.5