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

Contents of /src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Thu Sep 20 07:50:22 2012 UTC (18 months, 4 weeks ago) by rklochkov
File size: 8395 byte(s)
Initial
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