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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Thu Sep 20 07:50:22 2012 UTC (18 months, 4 weeks ago) by rklochkov
File size: 8395 byte(s)
Initial
1 rklochkov 1 (in-package #:advanced-readtable)
2    
3     ;;;
4     ;;; study virgin readtable
5     ;;;
6    
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)))))
14    
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))))))))
21    
22    
23     (defun whitespace[2]-p (c)
24     (ignore-errors
25     (= 2 (length (read-from-string (format nil "(#:a~A#:b)" c))))))
26    
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)))))))
32    
33     (defun single-escape-p (c)
34     (ignore-errors
35     (string= (symbol-name '#:\') (symbol-name
36     (read-from-string (format nil "#:~A'" c))))))
37    
38    
39    
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))
46    
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))
63    
64     (defvar *advanced-readtable* (copy-readtable nil))
65     (defvar *colon-readtable* (copy-readtable nil)
66     "Support readtable with colon as whitespace")
67    
68     ;;;
69     ;;; Readtable handlers
70     ;;;
71    
72     (defpackage #:advanced-readtable.junk)
73    
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))))
86    
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))))
95    
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")
100    
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))))
108    
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 (cl:find-package name)
114     (when current-package
115     (try-funcall (package-finders current-package) sname
116     current-package))
117     (try-funcall *package-finders* sname current-package)))))
118    
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    
124     (defun find-symbol (name &optional dpackage)
125     (declare (type string name))
126     (let ((package (find-package dpackage)))
127     (macrolet ((mv-or (&rest clauses)
128     (if clauses
129     `(multiple-value-bind (symbol status) ,(car clauses)
130     (if symbol (values symbol status)
131     (mv-or ,@(cdr clauses))))
132     `(values nil nil))))
133    
134     (mv-or (if package
135     (cl:find-symbol name package)
136     (cl:find-symbol name))
137     (when package
138     (try-funcall (symbol-finders package) name package))
139     (try-funcall *symbol-finders* name package)))))
140    
141     (defvar *symbol-readmacros* (make-hash-table :test 'eq))
142     (defvar *disable-symbol-readmacro* nil
143     "Disables processing of symbol-readmacro.")
144    
145     (defun def-symbol-readmacro (symbol func)
146     (setf (gethash symbol *symbol-readmacros*) func))
147    
148     (defun process-symbol-readmacro (symbol stream)
149     (let ((func (gethash symbol *symbol-readmacros*)))
150     (if func (funcall func symbol stream) symbol)))
151    
152     (defun read-token-with-colons (stream char)
153     "Reads token, then analize package part if needed"
154     (unread-char char stream)
155     (if *read-suppress* (let ((*readtable* (copy-readtable nil)))
156     (read stream))
157     (let* ((tok (read-token stream))
158     ;; We have read something.
159     ;; It may represent either symbol or package designator.
160     ;; Looking after it: do we have a colon?
161     (cnt (count-colons stream))
162     (sym (if (= cnt 0)
163     (if (stringp tok) (intern tok) tok)
164     (let ((package (find-package tok *package*)))
165     (assert package (package) "No package ~a" tok)
166     (multiple-value-bind (symbol status)
167     (find-symbol (read-token stream) package)
168     (when (and (= cnt 1) (not (eq status :external)))
169     (cerror "Use anyway"
170     "Symbol ~A not external" symbol))
171     symbol)))))
172    
173     (if (or *disable-symbol-readmacro*
174     (not (symbolp sym)) (eql char #\|))
175     sym
176     (process-symbol-readmacro sym stream)))))
177    
178    
179     ;;;
180     ;;; Prepare readtables
181     ;;;
182    
183     (let (initialized)
184     (defun activate (&optional force)
185     "Inits *advanced-readtable* and *colon-readtable*."
186     (when (or force (not initialized))
187     (setq initialized t)
188     (let ((char-table (fill-char-table)))
189     (dotimes (i (length char-table))
190     (let ((b (svref char-table i))
191     (c (code-char i)))
192     (unless (char= #\# c)
193     (when (member b '(:does-not-terminate-token
194     :multiple-escape :single-escape))
195     ;; will make it non-terminating macro character
196     ;; = potentially beginning of the package-name
197     (set-macro-character c #'read-token-with-colons
198     t *advanced-readtable*))))))
199    
200     (set-syntax-from-char #\: #\Space *colon-readtable* *colon-readtable*))
201     (setf *readtable* *advanced-readtable*)))
202    
203     (defun ! () (activate))
204    
205     (defun (setf package-finders) (value &optional (package *package*))
206     (setf (gethash package *per-package-finders*) value))
207    
208     (defun package-finders (&optional (package *package*))
209     (gethash package *per-package-finders*))
210    
211     (defun (setf symbol-finders) (value &optional (package *package*))
212     (setf (gethash package *package-symbol-finders*) value))
213    
214     (defun symbol-finders (&optional (package *package*))
215     (gethash package *package-symbol-finders*))
216    
217    
218     (defun push-import-prefix (package prefix)
219     (push (lambda (name package)
220     (declare (ignore package))
221     (cl:find-package (concatenate 'string prefix "." name)))
222     (package-finders package)))
223    
224     (defun push-local-nickname (long-package nick
225     &optional (current-package *package*))
226     (let ((long-name (package-name (find-package long-package))))
227     (push (lambda (name package)
228     (declare (ignore package))
229     (when (string= name (string nick)) long-name))
230     (package-finders current-package))))
231    

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.5