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

Contents of /climacs/ttcn3-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu May 26 08:31:53 2005 UTC (8 years, 10 months ago) by crhodes
Branch: MAIN
Changes since 1.1: +4 -2 lines
OK, no-one complained too much, so I'm going ahead with the syntax
file-type changes discussed in <sqmzqrhbma.fsf@cam.ac.uk>:
DEFINE-SYNTAX's syntax is changed incompatibly.
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     (:use :clim-lisp :clim :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 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     (defmacro define-parsing-rules ((grammar entry terminal syntax) &body rules)
187     (let (already-processed-rules)
188     (flet
189     ((process-rule (name rule-body start-p)
190     (assert (not (member name already-processed-rules)))
191     (push name already-processed-rules)
192     (cond
193     ((and (eql (length rule-body) 1)
194     (typep (first rule-body) 'string))
195     `((defclass ,name (,entry) ((word :initarg :word)))
196     (add-rule (grammar-rule (,name -> ((word identifier (word-is word ,(first rule-body)))) :word word))
197     ,grammar)
198     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
199     (defmethod display-parse-tree :around ((entity ,name) (syntax ,syntax) pane)
200     (with-drawing-options (pane :ink +blue-violet+)
201     (call-next-method)))))
202     ((and (eql (length rule-body) 1)
203     (typep (first rule-body) 'cons)
204     (eq (first (first rule-body)) 'or))
205     `((defclass ,name (,entry) ((item :initarg :item)))
206     ,@(loop for alt in (cdr (first rule-body))
207     collect `(add-rule (grammar-rule (,name -> ((item ,alt)) :item item)) ,grammar))
208     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
209     (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)
210     (display-parse-tree (slot-value entity 'item) syntax pane))))
211     ((and (eql (length rule-body) 1)
212     (typep (first rule-body) 'cons)
213     (eq (first (first rule-body)) 'nonempty-list-of))
214     `((define-simple-nonempty-list ,name ,(second (first rule-body)))
215     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
216     ((and (eql (length rule-body) 1)
217     (typep (first rule-body) 'cons)
218     (eq (first (first rule-body)) 'list-of))
219     `((define-simple-list ,name ,(second (first rule-body)))
220     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))))
221     ((every #'symbolp rule-body)
222     `((defclass ,name (,entry)
223     (,@(loop for component in rule-body
224     collect `(,component :initarg ,(intern (symbol-name component) :keyword)))))
225     (add-rule
226     (grammar-rule (,name ->
227     (,@(loop for component in rule-body
228     collect `(,component ,component)))
229     ,@(loop for component in rule-body
230     appending `(,(intern (symbol-name component) :keyword)
231     ,component)))) ,grammar)
232     ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
233     (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)
234     (with-slots ,rule-body
235     entity
236     ,@(loop for component in rule-body collect
237     `(display-parse-tree ,component syntax pane))))))
238     (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body name))))
239     (shake-up-defclasses (forms)
240     (append
241     (remove-if #'(lambda (e)
242     (and (consp e)
243     (not (eq (car e) 'defclass)))) forms)
244     (remove-if #'(lambda (e)
245     (and (consp e)
246     (eq (car e) 'defclass))) forms))))
247     `(progn
248     ,@(shake-up-defclasses
249     (loop for rule in rules
250     appending (destructuring-bind (=-thingy rule-name &body rule-body)
251     rule
252     (assert (member =-thingy '(:= :==)))
253     (process-rule rule-name rule-body (eq =-thingy :==)))))))))
254    
255     (define-list ttcn3-terminals empty-ttcn3-terminals
256     nonempty-ttcn3-terminals ttcn3-terminal)
257    
258     (define-parsing-rules (*ttcn3-grammar* ttcn3-entry ttcn3-terminal ttcn3-syntax)
259     (:== ttcn3-module
260     ttcn3-module-keyword ttcn3-module-id
261     block-open opt-module-definitions-part
262     ; opt-module-control-part
263     block-close ; opt-with-statement
264     opt-semicolon)
265     (:= opt-module-definitions-part
266     (or module-definitions-part empty-ttcn3-terminals))
267     (:= opt-semicolon
268     (or line-or-statement-terminator-symbol empty-ttcn3-terminals))
269     (:= ttcn3-module-keyword "module")
270     (:= ttcn3-module-id module-identifier opt-definitive-identifier)
271     (:= opt-definitive-identifier
272     (or definitive-identifier empty-ttcn3-terminals))
273     (:= module-identifier identifier)
274     (:= object-identifier-keyword "objid")
275     (:= definitive-obj-id-component-list
276     (nonempty-list-of definitive-obj-id-component))
277     (:= definitive-obj-id-component
278     (or identifier definitive-number-form definitive-name-and-number-form))
279     (:= definitive-identifier dot object-identifier-keyword block-open definitive-obj-id-component-list block-close)
280     (:= definitive-number-form number-form)
281     (:= definitive-name-and-number-form identifier list-open definitive-number-form list-close)
282     (:= module-definitions-list (nonempty-list-of module-definition-and-optional-semicolon))
283     (:= module-definitions-part module-definitions-list)
284     (:= module-definition-and-optional-semicolon
285     module-definition opt-semicolon)
286     (:= module-definition
287     (or ; type-def
288     const-def
289     ; template-def
290     ; module-par-def
291     ; function-def
292     ; signature-def
293     ; testcase-def
294     ; altstep-def
295     ; import-def
296     ; group-def
297     ; ext-function-def
298     ; ext-const-def
299     ))
300     (:= const-def const-keyword ttcn3-type const-list)
301     (:= const-list single-const-def comma-sep-single-const-defs)
302     (:= comma-sep-single-const-defs (list-of comma-and-single-const-def))
303     (:= comma-and-single-const-def comma single-const-def)
304     (:= single-const-def const-identifier ; opt-array-def
305     assignment constant-expression)
306     (:= const-keyword "const")
307     (:= const-identifier identifier)
308     (:= ttcn3-type #+(or) (or predefined-type referenced-type)
309     identifier)
310     (:= constant-expression
311     (or identifier number-form)))
312    
313    
314     (defmethod display-parse-tree ((entity ttcn3-terminal) (syntax ttcn3-syntax) pane)
315     (with-slots (item) entity
316     (display-parse-tree item syntax pane)))
317    
318     (defmethod display-parse-tree ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)
319     (flet ((cache-test (t1 t2)
320     (and (eq t1 t2)
321     (eq (slot-value t1 'ink)
322     (medium-ink (sheet-medium pane)))
323     (eq (slot-value t1 'face)
324     (text-style-face (medium-text-style (sheet-medium pane)))))))
325     (updating-output (pane :unique-id entity
326     :id-test #'eq
327     :cache-value entity
328     :cache-test #'cache-test)
329     (with-slots (ink face) entity
330     (setf ink (medium-ink (sheet-medium pane))
331     face (text-style-face (medium-text-style (sheet-medium pane))))
332     (present (coerce (buffer-sequence (buffer syntax)
333     (start-offset entity)
334     (end-offset entity))
335     'string)
336     'string
337     :stream pane)))))
338    
339     (defgeneric display-parse-stack (symbol stack syntax pane))
340    
341     (defmethod display-parse-stack (symbol stack (syntax ttcn3-syntax) pane)
342     (let ((next (parse-stack-next stack)))
343     (unless (null next)
344     (display-parse-stack (parse-stack-symbol next) next syntax pane))
345     (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
346     do (display-parse-tree parse-tree syntax pane))))
347    
348     (defun display-parse-state (state syntax pane)
349     (let ((top (parse-stack-top state)))
350     (if (not (null top))
351     (display-parse-stack (parse-stack-symbol top) top syntax pane)
352     (display-parse-tree (target-parse-tree state) syntax pane))))
353    
354     (defmethod update-syntax-for-display (buffer (syntax ttcn3-syntax) top bot)
355     (with-slots (parser lexer valid-parse) syntax
356     (loop until (= valid-parse (nb-lexemes lexer))
357     while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
358     do (let ((current-token (lexeme lexer (1- valid-parse)))
359     (next-lexeme (lexeme lexer valid-parse)))
360     (setf (slot-value next-lexeme 'state)
361     (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
362     (incf valid-parse))))
363    
364     (defmethod inter-lexeme-object-p ((lexer ttcn3-lexer) object)
365     (whitespacep object))
366    
367     (defmethod update-syntax (buffer (syntax ttcn3-syntax))
368     (with-slots (lexer valid-parse) syntax
369     (let* ((low-mark (low-mark buffer))
370     (high-mark (high-mark buffer)))
371     (when (mark<= low-mark high-mark)
372     (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
373     (setf valid-parse first-invalid-position)
374     (update-lex lexer first-invalid-position high-mark))))))
375    
376     (defvar *white-space-start* nil)
377    
378     (defvar *cursor-positions* nil)
379     (defvar *current-line* 0)
380    
381     (defun handle-whitespace (pane buffer start end)
382     (let ((space-width (space-width pane))
383     (tab-width (tab-width pane)))
384     (loop while (and (< start end)
385     (whitespacep (buffer-object buffer start)))
386     do (ecase (buffer-object buffer start)
387     (#\Newline (terpri pane)
388     (setf (aref *cursor-positions* (incf *current-line*))
389     (multiple-value-bind (x y) (stream-cursor-position pane)
390     (declare (ignore x))
391     y)))
392     (#\Space (stream-increment-cursor-position
393     pane space-width 0))
394     (#\Tab (let ((x (stream-cursor-position pane)))
395     (stream-increment-cursor-position
396     pane (- tab-width (mod x tab-width)) 0)))
397     (#\Page nil))
398     (incf start))))
399    
400     (defmethod display-parse-tree :before ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)
401     (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
402     (setf *white-space-start* (end-offset entity)))
403    
404     (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) syntax pane)
405     (with-slots (top bot) pane
406     (when (and (end-offset entity) (mark> (end-offset entity) top))
407     (call-next-method))))
408    
409     (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax ttcn3-syntax) current-p)
410     (with-slots (top bot) pane
411     (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
412     *current-line* 0
413     (aref *cursor-positions* 0) (stream-cursor-position pane))
414     (with-slots (lexer) syntax
415     (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
416     1.0)))
417     ;; find the last token before bot
418     (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
419     ;; go back to a token before bot
420     (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
421     do (decf end-token-index))
422     ;; go forward to the last token before bot
423     (loop until (or (= end-token-index (nb-lexemes lexer))
424     (mark> (start-offset (lexeme lexer end-token-index)) bot))
425     do (incf end-token-index))
426     (let ((start-token-index end-token-index))
427     ;; go back to the first token after top, or until the previous token
428     ;; contains a valid parser state
429     (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
430     (not (parse-state-empty-p
431     (slot-value (lexeme lexer (1- start-token-index)) 'state))))
432     do (decf start-token-index))
433     (let ((*white-space-start* (offset top)))
434     ;; display the parse tree if any
435     (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
436     (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
437     syntax
438     pane))
439     ;; display the lexemes
440     (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
441     (loop while (< start-token-index end-token-index)
442     do (let ((token (lexeme lexer start-token-index)))
443     (display-parse-tree token syntax pane))
444     (incf start-token-index))))))))
445     (let* ((cursor-line (number-of-lines-in-region top (point pane)))
446     (height (text-style-height (medium-text-style pane) pane))
447     (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
448     (cursor-column (column-number (point pane)))
449     (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
450     (updating-output (pane :unique-id -1)
451     (draw-rectangle* pane
452     (1- cursor-x) (- cursor-y (* 0.2 height))
453     (+ cursor-x 2) (+ cursor-y (* 0.8 height))
454     :ink (if current-p
455     (make-rgb-color 0.7 0.7 0.7) +blue+))))))
456    

  ViewVC Help
Powered by ViewVC 1.1.5