Mercurial > emacs
view lisp/progmodes/ebnf-otz.el @ 74829:55f1722d93af
(sh-make-vars-local): Fix a typo in message string.
author | Eli Zaretskii <eliz@gnu.org> |
---|---|
date | Fri, 22 Dec 2006 23:20:24 +0000 |
parents | 8c9e156de392 |
children | e3694f1cb928 |
line wrap: on
line source
;;; ebnf-otz.el --- syntactic chart OpTimiZer ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 ;; Free Sofware Foundation, Inc. ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, ebnf, PostScript ;; Version: 1.0 ;; This file is part of GNU Emacs. ;; GNU Emacs 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. ;; GNU Emacs 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., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; ;; This is part of ebnf2ps package. ;; ;; This package defines an optimizer for ebnf2ps. ;; ;; See ebnf2ps.el for documentation. ;; ;; ;; 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]. ;; ;; factorization: ;; 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. ;; ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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]. ;; factorization: ;; 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) "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)))) ;; 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]. ;; factorization: ;; 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 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 ;; 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) ;;; arch-tag: 7ef2249d-9e8b-4bc1-999f-95d784690636 ;;; ebnf-otz.el ends here