1 ;;; ebnf-otz.el --- syntactic chart OpTimiZer
3 ;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
5 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
6 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
7 ;; Keywords: wp, ebnf, PostScript
8 ;; Time-stamp: <2003-02-10 10:46:51 jbarranquero>
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
30 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
33 ;; This is part of ebnf2ps package.
35 ;; This package defines an optimizer for ebnf2ps.
37 ;; See ebnf2ps.el for documentation.
40 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 (defvar ebnf-empty-rule-list nil
52 "List of empty rule name.")
55 (defun ebnf-add-empty-rule-list (rule)
56 "Add empty RULE in `ebnf-empty-rule-list'."
57 (and ebnf-ignore-empty-rule
58 (eq (ebnf-node-kind (ebnf-node-production rule
))
60 (setq ebnf-empty-rule-list
(cons (ebnf-node-name rule
)
61 ebnf-empty-rule-list
))))
64 (defun ebnf-otz-initialize ()
65 "Initialize optimizer."
66 (setq ebnf-empty-rule-list nil
))
69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 ;; Eliminate empty rules
73 (defun ebnf-eliminate-empty-rules (syntax-list)
74 "Eliminate empty rules."
75 (while ebnf-empty-rule-list
76 (let ((ebnf-total (length syntax-list
))
78 (prod-list syntax-list
)
81 (ebnf-message-info "Eliminating empty rules")
82 (let ((rule (car prod-list
)))
83 ;; if any non-terminal pertains to ebnf-empty-rule-list
84 ;; then eliminate non-terminal from rule
85 (if (ebnf-eliminate-empty rule
)
86 (setq before prod-list
)
87 ;; eliminate empty rule from syntax-list
88 (setq new-list
(cons (ebnf-node-name rule
) new-list
))
90 (setcdr before
(cdr prod-list
))
91 (setq syntax-list
(cdr syntax-list
)))))
92 (setq prod-list
(cdr prod-list
)))
93 (setq ebnf-empty-rule-list new-list
)))
97 ;; [production width-func entry height width name production action]
98 ;; [sequence width-func entry height width list]
99 ;; [alternative width-func entry height width list]
100 ;; [non-terminal width-func entry height width name default]
101 ;; [empty width-func entry height width]
102 ;; [terminal width-func entry height width name default]
103 ;; [special width-func entry height width name default]
105 (defun ebnf-eliminate-empty (rule)
106 (let ((kind (ebnf-node-kind rule
)))
109 ((eq kind
'ebnf-generate-non-terminal
)
110 (if (member (ebnf-node-name rule
) ebnf-empty-rule-list
)
114 ((eq kind
'ebnf-generate-sequence
)
115 (let ((seq (ebnf-node-list rule
))
116 (header (ebnf-node-list rule
))
120 (if (ebnf-eliminate-empty elt
)
123 (setcdr before
(cdr seq
))
124 (setq header
(cdr header
))))
125 (setq seq
(cdr seq
)))
127 (ebnf-node-list rule header
)
130 ((eq kind
'ebnf-generate-alternative
)
131 (let ((seq (ebnf-node-list rule
))
132 (header (ebnf-node-list rule
))
136 (if (ebnf-eliminate-empty elt
)
139 (setcdr before
(cdr seq
))
140 (setq header
(cdr header
))))
141 (setq seq
(cdr seq
)))
143 (if (= (length header
) 1)
145 (ebnf-node-list rule header
)
148 ((eq kind
'ebnf-generate-production
)
149 (let ((prod (ebnf-eliminate-empty (ebnf-node-production rule
))))
151 (ebnf-node-production rule prod
)
153 ;; terminal, special and empty
159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
163 ;; *To be implemented*:
165 ;; A = B | A C B | A C D. ==> A = B {C (B | D)}*.
168 ;; A = B | C A. ==> A = {C}* B.
169 ;; A = B | D | C A | E A. ==> A = { C | E }* ( B | D ).
172 ;; A = B | C B. ==> A = [C] B.
173 ;; A = B | B C. ==> A = B [C].
174 ;; A = D | B D | B C D. ==> A = [B [C]] D.
177 ;; *Already implemented*:
179 ;; A = B | A C. ==> A = B {C}*.
180 ;; A = B | A B. ==> A = {B}+.
181 ;; A = | A B. ==> A = {B}*.
182 ;; A = B | A C B. ==> A = {B || C}+.
183 ;; A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
186 ;; A = B | . ==> A = [B].
187 ;; A = | B . ==> A = [B].
190 ;; A = B C | B D. ==> A = B (C | D).
191 ;; A = C B | D B. ==> A = (C | D) B.
192 ;; A = B C E | B D E. ==> A = B (C | D) E.
195 ;; A = B | C | . ==> A = B | C | .
196 ;; A = B | C A D. ==> A = B | C A D.
198 (defun ebnf-optimize (syntax-list)
199 "Syntactic chart optimizer."
200 (if (not ebnf-optimize
)
202 (let ((ebnf-total (length syntax-list
))
206 (setq new
(cons (ebnf-optimize1 (car syntax-list
)) new
)
207 syntax-list
(cdr syntax-list
)))
212 ;; 1. A = B | A C. ==> A = B {C}*.
213 ;; 2. A = B | A B. ==> A = {B}+.
214 ;; 3. A = | A B. ==> A = {B}*.
215 ;; 4. A = B | A C B. ==> A = {B || C}+.
216 ;; 5. A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
219 ;; 6. A = B | . ==> A = [B].
220 ;; 7. A = | B . ==> A = [B].
223 ;; 8. A = B C | B D. ==> A = B (C | D).
224 ;; 9. A = C B | D B. ==> A = (C | D) B.
225 ;; 10. A = B C E | B D E. ==> A = B (C | D) E.
227 (defun ebnf-optimize1 (prod)
228 (ebnf-message-info "Optimizing syntactic chart")
229 (let ((production (ebnf-node-production prod
)))
230 (and (eq (ebnf-node-kind production
) 'ebnf-generate-alternative
)
231 (let* ((hlist (ebnf-split-header-prefix
232 (ebnf-node-list production
)
233 (ebnf-node-name prod
)))
236 (elist (ebnf-split-header-suffix nlist zlist
)))
237 (ebnf-node-production
244 (setq elist
(or (ebnf-prefix-suffix elist
)
246 (let* ((nl (ebnf-extract-empty nlist
))
247 (el (or (ebnf-prefix-suffix (cdr nl
))
248 (ebnf-create-alternative (cdr nl
)))))
250 (ebnf-make-zero-or-more el elist
)
251 (ebnf-make-one-or-more el elist
))))
254 (let* ((xlist (cdr (ebnf-extract-empty zlist
)))
255 (znode (ebnf-make-zero-or-more
256 (or (ebnf-prefix-suffix xlist
)
257 (ebnf-create-alternative xlist
))))
258 (nnode (ebnf-map-list-to-optional nlist
)))
260 (setq nlist
(list nnode
)))
262 (and (= (length nlist
) 1)
263 (eq (ebnf-node-kind (car nlist
))
264 'ebnf-generate-empty
)))
267 (list (or (ebnf-prefix-suffix nlist
)
268 (ebnf-create-alternative nlist
))
271 ((ebnf-map-node-to-optional production
)
274 ((ebnf-prefix-suffix nlist
)
283 (defun ebnf-split-header-prefix (node-list header
)
284 (let* ((hlist (ebnf-split-header-prefix1 node-list header
))
287 (while (setq hlist
(cdr hlist
))
288 (let ((elt (car hlist
)))
289 (if (eq (ebnf-node-kind elt
) 'ebnf-generate-sequence
)
291 (let ((seq (cdr (ebnf-node-list elt
))))
292 (if (= (length seq
) 1)
294 (ebnf-node-list elt seq
)
299 (setq zlist
(cons (ebnf-make-empty)
301 (cons nlist
(nreverse zlist
))))
304 (defun ebnf-split-header-prefix1 (node-list header
)
307 (if (ebnf-node-equal-header (car node-list
) header
)
308 (setq hlist
(cons (car node-list
) hlist
))
309 (setq nlist
(cons (car node-list
) nlist
)))
310 (setq node-list
(cdr node-list
)))
311 (cons (nreverse nlist
) (nreverse hlist
))))
314 (defun ebnf-node-equal-header (node header
)
315 (let ((kind (ebnf-node-kind node
)))
317 ((eq kind
'ebnf-generate-sequence
)
318 (ebnf-node-equal-header (car (ebnf-node-list node
)) header
))
319 ((eq kind
'ebnf-generate-non-terminal
)
320 (string= (ebnf-node-name node
) header
))
326 (defun ebnf-map-node-to-optional (node)
327 (and (eq (ebnf-node-kind node
) 'ebnf-generate-alternative
)
328 (ebnf-map-list-to-optional (ebnf-node-list node
))))
331 (defun ebnf-map-list-to-optional (nlist)
332 (and (= (length nlist
) 2)
333 (let ((first (nth 0 nlist
))
334 (second (nth 1 nlist
)))
337 ((eq (ebnf-node-kind first
) 'ebnf-generate-empty
)
338 (ebnf-make-optional second
))
340 ((eq (ebnf-node-kind second
) 'ebnf-generate-empty
)
341 (ebnf-make-optional first
))
348 (defun ebnf-extract-empty (elist)
352 (if (not (eq (ebnf-node-kind (car now
)) 'ebnf-generate-empty
))
356 (setcdr before
(cdr now
))
357 (setq elist
(cdr elist
))))
358 (setq now
(cdr now
)))
359 (cons empty-p elist
)))
362 (defun ebnf-split-header-suffix (nlist zlist
)
365 ((= (length nlist
) 1)
368 (while (and ok zlist
)
369 (setq ok
(ebnf-split-header-suffix1 elt
(car zlist
))
373 (setq new
(cons ok new
))))
375 ((= (length nlist
) (length zlist
))
377 (while (and ok zlist
)
378 (setq ok
(ebnf-split-header-suffix1 (car nlist
) (car zlist
))
383 (setq new
(cons ok new
))))
388 (let* ((lis (ebnf-unique-list new
))
396 (ebnf-make-optional lis
)
400 (setq lis
(cons (ebnf-make-empty) lis
)))
401 (ebnf-create-alternative (nreverse lis
)))
405 (defun ebnf-split-header-suffix1 (ne ze
)
407 ((eq (ebnf-node-kind ne
) 'ebnf-generate-sequence
)
408 (and (eq (ebnf-node-kind ze
) 'ebnf-generate-sequence
)
409 (let ((nl (ebnf-node-list ne
))
410 (zl (ebnf-node-list ze
))
412 (and (>= (length zl
) (length nl
))
414 (setq len
(- (length zl
) (length nl
))
417 (setq ok
(ebnf-node-equal (car z
) (car nl
))
423 (setcdr (nthcdr (1- len
) zl
) nil
)
425 ((eq (ebnf-node-kind ze
) 'ebnf-generate-sequence
)
426 (let* ((zl (ebnf-node-list ze
))
428 (and (ebnf-node-equal ne
(car (nthcdr (1- len
) zl
)))
435 (setcdr (nthcdr (- len
2) zl
) nil
)
439 (ebnf-node-equal ne ze
))
443 (defun ebnf-prefix-suffix (lis)
445 (let* ((prefix (ebnf-split-prefix lis
))
446 (suffix (ebnf-split-suffix (cdr prefix
)))
447 (middle (cdr suffix
)))
448 (setq prefix
(car prefix
)
450 (and (or prefix suffix
)
454 (list (or (ebnf-map-list-to-optional middle
)
455 (ebnf-create-alternative middle
))))
459 (defun ebnf-split-prefix (lis)
460 (let* ((len (length lis
))
462 (head (if (eq (ebnf-node-kind (car lis
)) 'ebnf-generate-sequence
)
463 (ebnf-node-list (car lis
))
466 ;; determine prefix length
467 (while (and (> ipre
0) (setq tail
(cdr tail
)))
469 (this (if (eq (ebnf-node-kind (car tail
)) 'ebnf-generate-sequence
)
470 (ebnf-node-list (car tail
))
474 (ebnf-node-equal (car cur
) (car this
)))
478 (setq ipre
(min ipre i
))))
479 (if (or (zerop ipre
) (> ipre len
))
482 (let* ((tail (nthcdr ipre head
))
486 (setcdr (nthcdr (1- ipre
) head
) nil
))
489 ;; adjust first element
490 (if (or (not (eq (ebnf-node-kind (car lis
)) 'ebnf-generate-sequence
))
495 (if (= (length tail
) 1)
496 (setcar lis
(car tail
))
497 (ebnf-node-list (car lis
) tail
))
498 (setq tail
(cdr lis
)))
499 ;; eliminate prefix from lis based on ipre
501 (let ((elt (car tail
))
503 (if (and (eq (ebnf-node-kind elt
) 'ebnf-generate-sequence
)
504 (setq rest
(nthcdr ipre
(ebnf-node-list elt
))))
506 (if (= (length rest
) 1)
507 (setcar tail
(car rest
))
508 (ebnf-node-list elt rest
))
512 (setcdr before
(cdr tail
))
513 (setq lis
(cdr lis
))))
514 (setq tail
(cdr tail
))))
515 (cons prefix
(ebnf-unique-list
517 (nconc lis
(list (ebnf-make-empty)))
521 (defun ebnf-split-suffix (lis)
522 (let* ((len (length lis
))
525 (if (eq (ebnf-node-kind (car lis
)) 'ebnf-generate-sequence
)
526 (ebnf-node-list (car lis
))
529 ;; determine suffix length
530 (while (and (> isuf
0) (setq tail
(cdr tail
)))
533 (if (eq (ebnf-node-kind (car tail
)) 'ebnf-generate-sequence
)
534 (ebnf-node-list (car tail
))
539 (ebnf-node-equal (car cur
) (car this
)))
544 (setq isuf
(min isuf i
))))
545 (setq head
(nreverse head
))
546 (if (or (zerop isuf
) (> isuf len
))
549 (let* ((n (- (length head
) isuf
))
551 (suffix (nthcdr n head
))
554 (setcdr (nthcdr (1- n
) head
) nil
)
557 ;; adjust first element
558 (if (or (not (eq (ebnf-node-kind (car lis
)) 'ebnf-generate-sequence
))
563 (if (= (length tail
) 1)
564 (setcar lis
(car tail
))
565 (ebnf-node-list (car lis
) tail
))
566 (setq tail
(cdr lis
)))
567 ;; eliminate suffix from lis based on isuf
569 (let ((elt (car tail
))
571 (if (and (eq (ebnf-node-kind elt
) 'ebnf-generate-sequence
)
572 (setq rest
(ebnf-node-list elt
)
573 n
(- (length rest
) isuf
))
577 (setcar tail
(car rest
))
578 (setcdr (nthcdr (1- n
) rest
) nil
)
579 (ebnf-node-list elt rest
))
583 (setcdr before
(cdr tail
))
584 (setq lis
(cdr lis
))))
585 (setq tail
(cdr tail
))))
586 (cons suffix
(ebnf-unique-list
588 (nconc lis
(list (ebnf-make-empty)))
592 (defun ebnf-unique-list (nlist)
593 (let ((current nlist
)
596 (let ((tail (cdr current
))
600 (if (not (ebnf-node-equal head
(car tail
)))
601 (setq tail
(cdr tail
))
605 (setcdr before
(cdr current
))
606 (setq nlist
(cdr nlist
)))))
608 (setq before current
))
609 (setq current
(cdr current
))))
613 (defun ebnf-node-equal (A B
)
614 (let ((kindA (ebnf-node-kind A
))
615 (kindB (ebnf-node-kind B
)))
616 (and (eq kindA kindB
)
619 ((eq kindA
'ebnf-generate-empty
)
621 ;; non-terminal, terminal, special
622 ((memq kindA
'(ebnf-generate-non-terminal
623 ebnf-generate-terminal
624 ebnf-generate-special
))
625 (string= (ebnf-node-name A
) (ebnf-node-name B
)))
626 ;; alternative, sequence
627 ((memq kindA
'(ebnf-generate-alternative ; any order
628 ebnf-generate-sequence
)) ; order is important
629 (let ((listA (ebnf-node-list A
))
630 (listB (ebnf-node-list B
)))
631 (and (= (length listA
) (length listB
))
633 (while (and ok listA
)
634 (setq ok
(ebnf-node-equal (car listA
) (car listB
))
639 ((eq kindA
'ebnf-generate-production
)
640 (and (string= (ebnf-node-name A
) (ebnf-node-name B
))
641 (ebnf-node-equal (ebnf-node-production A
)
642 (ebnf-node-production B
))))
649 (defun ebnf-create-alternative (alt)
650 (if (> (length alt
) 1)
651 (ebnf-make-alternative alt
)
655 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
661 ;;; ebnf-otz.el ends here