/[mcclim]/mcclim/Drei/lr-syntax.lisp
ViewVC logotype

Contents of /mcclim/Drei/lr-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Sun Feb 17 14:54:47 2008 UTC (6 years, 1 month ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.18: +3 -0 lines
Fixed obscure Lisp syntax redisplay issue that could cause trouble with literal objects.
1 ;; -*- Mode: Lisp; Package: DREI-LR-SYNTAX -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2006 by
6 ;;; Troels Henriksen (athas@sigkill.dk)
7 ;;; (c) copyright 2007 by
8 ;;; John Q Splittist (splittist@gmail.com)
9 ;;;
10 ;;; This library is free software; you can redistribute it and/or
11 ;;; modify it under the terms of the GNU Library General Public
12 ;;; License as published by the Free Software Foundation; either
13 ;;; version 2 of the License, or (at your option) any later version.
14 ;;;
15 ;;; This library is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;;; Library General Public License for more details.
19 ;;;
20 ;;; You should have received a copy of the GNU Library General Public
21 ;;; License along with this library; if not, write to the
22 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;;; Boston, MA 02111-1307 USA.
24
25 ;;; Base lexing and parsing functionality of
26 ;;; syntax modules for analysing languages
27
28 (in-package :drei-lr-syntax)
29
30 (defclass lr-syntax-mixin ()
31 ((stack-top :initform nil
32 :accessor stack-top)
33 (potentially-valid-trees)
34 (lookahead-lexeme :initform nil :accessor lookahead-lexeme)
35 (current-state)
36 (initial-state :initarg :initial-state)
37 (current-start-mark)
38 (current-size)
39 (scan :accessor scan)))
40
41 (defmethod initialize-instance :after ((syntax lr-syntax-mixin) &rest args)
42 (declare (ignore args))
43 (with-accessors ((buffer buffer) (scan scan)) syntax
44 (setf scan (make-buffer-mark buffer 0 :left))))
45
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
47 ;;;
48 ;;; lexer
49
50 (defgeneric skip-inter (syntax state scan)
51 (:documentation "advance scan until the beginning of a new
52 lexeme. Return T if one can be found and NIL otherwise."))
53
54 (defgeneric lex (syntax state scan)
55 (:documentation "Return the next lexeme starting at scan."))
56
57 (defmethod lex :around (syntax state scan)
58 (when (skip-inter syntax state scan)
59 (let* ((start-offset (offset scan))
60 (lexeme (call-next-method))
61 (new-size (- (offset scan) start-offset)))
62 (with-slots (start-mark size) lexeme
63 (setf (offset scan) start-offset)
64 (setf start-mark scan
65 size new-size))
66 lexeme)))
67
68 (defclass lexer-state ()
69 ()
70 (:documentation "These states are used to determine how the lexer
71 should behave."))
72
73 (defmacro define-lexer-state (name superclasses &body body)
74 `(defclass ,name (,@superclasses lexer-state)
75 ,@body))
76
77 (define-lexer-state lexer-error-state ()
78 ()
79 (:documentation "In this state, the lexer returns error lexemes
80 consisting of entire lines of text"))
81
82 (define-lexer-state lexer-toplevel-state ()
83 ()
84 (:documentation "In this state, the lexer assumes it can skip
85 whitespace and should recognize ordinary lexemes of the language."))
86
87 (defclass parser-symbol ()
88 ((start-mark :initform nil :initarg :start-mark :reader start-mark)
89 (size :initform nil :initarg :size :reader size)
90 (parent :initform nil :accessor parent)
91 (children :initform '() :initarg :children :reader children)
92 (preceding-parse-tree :initform nil :reader preceding-parse-tree)
93 (parser-state :initform nil :initarg :parser-state :reader parser-state)))
94
95 (defmethod print-object ((object parser-symbol) stream)
96 (print-unreadable-object (object stream :type t :identity t)
97 (format stream "~s ~s" (start-offset object) (end-offset object))))
98
99 (defclass literal-object-mixin () ()
100 (:documentation "Mixin for parser symbols representing
101 literal (non-character) objects in the buffer."))
102
103 (defun literal-object-p (parser-symbol)
104 "Return true if `parser-symbol' is of type
105 `literal-object-mixin'."
106 (typep parser-symbol 'literal-object-mixin))
107
108 (defmethod start-offset ((state parser-symbol))
109 (let ((mark (start-mark state)))
110 (when mark
111 (offset mark))))
112
113 (defmethod end-offset ((state parser-symbol))
114 (with-slots (start-mark size) state
115 (when start-mark
116 (+ (offset start-mark) size))))
117
118 (defgeneric action (syntax state lexeme))
119 (defgeneric new-state (syntax state parser-symbol))
120
121 (defclass parser-state () ())
122
123 (defmacro define-parser-state (name superclasses &body body)
124 `(progn
125 (defclass ,name ,superclasses
126 ,@body)
127 (defvar ,name (make-instance ',name))))
128
129 (defclass lexeme (parser-symbol) ())
130
131 (defclass nonterminal (parser-symbol) ())
132
133 (defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args)
134 (declare (ignore args))
135 (with-slots (children start-mark size) parser-symbol
136 (loop for child in children
137 do (setf (parent child) parser-symbol))
138 (let ((start (find-if-not #'null children :key #'start-offset))
139 (end (find-if-not #'null children :key #'end-offset :from-end t)))
140 (when start
141 (setf start-mark (slot-value start 'start-mark)
142 size (- (end-offset end) (start-offset start)))))))
143
144 (defun pop-one (syntax)
145 (with-slots (stack-top current-state) syntax
146 (with-slots (preceding-parse-tree parser-state) stack-top
147 (prog1 stack-top
148 (setf current-state parser-state
149 stack-top preceding-parse-tree)))))
150
151 (defun pop-number (syntax how-many)
152 (loop with result = '()
153 repeat how-many
154 do (push (pop-one syntax) result)
155 finally (return result)))
156
157 (defmacro reduce-fixed-number (symbol nb-children)
158 `(let ((result (make-instance ',symbol :children (pop-number syntax ,nb-children))))
159 (when (zerop ,nb-children)
160 (with-slots (scan) syntax
161 (with-slots (start-mark size) result
162 (setf start-mark (clone-mark scan :right)
163 size 0))))
164 result))
165
166 (defun pop-until-type (syntax type)
167 (with-slots (stack-top) syntax
168 (loop with result = '()
169 for child = stack-top
170 do (push (pop-one syntax) result)
171 until (typep child type)
172 finally (return result))))
173
174 (defmacro reduce-until-type (symbol type &optional end-of-buffer)
175 `(let ((result (make-instance ',symbol
176 :children (pop-until-type syntax ',type))))
177 (with-slots (start-mark size) result
178 (when (null (children result))
179 (with-slots (scan) syntax
180 (setf start-mark (clone-mark scan :right)
181 size 0)))
182 (when ,end-of-buffer
183 (setf size (- (size (buffer syntax))
184 (start-offset result)))))
185 result))
186
187 (defun pop-all (syntax)
188 (with-slots (stack-top) syntax
189 (loop with result = '()
190 until (null stack-top)
191 do (push (pop-one syntax) result)
192 finally (return result))))
193
194 (defmacro reduce-all (symbol)
195 `(let ((result (make-instance ',symbol :children (pop-all syntax))))
196 (when (null (children result))
197 (with-slots (scan) syntax
198 (with-slots (start-mark size) result
199 (setf start-mark (clone-mark scan :right)
200 size 0))))
201 result))
202
203 (define-parser-state error-state (lexer-error-state parser-state) ())
204 (define-parser-state error-reduce-state (lexer-toplevel-state parser-state) ())
205
206 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
207 ;;;
208 ;;; parser step
209
210 (defgeneric parser-step (syntax))
211
212 (defmethod parser-step ((syntax lr-syntax-mixin))
213 (with-slots (lookahead-lexeme stack-top current-state scan) syntax
214 (setf lookahead-lexeme (lex syntax current-state (clone-mark scan :right)))
215 (let* ((new-parser-symbol (action syntax current-state lookahead-lexeme))
216 (new-state (new-state syntax current-state new-parser-symbol)))
217 (with-slots (parser-state parser-symbol preceding-parse-tree children) new-parser-symbol
218 (setf parser-state current-state
219 current-state new-state
220 preceding-parse-tree stack-top
221 stack-top new-parser-symbol)))
222 (setf (offset scan) (end-offset stack-top))))
223
224 (defun prev-tree (tree)
225 (assert (not (null tree)))
226 (if (null (children tree))
227 (preceding-parse-tree tree)
228 (car (last (children tree)))))
229
230 (defun next-tree (tree)
231 (assert (not (null tree)))
232 (if (null (parent tree))
233 nil
234 (let* ((parent (parent tree))
235 (siblings (children parent)))
236 (cond ((null parent) nil)
237 ((eq tree (car (last siblings))) parent)
238 (t (loop with new-tree = (cadr (member tree siblings :test #'eq))
239 until (null (children new-tree))
240 do (setf new-tree (car (children new-tree)))
241 finally (return new-tree)))))))
242
243 (defun find-last-valid-lexeme (parse-tree offset)
244 (cond ((or (null parse-tree) (null (start-offset parse-tree))) nil)
245 ((> (start-offset parse-tree) offset)
246 (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
247 ((not (typep parse-tree 'lexeme))
248 (find-last-valid-lexeme (car (last (children parse-tree))) offset))
249 ((>= (end-offset parse-tree) offset)
250 (find-last-valid-lexeme (preceding-parse-tree parse-tree) offset))
251 (t parse-tree)))
252
253 (defun find-first-potentially-valid-lexeme (parse-trees offset)
254 (cond ((null parse-trees) nil)
255 ((or (null (start-offset (car parse-trees)))
256 (< (end-offset (car parse-trees)) offset))
257 (find-first-potentially-valid-lexeme (cdr parse-trees) offset))
258 ((not (typep (car parse-trees) 'lexeme))
259 (find-first-potentially-valid-lexeme (children (car parse-trees)) offset))
260 ((<= (start-offset (car parse-trees)) offset)
261 (loop with tree = (next-tree (car parse-trees))
262 until (or (null tree) (> (start-offset tree) offset))
263 do (setf tree (next-tree tree))
264 finally (return tree)))
265 (t (car parse-trees))))
266
267 (defun parse-tree-equal (tree1 tree2)
268 (and (eq (class-of tree1) (class-of tree2))
269 (eq (parser-state tree1) (parser-state tree2))
270 (= (end-offset tree1) (end-offset tree2))))
271
272 (defmethod print-object ((mark mark) stream)
273 (print-unreadable-object (mark stream :type t :identity t)
274 (format stream "~s" (offset mark))))
275
276 (defun parse-patch (syntax)
277 (with-slots (current-state stack-top scan potentially-valid-trees) syntax
278 (parser-step syntax)
279 (finish-output *trace-output*)
280 (cond ((parse-tree-equal stack-top potentially-valid-trees)
281 (unless (or (null (parent potentially-valid-trees))
282 (eq potentially-valid-trees
283 (car (last (children (parent potentially-valid-trees))))))
284 (loop for tree = (cadr (member potentially-valid-trees
285 (children (parent potentially-valid-trees))
286 :test #'eq))
287 then (car (children tree))
288 until (null tree)
289 do (setf (slot-value tree 'preceding-parse-tree)
290 stack-top))
291 (setf stack-top (prev-tree (parent potentially-valid-trees))))
292 (setf potentially-valid-trees (parent potentially-valid-trees))
293 (setf current-state (new-state syntax (parser-state stack-top) stack-top))
294 (setf (offset scan) (end-offset stack-top)))
295 (t (loop until (or (null potentially-valid-trees)
296 (>= (start-offset potentially-valid-trees)
297 (end-offset stack-top)))
298 do (setf potentially-valid-trees
299 (next-tree potentially-valid-trees)))))))
300
301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302 ;;;
303 ;;; Utility functions
304
305 (defun invoke-do-parse-symbols-forward (start-offset nearby-symbol fn)
306 "Loop across the parse symbols of the syntax, calling `fn' on
307 any parse symbol that starts at or after
308 `start-offset'. `Nearby-symbol' is the symbol at which the
309 iteration will start. First, if `nearby-symbol' is at or after
310 `start-offset', `fn' will be called on
311 `nearby-symbol'. Afterwards, the children of `nearby-symbol' will
312 be looped over. Finally, the process will be repeated for each
313 sibling of `nearby-symbol'. It is guaranteed that `fn' will not
314 be called twice for the same parser symbol."
315 (labels ((act (parse-symbol previous)
316 (when (>= (end-offset parse-symbol) start-offset)
317 (when (>= (start-offset parse-symbol) start-offset)
318 (funcall fn parse-symbol))
319 (loop for child in (children parse-symbol)
320 unless (eq child previous)
321 do (act child parse-symbol)))
322 (unless (or (null (parent parse-symbol))
323 (eq (parent parse-symbol) previous))
324 (act (parent parse-symbol) parse-symbol))))
325 (act nearby-symbol nearby-symbol)))
326
327 (defmacro do-parse-symbols-forward ((symbol start-offset enclosing-symbol)
328 &body body)
329 "Loop across the parse symbols of the syntax, evaluating `body'
330 with `symbol' bound for each parse symbol that starts at or after
331 `start-offset'. `enclosing-symbol' is the symbol at which the
332 iteration will start. First, if `enclosing-symbol' is at or after
333 `start-offset', `symbol' will be bound to
334 `enclosing-symbol'. Afterwards, the children of
335 `enclosing-symbol' will be looped over. Finally, the process will
336 be repeated for each sibling of `nearby-symbol'. It is guaranteed
337 that `symbol' will not bound to the same parser symbol twice."
338 `(invoke-do-parse-symbols-forward ,start-offset ,enclosing-symbol
339 #'(lambda (,symbol)
340 ,@body)))
341
342 (defun parser-symbol-containing-offset (syntax offset)
343 "Find the most specific (leaf) parser symbol in `syntax' that
344 contains `offset'. If there is no such parser symbol, return the
345 stack-top of `syntax'."
346 (labels ((check (parser-symbol)
347 (cond ((or (and (<= (start-offset parser-symbol) offset)
348 (< offset (end-offset parser-symbol)))
349 (= offset (start-offset parser-symbol)))
350 (return-from parser-symbol-containing-offset
351 (if (null (children parser-symbol))
352 parser-symbol
353 (or (check-children (children parser-symbol))
354 parser-symbol))))
355 (t nil)))
356 (check-children (children)
357 (find-if #'check children)))
358 (or (check-children (children (stack-top syntax)))
359 (stack-top syntax))))
360
361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
362 ;;;
363 ;;; update syntax
364
365 (defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size
366 &optional (begin 0) (end (size (buffer syntax))))
367 (declare (ignore begin end))
368 (let* ((low-mark-offset prefix-size)
369 (high-mark-offset (- (size (buffer syntax)) suffix-size)))
370 (when (<= low-mark-offset high-mark-offset)
371 (catch 'done
372 (with-slots (current-state stack-top scan potentially-valid-trees
373 initial-state) syntax
374 (setf potentially-valid-trees
375 (if (null stack-top)
376 nil
377 (find-first-potentially-valid-lexeme (children stack-top)
378 high-mark-offset)))
379 (setf stack-top (find-last-valid-lexeme stack-top low-mark-offset))
380 (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
381 current-state (if (null stack-top)
382 initial-state
383 (new-state syntax
384 (parser-state stack-top)
385 stack-top)))
386 (loop do (parse-patch syntax)))))
387 (values 0 (size (buffer syntax)))))
388
389 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
390 ;;;
391 ;;; General redisplay for LR syntaxes, subclasses of `lr-syntax-mixin'
392 ;;; should be able to easily define some syntax rules, and need not
393 ;;; bother with all this complexity.
394 ;;;
395 ;;; _______________
396 ;;; / \
397 ;;; / \
398 ;;; / \
399 ;;; | XXXX XXXX |
400 ;;; | XXXX XXXX |
401 ;;; | XXX XXX |
402 ;;; | X |
403 ;;; \__ XXX __/
404 ;;; |\ XXX /|
405 ;;; | | | |
406 ;;; | I I I I I I I |
407 ;;; | I I I I I I |
408 ;;; \_ _/
409 ;;; \_ _/
410 ;;; \_______/
411 ;;; XXX XXX
412 ;;; XXXXX XXXXX
413 ;;; XXXXXXXXX XXXXXXXXXX
414 ;;; XXXXX XXXXX
415 ;;; XXXXXXX
416 ;;; XXXXX XXXXX
417 ;;; XXXXXXXXX XXXXXXXXXX
418 ;;; XXXXX XXXXX
419 ;;; XXX XXX
420
421 (defmacro define-syntax-highlighting-rules (name &body rules)
422 "Define a set of rules for highlighting a syntax. `Name', which
423 must be a symbol, is the name of this set of rules, and will be
424 bound to a function implementing the rules. `Rules' is a list of
425 rules of the form `(parser-symbol (type args...))', where
426 `parser-symbol' is a type that might be encountered in a parse
427 tree for the syntax. The rule specifies how to highlight that
428 kind of object (and all its children). `Type' can be one of three
429 special symbols.
430
431 `:face', in which case `args' will be used as arguments to a
432 call to `make-face'. The resulting face will be used to draw
433 the parsersymbol.
434
435 `:options', in which case `args' will be used as arguments to
436 `make-drawing-options'. The resulting options will be used to
437 draw the parser symbol.
438
439 `:function', in which case `args' must be a single element, a
440 function that takes two arguments. These arguments are the view
441 of the syntax and the parser symbol, and the return value of
442 this function is the `drawing-options' object that will be used
443 to draw the parser-symbol.
444
445 Alternatively, `type' can be any object (usually a dynamically
446 bound symbol), in which case it will be evaluated to get the
447 drawing options.
448
449 `Type' can also be a list, in which case the first element will
450 be interpreted as described above, and the remaining elements
451 will be considered keyword arguments. The following keyword
452 arguments are supported:
453
454 `:sticky': if true, the syntax highlighting options defined by
455 this rule will apply to all children as well, effectively
456 overriding their options. The default is false. For a
457 `:function', `:sticky' will not work. Instead, return a true
458 secondary value from the function."
459 (check-type name symbol)
460 `(progn
461 (fmakunbound ',name)
462 (defgeneric ,name (view parser-symbol)
463 (:method (view (parser-symbol parser-symbol))
464 nil))
465 ,@(flet ((make-rule-exp (type args)
466 (let ((actual-type (first (listed type))))
467 (destructuring-bind (&key sticky) (rest (listed type))
468 (case actual-type
469 (:face `(let ((options (make-drawing-options :face (make-face ,@args))))
470 #'(lambda (view parser-symbol)
471 (declare (ignore view parser-symbol))
472 (values options ,sticky))))
473 (:options `#'(lambda (view parser-symbol)
474 (declare (ignore view parser-symbol))
475 (values (make-drawing-options ,@args) ,sticky)))
476 (:function (first args))
477 (t `#'(lambda (view parser-symbol)
478 (declare (ignore view parser-symbol))
479 (values ,actual-type ,sticky))))))))
480 (loop for (parser-symbol (type . args)) in rules
481 collect `(let ((rule ,(make-rule-exp type args)))
482 (defmethod ,name (view (parser-symbol ,parser-symbol))
483 (funcall rule view parser-symbol)))))))
484
485 (define-syntax-highlighting-rules default-syntax-highlighting)
486
487 (defgeneric syntax-highlighting-rules (syntax)
488 (:documentation "Return the drawing options that should be used
489 for displaying `parser-symbol's for `syntax'. A method should be
490 defined on this function for any syntax that wants syntax
491 highlighting.")
492 (:method ((syntax lr-syntax-mixin))
493 'default-syntax-highlighting))
494
495 (defun get-drawing-options (highlighting-rules view parse-symbol)
496 "Get the drawing options with which `parse-symbol' should be
497 drawn. If `parse-symbol' or the stack-top of syntax, return
498 NIL. `View' must be a `drei-syntax-view' containing a syntax that
499 `highlighting-rules' supports."
500 (when (and parse-symbol (not (eq (stack-top (syntax view)) parse-symbol)))
501 (funcall highlighting-rules view parse-symbol)))
502
503 (defstruct (pump-state
504 (:constructor make-pump-state
505 (parser-symbol offset drawing-options
506 highlighting-rules)))
507 "A pump state object used in the LR syntax
508 module. `parser-symbol' is the a parse symbol object `offset' is
509 in. `Drawing-options' is a stack with elements `(end-offset
510 drawing-options)', where `end-offset' specifies there the drawing
511 options specified by `drawing-options' stop. `Highlighting-rules'
512 is the rules that are used for syntax highlighting."
513 parser-symbol offset
514 drawing-options highlighting-rules)
515
516 (defstruct (drawing-options-frame
517 (:constructor make-drawing-options-frame
518 (end-offset drawing-options sticky-p))
519 (:conc-name frame-))
520 "An entry in the drawing options stack maintained by the
521 `pump-state' structure. `End-offset' is the end buffer offset
522 for the frame, `drawing-options' is the drawing options that
523 should be used until that offset, and if `sticky-p' is true it
524 will not be possible to put other frames on top of this one in
525 the stack."
526 end-offset drawing-options sticky-p)
527
528 (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view)
529 (syntax lr-syntax-mixin) (offset integer))
530 (update-parse syntax 0 (size (buffer view)))
531 (let ((parser-symbol (parser-symbol-containing-offset syntax offset))
532 (highlighting-rules (syntax-highlighting-rules syntax)))
533 (labels ((initial-drawing-options (parser-symbol)
534 (if (null parser-symbol)
535 (make-drawing-options-frame
536 (size (buffer view)) +default-drawing-options+ nil)
537 (multiple-value-bind (drawing-options sticky)
538 (get-drawing-options highlighting-rules view parser-symbol)
539 (if (null drawing-options)
540 (initial-drawing-options (parent parser-symbol))
541 (make-drawing-options-frame (end-offset parser-symbol)
542 drawing-options sticky))))))
543 (make-pump-state parser-symbol offset
544 (list (initial-drawing-options parser-symbol)
545 (make-drawing-options-frame
546 (1+ (size (buffer view))) +default-drawing-options+ nil))
547 highlighting-rules))))
548
549 (defun find-next-stroke-end (view pump-state)
550 "Assuming that `pump-state' contains the previous pump state,
551 find out where the next stroke should end, and possibly push some
552 drawing options onto `pump-state'."
553 (with-accessors ((start-symbol pump-state-parser-symbol)
554 (offset pump-state-offset)
555 (drawing-options pump-state-drawing-options)
556 (highlighting-rules pump-state-highlighting-rules))
557 pump-state
558 (let* ((line (line-containing-offset view offset))
559 (line-end-offset (end-offset line)))
560 (flet ((finish (new-offset symbol &optional stroke-drawing-options sticky-p)
561 (setf start-symbol symbol)
562 (loop until (> (frame-end-offset (first drawing-options))
563 new-offset)
564 do (pop drawing-options))
565 (unless (null stroke-drawing-options)
566 (push (if (frame-sticky-p (first drawing-options))
567 (make-drawing-options-frame
568 (end-offset symbol) (frame-drawing-options (first drawing-options)) t)
569 (make-drawing-options-frame
570 (end-offset symbol) stroke-drawing-options sticky-p))
571 drawing-options))
572 (return-from find-next-stroke-end new-offset)))
573 (cond ((null start-symbol)
574 ;; This means that all remaining lines are blank.
575 (finish line-end-offset nil))
576 ((and (typep start-symbol 'literal-object-mixin)
577 (= offset (start-offset start-symbol)))
578 (finish (end-offset start-symbol) start-symbol nil))
579 (t
580 (or (let* ((current-frame (first drawing-options))
581 (currently-used-options (frame-drawing-options current-frame)))
582 (do-parse-symbols-forward (symbol offset start-symbol)
583 (multiple-value-bind (symbol-drawing-options sticky)
584 (get-drawing-options highlighting-rules view symbol)
585 ;; Remove frames that are no longer applicable...
586 (loop until (> (frame-end-offset (first drawing-options))
587 (start-offset symbol))
588 do (pop drawing-options))
589 (let ((options-to-be-used (if (frame-sticky-p (first drawing-options))
590 (frame-drawing-options (first drawing-options))
591 symbol-drawing-options)))
592 (cond ((> (start-offset symbol) line-end-offset)
593 (finish line-end-offset start-symbol))
594 ((and (typep symbol 'literal-object-mixin))
595 (finish (start-offset symbol) symbol
596 (or symbol-drawing-options
597 (make-drawing-options :function (object-drawer)))))
598 ((and (> (start-offset symbol) offset)
599 (not (drawing-options-equal (or options-to-be-used
600 +default-drawing-options+)
601 currently-used-options))
602 (if (null symbol-drawing-options)
603 (>= (start-offset symbol) (frame-end-offset current-frame))
604 t))
605 (finish (start-offset symbol) symbol symbol-drawing-options sticky))
606 ((and (= (start-offset symbol) offset)
607 symbol-drawing-options
608 (not (drawing-options-equal
609 options-to-be-used
610 (frame-drawing-options (first drawing-options)))))
611 (finish (start-offset symbol) symbol symbol-drawing-options sticky)))))))
612 ;; If there are no more parse symbols, we just go
613 ;; line-by-line from here. This should mean that all
614 ;; remaining lines are blank.
615 (finish line-end-offset nil))))))))
616
617 (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view)
618 (syntax lr-syntax-mixin) stroke
619 (pump-state pump-state))
620 ;; `Pump-state' will be destructively modified.
621 (prog1 pump-state
622 (with-accessors ((offset pump-state-offset)
623 (current-drawing-options pump-state-drawing-options))
624 pump-state
625 (let ((old-drawing-options (frame-drawing-options (first current-drawing-options)))
626 (end-offset (find-next-stroke-end view pump-state))
627 (old-offset offset))
628 (setf (stroke-start-offset stroke) offset
629 (stroke-end-offset stroke) end-offset
630 (stroke-drawing-options stroke) old-drawing-options
631 offset (if (offset-end-of-line-p (buffer view) end-offset)
632 (1+ end-offset)
633 end-offset))
634 ;; Don't use empty strokes, try again...
635 (when (= old-offset offset)
636 (stroke-pump-with-syntax view syntax stroke pump-state))))))

  ViewVC Help
Powered by ViewVC 1.1.5