(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))
(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 (ebnf-eliminate-empty rule)
(setq before prod-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)
(defun ebnf-eliminate-empty (rule)
(let ((kind (ebnf-node-kind rule)))
(cond
((eq kind 'ebnf-generate-non-terminal)
(if (member (ebnf-node-name rule) ebnf-empty-rule-list)
nil
rule))
((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)))
((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))))
((eq kind 'ebnf-generate-production)
(let ((prod (ebnf-eliminate-empty (ebnf-node-production rule))))
(when prod
(ebnf-node-production rule prod)
rule)))
(t
rule)
)))
(defun ebnf-optimize (syntax-list)
"Syntactic 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))))
(defun ebnf-optimize1 (prod)
(ebnf-message-info "Optimizing syntactic 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
(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))))
(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)))))
((ebnf-map-node-to-optional production)
)
((ebnf-prefix-suffix nlist)
)
(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
((eq (ebnf-node-kind first) 'ebnf-generate-empty)
(ebnf-make-optional second))
((eq (ebnf-node-kind second) 'ebnf-generate-empty)
(ebnf-make-optional first))
(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)))
(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))
(cons nil lis)
(let* ((tail (nthcdr ipre head))
(prefix (progn
(and tail
(setcdr (nthcdr (1- ipre) head) nil))
head))
empty-p before)
(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)))
(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)))
(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))
(cons nil lis)
(let* ((n (- (length head) isuf))
(suffix (nthcdr n head))
(tail (and (> n 0)
(progn
(setcdr (nthcdr (1- n) head) nil)
head)))
before empty-p)
(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)))
(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
((eq kindA 'ebnf-generate-empty)
t)
((memq kindA '(ebnf-generate-non-terminal
ebnf-generate-terminal
ebnf-generate-special))
(string= (ebnf-node-name A) (ebnf-node-name B)))
((memq kindA '(ebnf-generate-alternative ebnf-generate-sequence)) (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))))
((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))))
(t
nil)
))))
(defun ebnf-create-alternative (alt)
(if (> (length alt) 1)
(ebnf-make-alternative alt)
(car alt)))
(provide 'ebnf-otz)