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

Contents of /mcclim/Drei/syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Fri Feb 15 13:16:17 2008 UTC (6 years, 2 months ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.18: +1 -1 lines
Improved Drei redisplay performance by 66% in most cases.

The main difference is that syntaxes are now supposed to report which
parts of the display may need to be updated, previously their view of
the display was computed for every redisplay iteration, and any
changes drawn.

Of course, no syntaxes do that yet, so if you use Lisp block-comments
or string-quoting, you will see "delayed" redrawing of some parts of
the display. Just like Emacs!

Currently, a heuristic is used that invalidates parts of the display
corresponding to buffer regions that have actually been changed, so it
does work fine for the common cases.
1 ;;; -*- Mode: Lisp; Package: DREI-SYNTAX -*-
2
3 ;;; (c) copyright 2004-2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5 ;;; (c) copyright 2005 by
6 ;;; Matthieu Villeneuve (matthieu.villeneuve@free.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 (in-package :drei-syntax)
24
25 (defclass syntax (name-mixin observable-mixin)
26 ((%buffer :initarg :buffer :reader buffer)
27 (%command-table :initarg :command-table
28 :initform (error "A command table has not been provided for this syntax")
29 :reader command-table)
30 (%updater-fns :initarg :updater-fns
31 :initform '()
32 :accessor updater-fns
33 :documentation "A list of functions that are
34 called whenever a syntax function needs up-to-date syntax
35 information. `Update-syntax' is never called directly by syntax
36 commands. Each function should take two arguments, integer
37 offsets into the buffer of the syntax delimiting the region that
38 must have an up-to-date parse. These arguments should be passed
39 on to a call to `update-syntax'."))
40 (:metaclass modual-class)
41 (:documentation "The base class for all syntaxes."))
42
43 (defgeneric syntax-command-tables (syntax)
44 (:documentation "Returns additional command tables provided by
45 `syntax'.")
46 (:method-combination append :most-specific-last)
47 (:method append ((syntax syntax))
48 (list (command-table syntax))))
49
50 (defun syntaxp (object)
51 "Return T if `object' is an instance of a syntax, NIL
52 otherwise."
53 (typep object 'syntax))
54
55 (defun update-parse (syntax &optional (begin 0)
56 (end (size (buffer syntax))))
57 "Make sure the parse for `syntax' from offset `begin' to `end'
58 is up to date. `Begin' and `end' default to 0 and the size of the
59 buffer of `syntax', respectively."
60 (if (null (updater-fns syntax))
61 ;; Just call `update-syntax' manually. We assume the entire
62 ;; buffer has changed.
63 (update-syntax syntax 0 0 begin end)
64 (map nil #'(lambda (updater)
65 (funcall updater begin end))
66 (updater-fns syntax))))
67
68 (define-condition no-such-operation (simple-error)
69 ()
70 (:report (lambda (condition stream)
71 (declare (ignore condition))
72 (format stream "Operation unavailable for this syntax")))
73 (:documentation "This condition is signaled whenever an attempt is
74 made to execute an operation that is unavailable for the particular syntax" ))
75
76 (defgeneric update-syntax (syntax unchanged-prefix unchanged-suffix
77 &optional begin end)
78 (:documentation "Inform the syntax module that it must update
79 its view of the buffer. `Unchanged-prefix' `unchanged-suffix'
80 indicate what parts of the buffer has not been changed. `Begin'
81 and `end' are offsets specifying the minimum region of the buffer
82 that must have an up-to-date parse, defaulting to 0 and the size
83 of the buffer respectively. It is perfectly valid for a syntax to
84 ignore these hints and just make sure the entire syntax tree is
85 up to date, but it *must* make sure at at least the region
86 delimited by `begin' and `end' has an up to date parse. Returns
87 two values, offsets into the buffer of the syntax, denoting the
88 buffer region thas has an up to date parse.")
89 (:method-combination values-max-min :most-specific-last))
90
91 (defgeneric eval-defun (mark syntax))
92
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 ;;;
95 ;;; Syntax command tables.
96
97 (defclass syntax-command-table (standard-command-table)
98 ()
99 (:documentation "A syntax command table provides facilities for
100 having frame-specific commands that do not show up when the
101 syntax is used in other applications than the one it is supposed
102 to. For example, the Return From Definition command should be
103 available when Lisp syntax is used in Climacs (or another
104 editor), but not anywhere else."))
105
106 (defgeneric additional-command-tables (editor command-table)
107 (:method-combination append)
108 (:documentation "Return a list of additional command tables
109 that should be checked for commands in addition to those
110 `command-table' inherits from. The idea is that methods are
111 specialised to `editor' (which is at first a Drei instance), and
112 that those methods may call the function again recursively with a
113 new `editor' argument to provide arbitrary granularity for
114 command-table-selection. For instance, some commands may be
115 applicable in a situation where the editor is a pane or gadget in
116 its own right, but not when it functions as an input-editor. In
117 this case, a method could be defined for `application-frame' as
118 the `editor' argument, that calls `additional-command-tables'
119 again with whatever the \"current\" editor instance is. The
120 default method on this generic function just returns the empty
121 list.")
122 (:method append (editor command-table)
123 '()))
124
125 (defmethod command-table-inherit-from ((table syntax-command-table))
126 "Fetch extra command tables to inherit from (using
127 `additional-command-tables') as well as the command tables
128 `table' actually directly inherits from."
129 (append (mapcar #'find-command-table
130 (additional-command-tables *application-frame* table))
131 (call-next-method)))
132
133 (defmacro define-syntax-command-table (name &rest args &key &allow-other-keys)
134 "Define a syntax command table class with the provided name, as
135 well as defining a CLIM command table of the same name. `Args'
136 will be passed on to `make-command-table'. An :around method on
137 `command-table-inherit-from' for the defined class will also be
138 defined. This method will make sure that when an instance of the
139 syntax command table is asked for its inherited command tables,
140 it will return those of the defined CLIM command table, as well
141 as those provided by methods on
142 `additional-command-tables'. Command tables provided through
143 `additional-command-tables' will take precence over those
144 specified in the usual way with :inherit-from."
145 `(progn (make-command-table ',name ,@args)
146 (defclass ,name (syntax-command-table)
147 ())
148 (defmethod command-table-inherit-from ((table ,name))
149 (append (call-next-method)
150 '(,name)
151 (command-table-inherit-from (find-command-table ',name))))))
152
153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 ;;;
155 ;;; Commenting
156
157 (defgeneric syntax-line-comment-string (syntax)
158 (:documentation "string to use at the beginning of a line to
159 indicate a line comment"))
160
161 (defgeneric line-comment-region (syntax mark1 mark2)
162 (:documentation "inset a line comment string at the beginning of
163 every line in the region"))
164
165 (defmethod line-comment-region (syntax mark1 mark2)
166 (when (mark< mark2 mark1)
167 (rotatef mark1 mark2))
168 (let ((mark (clone-mark mark1)))
169 (unless (beginning-of-line-p mark)
170 (end-of-line mark)
171 (unless (end-of-buffer-p mark)
172 (forward-object mark)))
173 (loop while (mark< mark mark2)
174 do (insert-sequence mark (syntax-line-comment-string syntax))
175 (end-of-line mark)
176 (unless (end-of-buffer-p mark)
177 (forward-object mark)))))
178
179 (defgeneric line-uncomment-region (syntax mark1 mark2)
180 (:documentation "inset a line comment string at the beginning of
181 every line in the region"))
182
183 (defmethod line-uncomment-region (syntax mark1 mark2)
184 (when (mark< mark2 mark1)
185 (rotatef mark1 mark2))
186 (let ((mark (clone-mark mark1)))
187 (unless (beginning-of-line-p mark)
188 (end-of-line mark)
189 (unless (end-of-buffer-p mark)
190 (forward-object mark)))
191 (loop while (mark< mark mark2)
192 do (when (looking-at mark (syntax-line-comment-string syntax))
193 (delete-range mark (length (syntax-line-comment-string syntax))))
194 (end-of-line mark)
195 (unless (end-of-buffer-p mark)
196 (forward-object mark)))))
197
198 (defgeneric comment-region (syntax mark1 mark2)
199 (:documentation "turn the region between the two marks into a comment
200 in the specific syntax.")
201 (:method (syntax mark1 mark2) nil))
202
203 (defgeneric uncomment-region (syntax mark1 mark2)
204 (:documentation "remove comment around region")
205 (:method (syntax mark1 mark2) nil))
206
207 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
208 ;;;
209 ;;; Name for info-pane
210
211 (defgeneric name-for-info-pane (syntax &key &allow-other-keys)
212 (:documentation "Return the name that should be used for the
213 info-pane for panes displaying a buffer in this syntax.")
214 (:method (syntax &key &allow-other-keys)
215 (name syntax)))
216
217 (defgeneric display-syntax-name (syntax stream &key &allow-other-keys)
218 (:documentation "Draw the name of the syntax `syntax' to
219 `stream'. This is meant to be called for the info-pane.")
220 (:method (syntax stream &rest args &key)
221 (princ (apply #'name-for-info-pane syntax args) stream)))
222
223 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
224 ;;;
225 ;;; Syntax completion
226
227 (defparameter *syntaxes* '())
228
229 (defvar *default-syntax* nil
230 "The name of the default syntax. Must be a symbol.
231
232 This syntax will be used by default, when no other syntax is
233 mandated by file types or attribute lists.")
234
235 (defstruct (syntax-description (:type list))
236 (name (error "required argument") :type string)
237 (class-name (error "required argument") :type symbol)
238 (pathname-types nil :type list))
239
240 (defmacro define-syntax (class-name superclasses slots &rest options)
241 (let ((defclass-options nil)
242 (default-initargs nil)
243 (name nil)
244 (command-table nil)
245 (pathname-types nil))
246 (dolist (option options)
247 (case (car option)
248 ((:name)
249 (if name
250 (error "More than one ~S option provided to ~S"
251 ':name 'define-syntax)
252 (setf name (cadr option))))
253 ((:pathname-types)
254 (if pathname-types
255 (error "More than one ~S option provided to ~S"
256 ':pathname-types 'define-syntax)
257 (setf pathname-types (cdr option))))
258 ((:command-table)
259 (if command-table
260 (error "More than one ~S option provided to ~S"
261 ':command-table 'define-syntax)
262 (setf command-table `',(cadr option))))
263 ((:default-initargs)
264 (if default-initargs
265 (error "More than one ~S option provided to ~S"
266 ':default-initargs 'define-syntax)
267 (setf default-initargs (cdr option))))
268 (t (push (cdr option) defclass-options))))
269 (unless name
270 (error "~S not supplied to ~S" ':name 'define-syntax))
271 ;; FIXME: the :NAME initarg looks, well, a bit generic, and could
272 ;; collide with user-defined syntax initargs. Use
273 ;; DREI-SYNTAX::%NAME instead.
274 (setf default-initargs (list* :name name default-initargs))
275 `(progn
276 (push (make-syntax-description
277 :name ,name :class-name ',class-name
278 :pathname-types ',pathname-types)
279 *syntaxes*)
280 (defclass ,class-name ,superclasses ,slots
281 ,(append '(:default-initargs)
282 (when command-table
283 (list :command-table
284 (once-only (command-table)
285 `(when (find-command-table ,command-table)
286 (if (find-class ,command-table nil)
287 (make-instance ,command-table :name ,command-table)
288 ;; It must be just a command table.
289 (find-command-table ,command-table))))))
290 default-initargs)
291 (:metaclass modual-class)
292 ,@defclass-options))))
293
294 (defgeneric eval-option (syntax name value)
295 (:documentation "Evaluate the option `name' with the specified
296 `value' for `syntax'.")
297 (:method (syntax name value)
298 ;; We do not want to error out if an invalid option is
299 ;; specified. Signal a condition? For now, silently ignore.
300 (declare (ignore syntax name value))))
301
302 (defmethod eval-option :around (syntax (name string) value)
303 ;; Convert the name to a keyword symbol...
304 (eval-option syntax (intern (string-upcase name) (find-package :keyword))
305 value))
306
307 (defmacro define-option-for-syntax
308 (syntax option-name (syntax-symbol value-symbol) &body body)
309 "Define an option for the syntax specified by the symbol
310 `syntax'. `Option-name' should be a string that will be the
311 name of the option. The name will automatically be converted to
312 uppercase. When the option is being evaluated, `body' will be
313 run, with `syntax-symbol' bound to the syntax object the option
314 is being evaluated for, and `value-symbol' bound to the value
315 of the option."
316 ;; The name is converted to a keyword symbol which is used for all
317 ;; further identification.
318 (with-gensyms (name)
319 (let ((symbol (intern (string-upcase option-name)
320 (find-package :keyword))))
321 `(defmethod eval-option ((,syntax-symbol ,syntax)
322 (,name (eql ,symbol))
323 ,value-symbol)
324 ,@body))))
325
326 (defgeneric current-attributes-for-syntax (syntax)
327 (:method-combination append)
328 (:method append (syntax)
329 (list (cons :syntax (name syntax)))))
330
331 (defun make-attribute-line (syntax)
332 (apply #'concatenate 'string
333 (loop for (name . value) in (current-attributes-for-syntax syntax)
334 collect (string-downcase (symbol-name name) :start 1)
335 collect ": "
336 collect value
337 collect "; ")))
338
339 #+nil
340 (defmacro define-syntax (class-name (name superclasses) &body body)
341 `(progn (push '(,name . ,class-name) *syntaxes*)
342 (defclass ,class-name ,superclasses
343 ,@body
344 (:default-initargs :name ,name))))
345
346 (define-presentation-method accept
347 ((type syntax) stream (view textual-view) &key)
348 (multiple-value-bind (object success string)
349 (complete-input stream
350 (lambda (so-far action)
351 (complete-from-possibilities
352 so-far *syntaxes* '() :action action
353 :name-key #'syntax-description-name
354 :value-key #'syntax-description-class-name))
355 :partial-completers '(#\Space)
356 :allow-any-input t)
357 (declare (ignore success))
358 (if (find string *syntaxes* :key #'first :test #'string=)
359 (values object type)
360 (input-not-of-required-type string type))
361 object))
362
363 (defun syntax-from-name (syntax)
364 (let ((description (find syntax *syntaxes*
365 :key #'syntax-description-name
366 :test #'string-equal)))
367 (when description
368 (find-class (syntax-description-class-name description)))))
369
370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371 ;;;
372 ;;; Incremental Earley parser
373
374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;;
376 ;;; parse tree
377
378 (defclass parse-tree ()
379 ((start-mark :initform nil :initarg :start-mark :reader start-mark)
380 (size :initform nil :initarg :size))
381 (:documentation "The base class for all parse trees."))
382
383 (defgeneric start-offset (parse-tree)
384 (:documentation "The offset in the buffer of the first
385 character of a parse tree."))
386
387 (defmethod start-offset ((tree parse-tree))
388 (let ((mark (start-mark tree)))
389 (when mark
390 (offset mark))))
391
392 (defmethod (setf start-offset) ((offset number) (tree parse-tree))
393 (let ((mark (start-mark tree)))
394 (assert (not (null mark)))
395 (setf (offset mark) offset)))
396
397 (defmethod (setf start-offset) ((offset mark) (tree parse-tree))
398 (with-slots (start-mark) tree
399 (if (null start-mark)
400 (setf start-mark (clone-mark offset))
401 (setf (offset start-mark) (offset offset)))))
402
403 (defgeneric end-offset (parse-tree)
404 (:documentation "The offset in the buffer of the character
405 following the last one of a parse tree."))
406
407 (defmethod end-offset ((tree parse-tree))
408 (with-slots (start-mark size) tree
409 (when start-mark
410 (+ (offset start-mark) size))))
411
412 (defmethod (setf end-offset) ((offset number) (tree parse-tree))
413 (with-slots (start-mark size) tree
414 (assert (not (null start-mark)))
415 (setf size (- offset (offset start-mark)))))
416
417 (defmethod (setf end-offset) ((offset mark) (tree parse-tree))
418 (with-slots (start-mark size) tree
419 (assert (not (null start-mark)))
420 (setf size (- (offset offset) (offset start-mark)))))
421
422 (defmethod buffer ((tree parse-tree))
423 (let ((start-mark (start-mark tree)))
424 (when start-mark
425 (buffer start-mark))))
426
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
428 ;;;
429 ;;; lexer
430
431 (defclass lexer ()
432 ((buffer :initarg :buffer
433 :reader buffer
434 :documentation "The buffer associated with the
435 lexer."))
436 (:documentation "The base class for all lexers."))
437
438 (defgeneric nb-lexemes (lexer)
439 (:documentation "Return the number of lexemes in the lexer."))
440
441 (defgeneric lexeme (lexer pos)
442 (:documentation "Given a lexer and a position, return the
443 lexeme in that position in the lexer."))
444
445 (defgeneric insert-lexeme (lexer pos lexeme)
446 (:documentation "Insert a lexeme at the position in the lexer.
447 All lexemes following POS are moved to one position higher."))
448
449 (defgeneric delete-invalid-lexemes (lexer from to)
450 (:documentation "Invalidate all lexemes that could have changed
451 as a result of modifications to the buffer"))
452
453 (defgeneric inter-lexeme-object-p (lexer object)
454 (:documentation "This generic function is called by the
455 incremental lexer to determine whether a buffer object is an
456 inter-lexeme object, typically whitespace. Client code must
457 supply a method for this generic function."))
458
459 (defgeneric skip-inter-lexeme-objects (lexer scan)
460 (:documentation "This generic function is called by the
461 incremental lexer to skip inter-lexeme buffer objects. The
462 default method for this generic function increments the scan mark
463 until the object after the mark is not an inter-lexeme object, or
464 until the end of the buffer has been reached."))
465
466 (defgeneric update-lex (lexer start-pos end)
467 (:documentation "This function is called by client code as part
468 of the buffer-update protocol to inform the lexer that it needs
469 to analyze the contents of the buffer at least up to the `end'
470 mark of the buffer. `start-pos' is the position in the lexeme
471 sequence at which new lexemes should be inserted."))
472
473 (defgeneric next-lexeme (lexer scan)
474 (:documentation "This generic function is called by the
475 incremental lexer to get a new lexeme from the buffer. Client
476 code must supply a method for this function that specializes on
477 the lexer class. It is guaranteed that scan is not at the end of
478 the buffer, and that the first object after scan is not an
479 inter-lexeme object. Thus, a lexeme should always be returned by
480 this function."))
481
482 (defclass incremental-lexer (lexer)
483 ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))
484 (:documentation "A subclass of lexer which maintains the buffer
485 in the form of a sequence of lexemes that is updated
486 incrementally."))
487
488 (defmethod nb-lexemes ((lexer incremental-lexer))
489 (nb-elements (lexemes lexer)))
490
491 (defmethod lexeme ((lexer incremental-lexer) pos)
492 (element* (lexemes lexer) pos))
493
494 (defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme)
495 (insert* (lexemes lexer) pos lexeme))
496
497 (defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to)
498 "delete all lexemes between FROM and TO and return the first invalid
499 position in the lexemes of LEXER"
500 (with-slots (lexemes) lexer
501 (let ((start 1)
502 (end (nb-elements lexemes)))
503 ;; use binary search to find the first lexeme to delete
504 (loop while (< start end)
505 do (let ((middle (floor (+ start end) 2)))
506 (if (mark< (end-offset (element* lexemes middle)) from)
507 (setf start (1+ middle))
508 (setf end middle))))
509 ;; delete lexemes
510 (loop until (or (= start (nb-elements lexemes))
511 (mark> (start-mark (element* lexemes start)) to))
512 do (delete* lexemes start))
513 start)))
514
515 (defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan)
516 (loop until (end-of-buffer-p scan)
517 while (inter-lexeme-object-p lexer (object-after scan))
518 do (forward-object scan)))
519
520 (defmethod update-lex ((lexer incremental-lexer) start-pos end)
521 (let ((scan (clone-mark (low-mark (buffer lexer)) :left)))
522 (setf (offset scan)
523 (end-offset (lexeme lexer (1- start-pos))))
524 (loop do (skip-inter-lexeme-objects lexer scan)
525 until (if (end-of-buffer-p end)
526 (end-of-buffer-p scan)
527 (mark> scan end))
528 do (let* ((start-mark (clone-mark scan))
529 (lexeme (next-lexeme lexer scan))
530 (size (- (offset scan) (offset start-mark))))
531 (setf (slot-value lexeme 'start-mark) start-mark
532 (slot-value lexeme 'size) size)
533 (insert-lexeme lexer start-pos lexeme))
534 (incf start-pos))))
535
536 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
537 ;;;
538 ;;; grammar
539
540 (defclass rule ()
541 ((left-hand-side :initarg :left-hand-side :reader left-hand-side)
542 (right-hand-side :initarg :right-hand-side :reader right-hand-side)
543 (symbols :initarg :symbols :reader symbols)
544 (predict-test :initarg :predict-test :reader predict-test)
545 (number)))
546
547 (defclass grammar ()
548 ((rules :initform nil :accessor rules)
549 (hash :initform (make-hash-table) :accessor hash)
550 (number-of-rules :initform 0)))
551
552 (defmacro grammar-rule ((left-hand-side arrow arglist &body body) &key predict-test)
553 (declare (ignore arrow))
554 (labels ((var-of (arg)
555 (if (symbolp arg)
556 arg
557 (car arg)))
558 (sym-of (arg)
559 (cond ((symbolp arg) arg)
560 ((= (length arg) 3) (cadr arg))
561 ((symbolp (cadr arg)) (cadr arg))
562 (t (car arg))))
563 (test-of (arg)
564 (cond ((symbolp arg) t)
565 ((= (length arg) 3) (caddr arg))
566 ((symbolp (cadr arg)) t)
567 (t (cadr arg))))
568 (build-rule (arglist body)
569 (if (null arglist)
570 body
571 (let ((arg (car arglist)))
572 `(lambda (,(var-of arg))
573 (when (and (typep ,(var-of arg) ',(sym-of arg))
574 ,(test-of arg))
575 ,(build-rule (cdr arglist) body)))))))
576 `(make-instance 'rule
577 :left-hand-side ',left-hand-side
578 :right-hand-side
579 ,(build-rule arglist
580 (if (or (null body)
581 (symbolp (car body)))
582 `(make-instance ',left-hand-side ,@body)
583 `(progn ,@body)))
584 :symbols ,(coerce (mapcar #'sym-of arglist) 'vector)
585 :predict-test ,predict-test)))
586
587
588 (defmacro grammar (&body body)
589 "Create a grammar object from a set of rules."
590 (let ((rule (gensym "RULE"))
591 (rules (gensym "RULES"))
592 (result (gensym "RESULT")))
593 `(let* ((,rules (list ,@(loop for rule in body
594 collect `(grammar-rule ,rule))))
595 (,result (make-instance 'grammar)))
596 (dolist (,rule ,rules ,result)
597 (add-rule ,rule ,result)))))
598
599 (defgeneric add-rule (rule grammar))
600
601 (defmethod add-rule (rule (grammar grammar))
602 (push rule (rules grammar))
603 (setf (slot-value rule 'number) (slot-value grammar 'number-of-rules))
604 (incf (slot-value grammar 'number-of-rules))
605 (clrhash (hash grammar))
606 (let (rhs-symbols)
607 (dolist (rule (rules grammar))
608 (setf rhs-symbols (union rhs-symbols (coerce (symbols rule) 'list))))
609 (dolist (rule (rules grammar))
610 (let ((lhs-symbol (left-hand-side rule)))
611 (dolist (rhs-symbol rhs-symbols)
612 (when (or (subtypep lhs-symbol rhs-symbol)
613 (subtypep rhs-symbol lhs-symbol))
614 (pushnew rule (gethash rhs-symbol (hash grammar)))))))))
615
616 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
617 ;;;
618 ;;; parser
619
620 (defclass parser ()
621 ((grammar :initarg :grammar :reader parser-grammar)
622 (target :initarg :target :reader target)
623 (initial-state :reader initial-state)))
624
625 (defclass rule-item ()
626 ((parse-trees :initform '() :initarg :parse-trees :reader parse-trees)))
627
628
629 (defclass incomplete-item (rule-item)
630 ((orig-state :initarg :orig-state :reader orig-state)
631 (predicted-from :initarg :predicted-from :reader predicted-from)
632 (rule :initarg :rule :reader rule)
633 (dot-position :initarg :dot-position :reader dot-position)
634 (suffix :initarg :suffix :reader suffix)))
635
636 (defmethod print-object ((item incomplete-item) stream)
637 (format stream "[~a ->" (left-hand-side (rule item)))
638 (loop for i from 0 below (dot-position item)
639 do (format stream " ~a" (aref (symbols (rule item)) i)))
640 (format stream " *")
641 (loop for i from (dot-position item) below (length (symbols (rule item)))
642 do (format stream " ~a" (aref (symbols (rule item)) i)))
643 (format stream "]"))
644
645 (defun derive-and-handle-item (prev-item parse-tree orig-state to-state)
646 (let ((remaining (funcall (suffix prev-item) parse-tree)))
647 (cond ((null remaining)
648 nil)
649 ((functionp remaining)
650 (handle-incomplete-item
651 (make-instance 'incomplete-item
652 :orig-state (orig-state prev-item)
653 :predicted-from (predicted-from prev-item)
654 :rule (rule prev-item)
655 :dot-position (1+ (dot-position prev-item))
656 :parse-trees (cons parse-tree (parse-trees prev-item))
657 :suffix remaining)
658 orig-state to-state))
659 (t
660 (let* ((parse-trees (cons parse-tree (parse-trees prev-item)))
661 (start (find-if-not #'null parse-trees
662 :from-end t :key #'start-offset))
663 (end (find-if-not #'null parse-trees :key #'end-offset)))
664 (with-slots (start-mark size) remaining
665 (when start
666 (setf start-mark (start-mark start)
667 size (- (end-offset end) (start-offset start))))
668 (potentially-handle-parse-tree remaining orig-state to-state)))))))
669
670 (defun item-equal (item1 item2)
671 (declare (optimize speed))
672 (and (eq (rule item1) (rule item2))
673 (do ((trees1 (parse-trees item1) (cdr trees1))
674 (trees2 (parse-trees item2) (cdr trees2)))
675 ((and (null trees1) (null trees2)) t)
676 (when (or (null trees1) (null trees2))
677 (return nil))
678 (when (not (parse-tree-equal (car trees1) (car trees2)))
679 (return nil)))))
680
681 (defun parse-tree-equal (tree1 tree2)
682 (eq (class-of tree1) (class-of tree2)))
683
684 (defgeneric parse-tree-better (tree1 tree2))
685
686 (defmethod parse-tree-better (tree1 tree2)
687 nil)
688
689 (defclass parser-state ()
690 ((parser :initarg :parser :reader parser)
691 (incomplete-items :initform (make-hash-table :test #'eq)
692 :reader incomplete-items)
693 (parse-trees :initform (make-hash-table :test #'eq)
694 :reader parse-trees)
695 (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state)
696 (predicted-rules)))
697
698 (defmethod initialize-instance :after ((state parser-state) &rest args)
699 (declare (ignore args))
700 (with-slots (predicted-rules) state
701 (setf predicted-rules
702 (make-array (slot-value (parser-grammar (parser state))
703 'number-of-rules)
704 :element-type 'bit
705 :initial-element 0))))
706
707 (defun map-over-incomplete-items (state fun)
708 (maphash (lambda (key incomplete-items)
709 (loop for incomplete-item in incomplete-items
710 do (funcall fun key incomplete-item)))
711 (incomplete-items state)))
712
713 (defun potentially-handle-parse-tree (parse-tree from-state to-state)
714 (let ((parse-trees (parse-trees to-state)))
715 (flet ((handle-parse-tree ()
716 (map-over-incomplete-items from-state
717 (lambda (orig-state incomplete-item)
718 (derive-and-handle-item incomplete-item parse-tree orig-state to-state)))))
719 (cond ((find parse-tree (gethash from-state parse-trees)
720 :test #'parse-tree-better)
721 (setf (gethash from-state parse-trees)
722 (cons parse-tree
723 (remove parse-tree (gethash from-state parse-trees)
724 :test #'parse-tree-better)))
725 (handle-parse-tree))
726 ((find parse-tree (gethash from-state parse-trees)
727 :test (lambda (x y) (or (parse-tree-better y x) (parse-tree-equal y x))))
728 nil)
729 (t (push parse-tree (gethash from-state parse-trees))
730 (handle-parse-tree))))))
731
732 (defun predict (item state tokens)
733 (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item))
734 (hash (parser-grammar (parser state)))))
735 (if (functionp (right-hand-side rule))
736 (let ((predicted-rules (slot-value state 'predicted-rules))
737 (rule-number (slot-value rule 'number))
738 (predict-test (predict-test rule)))
739 (when (zerop (sbit predicted-rules rule-number))
740 (setf (sbit predicted-rules rule-number) 1)
741 (when (or (null predict-test)
742 (some predict-test tokens))
743 (handle-and-predict-incomplete-item
744 (make-instance 'incomplete-item
745 :orig-state state
746 :predicted-from item
747 :rule rule
748 :dot-position 0
749 :suffix (right-hand-side rule))
750 state tokens))))
751 (potentially-handle-parse-tree (right-hand-side rule) state state)))
752 (loop for parse-tree in (gethash state (parse-trees state))
753 do (derive-and-handle-item item parse-tree state state)))
754
755 (defun handle-incomplete-item (item orig-state to-state)
756 (declare (optimize speed))
757 (cond ((find item (the list (gethash orig-state (incomplete-items to-state)))
758 :test #'item-equal)
759 nil)
760 (t
761 (push item (gethash orig-state (incomplete-items to-state))))))
762
763 (defun handle-and-predict-incomplete-item (item state tokens)
764 (declare (optimize speed))
765 (cond ((find item (the list (gethash state (incomplete-items state)))
766 :test #'item-equal)
767 nil)
768 (t
769 (push item (gethash state (incomplete-items state)))
770 (predict item state tokens))))
771
772 (defmethod initialize-instance :after ((parser parser) &rest args)
773 (declare (ignore args))
774 (with-slots (grammar initial-state) parser
775 (setf initial-state (make-instance 'parser-state :parser parser))
776 (setf (last-nonempty-state initial-state) initial-state)
777 (loop for rule in (rules grammar)
778 do (when (let ((sym (left-hand-side rule)))
779 (or (subtypep (target parser) sym)
780 (subtypep sym (target parser))))
781 (if (functionp (right-hand-side rule))
782 (let ((predicted-rules (slot-value initial-state 'predicted-rules))
783 (rule-number (slot-value rule 'number))
784 (predict-test (predict-test rule)))
785 (when (zerop (sbit predicted-rules rule-number))
786 (setf (sbit predicted-rules rule-number) 1)
787 (when (null predict-test)
788 (handle-and-predict-incomplete-item
789 (make-instance 'incomplete-item
790 :orig-state initial-state
791 :predicted-from nil
792 :rule rule
793 :dot-position 0
794 :suffix (right-hand-side rule))
795 initial-state nil))))
796 (potentially-handle-parse-tree
797 (right-hand-side rule) initial-state initial-state))))))
798
799 (defun state-contains-target-p (state)
800 (loop with target = (target (parser state))
801 for parse-tree in (gethash (initial-state (parser state))
802 (parse-trees state))
803 when (typep parse-tree target)
804 do (return parse-tree)))
805
806 (defun advance-parse (parser tokens state)
807 (maphash (lambda (from-state items)
808 (declare (ignore from-state))
809 (dolist (item items)
810 (predict item state tokens)))
811 (incomplete-items state))
812 (let ((new-state (make-instance 'parser-state :parser parser)))
813 (loop for token in tokens
814 do (potentially-handle-parse-tree token state new-state))
815 (setf (last-nonempty-state new-state)
816 (if (or (plusp (hash-table-count (incomplete-items new-state)))
817 (state-contains-target-p new-state))
818 new-state
819 (last-nonempty-state state)))
820 new-state))
821
822 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
823 ;;;
824 ;;; Code for analysing parse stack
825
826 (defun parse-stack-top (state)
827 "for a given state, return the top of the parse stack, or NIL if the parse stack
828 is empty in that state."
829 (when (plusp (hash-table-count (incomplete-items state)))
830 (maphash (lambda (state items)
831 (declare (ignore state))
832 (return-from parse-stack-top (car items)))
833 (incomplete-items state))))
834
835 (defun target-parse-tree (state)
836 "for a given state, return a target parse tree, or NIL if this state does not
837 represent a complete parse of the target."
838 (state-contains-target-p state))
839
840 (defun parse-state-empty-p (state)
841 (and (null (parse-stack-top state))
842 (null (target-parse-tree state))))
843
844 (defun parse-stack-next (parse-stack)
845 "given a parse stack frame, return the next frame in the stack."
846 (assert (not (null parse-stack)))
847 (predicted-from parse-stack))
848
849 (defun parse-stack-symbol (parse-stack)
850 "given a parse stack frame, return the target symbol of the frame."
851 (assert (not (null parse-stack)))
852 (left-hand-side (rule parse-stack)))
853
854 (defun parse-stack-parse-trees (parse-stack)
855 "given a parse stack frame, return a list (in the reverse order of
856 analysis) of the parse trees recognized. The return value reveals
857 internal state of the parser. Do not alter it!"
858 (assert (not (null parse-stack)))
859 (parse-trees parse-stack))
860
861 (defun map-over-parse-trees (function state)
862 (labels ((map-incomplete-item (item)
863 (unless (null (predicted-from item))
864 (map-incomplete-item (predicted-from item)))
865 (loop for parse-tree in (reverse (parse-trees item))
866 do (funcall function parse-tree))))
867 (let ((state (last-nonempty-state state)))
868 (if (plusp (hash-table-count (incomplete-items state)))
869 (maphash (lambda (state items)
870 (declare (ignore state))
871 (map-incomplete-item (car items))
872 (return-from map-over-parse-trees nil))
873 (incomplete-items state))
874 (funcall function (state-contains-target-p state))))))
875
876 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
877 ;;;
878 ;;; Syntax querying functions.
879
880 (defgeneric word-constituentp (syntax obj)
881 (:documentation "Return T if `obj' is a word constituent
882 character in `syntax'.")
883 (:method ((syntax syntax) obj)
884 nil)
885 (:method ((syntax syntax) (obj character))
886 (alphanumericp obj)))
887
888 (defgeneric whitespacep (syntax obj)
889 (:documentation "Return T if `obj' is a whitespace character in
890 `syntax'.")
891 (:method ((syntax syntax) obj)
892 nil)
893 (:method ((syntax syntax) (obj character))
894 (when (member obj '(#\Space #\Tab #\Newline #\Page #\Return))
895 t)))
896
897 (defgeneric page-delimiter (syntax)
898 (:documentation "Return the object sequence used as a page
899 deliminter in `syntax'.")
900 (:method ((syntax syntax))
901 '(#\Newline #\Page)))
902
903 (defgeneric paragraph-delimiter (syntax)
904 (:documentation "Return the object sequence used as a paragraph
905 deliminter in `syntax'.")
906 (:method ((syntax syntax))
907 '(#\Newline #\Newline)))
908
909 (defgeneric syntax-line-indentation (syntax mark tab-width)
910 (:documentation "Return the correct indentation for the line
911 containing the mark, according to the specified syntax."))

  ViewVC Help
Powered by ViewVC 1.1.5