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

Contents of /climacs/ttcn3-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Mar 3 19:38:57 2006 UTC (8 years, 1 month ago) by tmoore
Branch: MAIN
Changes since 1.3: +21 -11 lines
Changes for running climacs in Allegro Common Lisp with Classic CLIM (tm). This includes a bunch of modern mode-related changes to symbol names and creating symbols and reordering of syntax rules definitions due to different compile-time behavior of defclass. The CLIM changes are suprisingly small
1 ;;; -*- Mode: Lisp -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Brian Mastenbrook (brian@mastenbrook.net)
5 ;;; Christophe Rhodes (c.rhodes@gold.ac.uk)
6 ;;; Robert Strandh (strandh@labri.fr)
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
23 (defpackage :climacs-ttcn3-syntax
24 (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
25 :climacs-syntax :flexichain :climacs-pane)
26 (:export))
27 (in-package :climacs-ttcn3-syntax)
28
29 (defgeneric display-parse-tree (entity syntax pane))
30
31 (defclass ttcn3-parse-tree (parse-tree) ())
32
33 (defclass ttcn3-entry (ttcn3-parse-tree)
34 ((ink) (face)
35 (state :initarg :state)))
36
37 (defclass ttcn3-nonterminal (ttcn3-entry) ())
38
39 (defclass ttcn3-terminal (ttcn3-entry)
40 ((item :initarg :item)))
41
42 (defclass ttcn3-lexeme (ttcn3-entry) ())
43
44 (defgeneric lexeme-string (foo))
45
46 (defmethod lexeme-string ((thing ttcn3-entry))
47 (coerce
48 (buffer-sequence (buffer thing)
49 (start-offset thing)
50 (end-offset thing))
51 'string))
52
53 (defmethod print-object ((o ttcn3-lexeme) s)
54 (print-unreadable-object (o s :type t)
55 (format s "~S" (lexeme-string o))))
56
57 (defmacro define-lexemes (superclass &body lexemes)
58 `(progn
59 ,@(loop for lexeme in lexemes
60 collect `(defclass ,lexeme (,superclass) ()))))
61
62 (define-lexemes ttcn3-lexeme
63 start-lexeme
64 list-open list-close
65 block-open block-close
66 alternative-open alternative-close
67 to-symbol
68 line-comment block-comment
69 line-or-statement-terminator-symbol
70 plus minus divide concatenation
71 not-equal equals greater-than less-than
72 double-quote single-quote question star
73 assignment communication identifier number-form
74 dot comma
75 other-entry)
76
77 (defclass ttcn3-lexer (incremental-lexer) ())
78
79 (defun identifier-char-p (var &key start)
80 (and (characterp var)
81 (if start (alpha-char-p var) t)
82 (or (alphanumericp var) (eql var #\_))))
83
84 (defmethod next-lexeme ((lexer ttcn3-lexer) scan)
85 (flet ((fo () (forward-object scan)))
86 (let ((object (object-after scan)))
87 (macrolet ((dispatch-object (&body cases)
88 `(case object
89 ,@(loop for case in cases
90 collect `(,(first case)
91 (fo)
92 ,@(if (and (eql (length case) 2)
93 (symbolp (second case)))
94 `((make-instance ',(second case)))
95 (cdr case)))))))
96 (dispatch-object
97 (#\( list-open)
98 (#\) list-close)
99 (#\{ block-open)
100 (#\} block-close)
101 (#\; line-or-statement-terminator-symbol)
102 (#\. dot)
103 (#\, comma)
104 (#\: (if (and (not (end-of-buffer-p scan))
105 (eql (object-after scan) #\=))
106 (progn (fo) (make-instance 'assignment))
107 (make-instance 'other-entry)))
108 (t
109 (cond
110 ((digit-char-p object)
111 (loop until (end-of-buffer-p scan)
112 while (digit-char-p (object-after scan))
113 do (fo))
114 (make-instance 'number-form))
115 ((identifier-char-p object :start t)
116 (loop until (end-of-buffer-p scan)
117 while (identifier-char-p (object-after scan))
118 do (fo))
119 (make-instance 'identifier))
120 (t (fo) (make-instance 'other-entry)))))))))
121
122 (define-syntax ttcn3-syntax (basic-syntax)
123 ((lexer :reader lexer)
124 (valid-parse :initform 1)
125 (parser))
126 (:name "TTCN3")
127 (:pathname-types "ttcn" "ttcn3"))
128
129 (defparameter *ttcn3-grammar* (grammar))
130
131 (defmethod initialize-instance :after ((syntax ttcn3-syntax) &rest args)
132 (declare (ignore args))
133 (with-slots (parser lexer buffer) syntax
134 (setf parser (make-instance 'parser
135 :grammar *ttcn3-grammar*
136 :target 'ttcn3-terminals))
137 (setf lexer (make-instance 'ttcn3-lexer :buffer (buffer syntax)))
138 (let ((m (clone-mark (low-mark buffer) :left))
139 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
140 (setf (offset m) 0)
141 (setf (start-offset lexeme) m
142 (end-offset lexeme) 0)
143 (insert-lexeme lexer 0 lexeme))))
144
145 (defmacro define-list (name empty-name nonempty-name item-name)
146 `(progn
147 (defclass ,name (ttcn3-entry) ())
148 (defclass ,empty-name (,name) ())
149
150 (defclass ,nonempty-name (,name)
151 ((items :initarg :items)
152 (item :initarg :item)))
153
154 (add-rule (grammar-rule (,name -> () (make-instance ',empty-name))) *ttcn3-grammar*)
155
156 (add-rule (grammar-rule
157 (,name -> (,name ,item-name)
158 (make-instance ',nonempty-name
159 :items ,name :item ,item-name))) *ttcn3-grammar*)
160
161 (defmethod display-parse-tree ((entity ,empty-name) (syntax ttcn3-syntax) pane)
162 (declare (ignore pane))
163 nil)
164
165 (defmethod display-parse-tree ((entity ,nonempty-name) (syntax ttcn3-syntax) pane)
166 (with-slots (items item) entity
167 (display-parse-tree items syntax pane)
168 (display-parse-tree item syntax pane)))))
169
170 (defmacro define-simple-list (name item-name)
171 (let ((empty-name (gensym))
172 (nonempty-name (gensym)))
173 `(define-list ,name ,empty-name ,nonempty-name ,item-name)))
174
175 (defmacro define-simple-nonempty-list (nonempty-name item-name)
176 (let ((empty-name (gensym))
177 (name (gensym)))
178 `(define-list ,name ,empty-name ,nonempty-name ,item-name)))
179
180 (defgeneric word-is (word string))
181
182 (defmethod word-is (word string)
183 (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
184 string))
185
186 (eval-when (:compile-toplevel :load-toplevel :execute)
187 (defun sort-definitions (forms)
188 (loop for form in forms
189 for name = (and (consp form) (car form))
190 if (eq name 'defclass)
191 collect form into defclasses
192 else if (eq name 'define-simple-list)
193 collect form into simple-lists
194 else if (eq name 'define-simple-nonempty-list)
195 collect form into nonempty-lists
196 else collect form into others
197 end
198 finally (return `(,@defclasses
199 ,@simple-lists
200 ,@nonempty-lists
201 ,@others)))))
202
203 (defmacro define-parsing-rules ((grammar entry terminal syntax) &body rules)
204 (let (already-processed-rules)
205 (flet
206 ((process-rule (name rule-body start-p)
207 (assert (not (member name already-processed-rules)))
208 (push name already-processed-rules)
209 (cond
210 ((and (eql (length rule-body) 1)
211 (typep (first rule-body) 'string))
212 `((defclass ,name (,entry) ((word :initarg :word)))
213 (add-rule (grammar-rule (,name -> ((word identifier (word-is word ,(first rule-body)))) :word word))
214 ,grammar)
215 ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
216 (defmethod display-parse-tree :around ((entity ,name) (syntax ,syntax) pane)
217 (with-drawing-options (pane :ink +blue-violet+)
218 (call-next-method)))))
219 ((and (eql (length rule-body) 1)
220 (typep (first rule-body) 'cons)
221 (eq (first (first rule-body)) 'or))
222 `((defclass ,name (,entry) ((item :initarg :item)))
223 ,@(loop for alt in (cdr (first rule-body))
224 collect `(add-rule (grammar-rule (,name -> ((item ,alt)) :item item)) ,grammar))
225 ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
226 (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)
227 (display-parse-tree (slot-value entity 'item) syntax pane))))
228 ((and (eql (length rule-body) 1)
229 (typep (first rule-body) 'cons)
230 (eq (first (first rule-body)) 'nonempty-list-of))
231 `((define-simple-nonempty-list ,name ,(second (first rule-body)))
232 ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
233 ((and (eql (length rule-body) 1)
234 (typep (first rule-body) 'cons)
235 (eq (first (first rule-body)) 'list-of))
236 `((define-simple-list ,name ,(second (first rule-body)))
237 ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
238 ((every #'symbolp rule-body)
239 `((defclass ,name (,entry)
240 (,@(loop for component in rule-body
241 collect `(,component :initarg ,(intern (symbol-name component) :keyword)))))
242 (add-rule
243 (grammar-rule (,name ->
244 (,@(loop for component in rule-body
245 collect `(,component ,component)))
246 ,@(loop for component in rule-body
247 appending `(,(intern (symbol-name component) :keyword)
248 ,component)))) ,grammar)
249 ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
250 (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)
251 (with-slots ,rule-body
252 entity
253 ,@(loop for component in rule-body collect
254 `(display-parse-tree ,component syntax pane))))))
255 (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
256 name)))))
257 `(progn
258 ,@(sort-definitions
259 (loop for rule in rules
260 appending (destructuring-bind (=-thingy rule-name &body rule-body)
261 rule
262 (assert (member =-thingy '(:= :==)))
263 (process-rule rule-name rule-body (eq =-thingy :==)))))))))
264
265 (define-list ttcn3-terminals empty-ttcn3-terminals
266 nonempty-ttcn3-terminals ttcn3-terminal)
267
268 (define-parsing-rules (*ttcn3-grammar* ttcn3-entry ttcn3-terminal ttcn3-syntax)
269 (:== ttcn3-module
270 ttcn3-module-keyword ttcn3-module-id
271 block-open opt-module-definitions-part
272 ; opt-module-control-part
273 block-close ; opt-with-statement
274 opt-semicolon)
275 (:= opt-module-definitions-part
276 (or module-definitions-part empty-ttcn3-terminals))
277 (:= opt-semicolon
278 (or line-or-statement-terminator-symbol empty-ttcn3-terminals))
279 (:= ttcn3-module-keyword "module")
280 (:= ttcn3-module-id module-identifier opt-definitive-identifier)
281 (:= opt-definitive-identifier
282 (or definitive-identifier empty-ttcn3-terminals))
283 (:= module-identifier identifier)
284 (:= object-identifier-keyword "objid")
285 (:= definitive-obj-id-component-list
286 (nonempty-list-of definitive-obj-id-component))
287 (:= definitive-obj-id-component
288 (or identifier definitive-number-form definitive-name-and-number-form))
289 (:= definitive-identifier dot object-identifier-keyword block-open definitive-obj-id-component-list block-close)
290 (:= definitive-number-form number-form)
291 (:= definitive-name-and-number-form identifier list-open definitive-number-form list-close)
292 (:= module-definitions-list (nonempty-list-of module-definition-and-optional-semicolon))
293 (:= module-definitions-part module-definitions-list)
294 (:= module-definition-and-optional-semicolon
295 module-definition opt-semicolon)
296 (:= module-definition
297 (or ; type-def
298 const-def
299 ; template-def
300 ; module-par-def
301 ; function-def
302 ; signature-def
303 ; testcase-def
304 ; altstep-def
305 ; import-def
306 ; group-def
307 ; ext-function-def
308 ; ext-const-def
309 ))
310 (:= const-def const-keyword ttcn3-type const-list)
311 (:= const-list single-const-def comma-sep-single-const-defs)
312 (:= comma-sep-single-const-defs (list-of comma-and-single-const-def))
313 (:= comma-and-single-const-def comma single-const-def)
314 (:= single-const-def const-identifier ; opt-array-def
315 assignment constant-expression)
316 (:= const-keyword "const")
317 (:= const-identifier identifier)
318 (:= ttcn3-type #+(or) (or predefined-type referenced-type)
319 identifier)
320 (:= constant-expression
321 (or identifier number-form)))
322
323
324 (defmethod display-parse-tree ((entity ttcn3-terminal) (syntax ttcn3-syntax) pane)
325 (with-slots (item) entity
326 (display-parse-tree item syntax pane)))
327
328 (defmethod display-parse-tree ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)
329 (flet ((cache-test (t1 t2)
330 (and (eq t1 t2)
331 (eq (slot-value t1 'ink)
332 (medium-ink (sheet-medium pane)))
333 (eq (slot-value t1 'face)
334 (text-style-face (medium-text-style (sheet-medium pane)))))))
335 (updating-output (pane :unique-id entity
336 :id-test #'eq
337 :cache-value entity
338 :cache-test #'cache-test)
339 (with-slots (ink face) entity
340 (setf ink (medium-ink (sheet-medium pane))
341 face (text-style-face (medium-text-style (sheet-medium pane))))
342 (present (coerce (buffer-sequence (buffer syntax)
343 (start-offset entity)
344 (end-offset entity))
345 'string)
346 'string
347 :stream pane)))))
348
349 (defgeneric display-parse-stack (symbol stack syntax pane))
350
351 (defmethod display-parse-stack (symbol stack (syntax ttcn3-syntax) pane)
352 (let ((next (parse-stack-next stack)))
353 (unless (null next)
354 (display-parse-stack (parse-stack-symbol next) next syntax pane))
355 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
356 do (display-parse-tree parse-tree syntax pane))))
357
358 (defun display-parse-state (state syntax pane)
359 (let ((top (parse-stack-top state)))
360 (if (not (null top))
361 (display-parse-stack (parse-stack-symbol top) top syntax pane)
362 (display-parse-tree (target-parse-tree state) syntax pane))))
363
364 (defmethod update-syntax-for-display (buffer (syntax ttcn3-syntax) top bot)
365 (with-slots (parser lexer valid-parse) syntax
366 (loop until (= valid-parse (nb-lexemes lexer))
367 while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
368 do (let ((current-token (lexeme lexer (1- valid-parse)))
369 (next-lexeme (lexeme lexer valid-parse)))
370 (setf (slot-value next-lexeme 'state)
371 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
372 (incf valid-parse))))
373
374 (defmethod inter-lexeme-object-p ((lexer ttcn3-lexer) object)
375 (whitespacep object))
376
377 (defmethod update-syntax (buffer (syntax ttcn3-syntax))
378 (with-slots (lexer valid-parse) syntax
379 (let* ((low-mark (low-mark buffer))
380 (high-mark (high-mark buffer)))
381 (when (mark<= low-mark high-mark)
382 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
383 (setf valid-parse first-invalid-position)
384 (update-lex lexer first-invalid-position high-mark))))))
385
386 (defvar *white-space-start* nil)
387
388 (defvar *cursor-positions* nil)
389 (defvar *current-line* 0)
390
391 (defun handle-whitespace (pane buffer start end)
392 (let ((space-width (space-width pane))
393 (tab-width (tab-width pane)))
394 (loop while (and (< start end)
395 (whitespacep (buffer-object buffer start)))
396 do (ecase (buffer-object buffer start)
397 (#\Newline (terpri pane)
398 (setf (aref *cursor-positions* (incf *current-line*))
399 (multiple-value-bind (x y) (stream-cursor-position pane)
400 (declare (ignore x))
401 y)))
402 (#\Space (stream-increment-cursor-position
403 pane space-width 0))
404 (#\Tab (let ((x (stream-cursor-position pane)))
405 (stream-increment-cursor-position
406 pane (- tab-width (mod x tab-width)) 0)))
407 (#\Page nil))
408 (incf start))))
409
410 (defmethod display-parse-tree :before ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)
411 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
412 (setf *white-space-start* (end-offset entity)))
413
414 (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) syntax pane)
415 (with-slots (top bot) pane
416 (when (and (end-offset entity) (mark> (end-offset entity) top))
417 (call-next-method))))
418
419 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax ttcn3-syntax) current-p)
420 (with-slots (top bot) pane
421 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
422 *current-line* 0
423 (aref *cursor-positions* 0) (stream-cursor-position pane))
424 (with-slots (lexer) syntax
425 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
426 1.0)))
427 ;; find the last token before bot
428 (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
429 ;; go back to a token before bot
430 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
431 do (decf end-token-index))
432 ;; go forward to the last token before bot
433 (loop until (or (= end-token-index (nb-lexemes lexer))
434 (mark> (start-offset (lexeme lexer end-token-index)) bot))
435 do (incf end-token-index))
436 (let ((start-token-index end-token-index))
437 ;; go back to the first token after top, or until the previous token
438 ;; contains a valid parser state
439 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
440 (not (parse-state-empty-p
441 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
442 do (decf start-token-index))
443 (let ((*white-space-start* (offset top)))
444 ;; display the parse tree if any
445 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
446 (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
447 syntax
448 pane))
449 ;; display the lexemes
450 (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
451 (loop while (< start-token-index end-token-index)
452 do (let ((token (lexeme lexer start-token-index)))
453 (display-parse-tree token syntax pane))
454 (incf start-token-index))))))))
455 (when (mark-visible-p pane) (display-mark pane syntax))
456 (display-cursor pane syntax current-p)))
457

  ViewVC Help
Powered by ViewVC 1.1.5