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

Contents of /climacs/ttcn3-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Mon Jun 12 19:10:58 2006 UTC (7 years, 10 months ago) by thenriksen
Branch: MAIN
Changes since 1.5: +3 -2 lines
Major motion and editing functions and commands refactoring (see the
thread "paredit.lisp, regularization of motion commands, and more" on
climacs-devel for full details).

Breakage not found during testing, but still expected.
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 tmoore 1.4 (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
25 bmastenbrook 1.1 :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 crhodes 1.2 (define-syntax ttcn3-syntax (basic-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     (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 tmoore 1.4 (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 bmastenbrook 1.1 (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 tmoore 1.4 (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
256     name)))))
257 bmastenbrook 1.1 `(progn
258 tmoore 1.4 ,@(sort-definitions
259 bmastenbrook 1.1 (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 thenriksen 1.6 (whitespacep (syntax (buffer lexer)) object))
376 bmastenbrook 1.1
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 thenriksen 1.6 (whitespacep (syntax buffer)
396     (buffer-object buffer start)))
397 bmastenbrook 1.1 do (ecase (buffer-object buffer start)
398     (#\Newline (terpri pane)
399     (setf (aref *cursor-positions* (incf *current-line*))
400     (multiple-value-bind (x y) (stream-cursor-position pane)
401     (declare (ignore x))
402     y)))
403     (#\Space (stream-increment-cursor-position
404     pane space-width 0))
405     (#\Tab (let ((x (stream-cursor-position pane)))
406     (stream-increment-cursor-position
407     pane (- tab-width (mod x tab-width)) 0)))
408     (#\Page nil))
409     (incf start))))
410    
411     (defmethod display-parse-tree :before ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)
412     (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
413     (setf *white-space-start* (end-offset entity)))
414    
415     (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) syntax pane)
416     (with-slots (top bot) pane
417     (when (and (end-offset entity) (mark> (end-offset entity) top))
418     (call-next-method))))
419    
420     (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax ttcn3-syntax) current-p)
421     (with-slots (top bot) pane
422     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
423     *current-line* 0
424     (aref *cursor-positions* 0) (stream-cursor-position pane))
425     (with-slots (lexer) syntax
426     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
427     1.0)))
428     ;; find the last token before bot
429     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
430     ;; go back to a token before bot
431     (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
432     do (decf end-token-index))
433     ;; go forward to the last token before bot
434     (loop until (or (= end-token-index (nb-lexemes lexer))
435     (mark> (start-offset (lexeme lexer end-token-index)) bot))
436     do (incf end-token-index))
437     (let ((start-token-index end-token-index))
438     ;; go back to the first token after top, or until the previous token
439     ;; contains a valid parser state
440     (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
441     (not (parse-state-empty-p
442     (slot-value (lexeme lexer (1- start-token-index)) 'state))))
443     do (decf start-token-index))
444     (let ((*white-space-start* (offset top)))
445     ;; display the parse tree if any
446     (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
447     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
448     syntax
449     pane))
450     ;; display the lexemes
451     (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
452     (loop while (< start-token-index end-token-index)
453     do (let ((token (lexeme lexer start-token-index)))
454     (display-parse-tree token syntax pane))
455     (incf start-token-index))))))))
456 dmurray 1.5 (when (region-visible-p pane) (display-region pane syntax))
457 dmurray 1.3 (display-cursor pane syntax current-p)))
458 bmastenbrook 1.1

  ViewVC Help
Powered by ViewVC 1.1.5