/[climacs]/climacs/cl-syntax.lisp
ViewVC logotype

Contents of /climacs/cl-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (show annotations)
Sun Nov 12 16:06:06 2006 UTC (7 years, 5 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.20: +1 -1 lines
Make Climacs use Drei. There are known problems (apart from the docs
now being outdated):

* Some syntaxes have not been updated.
* Group functionality has been disabled.
* It's a large change and Climacs has no test suite. Bugs probably
  still remain.

But it should work nicely most of the time. Otherwise, you'll get a
full refund.
1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-SYNTAX -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; Nada Ayad (nada.ayad@etu.u-bordeaux1.fr)
6 ;;; Julien Cazaban (bizounorc@hotmail.com)
7 ;;; Pascal Fong Kye (pfongkye@yahoo.com)
8 ;;; Bruno Mery (mery@member.fsf.org)
9 ;;; This library is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU Library General Public
11 ;;; License as published by the Free Software Foundation; either
12 ;;; version 2 of the License, or (at your option) any later version.
13 ;;;
14 ;;; This library is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;; Library General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU Library General Public
20 ;;; License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;;; Boston, MA 02111-1307 USA.
23
24 ;;; Syntax for analysing Common Lisp
25
26 (in-package :climacs-cl-syntax)
27
28
29 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;;
31 ;;; grammar classes
32
33 (defclass cl-parse-tree (parse-tree) ())
34
35 (defclass cl-entry (cl-parse-tree)
36 ((ink) (face)
37 (state :initarg :state)))
38
39 (defclass cl-nonterminal (cl-entry) ())
40
41 (defclass cl-terminal (cl-entry)
42 ((item :initarg :item)))
43
44
45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46 ;;;
47 ;;; lexer
48
49 (defclass cl-lexeme (cl-entry) ())
50
51 (defclass start-lexeme (cl-lexeme) ())
52 (defclass paren-open (cl-lexeme) ())
53 (defclass paren-close (cl-lexeme) ())
54 (defclass comma (cl-lexeme) ())
55 (defclass quote-symbol (cl-lexeme) ())
56 (defclass colon (cl-lexeme) ())
57 (defclass ampersand (cl-lexeme) ())
58 (defclass double-quote (cl-lexeme) ())
59 (defclass hex (cl-lexeme) ())
60 (defclass pipe (cl-lexeme) ())
61 (defclass line-comment-entry (cl-lexeme) ())
62 (defclass backquote (cl-lexeme) ())
63 (defclass at (cl-lexeme) ())
64 (defclass backslash (cl-lexeme) ())
65 (defclass slash (cl-lexeme) ())
66 (defclass dot (cl-lexeme) ())
67 (defclass plus-symbol (cl-lexeme) ())
68 (defclass minus-symbol (cl-lexeme) ())
69 (defclass default-item (cl-lexeme) ())
70 (defclass other-entry (cl-lexeme) ())
71
72 (defclass cl-lexer (incremental-lexer) ())
73
74 (defmethod next-lexeme ((lexer cl-lexer) scan)
75 (flet ((fo () (forward-object scan)))
76 (let ((object (object-after scan)))
77 (case object
78 (#\( (fo) (make-instance 'paren-open))
79 (#\) (fo) (make-instance 'paren-close))
80 (#\, (fo) (make-instance 'comma))
81 (#\" (fo) (make-instance 'double-quote))
82 (#\' (fo) (make-instance 'quote-symbol))
83 (#\: (fo) (make-instance 'colon))
84 (#\& (fo) (make-instance 'ampersand))
85 (#\# (fo) (make-instance 'hex))
86 (#\| (fo) (make-instance 'pipe))
87 (#\` (fo) (make-instance 'backquote))
88 (#\@ (fo) (make-instance 'at))
89 (#\\ (fo) (make-instance 'backslash))
90 (#\/ (fo) (make-instance 'slash))
91 (#\. (fo) (make-instance 'dot))
92 (#\+ (fo) (make-instance 'plus-symbol))
93 (#\- (fo) (make-instance 'minus-symbol))
94 (#\; (fo) (loop until (end-of-buffer-p scan)
95 until (eql (object-after scan) #\Newline)
96 do (fo))
97 (if (end-of-buffer-p scan)
98 (make-instance 'other-entry)
99 (make-instance 'line-comment-entry)))
100 (t (cond ((digit-char-p object)
101 (loop until (end-of-buffer-p scan)
102 while (digit-char-p (object-after scan))
103 do (fo))
104 (make-instance 'default-item))
105 ((neutralcharp object)
106 (loop until (end-of-buffer-p scan)
107 while (neutralcharp (object-after scan))
108 do (fo))
109 (make-instance 'default-item))
110 (t (fo)
111 (make-instance 'other-entry))))))))
112
113
114 (define-syntax cl-syntax (fundamental-syntax)
115 ((lexer :reader lexer)
116 (valid-parse :initform 1)
117 (parser))
118 (:name "Common Lisp")
119 (:pathname-types "lsp" "cl"))
120
121 (defun neutralcharp (var)
122 (and (characterp var)
123 (not (member var '(#\( #\) #\, #\" #\' #\# #\| #\` #\@ #\; #\\
124 #\: #\/ #\Newline #\Space #\Tab)
125 :test #'char=))))
126
127
128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129 ;;; parser
130
131 (defparameter *cl-grammar* (grammar))
132
133 (defmacro add-cl-rule (rule)
134 `(add-rule (grammar-rule ,rule) *cl-grammar*))
135
136 (defun item-sequence (item)
137 (buffer-sequence (buffer item) (start-offset item) (end-offset item)))
138
139 (defun default-item-is (default-item string)
140 (string-equal (coerce (item-sequence default-item) 'string)
141 string))
142
143 (defmacro define-list (name empty-name nonempty-name item-name)
144 `(progn
145 (defclass ,name (cl-entry) ())
146 (defclass ,empty-name (,name) ())
147
148 (defclass ,nonempty-name (,name)
149 ((items :initarg :items)
150 (item :initarg :item)))
151
152 (add-cl-rule (,name -> () (make-instance ',empty-name)))
153
154 (add-cl-rule (,name -> (,name ,item-name)
155 (make-instance ',nonempty-name
156 :items ,name :item ,item-name)))
157
158 (defmethod display-parse-tree ((entity ,empty-name) (syntax cl-syntax) pane)
159 (declare (ignore pane))
160 nil)
161
162 (defmethod display-parse-tree ((entity ,nonempty-name) (syntax cl-syntax) pane)
163 (with-slots (items item) entity
164 (display-parse-tree items syntax pane)
165 (display-parse-tree item syntax pane)))))
166
167
168 ;;;;;;;;;;;;; token-items
169
170 (defclass empty-item (cl-entry) ())
171
172 (defmethod display-parse-tree ((entity empty-item) (syntax cl-syntax) pane)
173 (declare (ignore pane))
174 nil)
175
176 (defclass cl-item (cl-entry)
177 ((item :initarg :item)))
178
179 (defclass token-char (cl-item) ())
180
181 (add-cl-rule (token-char -> (default-item) :item default-item))
182 (add-cl-rule (token-char -> (comma) :item comma))
183 (add-cl-rule (token-char -> (backquote) :item backquote))
184 (add-cl-rule (token-char -> (at) :item at))
185 (add-cl-rule (token-char -> (plus-symbol) :item plus-symbol))
186 (add-cl-rule (token-char -> (minus-symbol) :item minus-symbol))
187 (add-cl-rule (token-char -> (pipe) :item pipe))
188
189 (defmethod display-parse-tree ((entity token-char) (syntax cl-syntax) pane)
190 (with-slots (item) entity
191 (display-parse-tree item syntax pane)))
192
193 (defclass token-item (cl-entry)
194 ((item :initarg :item)
195 (ch :initarg :ch)))
196
197 (add-cl-rule (token-item -> ((ch token-char (or (alpha-char-p (coerce (item-head ch) 'character))
198 (member (item-head ch) '(#\= #\* #\+ #\> #\<) :test #'string-equal)
199 (member ch '(#\/ #\+ #\- #\*)
200 :test #'default-item-is))))
201 :item (make-instance 'empty-item) :ch ch))
202
203 (add-cl-rule (token-item -> ((item token-item) (ch token-char (= (end-offset
204 item)
205 (start-offset
206 ch))))
207 :item item :ch ch))
208
209 (defmethod display-parse-tree ((entity token-item) (syntax cl-syntax) pane)
210 (with-slots (item ch) entity
211 (display-parse-tree item syntax pane)
212 (display-parse-tree ch syntax pane)))
213
214 (define-list token-items empty-token-items nonempty-token-items token-item)
215
216
217 ;;;;;;;;;;;;; string-items
218
219 (defclass string-item (cl-item) ())
220
221 (add-cl-rule (string-item -> (token-item) :item token-item))
222 (add-cl-rule (string-item -> (default-item) :item default-item))
223 (add-cl-rule (string-item -> (paren-open) :item paren-open))
224 (add-cl-rule (string-item -> (paren-close) :item paren-close))
225 (add-cl-rule (string-item -> (hex) :item hex))
226 (add-cl-rule (string-item -> (backslash) :item backslash))
227 (add-cl-rule (string-item -> (slash) :item slash))
228 (add-cl-rule (string-item -> (dot) :item dot))
229 (add-cl-rule (string-item -> (line-comment-entry) :item line-comment-entry))
230
231
232 (define-list string-items empty-string-items
233 nonempty-string-items string-item)
234
235 (defmethod display-parse-tree ((entity string-item) (syntax cl-syntax) pane)
236 (with-slots (item) entity
237 (display-parse-tree item syntax pane)))
238
239
240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
241
242 (defclass identifier-item (cl-item) ())
243
244 (add-cl-rule (identifier-item -> (string-item) :item string-item))
245 (add-cl-rule (identifier-item -> (double-quote) :item double-quote))
246
247 (define-list identifier-items empty-identifier-items
248 nonempty-identifier-items identifier-item)
249
250 (defmethod display-parse-tree ((entity identifier-item) (syntax cl-syntax) pane)
251 (with-slots (item) entity
252 (display-parse-tree item syntax pane)))
253
254 (defclass identifier-compound (cl-entry)
255 ((start :initarg :start)
256 (items :initarg :items)
257 (end :initarg :end)))
258
259 (add-cl-rule (identifier-compound -> ((start pipe) identifier-items
260 (end pipe))
261 :start start :items identifier-items
262 :end end))
263
264 (defmethod display-parse-tree ((entity identifier-compound) (syntax cl-syntax) pane)
265 (with-slots (start items end) entity
266 (display-parse-tree start syntax pane)
267 (display-parse-tree items syntax pane)
268 (display-parse-tree end syntax pane)))
269
270
271 (defclass identifier (cl-item) ())
272
273 (add-cl-rule (identifier -> ((item token-item))
274 :item item))
275
276 (add-cl-rule (identifier -> ((item slash))
277 :item item))
278
279 (add-cl-rule (identifier -> (identifier-compound) :item identifier-compound))
280
281 (defmethod display-parse-tree ((entity identifier) (syntax cl-syntax) pane)
282 (with-slots (item) entity
283 (display-parse-tree item syntax pane)))
284
285 ;;;;;;;;;;;;; line-comment
286
287 (defclass line-comment (cl-item) ())
288
289 (add-cl-rule (line-comment -> ((item line-comment-entry)) :item item))
290
291 (defmethod display-parse-tree ((entity line-comment) (syntax cl-syntax) pane)
292 (with-slots (item) entity
293 (with-drawing-options (pane :ink (make-rgb-color 0.6 0.16 0.3))
294 (display-parse-tree item syntax pane))))
295
296 ;;;;;;;;;;;;; balanced-comment
297
298 (defclass balanced-comment (cl-entry)
299 ((start-hex :initarg :start-hex)
300 (start-pipe :initarg :start-pipe)
301 (item :initarg :item)
302 (end-pipe :initarg :end-pipe)
303 (end-hex :initarg :end-hex)))
304
305 (add-cl-rule (balanced-comment -> ((start-hex hex)
306 (start-pipe pipe (= (end-offset
307 start-hex)
308 (start-offset start-pipe)))
309 (item identifier-items)
310 (end-pipe pipe)
311 (end-hex hex (= (end-offset end-pipe)
312 (start-offset end-hex))))
313 :start-hex start-hex
314 :start-pipe start-pipe
315 :item item
316 :end-pipe end-pipe
317 :end-hex end-hex))
318
319 (defmethod display-parse-tree ((entity balanced-comment) (syntax cl-syntax) pane)
320 (with-slots (start-hex start-pipe item end-pipe end-hex) entity
321 (with-drawing-options (pane :ink (make-rgb-color 0.6 0.16 0.3))
322 (display-parse-tree start-hex syntax pane)
323 (display-parse-tree start-pipe syntax pane)
324 (display-parse-tree item syntax pane)
325 (display-parse-tree end-pipe syntax pane)
326 (display-parse-tree end-hex syntax pane))))
327
328 ;;;;;;;;;;;;; string
329
330 (defclass cl-string (cl-entry)
331 ((string-start :initarg :string-start)
332 (items :initarg :items)
333 (string-end :initarg :string-end)))
334
335 (add-cl-rule (cl-string -> ((start double-quote) string-items (end double-quote))
336 :string-start start :items string-items
337 :string-end end))
338
339
340 (defmethod display-parse-tree ((entity cl-string) (syntax cl-syntax) pane)
341 (with-slots (string-start items string-end) entity
342 (with-drawing-options (pane :ink (make-rgb-color 0.6 0.4 0.2))
343 (display-parse-tree string-start syntax pane)
344 (display-parse-tree items syntax pane)
345 (display-parse-tree string-end syntax pane))))
346
347
348 ;;;;;;;;;;;;;;;;;;;;; #-type constants
349
350 (defun item-head (default-item)
351 (coerce (buffer-sequence (buffer default-item)
352 (start-offset default-item)
353 (1+ (start-offset default-item))) 'string))
354
355 (defun item-tail (default-item)
356 (coerce (buffer-sequence (buffer default-item)
357 (1+ (start-offset default-item))
358 (end-offset default-item)) 'string))
359
360 (defun radix-is (num-string radix)
361 (values (ignore-errors
362 (parse-integer num-string :radix radix :junk-allowed 'nil))))
363
364 (defclass radix-expr (cl-entry)
365 ((start :initarg :start)
366 (item :initarg :item)))
367
368 (defmethod display-parse-tree ((entity radix-expr) (syntax cl-syntax) pane)
369 (with-slots (start item) entity
370 (display-parse-tree start syntax pane)
371 (display-parse-tree item syntax pane)))
372
373 (defclass hexadecimal-expr (radix-expr) ())
374
375 (add-cl-rule (hexadecimal-expr -> ((start hex)
376 (item token-item
377 (and (= (end-offset start)
378 (start-offset item))
379 (string-equal (item-head item) #\x)
380 (radix-is (item-tail item) 16))))
381 :start start :item item))
382
383 (defclass octal-expr (radix-expr) ())
384
385 (add-cl-rule (octal-expr -> ((start hex)
386 (item default-item
387 (and (= (end-offset start)
388 (start-offset item))
389 (string-equal (item-head item) #\o)
390 (radix-is (item-tail item) 8))))
391 :start start :item item))
392
393 (defclass binary-expr (radix-expr) ())
394
395 (add-cl-rule (binary-expr -> ((start hex)
396 (item default-item
397 (and (= (end-offset start)
398 (start-offset item))
399 (string-equal (item-head item) #\b)
400 (radix-is (item-tail
401 item) 2))))
402 :start start :item item))
403
404 (defclass simple-number (cl-item) ())
405
406 (add-cl-rule (simple-number -> ((item default-item (radix-is
407 (coerce
408 (item-sequence item) 'string) 10)))
409 :item item))
410
411 (defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
412 (with-slots (item) entity
413 (display-parse-tree item syntax pane)))
414
415 (defclass radix-n-expr (cl-entry)
416 ((start :initarg :start)
417 (radix :initarg :radix)
418 (item :initarg :item)))
419
420 (add-cl-rule (radix-n-expr -> ((start hex)
421 (radix simple-number (= (end-offset start)
422 (start-offset radix)))
423 (item default-item (and (= (end-offset radix)
424 (start-offset item))
425 (string-equal
426 (item-head item) #\r)
427 (radix-is
428 (item-tail item)
429 (values (parse-integer (coerce
430 (item-sequence radix) 'string)))))))
431
432 :start start :radix radix :item item))
433
434 (defmethod display-parse-tree ((entity radix-n-expr) (syntax cl-syntax) pane)
435 (with-slots (start radix item) entity
436 (display-parse-tree start syntax pane)
437 (display-parse-tree radix syntax pane)
438 (display-parse-tree item syntax pane)))
439
440 (defclass real-number (cl-entry)
441 ((primary :initarg :primary)
442 (separator :initarg :separator)
443 (secondary :initarg :secondary)))
444
445 (add-cl-rule (real-number -> ((primary simple-number)
446 (separator slash (= (end-offset primary)
447 (start-offset separator)))
448 (secondary simple-number (= (end-offset
449 separator)
450 (start-offset secondary))))
451 :primary primary :separator separator
452 :secondary secondary))
453
454 (add-cl-rule (real-number -> ((primary simple-number)
455 (separator dot (= (end-offset primary)
456 (start-offset separator)))
457 (secondary simple-number (= (end-offset
458 separator)
459 (start-offset secondary))))
460 :primary primary :separator separator
461 :secondary secondary))
462
463 (defmethod display-parse-tree ((entity real-number) (syntax cl-syntax) pane)
464 (with-slots (primary secondary separator) entity
465 (display-parse-tree primary syntax pane)
466 (display-parse-tree separator syntax pane)
467 (display-parse-tree secondary syntax pane)))
468
469
470 (defclass complex-number (cl-entry)
471 ((start :initarg :start)
472 (realpart :initarg :realpart)
473 (imagpart :initarg :imagpart)
474 (end :initarg :end)))
475
476 (add-cl-rule (complex-number -> ((start paren-open)
477 (realpart real-number)
478 (imagpart real-number (/=
479 (end-offset
480 realpart)
481 (start-offset imagpart)))
482 (end paren-close))
483 :start start :realpart realpart :imagpart
484 imagpart :end end))
485
486 (add-cl-rule (complex-number -> ((start paren-open)
487 (realpart simple-number)
488 (imagpart simple-number (/=
489 (end-offset
490 realpart)
491 (start-offset imagpart)))
492 (end paren-close))
493 :start start :realpart realpart :imagpart
494 imagpart :end end))
495
496 (defmethod display-parse-tree ((entity complex-number) (syntax cl-syntax) pane)
497 (with-slots (start realpart imagpart end) entity
498 (display-parse-tree start syntax pane)
499 (display-parse-tree realpart syntax pane)
500 (display-parse-tree imagpart syntax pane)
501 (display-parse-tree end syntax pane)))
502
503 (defclass complex-expr (cl-entry)
504 ((start :initarg :start)
505 (header :initarg :header)
506 (item :initarg :item)))
507
508 (add-cl-rule (complex-expr -> ((start hex)
509 (header default-item (and (default-item-is
510 header #\c)
511 (= (end-offset start)
512 (start-offset header))))
513 (item complex-number (= (end-offset header)
514 (start-offset item))))
515 :start start :header header :item
516 item))
517
518 (defmethod display-parse-tree ((entity complex-expr) (syntax cl-syntax) pane)
519 (with-slots (start header item) entity
520 (display-parse-tree start syntax pane)
521 (display-parse-tree header syntax pane)
522 (display-parse-tree item syntax pane)))
523
524 (defclass number-expr (cl-item) ())
525
526 (add-cl-rule (number-expr -> ((item simple-number)) :item item))
527 (add-cl-rule (number-expr -> ((item real-number)) :item item))
528 (add-cl-rule (number-expr -> ((item binary-expr)) :item item))
529 (add-cl-rule (number-expr -> ((item octal-expr)) :item item))
530 (add-cl-rule (number-expr -> ((item hexadecimal-expr)) :item item))
531 (add-cl-rule (number-expr -> ((item radix-n-expr)) :item item))
532 (add-cl-rule (number-expr -> ((item complex-expr)) :item item))
533
534 (defmethod display-parse-tree ((entity number-expr) (syntax cl-syntax) pane)
535 (with-slots (item) entity
536 (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
537 (display-parse-tree item syntax pane))))
538
539 (defclass pathname-expr (cl-entry)
540 ((start :initarg :start)
541 (item :initarg :item)))
542
543 (add-cl-rule (pathname-expr -> ((start hex)
544 (item default-item (and (string-equal
545 (item-head item) #\p)
546 (= (end-offset start)
547 (start-offset item)))))
548 :start start :item item))
549
550 (defmethod display-parse-tree ((entity pathname-expr) (syntax cl-syntax) pane)
551 (with-slots (start item) entity
552 (display-parse-tree start syntax pane)
553 (display-parse-tree item syntax pane)))
554
555
556 ;;;;;;;;;;;;; characters
557
558 (defclass char-item (cl-entry)
559 ((start :initarg :start)
560 (separator :initarg :separator)
561 (item :initarg :item)))
562
563 (add-cl-rule (char-item -> ((start hex)
564 (separator backslash (= (end-offset start)
565 (start-offset separator)))
566 (item cl-lexeme (and (= (end-offset separator)
567 (start-offset item))
568 (= (end-offset item)
569 (1+ (start-offset item))))))
570 :start start :separator separator :item item))
571
572 (add-cl-rule (char-item -> ((start hex)
573 (separator backslash (= (end-offset start)
574 (start-offset separator)))
575 (item default-item (and (= (end-offset separator)
576 (start-offset item))
577 (member item
578 '("Newline" "Tab" "Space") :test #'default-item-is))))
579 :start start :separator separator :item item))
580
581 (defmethod display-parse-tree ((entity char-item) (syntax cl-syntax) pane)
582 (with-slots (start separator item) entity
583 (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
584 (display-parse-tree start syntax pane)
585 (display-parse-tree separator syntax pane)
586 (display-parse-tree item syntax pane))))
587
588
589
590 (define-list cl-terminals empty-cl-terminals
591 nonempty-cl-terminals cl-terminal)
592
593 ;;;;;;;;;;;;; list-expression
594
595 (defclass list-expr (cl-entry)
596 ((start :initarg :start)
597 (items :initarg :items)
598 (end :initarg :end)))
599
600 (add-cl-rule (list-expr -> ((start paren-open)
601 (items cl-terminals)
602 (end paren-close))
603 :start start :items items :end end))
604
605 (defmethod display-parse-tree ((entity list-expr) (syntax cl-syntax) pane)
606 (with-slots (start items end) entity
607 (with-text-face (pane :bold)
608 (display-parse-tree start syntax pane))
609 (display-parse-tree items syntax pane)
610 (with-text-face (pane :bold)
611 (display-parse-tree end syntax pane))))
612
613
614 ;;;;;;;;;;;;; read-time-attr
615
616 (defclass read-time-attr (cl-entry)
617 ((read-car :initarg :read-car)
618 (read-expr :initarg :read-expr)))
619
620 (defmethod display-parse-tree ((entity read-time-attr) (syntax cl-syntax) pane)
621 (with-slots (read-car read-expr) entity
622 (display-parse-tree read-car syntax pane)
623 (display-parse-tree read-expr syntax pane)))
624
625
626 ;;;;;;;;;;;;; read-time-point-attr
627
628 (defclass read-time-point-attr (read-time-attr) ())
629
630 (add-cl-rule (read-time-point-attr -> ((read-car dot)
631 (read-expr identifier (= (end-offset read-car) (start-offset read-expr))))
632 :read-car read-car :read-expr read-expr))
633
634
635 ;;;;;;;;;;;;; read-time-evaluation
636
637 (defclass read-time-evaluation (cl-entry)
638 ((start :initarg :start)
639 (item :initarg :item)))
640
641
642 (add-cl-rule (read-time-evaluation -> ((start hex)
643 (item read-time-point-attr (= (end-offset start) (start-offset item))))
644 :start start :item item))
645
646 (defmethod display-parse-tree ((entity read-time-evaluation) (syntax cl-syntax) pane)
647 (with-slots (start item) entity
648 (with-drawing-options (pane :ink (make-rgb-color 0.0 0.42 0.42))
649 (display-parse-tree start syntax pane)
650 (display-parse-tree item syntax pane))))
651
652
653 ;;;;;;;;;;;;; read-time-expr
654
655 (defclass read-time-expr (cl-entry)
656 ((time-expr :initarg :time-expr)))
657
658 (add-cl-rule (read-time-expr -> (list-expr) :time-expr list-expr))
659
660 (add-cl-rule (read-time-expr -> (identifier) :time-expr identifier))
661
662
663 (defmethod display-parse-tree ((entity read-time-expr) (syntax cl-syntax) pane)
664 (with-slots (time-expr) entity
665 (display-parse-tree time-expr syntax pane)))
666
667
668 ;;;;;;;;;;;;;; read-time-plus-attr
669
670 (defclass read-time-plus-attr (read-time-attr) ())
671
672 (add-cl-rule (read-time-plus-attr -> ((read-car plus-symbol)
673 (read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
674 :read-car read-car :read-expr read-expr))
675
676
677 ;;;;;;;;;;;;;; read-time-minus-attr
678
679 (defclass read-time-minus-attr (read-time-attr) ())
680
681 (add-cl-rule (read-time-minus-attr -> ((read-car minus-symbol)
682 (read-expr read-time-expr (= (end-offset read-car) (start-offset read-expr))))
683 :read-car read-car :read-expr read-expr))
684
685
686 ;;;;;;;;;;;;; read-time-conditional
687
688 (defclass read-time-conditional (cl-entry)
689 ((start :initarg :start)
690 (test :initarg :test)
691 (expr :initarg :expr)))
692
693
694 (defmethod display-parse-tree ((entity read-time-conditional) (syntax cl-syntax) pane)
695 (with-slots (start test expr) entity
696 (with-drawing-options (pane :ink (make-rgb-color 0.0 0.42 0.42))
697 (display-parse-tree start syntax pane)
698 (display-parse-tree test syntax pane)
699 (display-parse-tree expr syntax pane))))
700
701
702 ;;;;;;;;;;;;; read-time-conditional-plus
703
704 (defclass read-time-conditional-plus (read-time-conditional) ())
705
706
707 (add-cl-rule (read-time-conditional-plus -> ((start hex)
708 (test read-time-plus-attr (= (end-offset start) (start-offset test)))
709 (expr cl-terminal (/= (end-offset test) (start-offset expr))))
710 :start start :test test :expr expr))
711
712
713 ;;;;;;;;;;;;; read-time-conditional-minus
714
715 (defclass read-time-conditional-minus (read-time-conditional) ())
716
717 (add-cl-rule (read-time-conditional-minus -> ((start hex)
718 (test read-time-minus-attr (= (end-offset start) (start-offset test)))
719 (expr cl-terminal (/= (end-offset test) (start-offset expr))))
720 :start start :test test :expr expr))
721
722 ;;; Avoid forward definition
723
724 (defclass quoted-expr (cl-entry)
725 ((start :initarg :start)
726 (item :initarg :item)))
727
728 ;;;;;;;;;;;;; function-expression
729
730 (defclass fun-expr (cl-entry)
731 ((start :initarg :start)
732 (quoted-expr :initarg :quoted-expr)))
733
734 (add-cl-rule (fun-expr -> ((start hex)
735 (quoted-expr quoted-expr (= (end-offset start)
736 (start-offset quoted-expr))))
737 :start start :quoted-expr quoted-expr))
738
739 (defmethod display-parse-tree ((entity fun-expr) (syntax cl-syntax) pane)
740 (with-slots (start quoted-expr) entity
741 (with-drawing-options (pane :ink (make-rgb-color 0.4 0.0 0.4))
742 (display-parse-tree start syntax pane)
743 (display-parse-tree quoted-expr syntax pane))))
744
745
746 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;vector-expression
747
748 (defclass vect-expr (cl-entry)
749 ((start :initarg :start)
750 (list-expr :initarg :list-expr)))
751
752 (add-cl-rule (vect-expr -> ((start hex)
753 (list-expr list-expr (= (end-offset start)
754 (start-offset list-expr))))
755 :start start :list-expr list-expr))
756
757 (defmethod display-parse-tree ((entity vect-expr) (syntax cl-syntax) pane)
758 (with-slots (start list-expr) entity
759 (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
760 (display-parse-tree start syntax pane)
761 (display-parse-tree list-expr syntax pane))))
762
763
764 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;bitvector-expression
765
766 (defclass bitvect-expr (radix-expr) ())
767
768 (add-cl-rule (bitvect-expr -> ((start hex)
769 (item default-item
770 (and (= (end-offset start)
771 (start-offset item))
772 (string-equal (item-head item) #\*)
773 (radix-is (item-tail
774 item) 2))))
775 :start start :item item))
776
777 (defmethod display-parse-tree ((entity bitvect-expr) (syntax cl-syntax) pane)
778 (with-slots (start item) entity
779 (with-drawing-options (pane :ink (make-rgb-color 0.14 0.0 0.86))
780 (display-parse-tree start syntax pane)
781 (display-parse-tree item syntax pane))))
782
783
784 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quoted expr
785
786 (add-cl-rule (quoted-expr -> ((start quote-symbol)
787 (item cl-terminal))
788 :start start :item item))
789
790 (defmethod display-parse-tree ((entity quoted-expr) (syntax cl-syntax) pane)
791 (with-slots (start item) entity
792 (with-text-face (pane :bold)
793 (display-parse-tree start syntax pane))
794 (display-parse-tree item syntax pane)))
795
796 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Qualified symbols
797
798 ;; XXX: There's a bit of duplication going on here. I'm not sure if
799 ;; that could be reduced by clever inheritance. But then, it's only
800 ;; OAOOM.
801
802 (defclass qualified-symbol (cl-entry)
803 ((package-name :initarg :package-name)
804 (colon1 :initarg :colon1)
805 (colon2 :initarg :colon2)
806 (symbol-name :initarg :symbol-name)))
807
808 (defclass qualified-exported-symbol (cl-entry)
809 ((package-name :initarg :package-name)
810 (colon :initarg :colon)
811 (symbol-name :initarg :symbol-name)))
812
813 (add-cl-rule (qualified-symbol -> ((package-name default-item)
814 (colon1 colon (= (end-offset package-name)
815 (start-offset colon1)))
816 (colon2 colon (= (end-offset colon1)
817 (start-offset colon2)))
818 (symbol-name default-item (= (end-offset colon2)
819 (start-offset symbol-name))))
820 :package-name package-name
821 :colon1 colon1
822 :colon2 colon2
823 :symbol-name symbol-name))
824
825 (add-cl-rule (qualified-exported-symbol -> ((package-name default-item)
826 (colon colon (= (end-offset package-name)
827 (start-offset colon)))
828 (symbol-name default-item (= (end-offset colon)
829 (start-offset symbol-name))))
830 :package-name package-name
831 :colon colon
832 :symbol-name symbol-name))
833
834 (defmethod display-parse-tree ((entity qualified-symbol) (syntax cl-syntax) pane)
835 (with-slots (package-name colon1 colon2 symbol-name) entity
836 (with-drawing-options (pane :text-style (make-text-style :fix :bold nil) :ink +purple+)
837 (display-parse-tree package-name syntax pane)
838 (display-parse-tree colon1 syntax pane)
839 (display-parse-tree colon2 syntax pane))
840 (display-parse-tree symbol-name syntax pane)))
841
842 (defmethod display-parse-tree ((entity qualified-exported-symbol) (syntax cl-syntax) pane)
843 (with-slots (package-name colon symbol-name) entity
844 (display-parse-tree package-name syntax pane)
845 (with-drawing-options (pane :ink (make-rgb-color 0.0 0.0 1.0))
846 (display-parse-tree colon syntax pane))
847 (display-parse-tree symbol-name syntax pane)))
848
849 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Keyword symbols
850
851 (defclass keyword-symbol (cl-entry)
852 ((start :initarg :start)
853 (item :initarg :item)))
854
855 (add-cl-rule (keyword-symbol -> ((start colon)
856 (item identifier))
857 :start start :item item))
858
859 (defmethod display-parse-tree ((entity keyword-symbol) (syntax cl-syntax) pane)
860 (with-slots (start item) entity
861 (with-text-face (pane :bold)
862 (display-parse-tree start syntax pane)
863 (display-parse-tree item syntax pane))))
864
865 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Lambda list Keywords
866
867 (defclass lambda-list-keyword (cl-entry)
868 ((start :initarg :start)
869 (item :initarg :item)))
870
871 (add-cl-rule (lambda-list-keyword -> ((start ampersand)
872 (item default-item (and
873 (= (end-offset start)
874 (start-offset item))
875 (member item
876 '( ;; ordinary LLs
877 "optional" "rest" "key" "aux" "allow-other-keys"
878 ;; macro LLs
879 "body" "whole" "environment")
880 :test #'default-item-is))))
881 :start start :item item))
882
883 (defmethod display-parse-tree ((entity lambda-list-keyword) (syntax cl-syntax) pane)
884 (with-slots (start item) entity
885 (with-drawing-options (pane :ink +blue+)
886 (display-parse-tree start syntax pane)
887 (display-parse-tree item syntax pane))))
888
889 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr
890
891 ;;; Avoid forward definition
892 (defclass unquoted-expr (cl-entry)
893 ((start :initarg :start)
894 (item :initarg :item)))
895
896 (defclass backquoted-expr (cl-entry)
897 ((start :initarg :start)
898 (item :initarg :item)))
899
900 (add-cl-rule (backquoted-expr -> ((start backquote)
901 (item cl-terminal))
902 :start start :item item))
903 (add-cl-rule (backquoted-expr -> ((start backquote)
904 (item unquoted-expr))
905 :start start :item item))
906
907 (defmethod display-parse-tree ((entity backquoted-expr) (syntax cl-syntax) pane)
908 (with-slots (start item) entity
909 (display-parse-tree start syntax pane)
910 (display-parse-tree item syntax pane)))
911
912
913 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;unquoted expr
914
915 (defclass unquoted-item (cl-entry)
916 ((start :initarg :start)
917 (end :initarg :end)))
918
919 (add-cl-rule (unquoted-item -> ((start comma)
920 (end at (= (end-offset start)
921 (start-offset end))))
922 :start start :end end))
923
924 (defmethod display-parse-tree ((entity unquoted-item) (syntax cl-syntax) pane)
925 (with-slots (start end) entity
926 (display-parse-tree start syntax pane)
927 (display-parse-tree end syntax pane)))
928
929 (add-cl-rule (unquoted-expr -> ((start comma)
930 (item identifier))
931 :start start :item item))
932 (add-cl-rule (unquoted-expr -> ((start comma)
933 (item list-expr))
934 :start start :item item))
935
936 (add-cl-rule (unquoted-expr -> ((start unquoted-item)
937 (item identifier))
938 :start start :item item))
939 (add-cl-rule (unquoted-expr -> ((start unquoted-item)
940 (item list-expr))
941 :start start :item item))
942
943 (defmethod display-parse-tree ((entity unquoted-expr) (syntax cl-syntax) pane)
944 (with-slots (start item) entity
945 (display-parse-tree start syntax pane)
946 (display-parse-tree item syntax pane)))
947
948
949 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;cl-terminal
950
951 (add-cl-rule (cl-terminal -> (number-expr) :item number-expr))
952 (add-cl-rule (cl-terminal -> (identifier) :item identifier))
953 (add-cl-rule (cl-terminal -> (balanced-comment) :item balanced-comment))
954 (add-cl-rule (cl-terminal -> (cl-string) :item cl-string))
955 (add-cl-rule (cl-terminal -> (quoted-expr) :item quoted-expr))
956 (add-cl-rule (cl-terminal -> (keyword-symbol) :item keyword-symbol))
957 (add-cl-rule (cl-terminal -> (lambda-list-keyword) :item lambda-list-keyword))
958 (add-cl-rule (cl-terminal -> (qualified-symbol) :item qualified-symbol))
959 (add-cl-rule (cl-terminal -> (qualified-exported-symbol) :item qualified-exported-symbol))
960 (add-cl-rule (cl-terminal -> (backquoted-expr) :item backquoted-expr))
961 (add-cl-rule (cl-terminal -> (char-item) :item char-item))
962 (add-cl-rule (cl-terminal -> (unquoted-expr) :item unquoted-expr))
963 (add-cl-rule (cl-terminal -> (list-expr) :item list-expr))
964 (add-cl-rule (cl-terminal -> (fun-expr) :item fun-expr))
965 (add-cl-rule (cl-terminal -> (vect-expr) :item vect-expr))
966 (add-cl-rule (cl-terminal -> (bitvect-expr) :item bitvect-expr))
967 (add-cl-rule (cl-terminal -> (pathname-expr) :item pathname-expr))
968 (add-cl-rule (cl-terminal -> (read-time-conditional-plus) :item read-time-conditional-plus))
969 (add-cl-rule (cl-terminal -> (read-time-conditional-minus) :item read-time-conditional-minus))
970 (add-cl-rule (cl-terminal -> (read-time-evaluation) :item read-time-evaluation))
971 (add-cl-rule (cl-terminal -> (line-comment) :item line-comment))
972
973 (defmethod display-parse-tree ((entity cl-terminal) (syntax cl-syntax) pane)
974 (with-slots (item) entity
975 (display-parse-tree item syntax pane)))
976
977
978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
979
980 (defmethod initialize-instance :after ((syntax cl-syntax) &rest args)
981 (declare (ignore args))
982 (with-slots (parser lexer buffer) syntax
983 (setf parser (make-instance 'parser
984 :grammar *cl-grammar*
985 :target 'cl-terminals))
986 (setf lexer (make-instance 'cl-lexer :buffer (buffer syntax)))
987 (let ((m (clone-mark (low-mark buffer) :left))
988 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
989 (setf (offset m) 0)
990 (setf (start-offset lexeme) m
991 (end-offset lexeme) 0)
992 (insert-lexeme lexer 0 lexeme))))
993
994
995 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
996 ;;; update syntax
997
998 (defmethod update-syntax-for-display (buffer (syntax cl-syntax) top bot)
999 (with-slots (parser lexer valid-parse) syntax
1000 (loop until (= valid-parse (nb-lexemes lexer))
1001 while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
1002 do (let ((current-token (lexeme lexer (1- valid-parse)))
1003 (next-lexeme (lexeme lexer valid-parse)))
1004 (setf (slot-value next-lexeme 'state)
1005 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
1006 (incf valid-parse))))
1007
1008 (defmethod inter-lexeme-object-p ((lexer cl-lexer) object)
1009 (whitespacep (syntax (buffer lexer)) object))
1010
1011 (defmethod update-syntax (buffer (syntax cl-syntax))
1012 (with-slots (lexer valid-parse) syntax
1013 (let* ((low-mark (low-mark buffer))
1014 (high-mark (high-mark buffer)))
1015 (when (mark<= low-mark high-mark)
1016 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
1017 (setf valid-parse first-invalid-position)
1018 (update-lex lexer first-invalid-position high-mark))))))
1019
1020
1021 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1022 ;;; display
1023
1024 (defvar *white-space-start* nil)
1025
1026 (defvar *cursor-positions* nil)
1027 (defvar *current-line* 0)
1028
1029 (defun handle-whitespace (pane buffer start end)
1030 (let ((space-width (space-width pane))
1031 (tab-width (tab-width pane)))
1032 (loop while (and (< start end)
1033 (whitespacep (syntax buffer)
1034 (buffer-object buffer start)))
1035 do (ecase (buffer-object buffer start)
1036 (#\Newline (terpri pane)
1037 (setf (aref *cursor-positions* (incf *current-line*))
1038 (multiple-value-bind (x y) (stream-cursor-position pane)
1039 (declare (ignore x))
1040 y)))
1041 (#\Space (stream-increment-cursor-position
1042 pane space-width 0))
1043 (#\Tab (let ((x (stream-cursor-position pane)))
1044 (stream-increment-cursor-position
1045 pane (- tab-width (mod x tab-width)) 0)))
1046 (#\Page nil))
1047 (incf start))))
1048
1049 (defmethod display-parse-tree :around ((entity cl-parse-tree) syntax pane)
1050 (with-slots (top bot) pane
1051 (when (and (end-offset entity) (mark> (end-offset entity) top))
1052 (call-next-method))))
1053
1054 (defun color-equal (c1 c2)
1055 (when (eq c1 c2)
1056 (return-from color-equal t))
1057 (when (or (eq c1 +foreground-ink+)
1058 (eq c2 +foreground-ink+)
1059 (eq c1 +background-ink+)
1060 (eq c2 +background-ink+))
1061 (return-from color-equal nil))
1062 (multiple-value-bind (r1 g1 b1)
1063 (color-rgb c1)
1064 (multiple-value-bind (r2 g2 b2)
1065 (color-rgb c2)
1066 (and (= r1 r2) (= g1 g2) (= b1 b2)))))
1067
1068 (defmethod display-parse-tree ((entity cl-entry) (syntax cl-syntax) pane)
1069 (flet ((cache-test (t1 t2)
1070 (and (eq t1 t2)
1071 (color-equal (slot-value t1 'ink)
1072 (medium-ink (sheet-medium pane)))
1073 (eq (slot-value t1 'face)
1074 (text-style-face (medium-text-style (sheet-medium pane)))))))
1075 (updating-output (pane :unique-id entity
1076 :id-test #'eq
1077 :cache-value entity
1078 :cache-test #'cache-test)
1079 (with-slots (ink face) entity
1080 (setf ink (medium-ink (sheet-medium pane))
1081 face (text-style-face (medium-text-style (sheet-medium pane))))
1082 (present (coerce (buffer-sequence (buffer syntax)
1083 (start-offset entity)
1084 (end-offset entity))
1085 'string)
1086 'string
1087 :stream pane)))))
1088
1089 (defmethod display-parse-tree :before ((entity cl-entry) (syntax cl-syntax) pane)
1090 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
1091 (setf *white-space-start* (end-offset entity)))
1092
1093 (defgeneric display-parse-stack (symbol stack syntax pane))
1094
1095 (defmethod display-parse-stack (symbol stack (syntax cl-syntax) pane)
1096 (let ((next (parse-stack-next stack)))
1097 (unless (null next)
1098 (display-parse-stack (parse-stack-symbol next) next syntax pane))
1099 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
1100 do (display-parse-tree parse-tree syntax pane))))
1101
1102 (defun display-parse-state (state syntax pane)
1103 (let ((top (parse-stack-top state)))
1104 (if (not (null top))
1105 (display-parse-stack (parse-stack-symbol top) top syntax pane)
1106 (display-parse-tree (target-parse-tree state) syntax pane))))
1107
1108
1109 (defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax cl-syntax) current-p)
1110 (with-slots (top bot) pane
1111 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
1112 *current-line* 0
1113 (aref *cursor-positions* 0) (stream-cursor-position pane))
1114 (with-slots (lexer) syntax
1115 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
1116 1.0)))
1117 ;; find the last token before bot
1118 (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
1119 ;; go back to a token before bot
1120 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
1121 do (decf end-token-index))
1122 ;; go forward to the last token before bot
1123 (loop until (or (= end-token-index (nb-lexemes lexer))
1124 (mark> (start-offset (lexeme lexer end-token-index)) bot))
1125 do (incf end-token-index))
1126 (let ((start-token-index end-token-index))
1127 ;; go back to the first token after top, or until the previous token
1128 ;; contains a valid parser state
1129 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
1130 (not (parse-state-empty-p
1131 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
1132 do (decf start-token-index))
1133 (let ((*white-space-start* (offset top)))
1134 ;; display the parse tree if any
1135 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
1136 (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
1137 syntax
1138 pane))
1139 ;; display the lexemes
1140 (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
1141 (loop while (< start-token-index end-token-index)
1142 do (let ((token (lexeme lexer start-token-index)))
1143 (display-parse-tree token syntax pane))
1144 (incf start-token-index))))))))
1145 (when (region-visible-p pane) (display-region pane syntax))
1146 (display-cursor pane syntax current-p)))
1147
1148
1149

  ViewVC Help
Powered by ViewVC 1.1.5