/[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 7 by rklochkov, Sun Dec 9 05:48:36 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 pcakage 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))))))))  
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    
 (defun whitespace[2]-p (c)  
   (ignore-errors  
     (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))  
18    
 (defun multiple-escape-p (c)  
   (ignore-errors  
     (string= "qQ" (symbol-name  
                    (with-case :upcase  
                      (read-from-string (format nil "#:~AqQ~A" c c)))))))  
19    
 (defun single-escape-p (c)  
   (ignore-errors  
     (string= (symbol-name '#:\ ) (symbol-name  
                                   (read-from-string (format nil "#:~A'" c))))))  
20    
21    ;;;
22    ;;; Prepare readtables
23    ;;;
24    
25    
 (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))  
26    
27  (defvar *advanced-readtable* (copy-readtable nil))  (defvar *advanced-readtable* (copy-readtable nil))
28  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
# Line 71  Line 34 
34    
35  (defpackage #:advanced-readtable.junk)  (defpackage #:advanced-readtable.junk)
36    
 (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))))  
37    
 (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")  
38    
39  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
40    (declare (type list handlers-list)    (declare (type list handlers-list)
41             (type string name)             (type string name)
42             (type (or null package) package))             (type (or null package) package))
43    (when handlers-list    (when handlers-list
44      (or (funcall (car handlers-list) name package)      (or (funcall (cdr (car handlers-list)) name package)
45          (try-funcall (cdr handlers-list) name package))))          (try-funcall (cdr handlers-list) name package))))
46    
47  (defun find-package (name &optional (current-package *package*))  (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))    (declare (type (or null package) current-package))
53    (if (typep name 'package) name    (if (typep name 'package) name
54        (let ((sname (string name)))        (let ((sname (string name)))
55          (or          (or
56             (cl:find-package name)
57           (when current-package           (when current-package
58             (try-funcall (package-finders current-package) sname current-package))             (try-funcall (package-finders current-package) sname current-package))
59           (try-funcall *package-finders* sname current-package)           (try-funcall *package-finders* sname current-package)))))
          (cl:find-package name)))))  
60    
61  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
62    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)")
63  (defvar *symbol-finders* nil  (defvar *symbol-finders* nil
64    "List of handlers (lambda (name package) ...) -> symbol")    "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)  (defvar *extra-finders* (make-hash-table :test 'eq)
67    "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol    "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")  These will be used before CL:FIND-SYMBOL")
70    
71  (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 89  Returns function, assigned by set-macro-
89    (let ((func (gethash symbol *symbol-readmacros*)))    (let ((func (gethash symbol *symbol-readmacros*)))
90      (if func (funcall func stream symbol) symbol)))      (if func (funcall func stream symbol) symbol)))
91    
92  (defvar %*extra-symbol-finders* nil "List of handlers: handlers for symbol, car of list")  ;;; Internal special variables. Do not export
93  (defvar %*car-list* nil "Boolean: iff reader in list and car is not read")  
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)  (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))    (declare (type string name))
127    (let ((package (find-package dpackage)))    (let ((package (if dpackage (find-package dpackage) *package*)))
128      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
129                   (if clauses                   (if clauses
130                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
131                          (if symbol (values symbol status)                          (if symbol (values symbol status)
132                              (mv-or ,@(cdr clauses))))                              (mv-or . ,(cdr clauses))))
133                       `(values nil nil))))                       `(values nil nil))))
134    
135        (mv-or        (mv-or
136         (try-funcall %*extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
137         (when package (try-funcall (symbol-finders package) name package))         (cl:find-symbol name package)
138         (try-funcall *symbol-finders* name package)         (unless dpackage (try-local-packages *local-packages* name))
139         (when package (cl:find-symbol name package))         (try-mv-funcall (symbol-finders package) name package)
140         (cl:find-symbol name)))))         (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)  (defun read-token-with-colons (stream char)
194    "Reads token, then analize package part if needed"    "Reads token, then analize package part if needed"
195    (unread-char char stream)    (unread-char char stream)
196    (if *read-suppress* (let ((*readtable* (copy-readtable nil)))    (when *read-suppress*
197                          (read stream))      (let ((*readtable* (copy-readtable nil)))
198        (let* ((tok (read-token stream))        (read stream))
199               ;; We have read something.      (return-from read-token-with-colons))
200               ;; It may represent either symbol or package designator.    (let* ((token (read-token stream))
201               ;; Looking after it: do we have a colon?           ;; We have read something.
202               (cnt (count-colons stream))           ;; It may represent either symbol or package designator.
203               (sym (if (= cnt 0)           ;; Looking after it: do we have a colon?
204                        (if (stringp tok) (or (find-symbol tok) (intern tok)) tok)           (colons (count-colons stream))
205                        (let ((package (find-package tok *package*)))           (object (read-after-colon stream token colons)))
206                          (assert package (package) "No package ~a" tok)  
207                          (multiple-value-bind (symbol status)      (when (or *disable-symbol-readmacro*
208                              (find-symbol (read-token stream) package)                (not (symbolp object))
209                            (when (and (= cnt 1) (not (eq status :external)))                (eql char #\|))
210                              (cerror "Use anyway"          (return-from read-token-with-colons object))
                                     "Symbol ~A not external" symbol))  
                           symbol)))))  
211    
212          (let ((res (if (or *disable-symbol-readmacro*      (let ((object (process-symbol-readmacro object stream)))
213                             (not (symbolp sym)) (eql char #\|))        (when *car-list*
214                         sym          (setf *car-list* nil
215                         (process-symbol-readmacro sym stream))))                *extra-symbol-finders*
216            (when %*car-list*                (append (extra-finders object) *extra-symbol-finders*)))
217              (setf %*car-list* nil)        object)))
218              (when (and (symbolp res) (not (eql char #\|)))  
219                (setf %*extra-symbol-finders*  (let ((default-open-paren-reader
220                      (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))))  
221    (defun open-paren-reader (stream char)    (defun open-paren-reader (stream char)
222      (let ((%*car-list* t) (%*extra-symbol-finders* %*extra-symbol-finders*))      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
223        (funcall default-open-paren-reader stream char))))        (funcall default-open-paren-reader stream char))))
224    
225    
 ;;;  
 ;;; 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))  
226    
227  (defun (setf package-finders) (value &optional (package *package*))  (defun (setf package-finders) (value &optional (package *package*))
228    (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 242  Returns function, assigned by set-macro-
242  (defun extra-finders (symbol)  (defun extra-finders (symbol)
243    (gethash symbol *extra-finders*))    (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*))  (defun push-import-prefix (prefix &optional (package *package*))
259    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
260  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 272  So, if you make
272    
273  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.
274  "  "
275    (push (lambda (name package)    (%set-handler (package-finders package) (list :prefix prefix) name
276            (declare (ignore package))      (cl:find-package (concatenate 'string prefix "." name))))
           (or (cl:find-package name)  
               (cl:find-package (concatenate 'string prefix "." name))))  
         (package-finders package)))  
277    
278  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
279                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 291  rename LIB version 1 to LIB1 and make Line 294  rename LIB version 1 to LIB1 and make
294   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
295  "  "
296    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package)))
297      (push (lambda (name package)      (%set-handler (package-finders current-package) (list :nick long-package nick) name
298              (declare (ignore package))        (when (string= name (string nick)) dpackage))))
             (when (string= name (string nick)) dpackage))  
         (package-finders current-package))))  
299    
300  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
301    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
302  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
303  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.
304   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 310  For example, this will be error: Line 311  For example, this will be error:
311  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
312  "  "
313    (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))))  
314        (%set-handler (extra-finders symbol) (list :nick long-package nick) name
315          (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
316            (when (eq status :external) symbol)))))
317    
318    ;;;
319    ;;; Readtable analysis and change
320    ;;;
321    
322    (defmacro with-case (case &body body)
323      (let ((save (gensym)))
324        `(let ((,save (readtable-case *readtable*)))
325           (setf (readtable-case *readtable*) ,case)
326           (unwind-protect
327                (progn ,@body)
328             (setf (readtable-case *readtable*) ,save)))))
329    
330    (defun does-not-terminate-token-p (c)
331      (ignore-errors
332        (let ((str (format nil "a~Ab" c)))
333          (string= str (symbol-name
334                        (with-case :preserve
335                          (read-from-string (format nil "#:~A" str))))))))
336    
337    
338    (defun whitespace-p (c)
339      (ignore-errors
340        (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
341    
342    (defun multiple-escape-p (c)
343      (ignore-errors
344        (string= "qQ" (symbol-name
345                       (with-case :upcase
346                         (read-from-string (format nil "#:~AqQ~A" c c)))))))
347    
348    (defun single-escape-p (c)
349      (ignore-errors
350        (string= (symbol-name '#:\ ) (symbol-name
351                                      (read-from-string (format nil "#:~A'" c))))))
352    
353    
354    
355    (defun macro-char-p (c)
356      "If C is macro-char, return GET-MACRO-CHARACTER"
357      #+allegro (unless
358                    (eql (get-macro-character c) #'excl::read-token)
359                  (get-macro-character c))
360      #-allegro (get-macro-character c))
361    
362    (defun fill-char-table ()
363      "Returns simple-vector with character syntax classes"
364      (let ((*readtable* (copy-readtable nil))
365            (char-table (make-array 127)))
366        (dotimes (i (length char-table))
367          (let ((c (code-char i)))
368            (setf
369             (svref char-table i)
370             (cond
371               ((eql c #\:) :colon)
372               ((macro-char-p c) :macro)
373               ((does-not-terminate-token-p c) :does-not-terminate-token)
374               ((whitespace-p c) :whitespace)
375               ((multiple-escape-p c) :multiple-escape)
376               ((single-escape-p c) :single-escape)))))
377        char-table))
378    
379    (let (initialized)
380      (defun activate (&optional force)
381        "Inits *advanced-readtable* and *colon-readtable*."
382        (when (or force (not initialized))
383          (setq initialized t)
384          (let ((char-table (fill-char-table)))
385            (dotimes (i (length char-table))
386              (let ((b (svref char-table i))
387                    (c (code-char i)))
388                (unless (char= #\# c)
389                  (when (member b '(:does-not-terminate-token
390                                    :multiple-escape :single-escape))
391                    ;; will make it non-terminating macro character
392                    ;;    = potentially beginning of the package-name
393                    (set-macro-character c #'read-token-with-colons
394                                         t *advanced-readtable*))))))
395    
396          (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
397          (set-macro-character #\( #'open-paren-reader))
398        (setf *readtable* *advanced-readtable*)))
399    
400    (defun ! () (activate))

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

  ViewVC Help
Powered by ViewVC 1.1.5