summaryrefslogtreecommitdiff
path: root/lisp/progmodes/ebnf-otz.el
diff options
context:
space:
mode:
authorGerd Moellmann <gerd@gnu.org>2000-01-27 14:31:16 +0000
committerGerd Moellmann <gerd@gnu.org>2000-01-27 14:31:16 +0000
commit984ae001715c945ef1e81fba2d80607f486332f2 (patch)
tree3955207c2206ec84347bcf2b6721544cd8ec7e44 /lisp/progmodes/ebnf-otz.el
parentf95d599c5167087059cfb25d380f69152ec3f587 (diff)
downloademacs-984ae001715c945ef1e81fba2d80607f486332f2.tar.gz
*** empty log message ***
Diffstat (limited to 'lisp/progmodes/ebnf-otz.el')
-rw-r--r--lisp/progmodes/ebnf-otz.el661
1 files changed, 661 insertions, 0 deletions
diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el
new file mode 100644
index 00000000000..5af9ef6925c
--- /dev/null
+++ b/lisp/progmodes/ebnf-otz.el
@@ -0,0 +1,661 @@
+;;; ebnf-otz --- Syntatic chart OpTimiZer
+
+;; Copyright (C) 1999 Vinicius Jose Latorre
+
+;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; Keywords: wp, ebnf, PostScript
+;; Time-stamp: <99/11/20 18:03:10 vinicius>
+;; Version: 1.0
+
+;; This file is *NOT* (yet?) part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;
+;; This is part of ebnf2ps package.
+;;
+;; This package defines an optimizer for ebnf2ps.
+;;
+;; See ebnf2ps.el for documentation.
+;;
+;;
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; code:
+
+
+(require 'ebnf2ps)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defvar ebnf-empty-rule-list nil
+ "List of empty rule name.")
+
+
+(defun ebnf-add-empty-rule-list (rule)
+ "Add empty RULE in `ebnf-empty-rule-list'."
+ (and ebnf-ignore-empty-rule
+ (eq (ebnf-node-kind (ebnf-node-production rule))
+ 'ebnf-generate-empty)
+ (setq ebnf-empty-rule-list (cons (ebnf-node-name rule)
+ ebnf-empty-rule-list))))
+
+
+(defun ebnf-otz-initialize ()
+ "Initialize optimizer."
+ (setq ebnf-empty-rule-list nil))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Eliminate empty rules
+
+
+(defun ebnf-eliminate-empty-rules (syntax-list)
+ "Eliminate empty rules."
+ (while ebnf-empty-rule-list
+ (let ((ebnf-total (length syntax-list))
+ (ebnf-nprod 0)
+ (prod-list syntax-list)
+ new-list before)
+ (while prod-list
+ (ebnf-message-info "Eliminating empty rules")
+ (let ((rule (car prod-list)))
+ ;; if any non-terminal pertains to ebnf-empty-rule-list
+ ;; then eliminate non-terminal from rule
+ (if (ebnf-eliminate-empty rule)
+ (setq before prod-list)
+ ;; eliminate empty rule from syntax-list
+ (setq new-list (cons (ebnf-node-name rule) new-list))
+ (if before
+ (setcdr before (cdr prod-list))
+ (setq syntax-list (cdr syntax-list)))))
+ (setq prod-list (cdr prod-list)))
+ (setq ebnf-empty-rule-list new-list)))
+ syntax-list)
+
+
+;; [production width-func entry height width name production action]
+;; [sequence width-func entry height width list]
+;; [alternative width-func entry height width list]
+;; [non-terminal width-func entry height width name default]
+;; [empty width-func entry height width]
+;; [terminal width-func entry height width name default]
+;; [special width-func entry height width name default]
+
+(defun ebnf-eliminate-empty (rule)
+ (let ((kind (ebnf-node-kind rule)))
+ (cond
+ ;; non-terminal
+ ((eq kind 'ebnf-generate-non-terminal)
+ (if (member (ebnf-node-name rule) ebnf-empty-rule-list)
+ nil
+ rule))
+ ;; sequence
+ ((eq kind 'ebnf-generate-sequence)
+ (let ((seq (ebnf-node-list rule))
+ (header (ebnf-node-list rule))
+ before elt)
+ (while seq
+ (setq elt (car seq))
+ (if (ebnf-eliminate-empty elt)
+ (setq before seq)
+ (if before
+ (setcdr before (cdr seq))
+ (setq header (cdr header))))
+ (setq seq (cdr seq)))
+ (when header
+ (ebnf-node-list rule header)
+ rule)))
+ ;; alternative
+ ((eq kind 'ebnf-generate-alternative)
+ (let ((seq (ebnf-node-list rule))
+ (header (ebnf-node-list rule))
+ before elt)
+ (while seq
+ (setq elt (car seq))
+ (if (ebnf-eliminate-empty elt)
+ (setq before seq)
+ (if before
+ (setcdr before (cdr seq))
+ (setq header (cdr header))))
+ (setq seq (cdr seq)))
+ (when header
+ (if (= (length header) 1)
+ (car header)
+ (ebnf-node-list rule header)
+ rule))))
+ ;; production
+ ((eq kind 'ebnf-generate-production)
+ (let ((prod (ebnf-eliminate-empty (ebnf-node-production rule))))
+ (when prod
+ (ebnf-node-production rule prod)
+ rule)))
+ ;; terminal, special and empty
+ (t
+ rule)
+ )))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Optimizations
+
+
+;; *To be implemented*:
+;; left recursion:
+;; A = B | A C B | A C D. ==> A = B {C (B | D)}*.
+
+;; right recursion:
+;; A = B | C A. ==> A = {C}* B.
+;; A = B | D | C A | E A. ==> A = { C | E }* ( B | D ).
+
+;; optional:
+;; A = B | C B. ==> A = [C] B.
+;; A = B | B C. ==> A = B [C].
+;; A = D | B D | B C D. ==> A = [B [C]] D.
+
+
+;; *Already implemented*:
+;; left recursion:
+;; A = B | A C. ==> A = B {C}*.
+;; A = B | A B. ==> A = {B}+.
+;; A = | A B. ==> A = {B}*.
+;; A = B | A C B. ==> A = {B || C}+.
+;; A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
+
+;; optional:
+;; A = B | . ==> A = [B].
+;; A = | B . ==> A = [B].
+
+;; factoration:
+;; A = B C | B D. ==> A = B (C | D).
+;; A = C B | D B. ==> A = (C | D) B.
+;; A = B C E | B D E. ==> A = B (C | D) E.
+
+;; none:
+;; A = B | C | . ==> A = B | C | .
+;; A = B | C A D. ==> A = B | C A D.
+
+(defun ebnf-optimize (syntax-list)
+ "Syntatic chart optimizer."
+ (if (not ebnf-optimize)
+ syntax-list
+ (let ((ebnf-total (length syntax-list))
+ (ebnf-nprod 0)
+ new)
+ (while syntax-list
+ (setq new (cons (ebnf-optimize1 (car syntax-list)) new)
+ syntax-list (cdr syntax-list)))
+ (nreverse new))))
+
+
+;; left recursion:
+;; 1. A = B | A C. ==> A = B {C}*.
+;; 2. A = B | A B. ==> A = {B}+.
+;; 3. A = | A B. ==> A = {B}*.
+;; 4. A = B | A C B. ==> A = {B || C}+.
+;; 5. A = B | D | A C | A E. ==> A = ( B | D ) { C | E }*.
+
+;; optional:
+;; 6. A = B | . ==> A = [B].
+;; 7. A = | B . ==> A = [B].
+
+;; factoration:
+;; 8. A = B C | B D. ==> A = B (C | D).
+;; 9. A = C B | D B. ==> A = (C | D) B.
+;; 10. A = B C E | B D E. ==> A = B (C | D) E.
+
+(defun ebnf-optimize1 (prod)
+ (ebnf-message-info "Optimizing syntatic chart")
+ (let ((production (ebnf-node-production prod)))
+ (and (eq (ebnf-node-kind production) 'ebnf-generate-alternative)
+ (let* ((hlist (ebnf-split-header-prefix
+ (ebnf-node-list production)
+ (ebnf-node-name prod)))
+ (nlist (car hlist))
+ (zlist (cdr hlist))
+ (elist (ebnf-split-header-suffix nlist zlist)))
+ (ebnf-node-production
+ prod
+ (cond
+ ;; cases 2., 4.
+ (elist
+ (and (eq elist t)
+ (setq elist nil))
+ (setq elist (or (ebnf-prefix-suffix elist)
+ elist))
+ (let* ((nl (ebnf-extract-empty nlist))
+ (el (or (ebnf-prefix-suffix (cdr nl))
+ (ebnf-create-alternative (cdr nl)))))
+ (if (car nl)
+ (ebnf-make-zero-or-more el elist)
+ (ebnf-make-one-or-more el elist))))
+ ;; cases 1., 3., 5.
+ (zlist
+ (let* ((xlist (cdr (ebnf-extract-empty zlist)))
+ (znode (ebnf-make-zero-or-more
+ (or (ebnf-prefix-suffix xlist)
+ (ebnf-create-alternative xlist))))
+ (nnode (ebnf-map-list-to-optional nlist)))
+ (and nnode
+ (setq nlist (list nnode)))
+ (if (or (null nlist)
+ (and (= (length nlist) 1)
+ (eq (ebnf-node-kind (car nlist))
+ 'ebnf-generate-empty)))
+ znode
+ (ebnf-make-sequence
+ (list (or (ebnf-prefix-suffix nlist)
+ (ebnf-create-alternative nlist))
+ znode)))))
+ ;; cases 6., 7.
+ ((ebnf-map-node-to-optional production)
+ )
+ ;; cases 8., 9., 10.
+ ((ebnf-prefix-suffix nlist)
+ )
+ ;; none
+ (t
+ production)
+ ))))
+ prod))
+
+
+(defun ebnf-split-header-prefix (node-list header)
+ (let* ((hlist (ebnf-split-header-prefix1 node-list header))
+ (nlist (car hlist))
+ zlist empty-p)
+ (while (setq hlist (cdr hlist))
+ (let ((elt (car hlist)))
+ (if (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
+ (setq zlist (cons
+ (let ((seq (cdr (ebnf-node-list elt))))
+ (if (= (length seq) 1)
+ (car seq)
+ (ebnf-node-list elt seq)
+ elt))
+ zlist))
+ (setq empty-p t))))
+ (and empty-p
+ (setq zlist (cons (ebnf-make-empty)
+ zlist)))
+ (cons nlist (nreverse zlist))))
+
+
+(defun ebnf-split-header-prefix1 (node-list header)
+ (let (hlist nlist)
+ (while node-list
+ (if (ebnf-node-equal-header (car node-list) header)
+ (setq hlist (cons (car node-list) hlist))
+ (setq nlist (cons (car node-list) nlist)))
+ (setq node-list (cdr node-list)))
+ (cons (nreverse nlist) (nreverse hlist))))
+
+
+(defun ebnf-node-equal-header (node header)
+ (let ((kind (ebnf-node-kind node)))
+ (cond
+ ((eq kind 'ebnf-generate-sequence)
+ (ebnf-node-equal-header (car (ebnf-node-list node)) header))
+ ((eq kind 'ebnf-generate-non-terminal)
+ (string= (ebnf-node-name node) header))
+ (t
+ nil)
+ )))
+
+
+(defun ebnf-map-node-to-optional (node)
+ (and (eq (ebnf-node-kind node) 'ebnf-generate-alternative)
+ (ebnf-map-list-to-optional (ebnf-node-list node))))
+
+
+(defun ebnf-map-list-to-optional (nlist)
+ (and (= (length nlist) 2)
+ (let ((first (nth 0 nlist))
+ (second (nth 1 nlist)))
+ (cond
+ ;; empty second
+ ((eq (ebnf-node-kind first) 'ebnf-generate-empty)
+ (ebnf-make-optional second))
+ ;; first empty
+ ((eq (ebnf-node-kind second) 'ebnf-generate-empty)
+ (ebnf-make-optional first))
+ ;; first second
+ (t
+ nil)
+ ))))
+
+
+(defun ebnf-extract-empty (elist)
+ (let ((now elist)
+ before empty-p)
+ (while now
+ (if (not (eq (ebnf-node-kind (car now)) 'ebnf-generate-empty))
+ (setq before now)
+ (setq empty-p t)
+ (if before
+ (setcdr before (cdr now))
+ (setq elist (cdr elist))))
+ (setq now (cdr now)))
+ (cons empty-p elist)))
+
+
+(defun ebnf-split-header-suffix (nlist zlist)
+ (let (new empty-p)
+ (and (cond
+ ((= (length nlist) 1)
+ (let ((ok t)
+ (elt (car nlist)))
+ (while (and ok zlist)
+ (setq ok (ebnf-split-header-suffix1 elt (car zlist))
+ zlist (cdr zlist))
+ (if (eq ok t)
+ (setq empty-p t)
+ (setq new (cons ok new))))
+ ok))
+ ((= (length nlist) (length zlist))
+ (let ((ok t))
+ (while (and ok zlist)
+ (setq ok (ebnf-split-header-suffix1 (car nlist) (car zlist))
+ nlist (cdr nlist)
+ zlist (cdr zlist))
+ (if (eq ok t)
+ (setq empty-p t)
+ (setq new (cons ok new))))
+ ok))
+ (t
+ nil)
+ )
+ (let* ((lis (ebnf-unique-list new))
+ (len (length lis)))
+ (cond
+ ((zerop len)
+ t)
+ ((= len 1)
+ (setq lis (car lis))
+ (if empty-p
+ (ebnf-make-optional lis)
+ lis))
+ (t
+ (and empty-p
+ (setq lis (cons (ebnf-make-empty) lis)))
+ (ebnf-create-alternative (nreverse lis)))
+ )))))
+
+
+(defun ebnf-split-header-suffix1 (ne ze)
+ (cond
+ ((eq (ebnf-node-kind ne) 'ebnf-generate-sequence)
+ (and (eq (ebnf-node-kind ze) 'ebnf-generate-sequence)
+ (let ((nl (ebnf-node-list ne))
+ (zl (ebnf-node-list ze))
+ len z)
+ (and (>= (length zl) (length nl))
+ (let ((ok t))
+ (setq len (- (length zl) (length nl))
+ z (nthcdr len zl))
+ (while (and ok z)
+ (setq ok (ebnf-node-equal (car z) (car nl))
+ z (cdr z)
+ nl (cdr nl)))
+ ok)
+ (if (zerop len)
+ t
+ (setcdr (nthcdr (1- len) zl) nil)
+ ze)))))
+ ((eq (ebnf-node-kind ze) 'ebnf-generate-sequence)
+ (let* ((zl (ebnf-node-list ze))
+ (len (length zl)))
+ (and (ebnf-node-equal ne (car (nthcdr (1- len) zl)))
+ (cond
+ ((= len 1)
+ t)
+ ((= len 2)
+ (car zl))
+ (t
+ (setcdr (nthcdr (- len 2) zl) nil)
+ ze)
+ ))))
+ (t
+ (ebnf-node-equal ne ze))
+ ))
+
+
+(defun ebnf-prefix-suffix (lis)
+ (and lis (listp lis)
+ (let* ((prefix (ebnf-split-prefix lis))
+ (suffix (ebnf-split-suffix (cdr prefix)))
+ (middle (cdr suffix)))
+ (setq prefix (car prefix)
+ suffix (car suffix))
+ (and (or prefix suffix)
+ (ebnf-make-sequence
+ (nconc prefix
+ (and middle
+ (list (or (ebnf-map-list-to-optional middle)
+ (ebnf-create-alternative middle))))
+ suffix))))))
+
+
+(defun ebnf-split-prefix (lis)
+ (let* ((len (length lis))
+ (tail lis)
+ (head (if (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence)
+ (ebnf-node-list (car lis))
+ (list (car lis))))
+ (ipre (1+ len)))
+ ;; determine prefix length
+ (while (and (> ipre 0) (setq tail (cdr tail)))
+ (let ((cur head)
+ (this (if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence)
+ (ebnf-node-list (car tail))
+ (list (car tail))))
+ (i 0))
+ (while (and cur this
+ (ebnf-node-equal (car cur) (car this)))
+ (setq cur (cdr cur)
+ this (cdr this)
+ i (1+ i)))
+ (setq ipre (min ipre i))))
+ (if (or (zerop ipre) (> ipre len))
+ ;; no prefix at all
+ (cons nil lis)
+ (let* ((tail (nthcdr ipre head))
+ ;; get prefix
+ (prefix (progn
+ (and tail
+ (setcdr (nthcdr (1- ipre) head) nil))
+ head))
+ empty-p before)
+ ;; adjust first element
+ (if (or (not (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence))
+ (null tail))
+ (setq lis (cdr lis)
+ tail lis
+ empty-p t)
+ (if (= (length tail) 1)
+ (setcar lis (car tail))
+ (ebnf-node-list (car lis) tail))
+ (setq tail (cdr lis)))
+ ;; eliminate prefix from lis based on ipre
+ (while tail
+ (let ((elt (car tail))
+ rest)
+ (if (and (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
+ (setq rest (nthcdr ipre (ebnf-node-list elt))))
+ (progn
+ (if (= (length rest) 1)
+ (setcar tail (car rest))
+ (ebnf-node-list elt rest))
+ (setq before tail))
+ (setq empty-p t)
+ (if before
+ (setcdr before (cdr tail))
+ (setq lis (cdr lis))))
+ (setq tail (cdr tail))))
+ (cons prefix (ebnf-unique-list
+ (if empty-p
+ (nconc lis (list (ebnf-make-empty)))
+ lis)))))))
+
+
+(defun ebnf-split-suffix (lis)
+ (let* ((len (length lis))
+ (tail lis)
+ (head (nreverse
+ (if (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence)
+ (ebnf-node-list (car lis))
+ (list (car lis)))))
+ (isuf (1+ len)))
+ ;; determine suffix length
+ (while (and (> isuf 0) (setq tail (cdr tail)))
+ (let* ((cur head)
+ (tlis (nreverse
+ (if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence)
+ (ebnf-node-list (car tail))
+ (list (car tail)))))
+ (this tlis)
+ (i 0))
+ (while (and cur this
+ (ebnf-node-equal (car cur) (car this)))
+ (setq cur (cdr cur)
+ this (cdr this)
+ i (1+ i)))
+ (nreverse tlis)
+ (setq isuf (min isuf i))))
+ (setq head (nreverse head))
+ (if (or (zerop isuf) (> isuf len))
+ ;; no suffix at all
+ (cons nil lis)
+ (let* ((n (- (length head) isuf))
+ ;; get suffix
+ (suffix (nthcdr n head))
+ (tail (and (> n 0)
+ (progn
+ (setcdr (nthcdr (1- n) head) nil)
+ head)))
+ before empty-p)
+ ;; adjust first element
+ (if (or (not (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence))
+ (null tail))
+ (setq lis (cdr lis)
+ tail lis
+ empty-p t)
+ (if (= (length tail) 1)
+ (setcar lis (car tail))
+ (ebnf-node-list (car lis) tail))
+ (setq tail (cdr lis)))
+ ;; eliminate suffix from lis based on isuf
+ (while tail
+ (let ((elt (car tail))
+ rest)
+ (if (and (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
+ (setq rest (ebnf-node-list elt)
+ n (- (length rest) isuf))
+ (> n 0))
+ (progn
+ (if (= n 1)
+ (setcar tail (car rest))
+ (setcdr (nthcdr (1- n) rest) nil)
+ (ebnf-node-list elt rest))
+ (setq before tail))
+ (setq empty-p t)
+ (if before
+ (setcdr before (cdr tail))
+ (setq lis (cdr lis))))
+ (setq tail (cdr tail))))
+ (cons suffix (ebnf-unique-list
+ (if empty-p
+ (nconc lis (list (ebnf-make-empty)))
+ lis)))))))
+
+
+(defun ebnf-unique-list (nlist)
+ (let ((current nlist)
+ before)
+ (while current
+ (let ((tail (cdr current))
+ (head (car current))
+ remove-p)
+ (while tail
+ (if (not (ebnf-node-equal head (car tail)))
+ (setq tail (cdr tail))
+ (setq remove-p t
+ tail nil)
+ (if before
+ (setcdr before (cdr current))
+ (setq nlist (cdr nlist)))))
+ (or remove-p
+ (setq before current))
+ (setq current (cdr current))))
+ nlist))
+
+
+(defun ebnf-node-equal (A B)
+ (let ((kindA (ebnf-node-kind A))
+ (kindB (ebnf-node-kind B)))
+ (and (eq kindA kindB)
+ (cond
+ ;; empty
+ ((eq kindA 'ebnf-generate-empty)
+ t)
+ ;; non-terminal, terminal, special
+ ((memq kindA '(ebnf-generate-non-terminal
+ ebnf-generate-terminal
+ ebnf-generate-special))
+ (string= (ebnf-node-name A) (ebnf-node-name B)))
+ ;; alternative, sequence
+ ((memq kindA '(ebnf-generate-alternative ; any order
+ ebnf-generate-sequence)) ; order is important
+ (let ((listA (ebnf-node-list A))
+ (listB (ebnf-node-list B)))
+ (and (= (length listA) (length listB))
+ (let ((ok t))
+ (while (and ok listA)
+ (setq ok (ebnf-node-equal (car listA) (car listB))
+ listA (cdr listA)
+ listB (cdr listB)))
+ ok))))
+ ;; production
+ ((eq kindA 'ebnf-generate-production)
+ (and (string= (ebnf-node-name A) (ebnf-node-name B))
+ (ebnf-node-equal (ebnf-node-production A)
+ (ebnf-node-production B))))
+ ;; otherwise
+ (t
+ nil)
+ ))))
+
+
+(defun ebnf-create-alternative (alt)
+ (if (> (length alt) 1)
+ (ebnf-make-alternative alt)
+ (car alt)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(provide 'ebnf-otz)
+
+
+;;; ebnf-otz.el ends here