/[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 14 by rklochkov, Fri Jan 25 14:09:35 2013 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 package 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. Each handler is a cons (key . function)
14      `(let ((,save (readtable-case *readtable*)))  function = (lambda (name package) ...) -> package")
        (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))))))  
15    
16    (defvar *package-finders* nil
17      "List of handlers. Each handler is a cons (key . function)
18    function = (lambda (name package) ...) -> package")
19    
20    (defvar *global-nicknames* nil
21      "Placeholder for global nicknames, when not null, it is an alias hash")
22    
23  (defun macro-char-p (c)  ;;;
24    "If C is macro-char, return GET-MACRO-CHARACTER"  ;;; Prepare readtables
25    #+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    
 (defvar *advanced-readtable* (copy-readtable nil))  
27  (defvar *colon-readtable* (copy-readtable nil)  (defvar *colon-readtable* (copy-readtable nil)
28    "Support readtable with colon as whitespace")    "Support readtable with colon as whitespace")
29    (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*)
30    
31  ;;;  ;;;
32  ;;; Readtable handlers  ;;; Readtable handlers
33  ;;;  ;;;
34    
35  (defpackage #:advanced-readtable.junk)  (|CL|: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")  
36    
37  (defun try-funcall (handlers-list name package)  (defun try-funcall (handlers-list name package)
38    (declare (type list handlers-list)    (declare (type list handlers-list)
39             (type string name)             (type string name)
40             (type (or null package) package))             (type (or null package) package))
41    (when handlers-list    (when handlers-list
42      (or (funcall (car handlers-list) name package)      (or (funcall (cdr (car handlers-list)) name package)
43          (try-funcall (cdr handlers-list) name package))))          (try-funcall (cdr handlers-list) name package))))
44    
45  (defun find-package (name &optional (current-package *package*))  (defun find-package (name &optional (current-package *package*))
46    (declare (type (or null package) current-package))    "We try to find package.
47    1. By full name with CL:FIND-PACKAGE.
48    2. By per-package handlers. Here we wil try local-nicknames and so on.
49    3. By global handlers. Here we may use, for example, hierarchical packages."
50      (declare (type package current-package))
51    (if (typep name 'package) name    (if (typep name 'package) name
52        (let ((sname (string name)))        (let ((sname (string name)))
53          (or          (or
54           (when current-package           (cl:find-package name)
55             (try-funcall (package-finders current-package) sname current-package))           (try-funcall (package-finders current-package)
56           (try-funcall *package-finders* sname current-package)                        sname current-package)
57           (cl:find-package name)))))           (try-funcall *package-finders* sname current-package)))))
58    
59  (defvar *package-symbol-finders* (make-hash-table :test 'eq)  (defvar *package-symbol-finders* (make-hash-table :test 'eq)
60    "Hash package -> list of handlers")    "Hash package -> list of handlers. Each handler is a cons (key . function)
61    function =  (lambda (name package) ...) -> symbol")
62    
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    
67  (defvar *extra-finders* (make-hash-table :test 'eq)  (defvar *extra-finders* (make-hash-table :test 'eq)
68    "Hash symbol -> list of handlers (lambda (name package) ...) -> symbol    "Hash symbol -> list of handlers. Each handler is a cons (key . function)
69    function = (lambda (name package) ...) -> symbol
70  These will be used before CL:FIND-SYMBOL")  These will be used before CL:FIND-SYMBOL")
71    
72  (defvar *symbol-readmacros* (make-hash-table :test 'eq))  (defvar *symbol-readmacros* (make-hash-table :test 'eq))
73    
74  (defvar *disable-symbol-readmacro* nil  (defvar *disable-symbol-readmacro* nil
75    "Disables processing of symbol-readmacro.")    "Disables processing of symbol-readmacro.")
76    
# Line 145  Returns function, assigned by set-macro- Line 91  Returns function, assigned by set-macro-
91    (let ((func (gethash symbol *symbol-readmacros*)))    (let ((func (gethash symbol *symbol-readmacros*)))
92      (if func (funcall func stream symbol) symbol)))      (if func (funcall func stream symbol) symbol)))
93    
94  (defvar %*extra-symbol-finders* nil "List of handlers: handlers for symbol, car of list")  ;;; Internal special variables. Do not export
95  (defvar %*car-list* nil "Boolean: iff reader in list and car is not read")  
96    (defvar *extra-symbol-finders* nil
97      "List of handlers: handlers for symbol, car of list")
98    (defvar *car-list* nil "Boolean: iff reader in list and car is not read")
99    (defvar *local-packages* nil "List of packages: for pack:( ... pack2:(...))")
100    
101    (defun try-local-packages (packages name)
102      (when packages
103        (multiple-value-bind (symbol status) (cl:find-symbol name (car packages))
104          (if symbol
105              (values symbol status)
106              (try-local-packages (cdr packages) name)))))
107    
108    (defun try-mv-funcall (handlers-list name package)
109      "Returns symbol, status"
110      (declare (type list handlers-list)
111               (type string name)
112               (type (or null package) package))
113      (when handlers-list
114        (multiple-value-bind (symbol status)
115            (funcall (cdr (car handlers-list)) name package)
116          (if symbol
117              (values symbol status)
118              (try-funcall (cdr handlers-list) name package)))))
119    
120  (defun find-symbol (name &optional dpackage)  (defun find-symbol (name &optional dpackage)
121      "We try to find symbol
122    1. In package set with car of list, for example, PUSH-LOCAL-PACKAGE
123    2. By CL-FIND-SYMBOL, when package explicitly given
124    3. By packages added with package:(...)
125    4. By per-package finders
126    5. By global finders
127    6. By CL-FIND-SYMBOL"
128    (declare (type string name))    (declare (type string name))
129    (let ((package (find-package dpackage)))  ;  (when (string= name "NIL")
130    ;    (return-from find-symbol (cl:find-symbol name (or dpackage *package*))))
131      (let ((package (if dpackage (find-package dpackage) *package*)))
132      (macrolet ((mv-or (&rest clauses)      (macrolet ((mv-or (&rest clauses)
133                   (if clauses                   (if clauses
134                       `(multiple-value-bind (symbol status) ,(car clauses)                       `(multiple-value-bind (symbol status) ,(car clauses)
135                          (if symbol (values symbol status)                          (if status (values symbol status)
136                              (mv-or ,@(cdr clauses))))                              (mv-or . ,(cdr clauses))))
137                       `(values nil nil))))                       `(values nil nil))))
   
138        (mv-or        (mv-or
139         (try-funcall %*extra-symbol-finders* name package)         (try-mv-funcall *extra-symbol-finders* name package)
140         (when package (try-funcall (symbol-finders package) name package))         (when dpackage (cl:find-symbol name package))
141         (try-funcall *symbol-finders* name package)         (unless dpackage (try-local-packages *local-packages* name))
142         (when package (cl:find-symbol name package))         (try-mv-funcall (symbol-finders package) name package)
143         (cl:find-symbol name)))))         (try-mv-funcall *symbol-finders* name package)
144           (unless dpackage (cl:find-symbol name package))))))
145    
146    (defun collect-dots (stream)
147      (do ((n 0 (1+ n))
148           (c (read-char stream nil) (read-char stream nil)))
149          ((or (null c) (char/= c #\.))
150           (when c
151             (unread-char c stream))
152           (if (and (plusp n) (member c '(nil #\Space #\) #\( #\Tab #\Newline #\:)))
153             (intern (make-string n :initial-element #\.))
154             (dotimes (foo n) (unread-char #\. stream))))))
155    
156    (defun read-token (stream)
157      "
158    DO: Reads from STREAM a symbol or number up to whitespace or colon
159    RETURN: symbols name or numbers value"
160      (let ((*readtable* *colon-readtable*)
161            (*package* (cl:find-package '#:advanced-readtable.junk)))
162        (or (collect-dots stream)
163            (read-preserving-whitespace stream nil))))
164    
165    (defun count-colons (stream)
166      "
167    DO: Reads colons from STREAM
168    RETURN: number of the colons"
169      (do ((n 0 (1+ n))
170           (c (read-char stream nil) (read-char stream nil)))
171          ((or (null c) (char/= c #\:))
172           (when c (unread-char c stream)) n)))
173    
174    (defun read-after-colon (stream maybe-package colons)
175      "Read symbol package:sym or list package:(...)"
176      (declare (type stream stream)
177               (type integer colons))
178      (check-type colons (integer 0 2))
179      (when (= colons 0) ; no colon: this is a symbol or an atom
180        (return-from read-after-colon
181          (if (symbolp maybe-package)
182              (prog1
183                  (let ((name (symbol-name maybe-package)))
184                    (or (find-symbol name) (intern name)))
185                (unintern maybe-package))
186              maybe-package)))
187    
188      (let ((package (find-package maybe-package)))
189        (assert package (package) "No package ~a" maybe-package)
190        (unintern maybe-package)
191        (when (eql (peek-char t stream) #\()
192          ;; package:(...) or package::(...)
193          (ecase colons
194            (1 (let ((*local-packages* (cons package *local-packages*)))
195                 (return-from read-after-colon
196                   (read stream nil))))
197            (2 (let ((*package* package))
198                 (return-from read-after-colon
199                   (read stream nil))))))
200    
201        (let ((token (read-token stream)))
202          (check-type token symbol)
203          (multiple-value-bind (symbol status)
204              (find-symbol (symbol-name token) package)
205            (unless status
206              (if (= colons 1) (error "No external symbol ~S in ~S"
207                                      (symbol-name token) package)
208                  (progn
209                    (cerror "Intern ~S in ~S" "No such symbol ~S in package ~S"
210                            (symbol-name token) package)
211                    (setf symbol (intern (symbol-name token) package)))))
212            (unintern token)
213            (when (and (= colons 1) (not (eq status :external)))
214              (cerror "Use anyway"
215                      "Symbol ~A not external" symbol))
216            symbol))))
217    
218  (defun read-token-with-colons (stream char)  (defun read-token-with-colons (stream char)
219    "Reads token, then analize package part if needed"    "Reads token, then analize package part if needed"
220    (unread-char char stream)    (unread-char char stream)
221    (if *read-suppress* (let ((*readtable* (copy-readtable nil)))    (when *read-suppress*
222                          (read stream))      (let ((*readtable* (copy-readtable nil)))
223        (let* ((tok (read-token stream))        (read stream))
224               ;; We have read something.      (return-from read-token-with-colons))
225               ;; It may represent either symbol or package designator.    (let* ((token (read-token stream))
226               ;; Looking after it: do we have a colon?           ;; We have read something.
227               (cnt (count-colons stream))           ;; It may represent either symbol or package designator.
228               (sym (if (= cnt 0)           ;; Looking after it: do we have a colon?
229                        (if (stringp tok) (or (find-symbol tok) (intern tok)) tok)           (colons (count-colons stream))
230                        (let ((package (find-package tok *package*)))           (object (read-after-colon stream token colons)))
231                          (assert package (package) "No package ~a" tok)  
232                          (multiple-value-bind (symbol status)      (when (or *disable-symbol-readmacro*
233                              (find-symbol (read-token stream) package)                (not (symbolp object))
234                            (when (and (= cnt 1) (not (eq status :external)))                (eql char #\|))
235                              (cerror "Use anyway"          (return-from read-token-with-colons object))
                                     "Symbol ~A not external" symbol))  
                           symbol)))))  
236    
237          (let ((res (if (or *disable-symbol-readmacro*      (let ((object (process-symbol-readmacro object stream)))
238                             (not (symbolp sym)) (eql char #\|))        (when *car-list*
239                         sym          (setf *car-list* nil
240                         (process-symbol-readmacro sym stream))))                *extra-symbol-finders*
241            (when %*car-list*                (append (extra-finders object) *extra-symbol-finders*)))
242              (setf %*car-list* nil)        object)))
243              (when (and (symbolp res) (not (eql char #\|)))  
244                (setf %*extra-symbol-finders*  (let ((default-open-paren-reader
245                      (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))))  
246    (defun open-paren-reader (stream char)    (defun open-paren-reader (stream char)
247      (let ((%*car-list* t) (%*extra-symbol-finders* %*extra-symbol-finders*))      (let ((*car-list* t) (*extra-symbol-finders* *extra-symbol-finders*))
248        (funcall default-open-paren-reader stream char))))        (funcall default-open-paren-reader stream char))))
   
   
 ;;;  
 ;;; 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))  
249    
250  (defun (setf package-finders) (value &optional (package *package*))  (defun (setf package-finders) (value &optional (package *package*))
251    (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 265  Returns function, assigned by set-macro-
265  (defun extra-finders (symbol)  (defun extra-finders (symbol)
266    (gethash symbol *extra-finders*))    (gethash symbol *extra-finders*))
267    
268    (defmacro set-handler (handler-list key function)
269      "This is middle-level public API for changing handlers for
270    find-symbol and find-package. There are five lists:
271      *package-finders* -- global for find-package
272      *symbol-finders* -- global for find-symbol
273      (package-finders package) -- per-package for find-package
274      (symbol-finders package) -- per-package for find-symbol
275      (extra-finders symbol) -- per-symbol for (symbol ....) package substitution
276    
277    Key should be uniq in the sense of EQUAL in the list. SET-HANDLER adds
278    new handler if it is not already there.
279    "
280      (let ((key-var (gensym "key")))
281        `(let ((,key-var ,key))
282           (unless (assoc ,key-var ,handler-list :test #'equal)
283             (push (cons ,key-var ,function)
284                   ,handler-list)))))
285    
286    (defmacro %set-handler (handler-list key name &body handler-body)
287      "Local macros for push-* functions. No gensyms intended."
288      `(set-handler ,handler-list ,key
289                    (lambda (,name package)
290                      (declare (ignore package)) . ,handler-body)))
291    
292  (defun push-import-prefix (prefix &optional (package *package*))  (defun push-import-prefix (prefix &optional (package *package*))
293    "Enables using package name omitting prefix.    "Enables using package name omitting prefix.
294  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 306  So, if you make
306    
307  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.
308  "  "
309    (push (lambda (name package)    (%set-handler (package-finders package) `(:prefix ,prefix) name
310            (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)))  
311    
312  (defun push-local-nickname (long-package nick  (defun push-local-nickname (long-package nick
313                              &optional (current-package *package*))                              &optional (current-package *package*))
# Line 285  You may do it right: Line 322  You may do it right:
322    
323  Local-nicknames are local, so you may use it freely.  Local-nicknames are local, so you may use it freely.
324    
325  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
326  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
327  rename LIB version 1 to LIB1 and make  version 2 to LIB2 and make
328   (push-local-nickname :lib1 :lib :a)   (push-local-nickname :lib1 :lib :a)
329     (push-local-nickname :lib2 :lib :b)
330    
331    If enabled global-nicknames via enable-global-nicknames,
332    then also created alias in current package.
333    
334    For example,
335     (push-local-nickname :lib1 :lib :a), states, that package A.LIB is eq to LIB1.
336  "  "
337    (let ((dpackage (find-package long-package)))    (let ((dpackage (find-package long-package))
338      (push (lambda (name package)          (s-nick (string nick)))
339              (declare (ignore package))      (%set-handler (package-finders current-package)
340              (when (string= name (string nick)) dpackage))                    `(:nick ,(string long-package) ,s-nick) name
341          (package-finders current-package))))        (when (string= name s-nick) dpackage))
342        (when *global-nicknames*
343          (setf (gethash (concatenate 'string
344                                      (package-name current-package)
345                                      "." s-nick) *global-nicknames*)
346                dpackage))))
347    
348  (defun push-local-package (symbol local-package)  (defun push-local-package (symbol local-package)
349    "Sets local-package for a symbol. Many macroses use the own clauses.    "Sets local-package for a symbol. Many macroses use there own clauses.
350  For example, ITERATE uses FOR, COLLECT and so on.  For example, ITERATE uses FOR, COLLECT and so on.
351  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.
352   (push-local-package 'iter:iter :iterate)   (push-local-package 'iter:iter :iterate)
# Line 310  For example, this will be error: Line 359  For example, this will be error:
359  , because first for is in ITERATE package, but second -- is not.  , because first for is in ITERATE package, but second -- is not.
360  "  "
361    (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))))  
362        (%set-handler (extra-finders symbol) `(:local ,symbol ,local-package) name
363          (multiple-value-bind (symbol status) (cl:find-symbol name dpackage)
364            (when (eq status :external) symbol)))))
365    
366    ;;; TODO: process nicknames in hierarchy
367    ;;; ex: cl-user.test == common-lisp-user.test
368    ;;; cl-user.test.a == common-lisp-user.test.a
369    
370    (defun normalize-package (name)
371      "Returns nil if already normalized.
372    Replace first section of hierarchy with proper name"
373      (let ((pos (position #\. name)))
374        (when pos
375          (if (= pos 0)  ; .subpackage
376              (concatenate 'string (package-name *package*) name)
377              (let* ((base (subseq name 0 pos))
378                     (p (find-package base)))
379                (when (and p (string/= (package-name p) base))
380                  (concatenate 'string (package-name p) "."
381                               (subseq name (1+ pos)))))))))
382    
383    (flet ((parent (name)
384             (let ((pos (position #\. name :from-end t)))
385               (if pos (subseq name 0 pos) "")))
386           (relative-to (parent name)
387             (cond
388               ((string= parent "") name)
389               ((string= name "") parent)
390               (t (concatenate 'string parent "." name)))))
391      (defun hierarchy-find-package (name package)
392        (if (char= (char name 0) #\.)
393          (do ((i 1 (1+ i))
394               (p (package-name package) (parent p)))
395              ((or (= i (length name)) (char/= (char name i) #\.))
396               (find-package (relative-to p (subseq name i)))))
397          (let ((normalized (normalize-package name)))
398            (when normalized
399              (find-package normalized package))))))
400    
401    (defun correct-package (designator)
402      (let ((p (find-package designator)))
403        (if p (package-name p) designator)))
404    
405    (defmacro in-package (designator)
406      `(|CL|:in-package ,(correct-package (string designator))))
407    
408    (defmacro defpackage (package &rest options)
409      (let ((normalized (normalize-package (string package)))
410            (options
411             (mapcar (lambda (option)
412                       (cons (car option)
413                             (case (car option)
414                               (:use (mapcar #'correct-package (cdr option)))
415                               ((:import-from :shadowing-import-from)
416                                (cons (correct-package (second option))
417                                      (cddr option)))
418                               (t (cdr option)))))
419                     options)))
420        `(|CL|:defpackage ,(or normalized package) . ,options)))
421    
422    (defun substitute-symbol (stream symbol)
423      (declare (ignore stream))
424      (find-symbol (symbol-name symbol) #.*package*))
425    
426    (defun enable-hierarchy-packages ()
427      (set-handler *package-finders* :hierarchy #'hierarchy-find-package)
428      (set-macro-symbol '|CL|:in-package #'substitute-symbol)
429      (set-macro-symbol '|CL|:defpackage #'substitute-symbol))
430    
431    (defun enable-global-nicknames ()
432      (setf *global-nicknames* (make-hash-table :test 'equal))
433      (%set-handler *package-finders* :global-nicknames name
434        (gethash name *global-nicknames*)))
435    
436    (enable-hierarchy-packages)
437    (enable-global-nicknames)
438    
439    ;;;
440    ;;; Readtable analysis and change
441    ;;;
442    (eval-when (:compile-toplevel :load-toplevel :execute)
443      (defmacro with-case (case &body body)
444        (let ((save (gensym)))
445          `(let ((,save (readtable-case *readtable*)))
446             (setf (readtable-case *readtable*) ,case)
447             (unwind-protect
448                  (progn ,@body)
449               (setf (readtable-case *readtable*) ,save)))))
450    
451      (defun does-not-terminate-token-p (c)
452        (ignore-errors
453          (let ((str (format nil "a~Ab" c)))
454            (string= str (symbol-name
455                          (with-case :preserve
456                            (read-from-string (format nil "#:~A" str))))))))
457    
458      (defun whitespace-p (c)
459        (ignore-errors
460          (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
461    
462      (defun multiple-escape-p (c)
463        (ignore-errors
464          (string= "qQ" (symbol-name
465                         (with-case :upcase
466                           (read-from-string (format nil "#:~AqQ~A" c c)))))))
467    
468      (defun single-escape-p (c)
469        (ignore-errors
470          (string= (symbol-name '#:\ ) (symbol-name
471                                        (read-from-string
472                                         (format nil "#:~A'" c))))))
473    
474      (defun macro-char-p (c)
475        "If C is macro-char, return GET-MACRO-CHARACTER"
476        #+allegro (unless
477                      (eql (get-macro-character c) #'excl::read-token)
478                    (get-macro-character c))
479        #-allegro (get-macro-character c))
480    
481      (defun to-process (c)
482        (cond
483          ((eql c #\:) nil)
484          ((macro-char-p c) nil)
485          ((does-not-terminate-token-p c) t)
486          ((whitespace-p c) nil)
487          ((multiple-escape-p c) t)
488          ((single-escape-p c) t)
489          (t nil)))
490    
491      (defparameter +additional-chars+ ""
492        "Fill this, if you need extra characters for packages to begin with")
493    
494      (defun chars-to-process ()
495        (let ((*readtable* (copy-readtable nil)))
496          (nconc
497           (loop :for i :from 1 :to 127
498              :for c = (code-char i)
499              :when (to-process c) :collect c)
500           (loop :for c :across +additional-chars+
501              :when (to-process c) :collect c))))
502    
503      (defun make-named-rt ()
504        `(,(cl:find-symbol "DEFREADTABLE" "NAMED-READTABLES") :advanced
505           (:merge :standard)
506           ,@(loop :for c :in (chars-to-process)
507                :collect `(:macro-char ,c #'read-token-with-colons t))
508           (:macro-char #\( #'open-paren-reader nil))))
509    
510    (macrolet ((def-advanced-readtable ()
511                 (make-named-rt)))
512      (when (cl:find-package "NAMED-READTABLES")
513        (def-advanced-readtable)))
514    
515    (defun activate ()
516      (dolist (c (chars-to-process))
517        (set-macro-character c #'read-token-with-colons t))
518      (set-macro-character #\( #'open-paren-reader t))
519    
520    (defun ! () (activate))

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

  ViewVC Help
Powered by ViewVC 1.1.5