/[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 4 by rklochkov, Sat Dec 8 06:20:09 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    ;;; 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  (defmacro with-case (case &body body)  (defvar *per-package-finders* (make-hash-table :test 'eq)
13    (let ((save (gensym)))    "Hash package -> list of handlers")
14      `(let ((,save (readtable-case *readtable*)))  (defvar *package-finders* nil
15         (setf (readtable-case *readtable*) ,case)    "List of handlers (lambda (name package) ...) -> package")
        (unwind-protect  
             (progn ,@body)  
          (setf (readtable-case *readtable*) ,save)))))  
16    
 (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))))))))  
17    
18    
 (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))))))  
19    
20    ;;;
21    ;;; Prepare readtables
22    ;;;
23    
24    
 (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))  
25    
26  (defvar *advanced-readtable* (copy-readtable nil))  (defvar *advanced-readtable* (copy-readtable nil))
27  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
# Line 71  Line 33 
33    
34  (defpackage #:advanced-readtable.junk)  (defpackage #:advanced-readtable.junk)
35    
 (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))))  
36    
 (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")  
37    
38  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
39    (declare (type list handlers-list)    (declare (type list handlers-list)
# Line 145  Returns function, assigned by set-macro- Line 82  Returns function, assigned by set-macro-
82    (let ((func (gethash symbol *symbol-readmacros*)))    (let ((func (gethash symbol *symbol-readmacros*)))
83      (if func (funcall func stream symbol) symbol)))      (if func (funcall func stream symbol) symbol)))
84    
85  (defvar %*extra-symbol-finders* nil "List of handlers: handlers for symbol, car of list")  ;;; Internal special variables. Do not export
86  (defvar %*car-list* nil "Boolean: iff reader in list and car is not read")  
87    (defvar *extra-symbol-finders* nil
88      "List of handlers: handlers for symbol, car of list")
89    (defvar *car-list* nil "Boolean: iff reader in list and car is not read")
90    (defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
91    
92    (defun try-local-packages (packages name)
93      (when packages
94        (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
95          (if symbol
96              (values symbol status)
97              (try-local-packages (cdr packages) name)))))
98    
99    (defun try-mv-funcall (handlers-list name package)
100      "Returns symbol, status"
101      (declare (type list handlers-list)
102               (type string name)
103               (type (or null package) package))
104      (when handlers-list
105        (multiple-value-bind (symbol status)
106            (funcall (car handlers-list) name package)
107          (if symbol
108              (values symbol status)
109              (try-funcall (cdr handlers-list) name package)))))
110    
111    
112  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
113    (declare (type string name))    (declare (type string name))
# Line 155  Returns function, assigned by set-macro- Line 116  Returns function, assigned by set-macro-
116                   (if clauses                   (if clauses
117                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
118                          (if symbol (values symbol status)                          (if symbol (values symbol status)
119                              (mv-or ,@(cdr clauses))))                              (mv-or . ,(cdr clauses))))
120                       `(values nil nil))))                       `(values nil nil))))
121    
122        (mv-or        (mv-or
123         (try-funcall %*extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
124         (when package (try-funcall (symbol-finders package) name package))         (unless package (try-local-packages *local-packages* name))
125         (try-funcall *symbol-finders* name package)         (when package (try-mv-funcall (symbol-finders package) name package))
126         (when package (cl:find-symbol name package))         (try-mv-funcall *symbol-finders* name package)
127         (cl:find-symbol name)))))         (if package
128               (cl:find-symbol name package)
129               (cl:find-symbol name))))))
130    
131    (defun read-token (stream)
132      "
133    DO: Reads from STREAM a symbol or number up to whitespace or colon
134    RETURN: symbols name or numbers value"
135      (let ((*readtable* *colon-readtable*)
136            (*package* (cl:find-package '#:advanced-readtable.junk)))
137        (read-preserving-whitespace stream nil)))
138    
139    (defun count-colons (stream)
140      "
141    DO: Reads colons from STREAM
142    RETURN: number of the colons"
143      (let ((c (read-char stream nil)))
144        (if (eql c #\:)
145            (+ 1 (count-colons stream))
146            (progn (unread-char c stream) 0))))
147    
148    (defun read-after-colon (stream maybe-package colons)
149      "Read symbol package:sym or list package:(...)"
150      (when (= colons 0)
151        (return-from read-after-colon
152          (if (symbolp maybe-package)
153              (let ((name (symbol-name maybe-package)))
154                (or (find-symbol name)(intern name)))
155              maybe-package)))
156    
157      (let ((package (find-package maybe-package)))
158        (assert package (package) "No package ~a" maybe-package)
159        (unintern maybe-package)
160        (when (eql (peek-char t stream) #\()
161          ;; package:(...) or package::(...)
162          (ecase colons
163            (1 (let ((*local-packages* (cons package *local-packages*)))
164                 (return-from read-after-colon
165                   (read stream nil))))
166            (2 (let ((*package* package))
167                 (return-from read-after-colon
168                   (read stream nil))))))
169    
170        (let ((token (read-token stream)))
171          (multiple-value-bind (symbol status)
172              (find-symbol token package)
173            (unintern token)
174            (when (and (= colons 1) (not (eq status :external)))
175              (cerror "Use anyway"
176                      "Symbol ~A not external" symbol))
177            symbol))))
178    
179    
180    
181  (defun read-token-with-colons (stream char)  (defun read-token-with-colons (stream char)
182    "Reads token, then analize package part if needed"    "Reads token, then analize package part if needed"
183    (unread-char char stream)    (unread-char char stream)
184    (if *read-suppress* (let ((*readtable* (copy-readtable nil)))    (when *read-suppress*
185                          (read stream))      (let ((*readtable* (copy-readtable nil)))
186        (let* ((tok (read-token stream))        (read stream))
187               ;; We have read something.      (return-from read-token-with-colons))
188               ;; It may represent either symbol or package designator.    (let* ((token (read-token stream))
189               ;; Looking after it: do we have a colon?           ;; We have read something.
190               (cnt (count-colons stream))           ;; It may represent either symbol or package designator.
191               (sym (if (= cnt 0)           ;; Looking after it: do we have a colon?
192                        (if (stringp tok) (or (find-symbol tok) (intern tok)) tok)           (colons (count-colons stream))
193                        (let ((package (find-package tok *package*)))           (object (read-after-colon stream token colons)))
194                          (assert package (package) "No package ~a" tok)  
195                          (multiple-value-bind (symbol status)      (when (or *disable-symbol-readmacro*
196                              (find-symbol (read-token stream) package)                (not (symbolp object))
197                            (when (and (= cnt 1) (not (eq status :external)))                (eql char #\|))
198                              (cerror "Use anyway"          (return-from read-token-with-colons object))
                                     "Symbol ~A not external" symbol))  
                           symbol)))))  
199    
200          (let ((res (if (or *disable-symbol-readmacro*      (let ((object (process-symbol-readmacro object stream)))
201                             (not (symbolp sym)) (eql char #\|))        (when *car-list*
202                         sym          (setf *car-list* nil
203                         (process-symbol-readmacro sym stream))))                *extra-symbol-finders*
204            (when %*car-list*                (append (extra-finders object) *extra-symbol-finders*)))
205              (setf %*car-list* nil)        object)))
206              (when (and (symbolp res) (not (eql char #\|)))  
207                (setf %*extra-symbol-finders*  (let ((default-open-paren-reader
208                      (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))))  
209    (defun open-paren-reader (stream char)    (defun open-paren-reader (stream char)
210      (let ((%*car-list* t) (%*extra-symbol-finders* %*extra-symbol-finders*))      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
211        (funcall default-open-paren-reader stream char))))        (funcall default-open-paren-reader stream char))))
212    
213    
 ;;;  
 ;;; 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))  
214    
215  (defun (setf package-finders) (value &optional (package *package*))  (defun (setf package-finders) (value &optional (package *package*))
216    (setf (gethash (find-package package) *per-package-finders*) value))    (setf (gethash (find-package package) *per-package-finders*) value))
# Line 312  For example, this will be error: Line 293  For example, this will be error:
293    (let ((dpackage (find-package local-package)))    (let ((dpackage (find-package local-package)))
294      (push (lambda (name package)      (push (lambda (name package)
295              (declare (ignore package))              (declare (ignore package))
             (cl:find-symbol name dpackage))  
         (extra-finders symbol))))  
296                (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
297                  (when (eq status :external) symbol)))
298            (extra-finders symbol))))
299    
300    ;;;
301    ;;; Readtable analysis and change
302    ;;;
303    
304    (defmacro with-case (case &body body)
305      (let ((save (gensym)))
306        `(let ((,save (readtable-case *readtable*)))
307           (setf (readtable-case *readtable*) ,case)
308           (unwind-protect
309                (progn ,@body)
310             (setf (readtable-case *readtable*) ,save)))))
311    
312    (defun does-not-terminate-token-p (c)
313      (ignore-errors
314        (let ((str (format nil "a~Ab" c)))
315          (string= str (symbol-name
316                        (with-case :preserve
317                          (read-from-string (format nil "#:~A" str))))))))
318    
319    
320    (defun whitespace-p (c)
321      (ignore-errors
322        (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
323    
324    (defun multiple-escape-p (c)
325      (ignore-errors
326        (string= "qQ" (symbol-name
327                       (with-case :upcase
328                         (read-from-string (format nil "#:~AqQ~A" c c)))))))
329    
330    (defun single-escape-p (c)
331      (ignore-errors
332        (string= (symbol-name '#:\ ) (symbol-name
333                                      (read-from-string (format nil "#:~A'" c))))))
334    
335    
336    
337    (defun macro-char-p (c)
338      "If C is macro-char, return GET-MACRO-CHARACTER"
339      #+allegro (unless
340                    (eql (get-macro-character c) #'excl::read-token)
341                  (get-macro-character c))
342      #-allegro (get-macro-character c))
343    
344    (defun fill-char-table ()
345      "Returns simple-vector with character syntax classes"
346      (let ((*readtable* (copy-readtable nil))
347            (char-table (make-array 127)))
348        (dotimes (i (length char-table))
349          (let ((c (code-char i)))
350            (setf
351             (svref char-table i)
352             (cond
353               ((eql c #\:) :colon)
354               ((macro-char-p c) :macro)
355               ((does-not-terminate-token-p c) :does-not-terminate-token)
356               ((whitespace-p c) :whitespace)
357               ((multiple-escape-p c) :multiple-escape)
358               ((single-escape-p c) :single-escape)))))
359        char-table))
360    
361    (let (initialized)
362      (defun activate (&optional force)
363        "Inits *advanced-readtable* and *colon-readtable*."
364        (when (or force (not initialized))
365          (setq initialized t)
366          (let ((char-table (fill-char-table)))
367            (dotimes (i (length char-table))
368              (let ((b (svref char-table i))
369                    (c (code-char i)))
370                (unless (char= #\# c)
371                  (when (member b '(:does-not-terminate-token
372                                    :multiple-escape :single-escape))
373                    ;; will make it non-terminating macro character
374                    ;;    = potentially beginning of the package-name
375                    (set-macro-character c #'read-token-with-colons
376                                         t *advanced-readtable*))))))
377    
378          (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
379          (set-macro-character #\( #'open-paren-reader))
380        (setf *readtable* *advanced-readtable*)))
381    
382    (defun ! () (activate))

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

  ViewVC Help
Powered by ViewVC 1.1.5