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

Diff of /climacs/ttcn3-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by thenriksen, Sun Nov 12 16:06:06 2006 UTC revision 1.9 by thenriksen, Mon Nov 13 09:01:52 2006 UTC
# Line 26  Line 26 
26    (:export))    (:export))
27  (in-package :climacs-ttcn3-syntax)  (in-package :climacs-ttcn3-syntax)
28    
29  (defgeneric display-parse-tree (entity syntax pane))  (defgeneric display-parse-tree (parse-symbol pane drei syntax))
30    
31  (defclass ttcn3-parse-tree (parse-tree) ())  (defclass ttcn3-parse-tree (parse-tree) ())
32    
# Line 158  Line 158 
158                         (make-instance ',nonempty-name                         (make-instance ',nonempty-name
159                                        :items ,name :item ,item-name))) *ttcn3-grammar*)                                        :items ,name :item ,item-name))) *ttcn3-grammar*)
160    
161       (defmethod display-parse-tree ((entity ,empty-name) (syntax ttcn3-syntax) pane)       (defmethod display-parse-tree ((entity ,empty-name) (pane clim-stream-pane)
162                                        (drei drei) (syntax ttcn3-syntax))
163         (declare (ignore pane))         (declare (ignore pane))
164         nil)         nil)
165    
166       (defmethod display-parse-tree ((entity ,nonempty-name) (syntax ttcn3-syntax) pane)       (defmethod display-parse-tree ((entity ,nonempty-name) (pane clim-stream-pane)
167                                        (drei drei) (syntax ttcn3-syntax))
168         (with-slots (items item) entity         (with-slots (items item) entity
169            (display-parse-tree items syntax pane)            (display-parse-tree items drei pane syntax)
170            (display-parse-tree item syntax pane)))))            (display-parse-tree item drei pane syntax)))))
171    
172  (defmacro define-simple-list (name item-name)  (defmacro define-simple-list (name item-name)
173    (let ((empty-name (gensym))    (let ((empty-name (gensym))
# Line 213  Line 215 
215                  (add-rule (grammar-rule (,name -> ((word identifier (word-is word ,(first rule-body)))) :word word))                  (add-rule (grammar-rule (,name -> ((word identifier (word-is word ,(first rule-body)))) :word word))
216                            ,grammar)                            ,grammar)
217                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
218                  (defmethod display-parse-tree :around ((entity ,name) (syntax ,syntax) pane)                  (defmethod display-parse-tree :around ((entity ,name) (pane clim-stream-pane)
219                                                           (drei drei) (syntax ,syntax))
220                    (with-drawing-options (pane :ink +blue-violet+)                    (with-drawing-options (pane :ink +blue-violet+)
221                      (call-next-method)))))                      (call-next-method)))))
222               ((and (eql (length rule-body) 1)               ((and (eql (length rule-body) 1)
# Line 223  Line 226 
226                  ,@(loop for alt in (cdr (first rule-body))                  ,@(loop for alt in (cdr (first rule-body))
227                       collect `(add-rule (grammar-rule (,name -> ((item ,alt)) :item item)) ,grammar))                       collect `(add-rule (grammar-rule (,name -> ((item ,alt)) :item item)) ,grammar))
228                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
229                  (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)                  (defmethod display-parse-tree ((entity ,name) (pane clim-stream-pane)
230                    (display-parse-tree (slot-value entity 'item) syntax pane))))                                                 (drei drei) (syntax ,syntax))
231                      (display-parse-tree (slot-value entity 'item) pane drei syntax))))
232               ((and (eql (length rule-body) 1)               ((and (eql (length rule-body) 1)
233                     (typep (first rule-body) 'cons)                     (typep (first rule-body) 'cons)
234                     (eq (first (first rule-body)) 'nonempty-list-of))                     (eq (first (first rule-body)) 'nonempty-list-of))
# Line 247  Line 251 
251                                             appending `(,(intern (symbol-name component) :keyword)                                             appending `(,(intern (symbol-name component) :keyword)
252                                                          ,component)))) ,grammar)                                                          ,component)))) ,grammar)
253                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))                  ,@(if start-p `((add-rule (grammar-rule (,terminal -> (,name) :item ,name)) ,grammar)))
254                  (defmethod display-parse-tree ((entity ,name) (syntax ,syntax) pane)                  (defmethod display-parse-tree ((entity ,name) (pane clim-stream-pane)
255                                                   (drei drei) (syntax ,syntax))
256                    (with-slots ,rule-body                    (with-slots ,rule-body
257                        entity                        entity
258                      ,@(loop for component in rule-body collect                      ,@(loop for component in rule-body collect
259                             `(display-parse-tree ,component syntax pane))))))                             `(display-parse-tree ,component pane drei syntax))))))
260               (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body               (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
261                         name)))))                         name)))))
262        `(progn        `(progn
# Line 321  Line 326 
326        (or identifier number-form)))        (or identifier number-form)))
327    
328    
329  (defmethod display-parse-tree ((entity ttcn3-terminal) (syntax ttcn3-syntax) pane)  (defmethod display-parse-tree ((entity ttcn3-terminal) (pane clim-stream-pane)
330                                   (drei drei) (syntax ttcn3-syntax))
331    (with-slots (item) entity    (with-slots (item) entity
332        (display-parse-tree item syntax pane)))        (display-parse-tree item pane drei syntax)))
333    
334  (defmethod display-parse-tree ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)  (defmethod display-parse-tree ((entity ttcn3-entry) (pane clim-stream-pane)
335                                   (drei drei) (syntax ttcn3-syntax))
336    (flet ((cache-test (t1 t2)    (flet ((cache-test (t1 t2)
337             (and (eq t1 t2)             (and (eq t1 t2)
338                  (eq (slot-value t1 'ink)                  (eq (slot-value t1 'ink)
# Line 346  Line 353 
353                                  'string                                  'string
354                                  :stream pane)))))                                  :stream pane)))))
355    
356  (defgeneric display-parse-stack (symbol stack syntax pane))  (defgeneric display-parse-stack (symbol stack pane drei syntax))
357    
358  (defmethod display-parse-stack (symbol stack (syntax ttcn3-syntax) pane)  (defmethod display-parse-stack (symbol stack (pane clim-stream-pane)
359                                   (drei drei) (syntax ttcn3-syntax))
360    (let ((next (parse-stack-next stack)))    (let ((next (parse-stack-next stack)))
361      (unless (null next)      (unless (null next)
362        (display-parse-stack (parse-stack-symbol next) next syntax pane))        (display-parse-stack (parse-stack-symbol next) next pane drei syntax))
363      (loop for parse-tree in (reverse (parse-stack-parse-trees stack))      (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
364         do (display-parse-tree parse-tree syntax pane))))         do (display-parse-tree parse-tree pane drei syntax))))
365    
366  (defun display-parse-state (state syntax pane)  (defun display-parse-state (state pane drei syntax)
367    (let ((top (parse-stack-top state)))    (let ((top (parse-stack-top state)))
368      (if (not (null top))      (if (not (null top))
369          (display-parse-stack (parse-stack-symbol top) top syntax pane)          (display-parse-stack (parse-stack-symbol top) top pane drei syntax)
370          (display-parse-tree (target-parse-tree state) syntax pane))))          (display-parse-tree (target-parse-tree state) pane drei syntax))))
371    
372  (defmethod update-syntax-for-display (buffer (syntax ttcn3-syntax) top bot)  (defmethod update-syntax-for-display (buffer (syntax ttcn3-syntax) top bot)
373    (with-slots (parser lexer valid-parse) syntax    (with-slots (parser lexer valid-parse) syntax
# Line 390  Line 398 
398    
399  (defun handle-whitespace (pane buffer start end)  (defun handle-whitespace (pane buffer start end)
400    (let ((space-width (space-width pane))    (let ((space-width (space-width pane))
401          (tab-width (tab-width pane)))          (tab-width (tab-width pane)))
402      (loop while (and (< start end)      (with-sheet-medium (medium pane)
403                       (whitespacep (syntax buffer)        (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
404                                    (buffer-object buffer start)))          (loop while (< start end)
405            do (ecase (buffer-object buffer start)             do (case (buffer-object buffer start)
406                 (#\Newline (terpri pane)                  (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
407                            (setf (aref *cursor-positions* (incf *current-line*))                             (terpri pane)
408                                  (multiple-value-bind (x y) (stream-cursor-position pane)                             (stream-increment-cursor-position
409                                    (declare (ignore x))                              pane (first (aref cursor-positions 0)) 0))
410                                    y)))                  ((#\Page #\Return #\Space) (stream-increment-cursor-position
411                 (#\Space (stream-increment-cursor-position                                              pane space-width 0))
412                           pane space-width 0))                  (#\Tab (let ((x (stream-cursor-position pane)))
413                 (#\Tab (let ((x (stream-cursor-position pane)))                           (stream-increment-cursor-position
414                          (stream-increment-cursor-position                            pane (- tab-width (mod x tab-width)) 0))))
415                           pane (- tab-width (mod x tab-width)) 0)))             (incf start))))))
                (#\Page nil))  
          (incf start))))  
416    
417  (defmethod display-parse-tree :before ((entity ttcn3-entry) (syntax ttcn3-syntax) pane)  (defmethod display-parse-tree :before ((entity ttcn3-entry) (pane clim-stream-pane)
418                                   (drei drei) (syntax ttcn3-syntax))
419    (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))    (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
420    (setf *white-space-start* (end-offset entity)))    (setf *white-space-start* (end-offset entity)))
421    
422  (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) syntax pane)  (defmethod display-parse-tree :around ((entity ttcn3-parse-tree) pane drei syntax)
423    (with-slots (top bot) pane    (with-slots (top bot) pane
424      (when (and (end-offset entity) (mark> (end-offset entity) top))      (when (and (end-offset entity) (mark> (end-offset entity) top))
425        (call-next-method))))        (call-next-method))))
426    
427  (defmethod redisplay-pane-with-syntax ((pane drei-pane) (syntax ttcn3-syntax) current-p)  (defmethod display-drei-contents ((pane clim-stream-pane) (drei drei) (syntax ttcn3-syntax))
428    (with-slots (top bot) pane    (with-slots (top bot) pane
429      (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))      (with-accessors ((cursor-positions cursor-positions)) syntax
430            *current-line* 0        (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
431            (aref *cursor-positions* 0) (stream-cursor-position pane))                                           :initial-element nil)
432                *current-line* 0
433                (aref cursor-positions 0) (multiple-value-list
434                                           (stream-cursor-position pane))))
435      (with-slots (lexer) syntax      (with-slots (lexer) syntax
436        (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))        (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
437                                       1.0)))                                       1.0)))
# Line 440  Line 450 
450              (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)              (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
451                              (not (parse-state-empty-p                              (not (parse-state-empty-p
452                                    (slot-value (lexeme lexer (1- start-token-index)) 'state))))                                    (slot-value (lexeme lexer (1- start-token-index)) 'state))))
453                   do (decf start-token-index))                 do (decf start-token-index))
454              (let ((*white-space-start* (offset top)))              (let ((*white-space-start* (offset top)))
455                ;; display the parse tree if any                ;; display the parse tree if any
456                (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))                (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)                  (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
458                                       syntax                                       pane drei syntax))
                                      pane))  
459                ;; display the lexemes                ;; display the lexemes
460                (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))                (with-drawing-options (pane :ink (make-rgb-color 0.7 0.7 0.7))
461                  (loop while (< start-token-index end-token-index)                  (loop while (< start-token-index end-token-index)
462                     do (let ((token (lexeme lexer start-token-index)))                     do (let ((token (lexeme lexer start-token-index)))
463                          (display-parse-tree token syntax pane))                          (display-parse-tree token pane drei syntax))
464                       (incf start-token-index))))))))                     (incf start-token-index))))))))))
     (when (region-visible-p pane) (display-region pane syntax))  
     (display-cursor pane syntax current-p)))  
   

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

  ViewVC Help
Powered by ViewVC 1.1.5