syntax.lisp 27.2 KB
Newer Older
1
2
;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-

3
;;;  (c) copyright 2004-2005 by
4
;;;           Robert Strandh (strandh@labri.fr)
5
6
;;;  (c) copyright 2005 by
;;;           Matthieu Villeneuve (matthieu.villeneuve@free.fr)
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

(in-package :climacs-syntax)

25
(defclass syntax (name-mixin)
26
27
  ((buffer :initarg :buffer :reader buffer)
   (command-table :initarg :command-table)))
28

29
30
31
(define-condition no-such-operation (simple-error)
  ()
  (:report (lambda (condition stream)
32
	     (declare (ignore condition))
33
34
35
36
37
38
39
	     (format stream "Operation unavailable for this syntax")))
  (:documentation "This condition is signaled whenever an attempt is
made to execute an operation that is unavailable for the particular syntax" ))

(define-condition no-expression (simple-error)
  ()
  (:report (lambda (condition stream)
40
	     (declare (ignore condition))
41
42
43
44
	     (format stream "No expression at point")))
  (:documentation "This condition is signaled whenever an attempt is
made to execute a by-experssion motion command and no expression is available." ))

45
(defgeneric update-syntax (buffer syntax))
46

47
48
(defgeneric update-syntax-for-display (buffer syntax from to))

49
50
51
52
(defgeneric syntax-line-indentation (mark tab-width syntax)
  (:documentation "Return the correct indentation for the line containing
the mark, according to the specified syntax."))

53
54
(defgeneric eval-defun (mark syntax))

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Commenting

(defgeneric syntax-line-comment-string (syntax)
  (:documentation "string to use at the beginning of a line to 
indicate a line comment"))

(defgeneric line-comment-region (syntax mark1 mark2)
  (:documentation "inset a line comment string at the beginning of 
every line in the region"))

(defmethod line-comment-region (syntax mark1 mark2)
  (when (mark< mark2 mark1)
    (rotatef mark1 mark2))
  (let ((mark (clone-mark mark1)))
    (unless (beginning-of-line-p mark)
      (end-of-line mark)
      (unless (end-of-buffer-p mark)
	(forward-object mark)))
    (loop while (mark< mark mark2)
	  do (insert-sequence mark (syntax-line-comment-string syntax))
	     (end-of-line mark)
	     (unless (end-of-buffer-p mark)
	       (forward-object mark)))))	  

(defgeneric line-uncomment-region (syntax mark1 mark2)
  (:documentation "inset a line comment string at the beginning of 
every line in the region"))

(defmethod line-uncomment-region (syntax mark1 mark2)
  (when (mark< mark2 mark1)
    (rotatef mark1 mark2))
  (let ((mark (clone-mark mark1)))
    (unless (beginning-of-line-p mark)
      (end-of-line mark)
      (unless (end-of-buffer-p mark)
	(forward-object mark)))
    (loop while (mark< mark mark2)
	  do (when (looking-at mark (syntax-line-comment-string syntax))
	       (delete-range mark (length (syntax-line-comment-string syntax))))
	     (end-of-line mark)
	     (unless (end-of-buffer-p mark)
	       (forward-object mark)))))

(defgeneric comment-region (syntax mark1 mark2)
  (:documentation "turn the region between the two marks into a comment
in the specific syntax.")
  (:method (syntax mark1 mark2) nil))

(defgeneric uncomment-region (syntax mark1 mark2)
  (:documentation "remove comment around region")
  (:method (syntax mark1 mark2) nil))

109
110
111
112
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Name for info-pane

113
114
115
(defgeneric name-for-info-pane (syntax &key &allow-other-keys)
  (:documentation "Return the name that should be used for the
  info-pane for panes displaying a buffer in this syntax."))
116

117
118
119
120
(defgeneric display-syntax-name (syntax stream &key &allow-other-keys)
  (:documentation "Draw the name of the syntax `syntax' to
  `stream'. This is meant to be called for the info-pane."))

121
122
123
124
125
126
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Syntax completion

(defparameter *syntaxes* '())

127
128
129
130
131
132
133
134
135
(defstruct (syntax-description (:type list))
  (name (error "required argument") :type string)
  (class-name (error "required argument") :type symbol)
  (pathname-types nil :type list))

(defmacro define-syntax (class-name superclasses slots &rest options)
  (let ((defclass-options nil)
	(default-initargs nil)
	(name nil)
136
        (command-table nil)
137
138
139
140
141
142
143
144
145
146
147
148
149
	(pathname-types nil))
    (dolist (option options)
      (case (car option)
	((:name)
	 (if name
	     (error "More than one ~S option provided to ~S"
		    ':name 'define-syntax)
	     (setf name (cadr option))))
	((:pathname-types)
	 (if pathname-types
	     (error "More than one ~S option provided to ~S"
		    ':pathname-types 'define-syntax)
	     (setf pathname-types (cdr option))))
150
151
152
153
154
        ((:command-table)
         (if command-table
             (error "More than one ~S option provided to ~S"
                    ':command-table 'define-syntax)
             (setf command-table (cadr option))))
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
	((:default-initargs)
	 (if default-initargs
	     (error "More than one ~S option provided to ~S"
		    ':default-initargs 'define-syntax)
	     (setf default-initargs (cdr option))))
	(t (push (cdr option) defclass-options))))
    (unless name
      (error "~S not supplied to ~S" ':name 'define-syntax))
    ;; FIXME: the :NAME initarg looks, well, a bit generic, and could
    ;; collide with user-defined syntax initargs.  Use
    ;; CLIMACS-SYNTAX::%NAME instead.
    (setf default-initargs (list* :name name default-initargs))
    `(progn
      (push (make-syntax-description
	     :name ,name :class-name ',class-name
	     :pathname-types ',pathname-types)
       *syntaxes*)
      (defclass ,class-name ,superclasses ,slots
173
	(:default-initargs :command-table ',command-table ,@default-initargs)
174
	,@defclass-options))))
175

176
177
178
179
180
181
182
183
184
185
(defgeneric eval-option (syntax name value)
  (:documentation "Evaluate the option `name' with the specified
  `value' for `syntax'.")
  (:method (syntax name value)
    ;; We do not want to error out if an invalid option is
    ;; specified. Signal a condition? For now, silently ignore.
    (declare (ignore syntax name value))))

(defmethod eval-option :around (syntax (name string) value)
  ;; Convert the name to a keyword symbol...
186
  (eval-option syntax (intern (string-upcase name) (find-package :keyword))
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
               value))

(defmacro define-option-for-syntax
    (syntax option-name (syntax-symbol value-symbol) &body body)
  "Define an option for the syntax specified by the symbol
  `syntax'. `Option-name' should be a string that will be the
  name of the option. The name will automatically be converted to
  uppercase. When the option is being evaluated, `body' will be
  run, with `syntax-symbol' bound to the syntax object the option
  is being evaluated for, and `value-symbol' bound to the value
  of the option."
  ;; The name is converted to a keyword symbol which is used for all
  ;; further identification.
  (let ((name-symbol (gensym))
        (symbol (intern (string-upcase option-name)
                        (find-package :keyword))))
   `(defmethod eval-option ((,syntax-symbol ,syntax)
                            (,name-symbol (eql ,symbol))
                            ,value-symbol)
      ,@body)))

Troels Henriksen's avatar
Troels Henriksen committed
208
209
210
211
212
213
214
215
216
217
218
219
220
(defgeneric current-attributes-for-syntax (syntax)
  (:method-combination append)
  (:method append (syntax)
           (list (cons :syntax (name syntax)))))

(defun make-attribute-line (syntax)
  (apply #'concatenate 'string
         (loop for (name . value) in (current-attributes-for-syntax syntax)
            collect (string-downcase (symbol-name name) :start 1)
            collect ": "
            collect value
            collect "; ")))

221
#+nil
222
223
224
225
226
227
228
229
(defmacro define-syntax (class-name (name superclasses) &body body)
  `(progn (push '(,name . ,class-name) *syntaxes*)
	  (defclass ,class-name ,superclasses
	       ,@body
	    (:default-initargs :name ,name))))

(define-presentation-method accept
    ((type syntax) stream (view textual-view) &key)
230
  (multiple-value-bind (object success string)
231
232
233
234
      (complete-input stream
		      (lambda (so-far action)
			(complete-from-possibilities
			 so-far *syntaxes* '() :action action
235
236
			 :name-key #'syntax-description-name
			 :value-key #'syntax-description-class-name))
237
238
		      :partial-completers '(#\Space)
		      :allow-any-input t)
239
240
241
242
    (declare (ignore success))
    (if (find string *syntaxes* :key #'first :test #'string=)
        (values object type)
        (input-not-of-required-type string type))
243
    object))
244

245
246
247
248
249
250
251
(defun syntax-from-name (syntax)
  (let ((description (find syntax *syntaxes*
			   :key #'syntax-description-name
			   :test #'string-equal)))
    (when description
      (find-class (syntax-description-class-name description)))))

252
253
254
255
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Basic syntax

256
257
258
259
260
;;; FIXME: this is a really bad name.  It's even worse if it's
;;; case-insensitive.  Emacs' "Fundamental" isn't too bad.
(define-syntax basic-syntax (syntax)
  ()
  (:name "Basic"))
261

262
(defmethod update-syntax (buffer (syntax basic-syntax))
263
  (declare (ignore buffer))
264
  nil)
265

266
267
268
269
(defmethod update-syntax-for-display (buffer (syntax basic-syntax) from to)
  (declare (ignore buffer from to))
  nil)

270
(defmethod name-for-info-pane ((syntax basic-syntax) &key)
271
272
  (name syntax))

273
274
275
(defmethod display-syntax-name ((syntax basic-syntax) stream &rest args &key)
  (princ (apply #'name-for-info-pane syntax args) stream))

276
277
278
(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))
  (declare (ignore mark tab-width))
  0)
279

280
281
282
(defmethod eval-defun (mark syntax)
  (error 'no-such-operation))

283
284
285
286
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Incremental Earley parser

287
288
289
290
291
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parse tree

(defclass parse-tree ()
292
293
  ((start-mark :initform nil :initarg :start-mark :reader start-mark)
   (size :initform nil :initarg :size)))
294
295
296
297

(defgeneric start-offset (parse-tree))

(defmethod start-offset ((tree parse-tree))
298
299
300
  (let ((mark (start-mark tree)))
    (when mark
      (offset mark))))
301

302
303
304
305
306
307
308
309
310
311
312
(defmethod (setf start-offset) ((offset number) (tree parse-tree))
  (let ((mark (start-mark tree)))
    (assert (not (null mark)))
    (setf (offset mark) offset)))

(defmethod (setf start-offset) ((offset mark) (tree parse-tree))
  (with-slots (start-mark) tree
     (if (null start-mark)
	 (setf start-mark (clone-mark offset))
	 (setf (offset start-mark) (offset offset)))))

313
314
315
316
(defgeneric end-offset (parse-tree))

(defmethod end-offset ((tree parse-tree))
  (with-slots (start-mark size) tree
317
318
     (when start-mark
       (+ (offset start-mark) size))))
319

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
(defmethod (setf end-offset) ((offset number) (tree parse-tree))
  (with-slots (start-mark size) tree
     (assert (not (null start-mark)))
     (setf size (- offset (offset start-mark)))))

(defmethod (setf end-offset) ((offset mark) (tree parse-tree))
  (with-slots (start-mark size) tree
     (assert (not (null start-mark)))
     (setf size (- (offset offset) (offset start-mark)))))

(defmethod buffer ((tree parse-tree))
  (let ((start-mark (start-mark tree)))
    (when start-mark
      (buffer start-mark))))

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer

(defclass lexer ()
  ((buffer :initarg :buffer :reader buffer)))

(defgeneric nb-lexemes (lexer))
(defgeneric lexeme (lexer pos))
(defgeneric insert-lexeme (lexer pos lexeme))
(defgeneric delete-invalid-lexemes (lexer from to))
(defgeneric inter-lexeme-object-p (lexer object))
(defgeneric skip-inter-lexeme-objects (lexer scan))
(defgeneric update-lex (lexer start-pos end))
(defgeneric next-lexeme (lexer scan))

(defclass incremental-lexer (lexer)
  ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes)))

(defmethod nb-lexemes ((lexer incremental-lexer))
  (nb-elements (lexemes lexer)))

(defmethod lexeme ((lexer incremental-lexer) pos)
  (element* (lexemes lexer) pos))

(defmethod insert-lexeme ((lexer incremental-lexer) pos lexeme)
  (insert* (lexemes lexer) pos lexeme))

(defmethod delete-invalid-lexemes ((lexer incremental-lexer) from to)
  "delete all lexemes between FROM and TO and return the first invalid 
position in the lexemes of LEXER"
  (with-slots (lexemes) lexer
     (let ((start 1)
	   (end (nb-elements lexemes)))
       ;; use binary search to find the first lexeme to delete
       (loop while (< start end)
	     do (let ((middle (floor (+ start end) 2)))
		  (if (mark< (end-offset (element* lexemes middle)) from)
		      (setf start (1+ middle))
		      (setf end middle))))
       ;; delete lexemes
       (loop until (or (= start (nb-elements lexemes))
		       (mark> (start-mark (element* lexemes start)) to))
	     do (delete* lexemes start))
       start)))
	       
(defmethod skip-inter-lexeme-objects ((lexer incremental-lexer) scan)
  (loop until (end-of-buffer-p scan)
	while (inter-lexeme-object-p lexer (object-after scan))
	do (forward-object scan)))

(defmethod update-lex ((lexer incremental-lexer) start-pos end)
  (let ((scan (clone-mark (low-mark (buffer lexer)) :left)))
    (setf (offset scan)
	  (end-offset (lexeme lexer (1- start-pos))))
    (loop do (skip-inter-lexeme-objects lexer scan)
	  until (if (end-of-buffer-p end)
		    (end-of-buffer-p scan)
		    (mark> scan end))
	  do (let* ((start-mark (clone-mark scan))
		    (lexeme (next-lexeme lexer scan))
		    (size (- (offset scan) (offset start-mark))))
	       (setf (slot-value lexeme 'start-mark) start-mark
		     (slot-value lexeme 'size) size)
	       (insert-lexeme lexer start-pos lexeme))
	     (incf start-pos))))

402
403
404
405
406
407
408
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; grammar

(defclass rule ()
  ((left-hand-side :initarg :left-hand-side :reader left-hand-side)
   (right-hand-side :initarg :right-hand-side :reader right-hand-side)
409
   (symbols :initarg :symbols :reader symbols)
410
   (predict-test :initarg :predict-test :reader predict-test)
411
   (number)))
412
413

(defclass grammar ()
414
  ((rules :initform nil :accessor rules)
415
416
   (hash :initform (make-hash-table) :accessor hash)
   (number-of-rules :initform 0)))
417

418
(defmacro grammar-rule ((left-hand-side arrow arglist &body body) &key predict-test)
419
  (declare (ignore arrow))
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
  (labels ((var-of (arg)
	     (if (symbolp arg)
		 arg
		 (car arg)))
	   (sym-of (arg)
	     (cond ((symbolp arg) arg)
		   ((= (length arg) 3) (cadr arg))
		   ((symbolp (cadr arg)) (cadr arg))
		   (t (car arg))))
	   (test-of (arg)
	     (cond ((symbolp arg) t)
		   ((= (length arg) 3) (caddr arg))
		   ((symbolp (cadr arg)) t)
		   (t (cadr arg))))
	   (build-rule (arglist body)
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
	     (if (null arglist)
		 body
		 (let ((arg (car arglist)))
		   `(lambda (,(var-of arg))
		      (when (and (typep ,(var-of arg) ',(sym-of arg))
				 ,(test-of arg))
			,(build-rule (cdr arglist) body)))))))
    `(make-instance 'rule
	:left-hand-side ',left-hand-side
	:right-hand-side
	,(build-rule arglist
		     (if (or (null body)
			     (symbolp (car body)))
			 `(make-instance ',left-hand-side ,@body)
			 `(progn ,@body)))
450
451
	:symbols ,(coerce (mapcar #'sym-of arglist) 'vector)
	:predict-test ,predict-test)))
452
453
454


(defmacro grammar (&body body)
455
456
457
458
459
460
461
462
  (let ((rule (gensym "RULE"))
	(rules (gensym "RULES"))
	(result (gensym "RESULT")))
    `(let* ((,rules (list ,@(loop for rule in body 
				  collect `(grammar-rule ,rule))))
	    (,result (make-instance 'grammar)))
       (dolist (,rule ,rules ,result)
	 (add-rule ,rule ,result)))))
463
464
465
466

(defgeneric add-rule (rule grammar))

(defmethod add-rule (rule (grammar grammar))
467
  (push rule (rules grammar))
468
469
  (setf (slot-value rule 'number) (slot-value grammar 'number-of-rules))
  (incf (slot-value grammar 'number-of-rules))
470
471
472
473
474
475
476
477
478
479
  (clrhash (hash grammar))
  (let (rhs-symbols)
    (dolist (rule (rules grammar))
      (setf rhs-symbols (union rhs-symbols (coerce (symbols rule) 'list))))
    (dolist (rule (rules grammar))
      (let ((lhs-symbol (left-hand-side rule)))
	(dolist (rhs-symbol rhs-symbols)
	  (when (or (subtypep lhs-symbol rhs-symbol)
		    (subtypep rhs-symbol lhs-symbol))
	    (pushnew rule (gethash rhs-symbol (hash grammar)))))))))
480
481
482
483
484
485

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser

(defclass parser ()
486
  ((grammar :initarg :grammar :reader parser-grammar)
487
   (target :initarg :target :reader target)
488
   (initial-state :reader initial-state)))
489

490
491
492
(defclass rule-item ()
  ((parse-trees :initform '() :initarg :parse-trees :reader parse-trees)))

493
494

(defclass incomplete-item (rule-item)
495
  ((orig-state :initarg :orig-state :reader orig-state)
496
   (predicted-from :initarg :predicted-from :reader predicted-from)
497
   (rule :initarg :rule :reader rule)
498
499
500
501
502
503
504
505
506
507
508
509
   (dot-position :initarg :dot-position :reader dot-position)
   (suffix :initarg :suffix :reader suffix)))

(defmethod print-object ((item incomplete-item) stream)
  (format stream "[~a ->" (left-hand-side (rule item)))
  (loop for i from 0 below (dot-position item)
	do (format stream " ~a" (aref (symbols (rule item)) i)))
  (format stream " *")
  (loop for i from (dot-position item) below (length (symbols (rule item)))
	do (format stream " ~a" (aref (symbols (rule item)) i)))
  (format stream "]"))	  

510
(defun derive-and-handle-item (prev-item parse-tree orig-state to-state)
511
512
513
514
  (let ((remaining (funcall (suffix prev-item) parse-tree)))
    (cond ((null remaining)
	   nil)
	  ((functionp remaining)
515
516
517
518
519
520
521
522
523
	   (handle-incomplete-item
	    (make-instance 'incomplete-item
	       :orig-state (orig-state prev-item)
	       :predicted-from (predicted-from prev-item)
	       :rule (rule prev-item)
	       :dot-position (1+ (dot-position prev-item))
	       :parse-trees (cons parse-tree (parse-trees prev-item))
	       :suffix remaining)
	    orig-state to-state))
524
	  (t
525
526
527
528
529
530
531
532
	   (let* ((parse-trees (cons parse-tree (parse-trees prev-item)))
		  (start (find-if-not #'null parse-trees
				      :from-end t :key #'start-offset))
		  (end (find-if-not #'null parse-trees :key #'end-offset)))
	     (with-slots (start-mark size) remaining
		(when start
		  (setf start-mark (start-mark start)
			size (- (end-offset end) (start-offset start))))
533
		(potentially-handle-parse-tree remaining orig-state to-state)))))))
534

535
536
(defun item-equal (item1 item2)
  (declare (optimize speed))
537
  (and (eq (rule item1) (rule item2))
538
539
540
541
542
543
544
545
546
       (do ((trees1 (parse-trees item1) (cdr trees1))
	    (trees2 (parse-trees item2) (cdr trees2)))
	   ((and (null trees1) (null trees2)) t)
	 (when (or (null trees1) (null trees2))
	   (return nil))
	 (when (not (parse-tree-equal (car trees1) (car trees2)))
	   (return nil)))))

(defun parse-tree-equal (tree1 tree2)
547
548
549
550
551
552
553
554
  (eq (class-of tree1) (class-of tree2)))

(defgeneric parse-tree-better (tree1 tree2))

(defmethod parse-tree-better (tree1 tree2)
  nil)

(defclass parser-state ()
555
  ((parser :initarg :parser :reader parser)
556
557
558
   (incomplete-items :initform (make-hash-table :test #'eq)
		     :reader incomplete-items)
   (parse-trees :initform (make-hash-table :test #'eq)
559
		:reader parse-trees)
560
561
562
563
564
565
566
567
568
569
570
   (last-nonempty-state :initarg :last-nonempty-state :accessor last-nonempty-state)
   (predicted-rules)))

(defmethod initialize-instance :after ((state parser-state) &rest args)
  (declare (ignore args))
  (with-slots (predicted-rules) state
     (setf predicted-rules
	   (make-array (slot-value (parser-grammar (parser state))
				   'number-of-rules)
		       :element-type 'bit
		       :initial-element 0))))
571
572
573
574
575
576
577
578
579
580
581
582

(defun map-over-incomplete-items (state fun)
  (maphash (lambda (key incomplete-items)
	     (loop for incomplete-item in incomplete-items
		   do (funcall fun key incomplete-item)))
	   (incomplete-items state)))

(defun potentially-handle-parse-tree (parse-tree from-state to-state)
  (let ((parse-trees (parse-trees to-state)))
    (flet ((handle-parse-tree ()
	     (map-over-incomplete-items from-state
	       (lambda (orig-state incomplete-item)
583
		 (derive-and-handle-item incomplete-item parse-tree orig-state to-state)))))
584
585
586
587
588
589
590
591
592
593
594
595
596
      (cond ((find parse-tree (gethash from-state parse-trees)
		   :test #'parse-tree-better)
	     (setf (gethash from-state parse-trees)
		   (cons parse-tree
			 (remove parse-tree (gethash from-state parse-trees)
				 :test #'parse-tree-better)))
	     (handle-parse-tree))
	    ((find parse-tree (gethash from-state parse-trees)
		   :test (lambda (x y) (or (parse-tree-better y x) (parse-tree-equal y x))))
	     nil)
	    (t (push parse-tree (gethash from-state parse-trees))
	       (handle-parse-tree))))))

597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
(defun predict (item state tokens)
  (dolist (rule (gethash (aref (symbols (rule item)) (dot-position item))
			 (hash (parser-grammar (parser state)))))
    (if (functionp (right-hand-side rule))
	(let ((predicted-rules (slot-value state 'predicted-rules))
	      (rule-number (slot-value rule 'number))
	      (predict-test (predict-test rule)))
	  (when (zerop (sbit predicted-rules rule-number))
	    (setf (sbit predicted-rules rule-number) 1)
	    (when (or (null predict-test)
		      (some predict-test tokens))
	      (handle-and-predict-incomplete-item
	       (make-instance 'incomplete-item
		  :orig-state state
		  :predicted-from item
		  :rule rule
		  :dot-position 0
		  :suffix (right-hand-side rule))
	       state tokens))))
	(potentially-handle-parse-tree (right-hand-side rule) state state)))
  (loop for parse-tree in (gethash state (parse-trees state))
	do (derive-and-handle-item item parse-tree state state)))

620
(defun handle-incomplete-item (item orig-state to-state)
621
622
  (declare (optimize speed))
  (cond ((find item (the list (gethash orig-state (incomplete-items to-state)))
623
624
625
 	       :test #'item-equal)
	  nil)
 	(t
626
627
628
629
630
631
632
633
634
635
 	 (push item (gethash orig-state (incomplete-items to-state))))))

(defun handle-and-predict-incomplete-item (item state tokens)
  (declare (optimize speed))
  (cond ((find item (the list (gethash state (incomplete-items state)))
 	       :test #'item-equal)
	  nil)
 	(t
 	 (push item (gethash state (incomplete-items state)))
	 (predict item state tokens))))
636
637
638
639

(defmethod initialize-instance :after ((parser parser) &rest args)
  (declare (ignore args))
  (with-slots (grammar initial-state) parser
640
     (setf initial-state (make-instance 'parser-state :parser parser))
641
     (setf (last-nonempty-state initial-state) initial-state)
642
643
644
645
     (loop for rule in (rules grammar)
	   do (when (let ((sym (left-hand-side rule)))
		      (or (subtypep (target parser) sym)
			  (subtypep sym (target parser))))
646
		(if (functionp (right-hand-side rule))
647
648
649
650
651
652
653
654
655
656
657
658
659
660
		    (let ((predicted-rules (slot-value initial-state 'predicted-rules))
			  (rule-number (slot-value rule 'number))
			  (predict-test (predict-test rule)))
		      (when (zerop (sbit predicted-rules rule-number))
			(setf (sbit predicted-rules rule-number) 1)
			(when (null predict-test)
			  (handle-and-predict-incomplete-item
			   (make-instance 'incomplete-item
					  :orig-state initial-state
					  :predicted-from nil
					  :rule rule
					  :dot-position 0
					  :suffix (right-hand-side rule))
			   initial-state nil))))
661
662
		    (potentially-handle-parse-tree
		     (right-hand-side rule) initial-state initial-state))))))
663

664
665
666
667
668
669
670
(defun state-contains-target-p (state)
  (loop with target = (target (parser state))
	for parse-tree in (gethash (initial-state (parser state))
				   (parse-trees state))
	when (typep parse-tree target)
	  do (return parse-tree)))

671
(defun advance-parse (parser tokens state)
672
673
674
675
676
  (maphash (lambda (from-state items)
	     (declare (ignore from-state))
	     (dolist (item items)
	       (predict item state tokens)))
	   (incomplete-items state))
677
678
679
  (let ((new-state (make-instance 'parser-state :parser parser)))
    (loop for token in tokens 
	  do (potentially-handle-parse-tree token state new-state))
680
681
682
683
684
    (setf (last-nonempty-state new-state)
	  (if (or (plusp (hash-table-count (incomplete-items new-state)))
		  (state-contains-target-p new-state))
	      new-state
	      (last-nonempty-state state)))
685
    new-state))
686

687
688
689
690
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Code for analysing parse stack

691
692
693
694
695
696
697
698
699
700
701
702
703
704
(defun parse-stack-top (state)
  "for a given state, return the top of the parse stack, or NIL if the parse stack
is empty in that state."
  (when (plusp (hash-table-count (incomplete-items state)))
    (maphash (lambda (state items)
	       (declare (ignore state))
	       (return-from parse-stack-top (car items)))
	     (incomplete-items state))))

(defun target-parse-tree (state)
  "for a given state, return a target parse tree, or NIL if this state does not
represent a complete parse of the target."
  (state-contains-target-p state))

705
706
707
708
(defun parse-state-empty-p (state)
  (and (null (parse-stack-top state))
       (null (target-parse-tree state))))

709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
(defun parse-stack-next (parse-stack)
  "given a parse stack frame, return the next frame in the stack."
  (assert (not (null parse-stack)))
  (predicted-from parse-stack))

(defun parse-stack-symbol (parse-stack)
  "given a parse stack frame, return the target symbol of the frame."
  (assert (not (null parse-stack)))
  (left-hand-side (rule parse-stack)))

(defun parse-stack-parse-trees (parse-stack)
  "given a parse stack frame, return a list (in the reverse order of
analysis) of the parse trees recognized.  The return value reveals 
internal state of the parser.  Do not alter it!"
  (assert (not (null parse-stack)))
  (parse-trees parse-stack))

726
727
728
729
730
731
732
733
734
735
736
737
738
739
(defun map-over-parse-trees (function state)
  (labels ((map-incomplete-item (item)
	     (unless (null (predicted-from item))
	       (map-incomplete-item (predicted-from item)))
	     (loop for parse-tree in (reverse (parse-trees item))
		   do (funcall function parse-tree))))
    (let ((state (last-nonempty-state state)))
      (if (plusp (hash-table-count (incomplete-items state)))
	  (maphash (lambda (state items)
		     (declare (ignore state))
		     (map-incomplete-item (car items))
		     (return-from map-over-parse-trees nil))
		   (incomplete-items state))
	  (funcall function (state-contains-target-p state))))))
Robert Strandh's avatar
Robert Strandh committed
740
741
742
743
744
745
746

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Display

(defgeneric redisplay-pane-with-syntax (pane syntax current-p))

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Querying

(defgeneric word-constituentp (syntax obj)
  (:documentation "Return T if `obj' is a word constituent
  character in `syntax'.")
  (:method (syntax obj)
    nil)
  (:method (syntax (obj character))
    (alphanumericp obj)))

(defgeneric whitespacep (syntax obj)
  (:documentation "Return T if `obj' is a whitespace character in
  `syntax'.")
  (:method (syntax obj)
    nil)
  (:method (syntax (obj character))
765
766
    (when (member obj '(#\Space #\Tab #\Newline #\Page #\Return))
      t)))
767
768
769
770
771
772
773
774

(defgeneric page-delimiter (syntax)
  (:documentation "Return the object sequence used as a page
  deliminter in `syntax'.")
  (:method (syntax)
    '(#\Newline #\Page)))

(defgeneric paragraph-delimiter (syntax)
Troels Henriksen's avatar
Troels Henriksen committed
775
  (:documentation "Return the object sequence used as a paragraph
776
777
778
  deliminter in `syntax'.")
  (:method (syntax)
    '(#\Newline #\Newline)))