ViewVC logotype

Diff of /src.lisp

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

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

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

  ViewVC Help
Powered by ViewVC 1.1.5