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

Contents of /climacs/ttcn3-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Mon Nov 13 09:01:52 2006 UTC (7 years, 5 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.8: +57 -51 lines
TTCN3 syntax and HTML syntax should work now, but they have not been
fully tested.
1 bmastenbrook 1.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 thenriksen 1.8 (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
25     :drei-syntax :flexichain :drei :drei-fundamental-syntax)
26 bmastenbrook 1.1 (:export))
27     (in-package :climacs-ttcn3-syntax)
28    
29 thenriksen 1.9 (defgeneric display-parse-tree (parse-symbol pane drei syntax))
30 bmastenbrook 1.1
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 thenriksen 1.7 (define-syntax ttcn3-syntax (fundamental-syntax)
123 bmastenbrook 1.1 ((lexer :reader lexer)
124     (valid-parse :initform 1)
125 crhodes 1.2 (parser))
126     (:name "TTCN3")
127     (:pathname-types "ttcn" "ttcn3"))
128 bmastenbrook 1.1
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 thenriksen 1.9 (defmethod display-parse-tree ((entity ,empty-name) (pane clim-stream-pane)
162     (drei drei) (syntax ttcn3-syntax))
163 bmastenbrook 1.1 (declare (ignore pane))
164     nil)
165    
166 thenriksen 1.9 (defmethod display-parse-tree ((entity ,nonempty-name) (pane clim-stream-pane)
167     (drei drei) (syntax ttcn3-syntax))
168 bmastenbrook 1.1 (with-slots (items item) entity
169 thenriksen 1.9 (display-parse-tree items drei pane syntax)
170     (display-parse-tree item drei pane syntax)))))
171 bmastenbrook 1.1
172     (defmacro define-simple-list (name item-name)
173     (let ((empty-name (gensym))
174     (nonempty-name (gensym)))
175     `(define-list ,name ,empty-name ,nonempty-name ,item-name)))
176    
177     (defmacro define-simple-nonempty-list (nonempty-name item-name)
178     (let ((empty-name (gensym))
179     (name (gensym)))
180     `(define-list ,name ,empty-name ,nonempty-name ,item-name)))
181    
182     (defgeneric word-is (word string))
183    
184     (defmethod word-is (word string)
185     (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
186     string))
187    
188 tmoore 1.4 (eval-when (:compile-toplevel :load-toplevel :execute)
189     (defun sort-definitions (forms)
190     (loop for form in forms
191     for name = (and (consp form) (car form))
192     if (eq name 'defclass)
193     collect form into defclasses
194     else if (eq name 'define-simple-list)
195     collect form into simple-lists
196     else if (eq name 'define-simple-nonempty-list)
197     collect form into nonempty-lists
198     else collect form into others
199     end
200     finally (return `(,@defclasses
201     ,@simple-lists
202     ,@nonempty-lists
203     ,@others)))))
204    
205 bmastenbrook 1.1 (defmacro define-parsing-rules ((grammar entry terminal syntax) &body rules)
206     (let (already-processed-rules)
207     (flet
208     ((process-rule (name rule-body start-p)
209     (assert (not (member name already-processed-rules)))
210     (push name already-processed-rules)
211     (cond
212     ((and (eql (length rule-body) 1)
213     (typep (first rule-body) 'string))
214     `((defclass ,name (,entry) ((word :initarg :word)))
215     (add-rule (grammar-rule (,name -> ((word identifier (word-is word ,(first rule-body)))) :word word))
216     ,grammar)
217     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
218 thenriksen 1.9 (defmethod display-parse-tree :around ((entity ,name) (pane clim-stream-pane)
219     (drei drei) (syntax ,syntax))
220 bmastenbrook 1.1 (with-drawing-options (pane :ink +blue-violet+)
221     (call-next-method)))))
222     ((and (eql (length rule-body) 1)
223     (typep (first rule-body) 'cons)
224     (eq (first (first rule-body)) 'or))
225     `((defclass ,name (,entry) ((item :initarg :item)))
226     ,@(loop for alt in (cdr (first rule-body))
227     collect `(add-rule (grammar-rule (,name -> ((item ,alt)) :item item)) ,grammar))
228     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
229 thenriksen 1.9 (defmethod display-parse-tree ((entity ,name) (pane clim-stream-pane)
230     (drei drei) (syntax ,syntax))
231     (display-parse-tree (slot-value entity 'item) pane drei syntax))))
232 bmastenbrook 1.1 ((and (eql (length rule-body) 1)
233     (typep (first rule-body) 'cons)
234     (eq (first (first rule-body)) 'nonempty-list-of))
235     `((define-simple-nonempty-list ,name ,(second (first rule-body)))
236     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
237     ((and (eql (length rule-body) 1)
238     (typep (first rule-body) 'cons)
239     (eq (first (first rule-body)) 'list-of))
240     `((define-simple-list ,name ,(second (first rule-body)))
241     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
242     ((every #'symbolp rule-body)
243     `((defclass ,name (,entry)
244     (,@(loop for component in rule-body
245     collect `(,component :initarg ,(intern (symbol-name component) :keyword)))))
246     (add-rule
247     (grammar-rule (,name ->
248     (,@(loop for component in rule-body
249     collect `(,component ,component)))
250     ,@(loop for component in rule-body
251     appending `(,(intern (symbol-name component) :keyword)
252     ,component)))) ,grammar)
253     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
254 thenriksen 1.9 (defmethod display-parse-tree ((entity ,name) (pane clim-stream-pane)
255     (drei drei) (syntax ,syntax))
256 bmastenbrook 1.1 (with-slots ,rule-body
257     entity
258     ,@(loop for component in rule-body collect
259 thenriksen 1.9 `(display-parse-tree ,component pane drei syntax))))))
260 tmoore 1.4 (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
261     name)))))
262 bmastenbrook 1.1 `(progn
263 tmoore 1.4 ,@(sort-definitions
264 bmastenbrook 1.1 (loop for rule in rules
265     appending (destructuring-bind (=-thingy rule-name &body rule-body)
266     rule
267     (assert (member =-thingy '(:= :==)))
268     (process-rule rule-name rule-body (eq =-thingy :==)))))))))
269    
270     (define-list ttcn3-terminals empty-ttcn3-terminals
271     nonempty-ttcn3-terminals ttcn3-terminal)
272    
273     (define-parsing-rules (*ttcn3-grammar* ttcn3-entry ttcn3-terminal ttcn3-syntax)
274     (:== ttcn3-module
275     ttcn3-module-keyword ttcn3-module-id
276     block-open opt-module-definitions-part
277     ; opt-module-control-part
278     block-close ; opt-with-statement
279     opt-semicolon)
280     (:= opt-module-definitions-part
281     (or module-definitions-part empty-ttcn3-terminals))
282     (:= opt-semicolon
283     (or line-or-statement-terminator-symbol empty-ttcn3-terminals))
284     (:= ttcn3-module-keyword "module")
285     (:= ttcn3-module-id module-identifier opt-definitive-identifier)
286     (:= opt-definitive-identifier
287     (or definitive-identifier empty-ttcn3-terminals))
288     (:= module-identifier identifier)
289     (:= object-identifier-keyword "objid")
290     (:= definitive-obj-id-component-list
291     (nonempty-list-of definitive-obj-id-component))
292     (:= definitive-obj-id-component
293     (or identifier definitive-number-form definitive-name-and-number-form))
294     (:= definitive-identifier dot object-identifier-keyword block-open definitive-obj-id-component-list block-close)
295     (:= definitive-number-form number-form)
296     (:= definitive-name-and-number-form identifier list-open definitive-number-form list-close)
297     (:= module-definitions-list (nonempty-list-of module-definition-and-optional-semicolon))
298     (:= module-definitions-part module-definitions-list)
299     (:= module-definition-and-optional-semicolon
300     module-definition opt-semicolon)
301     (:= module-definition
302     (or ; type-def
303     const-def
304     ; template-def
305     ; module-par-def
306     ; function-def
307     ; signature-def
308     ; testcase-def
309     ; altstep-def
310     ; import-def
311     ; group-def
312     ; ext-function-def
313     ; ext-const-def
314     ))
315     (:= const-def const-keyword ttcn3-type const-list)
316     (:= const-list single-const-def comma-sep-single-const-defs)
317     (:= comma-sep-single-const-defs (list-of comma-and-single-const-def))
318     (:= comma-and-single-const-def comma single-const-def)
319     (:= single-const-def const-identifier ; opt-array-def
320     assignment constant-expression)
321     (:= const-keyword "const")
322     (:= const-identifier identifier)
323     (:= ttcn3-type #+(or) (or predefined-type referenced-type)
324     identifier)
325     (:= constant-expression
326     (or identifier number-form)))
327    
328    
329 thenriksen 1.9 (defmethod display-parse-tree ((entity ttcn3-terminal) (pane clim-stream-pane)
330     (drei drei) (syntax ttcn3-syntax))
331 bmastenbrook 1.1 (with-slots (item) entity
332 thenriksen 1.9 (display-parse-tree item pane drei syntax)))
333 bmastenbrook 1.1
334 thenriksen 1.9 (defmethod display-parse-tree ((entity ttcn3-entry) (pane clim-stream-pane)
335     (drei drei) (syntax ttcn3-syntax))
336 bmastenbrook 1.1 (flet ((cache-test (t1 t2)
337     (and (eq t1 t2)
338     (eq (slot-value t1 'ink)
339     (medium-ink (sheet-medium pane)))
340     (eq (slot-value t1 'face)
341     (text-style-face (medium-text-style (sheet-medium pane)))))))
342     (updating-output (pane :unique-id entity
343     :id-test #'eq
344     :cache-value entity
345     :cache-test #'cache-test)
346     (with-slots (ink face) entity
347     (setf ink (medium-ink (sheet-medium pane))
348     face (text-style-face (medium-text-style (sheet-medium pane))))
349     (present (coerce (buffer-sequence (buffer syntax)
350     (start-offset entity)
351     (end-offset entity))
352     'string)
353     'string
354     :stream pane)))))
355    
356 thenriksen 1.9 (defgeneric display-parse-stack (symbol stack pane drei syntax))
357 bmastenbrook 1.1
358 thenriksen 1.9 (defmethod display-parse-stack (symbol stack (pane clim-stream-pane)
359     (drei drei) (syntax ttcn3-syntax))
360 bmastenbrook 1.1 (let ((next (parse-stack-next stack)))
361     (unless (null next)
362 thenriksen 1.9 (display-parse-stack (parse-stack-symbol next) next pane drei syntax))
363 bmastenbrook 1.1 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
364 thenriksen 1.9 do (display-parse-tree parse-tree pane drei syntax))))
365 bmastenbrook 1.1
366 thenriksen 1.9 (defun display-parse-state (state pane drei syntax)
367 bmastenbrook 1.1 (let ((top (parse-stack-top state)))
368     (if (not (null top))
369 thenriksen 1.9 (display-parse-stack (parse-stack-symbol top) top pane drei syntax)
370     (display-parse-tree (target-parse-tree state) pane drei syntax))))
371 bmastenbrook 1.1
372     (defmethod update-syntax-for-display (buffer (syntax ttcn3-syntax) top bot)
373     (with-slots (parser lexer valid-parse) syntax
374     (loop until (= valid-parse (nb-lexemes lexer))
375     while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
376     do (let ((current-token (lexeme lexer (1- valid-parse)))
377     (next-lexeme (lexeme lexer valid-parse)))
378     (setf (slot-value next-lexeme 'state)
379     (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
380     (incf valid-parse))))
381    
382     (defmethod inter-lexeme-object-p ((lexer ttcn3-lexer) object)
383 thenriksen 1.6 (whitespacep (syntax (buffer lexer)) object))
384 bmastenbrook 1.1
385     (defmethod update-syntax (buffer (syntax ttcn3-syntax))
386     (with-slots (lexer valid-parse) syntax
387     (let* ((low-mark (low-mark buffer))
388     (high-mark (high-mark buffer)))
389     (when (mark<= low-mark high-mark)
390     (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
391     (setf valid-parse first-invalid-position)
392     (update-lex lexer first-invalid-position high-mark))))))
393    
394     (defvar *white-space-start* nil)
395    
396     (defvar *cursor-positions* nil)
397     (defvar *current-line* 0)
398    
399     (defun handle-whitespace (pane buffer start end)
400     (let ((space-width (space-width pane))
401 thenriksen 1.9 (tab-width (tab-width pane)))
402     (with-sheet-medium (medium pane)
403     (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
404     (loop while (< start end)
405     do (case (buffer-object buffer start)
406     (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
407     (terpri pane)
408     (stream-increment-cursor-position
409     pane (first (aref cursor-positions 0)) 0))
410     ((#\Page #\Return #\Space) (stream-increment-cursor-position
411     pane space-width 0))
412     (#\Tab (let ((x (stream-cursor-position pane)))
413     (stream-increment-cursor-position
414     pane (- tab-width (mod x tab-width)) 0))))
415     (incf start))))))
416 bmastenbrook 1.1
417 thenriksen 1.9 (defmethod display-parse-tree :before ((entity ttcn3-entry) (pane clim-stream-pane)
418     (drei drei) (syntax ttcn3-syntax))
419 bmastenbrook 1.1 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
420     (setf *white-space-start* (end-offset entity)))
421    
422 thenriksen 1.9 (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) pane drei syntax)
423 bmastenbrook 1.1 (with-slots (top bot) pane
424     (when (and (end-offset entity) (mark> (end-offset entity) top))
425     (call-next-method))))
426    
427 thenriksen 1.9 (defmethod display-drei-contents ((pane clim-stream-pane) (drei drei) (syntax ttcn3-syntax))
428 bmastenbrook 1.1 (with-slots (top bot) pane
429 thenriksen 1.9 (with-accessors ((cursor-positions cursor-positions)) syntax
430     (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
431     :initial-element nil)
432     *current-line* 0
433     (aref cursor-positions 0) (multiple-value-list
434     (stream-cursor-position pane))))
435 bmastenbrook 1.1 (with-slots (lexer) syntax
436     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
437     1.0)))
438     ;; find the last token before bot
439     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
440     ;; go back to a token before bot
441     (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
442     do (decf end-token-index))
443     ;; go forward to the last token before bot
444     (loop until (or (= end-token-index (nb-lexemes lexer))
445     (mark> (start-offset (lexeme lexer end-token-index)) bot))
446     do (incf end-token-index))
447     (let ((start-token-index end-token-index))
448     ;; go back to the first token after top, or until the previous token
449     ;; contains a valid parser state
450     (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
451     (not (parse-state-empty-p
452     (slot-value (lexeme lexer (1- start-token-index)) 'state))))
453 thenriksen 1.9 do (decf start-token-index))
454 bmastenbrook 1.1 (let ((*white-space-start* (offset top)))
455     ;; display the parse tree if any
456     (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
457     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
458 thenriksen 1.9 pane drei syntax))
459 bmastenbrook 1.1 ;; display the lexemes
460     (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
461     (loop while (< start-token-index end-token-index)
462     do (let ((token (lexeme lexer start-token-index)))
463 thenriksen 1.9 (display-parse-tree token pane drei syntax))
464     (incf start-token-index))))))))))

  ViewVC Help
Powered by ViewVC 1.1.5