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

Diff of /src.lisp

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

revision 3 by rklochkov, Sat Nov 10 03:49:04 2012 UTC revision 12 by rklochkov, Mon Dec 31 13:39:29 2012 UTC
# Line 1  Line 1 
1  (in-package #:advanced-readtable)  (in-package #:advanced-readtable)
2    
3  ;;;  ;;;; Advanced-readtable
4  ;;; study virgin readtable  ;;;;
5  ;;;  ;;;; per-package aliases for packages
6    ;;;; per-package shortcuts for package hierarchies
7  (defmacro with-case (case &body body)  ;;;; extendable find-package and find-symbol
8    (let ((save (gensym)))  ;;;; local use package in form package:(here form where package used)
9      `(let ((,save (readtable-case *readtable*)))  ;;;; local intern package like in SBCL: package::(symbol1 symbol2) will intern
10         (setf (readtable-case *readtable*) ,case)  ;;;;                                    package::symbol1 and package::symbol2
        (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)))))))  
11    
12  (defun single-escape-p (c)  (defvar *per-package-finders* (make-hash-table :test 'eq)
13    (ignore-errors    "Hash package -> list of handlers. Each handler is a cons (key . function)")
14      (string= (symbol-name '#:\ ) (symbol-name  (defvar *package-finders* nil
15                                    (read-from-string (format nil "#:~A'" c))))))    "List of handlers. Each handler is a cons (key . function)
16    function = (lambda (name package) ...) -> package")
   
   
 (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))  
17    
18  (defun fill-char-table ()  ;;;
19    "Returns simple-vector with character syntax classes"  ;;; Prepare readtables
20    (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))  
21    
22  (defvar *advanced-readtable* (copy-readtable nil))  (defvar *advanced-readtable* (copy-readtable nil))
23  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
# Line 71  Line 29 
29    
30  (defpackage #:advanced-readtable.junk)  (defpackage #:advanced-readtable.junk)
31    
 (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")  
   
32  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
33    (declare (type list handlers-list)    (declare (type list handlers-list)
34             (type string name)             (type string name)
35             (type (or null package) package))             (type (or null package) package))
36    (when handlers-list    (when handlers-list
37      (or (funcall (car handlers-list) name package)      (or (funcall (cdr (car handlers-list)) name package)
38          (try-funcall (cdr handlers-list) name package))))          (try-funcall (cdr handlers-list) name package))))
39    
40  (defun find-package (name &optional (current-package *package*))  (defun find-package (name &optional (current-package *package*))
41      "We try to find package.
42    1. By full name with CL:FIND-PACKAGE.
43    2. By per-package handlers. Here we wil try local-nicknames and so on.
44    3. By global handlers. Here we may use, for example, hierarchical packages."
45    (declare (type (or null package) current-package))    (declare (type (or null package) current-package))
46    (if (typep name 'package) name    (if (typep name 'package) name
47        (let ((sname (string name)))        (let ((sname (string name)))
48          (or          (or
49             (cl:find-package name)
50           (when current-package           (when current-package
51             (try-funcall (package-finders current-package) sname current-package))             (try-funcall (package-finders current-package)
52           (try-funcall *package-finders* sname current-package)                          sname current-package))
53           (cl:find-package name)))))           (try-funcall *package-finders* sname current-package)))))
54    
55  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
56    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
57  (defvar *symbol-finders* nil  (defvar *symbol-finders* nil
58    "List of handlers (lambda (name package) ...) -> symbol")    "List of handlers. Each handler is a cons (key . function)
59    function =  (lambda (name package) ...) -> symbol")
60  (defvar *extra-finders* (make-hash-table :test 'eq)  (defvar *extra-finders* (make-hash-table :test 'eq)
61    "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol    "Hash symbol -> list of handlers. Each handler is a cons (key . function)
62    function = (lambda (name package) ...) -> symbol
63  These will be used before CL:FIND-SYMBOL")  These will be used before CL:FIND-SYMBOL")
64    
65  (defvar *symbol-readmacros* (make-hash-table :test 'eq))  (defvar *symbol-readmacros* (make-hash-table :test 'eq))
# Line 145  Returns function, assigned by set-macro- Line 83  Returns function, assigned by set-macro-
83    (let ((func (gethash symbol *symbol-readmacros*)))    (let ((func (gethash symbol *symbol-readmacros*)))
84      (if func (funcall func stream symbol) symbol)))      (if func (funcall func stream symbol) symbol)))
85    
86  (defvar %*extra-symbol-finders* nil "List of handlers: handlers for symbol, car of list")  ;;; Internal special variables. Do not export
87  (defvar %*car-list* nil "Boolean: iff reader in list and car is not read")  
88    (defvar *extra-symbol-finders* nil
89      "List of handlers: handlers for symbol, car of list")
90    (defvar *car-list* nil "Boolean: iff reader in list and car is not read")
91    (defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
92    
93    (defun try-local-packages (packages name)
94      (when packages
95        (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
96          (if symbol
97              (values symbol status)
98              (try-local-packages (cdr packages) name)))))
99    
100    (defun try-mv-funcall (handlers-list name package)
101      "Returns symbol, status"
102      (declare (type list handlers-list)
103               (type string name)
104               (type (or null package) package))
105      (when handlers-list
106        (multiple-value-bind (symbol status)
107            (funcall (cdr (car handlers-list)) name package)
108          (if symbol
109              (values symbol status)
110              (try-funcall (cdr handlers-list) name package)))))
111    
112    
113  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
114      "We try to find symbol
115    1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
116    2. By CL-FIND-SYMBOL, when package explicitly given
117    3. By packages added with package:(...)
118    4. By per-package finders
119    5. By global finders
120    6. By CL-FIND-SYMBOL"
121    (declare (type string name))    (declare (type string name))
122    (let ((package (find-package dpackage)))    (let ((package (if dpackage (find-package dpackage) *package*)))
123      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
124                   (if clauses                   (if clauses
125                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
126                          (if symbol (values symbol status)                          (if symbol (values symbol status)
127                              (mv-or ,@(cdr clauses))))                              (mv-or . ,(cdr clauses))))
128                       `(values nil nil))))                       `(values nil nil))))
129    
130        (mv-or        (mv-or
131         (try-funcall %*extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
132         (when package (try-funcall (symbol-finders package) name package))         (when dpackage (cl:find-symbol name package))
133         (try-funcall *symbol-finders* name package)         (unless dpackage (try-local-packages *local-packages* name))
134         (when package (cl:find-symbol name package))         (try-mv-funcall (symbol-finders package) name package)
135         (cl:find-symbol name)))))         (try-mv-funcall *symbol-finders* name package)
136           (unless dpackage (cl:find-symbol name package))))))
137    
138    (defun read-token (stream)
139      "
140    DO: Reads from STREAM a symbol or number up to whitespace or colon
141    RETURN: symbols name or numbers value"
142      (let ((*readtable* *colon-readtable*)
143            (*package* (cl:find-package '#:advanced-readtable.junk)))
144        (read-preserving-whitespace stream nil)))
145    
146    (defun count-colons (stream)
147      "
148    DO: Reads colons from STREAM
149    RETURN: number of the colons"
150      (let ((c (read-char stream nil)))
151        (if (eql c #\:)
152            (+ 1 (count-colons stream))
153            (progn (unread-char c stream) 0))))
154    
155    (defun read-after-colon (stream maybe-package colons)
156      "Read symbol package:sym or list package:(...)"
157      (declare (type stream stream)
158               (type (integer 0 2) colons))
159      (check-type colons (integer 0 2))
160      (when (= colons 0) ; no colon: this is a symbol or an atom
161        (return-from read-after-colon
162          (if (symbolp maybe-package)
163              (prog1
164                  (let ((name (symbol-name maybe-package)))
165                    (or (find-symbol name) (intern name)))
166                (unintern maybe-package))
167              maybe-package)))
168    
169      (let ((package (find-package maybe-package)))
170        (assert package (package) "No package ~a" maybe-package)
171        (unintern maybe-package)
172        (when (eql (peek-char t stream) #\()
173          ;; package:(...) or package::(...)
174          (ecase colons
175            (1 (let ((*local-packages* (cons package *local-packages*)))
176                 (return-from read-after-colon
177                   (read stream nil))))
178            (2 (let ((*package* package))
179                 (return-from read-after-colon
180                   (read stream nil))))))
181    
182        (let ((token (read-token stream)))
183          (check-type token symbol)
184          (multiple-value-bind (symbol status)
185              (find-symbol (symbol-name token) package)
186            (unless status
187              (if (= colons 1) (error "No external symbol ~S in ~S"
188                                      (symbol-name token) package)
189                  (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
190                          (symbol-name token) package)))
191            (unintern token)
192            (when (and (= colons 1) (not (eq status :external)))
193              (cerror "Use anyway"
194                      "Symbol ~A not external" symbol))
195            symbol))))
196    
197    
198    
199  (defun read-token-with-colons (stream char)  (defun read-token-with-colons (stream char)
200    "Reads token, then analize package part if needed"    "Reads token, then analize package part if needed"
201    (unread-char char stream)    (unread-char char stream)
202    (if *read-suppress* (let ((*readtable* (copy-readtable nil)))    (when *read-suppress*
203                          (read stream))      (let ((*readtable* (copy-readtable nil)))
204        (let* ((tok (read-token stream))        (read stream))
205               ;; We have read something.      (return-from read-token-with-colons))
206               ;; It may represent either symbol or package designator.    (let* ((token (read-token stream))
207               ;; Looking after it: do we have a colon?           ;; We have read something.
208               (cnt (count-colons stream))           ;; It may represent either symbol or package designator.
209               (sym (if (= cnt 0)           ;; Looking after it: do we have a colon?
210                        (if (stringp tok) (or (find-symbol tok) (intern tok)) tok)           (colons (count-colons stream))
211                        (let ((package (find-package tok *package*)))           (object (read-after-colon stream token colons)))
212                          (assert package (package) "No package ~a" tok)  
213                          (multiple-value-bind (symbol status)      (when (or *disable-symbol-readmacro*
214                              (find-symbol (read-token stream) package)                (not (symbolp object))
215                            (when (and (= cnt 1) (not (eq status :external)))                (eql char #\|))
216                              (cerror "Use anyway"          (return-from read-token-with-colons object))
                                     "Symbol ~A not external" symbol))  
                           symbol)))))  
217    
218          (let ((res (if (or *disable-symbol-readmacro*      (let ((object (process-symbol-readmacro object stream)))
219                             (not (symbolp sym)) (eql char #\|))        (when *car-list*
220                         sym          (setf *car-list* nil
221                         (process-symbol-readmacro sym stream))))                *extra-symbol-finders*
222            (when %*car-list*                (append (extra-finders object) *extra-symbol-finders*)))
223              (setf %*car-list* nil)        object)))
224              (when (and (symbolp res) (not (eql char #\|)))  
225                (setf %*extra-symbol-finders*  (let ((default-open-paren-reader
226                      (append (extra-finders res) %*extra-symbol-finders*))))         (get-macro-character #\( (copy-readtable nil))))
           res))))  
   
 (let ((default-open-paren-reader (get-macro-character #\( (copy-readtable nil))))  
227    (defun open-paren-reader (stream char)    (defun open-paren-reader (stream char)
228      (let ((%*car-list* t) (%*extra-symbol-finders* %*extra-symbol-finders*))      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
229        (funcall default-open-paren-reader stream char))))        (funcall default-open-paren-reader stream char))))
230    
231    
 ;;;  
 ;;; 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*)  
       (set-macro-character #\( #'open-paren-reader))  
     (setf *readtable* *advanced-readtable*)))  
   
 (defun ! () (activate))  
232    
233  (defun (setf package-finders) (value &optional (package *package*))  (defun (setf package-finders) (value &optional (package *package*))
234    (setf (gethash (find-package package) *per-package-finders*) value))    (setf (gethash (find-package package) *per-package-finders*) value))
# Line 249  Returns function, assigned by set-macro- Line 248  Returns function, assigned by set-macro-
248  (defun extra-finders (symbol)  (defun extra-finders (symbol)
249    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
250    
251    (defmacro set-handler (handler-list key function)
252      "This is middle-level public API for changing handlers for
253    find-symbol and find-package. There are five lists:
254      *package-finders* -- global for find-package
255      *symbol-finders* -- global for find-symbol
256      (package-finders package) -- per-package for find-package
257      (symbol-finders package) -- per-package for find-symbol
258      (extra-finders symbol) -- per-symbol for (symbol ....) package substitution
259    
260    Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds
261    new handler if it is not already there.
262    "
263      (let ((key-var (gensym "key")))
264        `(let ((,key-var ,key))
265           (unless (assoc ,key-var ,handler-list :test #'equal)
266             (push (cons ,key-var ,function)
267                   ,handler-list)))))
268    
269    (defmacro %set-handler (handler-list key name &body handler-body)
270      "Local macros for push-* functions. No gensyms intended."
271      `(set-handler ,handler-list ,key
272                    (lambda (,name package)
273                      (declare (ignore package)) . ,handler-body)))
274    
275  (defun push-import-prefix (prefix &optional (package *package*))  (defun push-import-prefix (prefix &optional (package *package*))
276    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
277  For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...  For example, you have packages com.clearly-useful.iterator-protocol, com.clearly-useful.reducers, ...
# Line 266  So, if you make Line 289  So, if you make
289    
290  after that reducers:... will refer to new package, not com.clearly-useful.reducers.  after that reducers:... will refer to new package, not com.clearly-useful.reducers.
291  "  "
292    (push (lambda (name package)    (%set-handler (package-finders package) `(:prefix ,prefix) name
293            (declare (ignore package))      (cl:find-package (concatenate 'string (string prefix) "." name))))
           (or (cl:find-package name)  
               (cl:find-package (concatenate 'string prefix "." name))))  
         (package-finders package)))  
294    
295  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
296                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 285  You may do it right: Line 305  You may do it right:
305    
306  Local-nicknames are local, so you may use it freely.  Local-nicknames are local, so you may use it freely.
307    
308  Local-nickname shadows any package, which name is NICK, so if package A wants  If package A wants  package LIB version 1, and package B wants package
309  package LIB version 1, and package B wants package LIB version 2, one can simply  LIB version 2, one can simply rename LIB version 1 to LIB1 and rename LIB
310  rename LIB version 1 to LIB1 and make  version 2 to LIB2 and make
311   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
312     (push-local-nickname :lib2 :lib :b)
313  "  "
314    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package)))
315      (push (lambda (name package)      (%set-handler (package-finders current-package) `(:nick ,long-package ,nick) name
316              (declare (ignore package))        (when (string= name (string nick)) dpackage))))
             (when (string= name (string nick)) dpackage))  
         (package-finders current-package))))  
317    
318  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
319    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
320  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
321  If you don't want to USE-PACKAGE iterate, this function will help.  If you don't want to USE-PACKAGE iterate, this function will help.
322   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 310  For example, this will be error: Line 329  For example, this will be error:
329  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
330  "  "
331    (let ((dpackage (find-package local-package)))    (let ((dpackage (find-package local-package)))
     (push (lambda (name package)  
             (declare (ignore package))  
             (cl:find-symbol name dpackage))  
         (extra-finders symbol))))  
332        (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
333          (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
334            (when (eq status :external) symbol)))))
335    
336    ;;;
337    ;;; Readtable analysis and change
338    ;;;
339    
340    (defmacro with-case (case &body body)
341      (let ((save (gensym)))
342        `(let ((,save (readtable-case *readtable*)))
343           (setf (readtable-case *readtable*) ,case)
344           (unwind-protect
345                (progn ,@body)
346             (setf (readtable-case *readtable*) ,save)))))
347    
348    (defun does-not-terminate-token-p (c)
349      (ignore-errors
350        (let ((str (format nil "a~Ab" c)))
351          (string= str (symbol-name
352                        (with-case :preserve
353                          (read-from-string (format nil "#:~A" str))))))))
354    
355    
356    (defun whitespace-p (c)
357      (ignore-errors
358        (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
359    
360    (defun multiple-escape-p (c)
361      (ignore-errors
362        (string= "qQ" (symbol-name
363                       (with-case :upcase
364                         (read-from-string (format nil "#:~AqQ~A" c c)))))))
365    
366    (defun single-escape-p (c)
367      (ignore-errors
368        (string= (symbol-name '#:\ ) (symbol-name
369                                      (read-from-string (format nil "#:~A'" c))))))
370    
371    
372    
373    (defun macro-char-p (c)
374      "If C is macro-char, return GET-MACRO-CHARACTER"
375      #+allegro (unless
376                    (eql (get-macro-character c) #'excl::read-token)
377                  (get-macro-character c))
378      #-allegro (get-macro-character c))
379    
380    (defun fill-char-table ()
381      "Returns simple-vector with character syntax classes"
382      (let ((*readtable* (copy-readtable nil))
383            (char-table (make-array 127)))
384        (dotimes (i (length char-table))
385          (let ((c (code-char i)))
386            (setf
387             (svref char-table i)
388             (cond
389               ((eql c #\:) :colon)
390               ((macro-char-p c) :macro)
391               ((does-not-terminate-token-p c) :does-not-terminate-token)
392               ((whitespace-p c) :whitespace)
393               ((multiple-escape-p c) :multiple-escape)
394               ((single-escape-p c) :single-escape)))))
395        char-table))
396    
397    (let (initialized)
398      (defun activate (&optional force)
399        "Inits *advanced-readtable* and *colon-readtable*."
400        (when (or force (not initialized))
401          (setq initialized t)
402          (let ((char-table (fill-char-table)))
403            (dotimes (i (length char-table))
404              (let ((b (svref char-table i))
405                    (c (code-char i)))
406                (unless (char= #\# c)
407                  (when (member b '(:does-not-terminate-token
408                                    :multiple-escape :single-escape))
409                    ;; will make it non-terminating macro character
410                    ;;    = potentially beginning of the package-name
411                    (set-macro-character c #'read-token-with-colons
412                                         t *advanced-readtable*))))))
413    
414          (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
415          (set-macro-character #\( #'open-paren-reader nil *advanced-readtable*))
416        (setf *readtable* *advanced-readtable*)))
417    
418    (defun ! () (activate))

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

  ViewVC Help
Powered by ViewVC 1.1.5