lisp/progmodes/ebnf-otz.el

   1 ;;; ebnf-otz.el --- syntactic chart OpTimiZer
   2
   3 ;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005
   4 ;; Free Sofware Foundation, Inc.
   5
   6 ;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br>
   7 ;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br>
   8 ;; Time-stamp: <2004/11/19 22:24:07 vinicius>
   9 ;; Keywords: wp, ebnf, PostScript
  10 ;; Version: 1.0
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;;
  33 ;;
  34 ;; This is part of ebnf2ps package.
  35 ;;
  36 ;; This package defines an optimizer for ebnf2ps.
  37 ;;
  38 ;; See ebnf2ps.el for documentation.
  39 ;;
  40 ;;
  41 ;; Optimizations
  42 ;; -------------
  43 ;;
  44 ;;
  45 ;; *To be implemented*:
  46 ;;    left recursion:
  47 ;;    A = B | A C B | A C D.   ==>   A = B {C (B | D)}*.
  48 ;;
  49 ;;    right recursion:
  50 ;;    A = B | C A.             ==>   A = {C}* B.
  51 ;;    A = B | D | C A | E A.   ==>   A = { C | E }* ( B | D ).
  52 ;;
  53 ;;    optional:
  54 ;;    A = B | C B.             ==>   A = [C] B.
  55 ;;    A = B | B C.             ==>   A = B [C].
  56 ;;    A = D | B D | B C D.     ==>   A = [B [C]] D.
  57 ;;
  58 ;;
  59 ;; *Already implemented*:
  60 ;;    left recursion:
  61 ;;    A = B | A C.             ==>   A = B {C}*.
  62 ;;    A = B | A B.             ==>   A = {B}+.
  63 ;;    A =   | A B.             ==>   A = {B}*.
  64 ;;    A = B | A C B.           ==>   A = {B || C}+.
  65 ;;    A = B | D | A C | A E.   ==>   A = ( B | D ) { C | E }*.
  66 ;;
  67 ;;    optional:
  68 ;;    A = B | .                ==>   A = [B].
  69 ;;    A =   | B .              ==>   A = [B].
  70 ;;
  71 ;;    factorization:
  72 ;;    A = B C | B D.           ==>   A = B (C | D).
  73 ;;    A = C B | D B.           ==>   A = (C | D) B.
  74 ;;    A = B C E | B D E.       ==>   A = B (C | D) E.
  75 ;;
  76 ;;    none:
  77 ;;    A = B | C | .            ==>   A = B | C | .
  78 ;;    A = B | C A D.           ==>   A = B | C A D.
  79 ;;
  80 ;;
  81 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  82
  83 ;;; Code:
  84
  85
  86 (require 'ebnf2ps)
  87
  88 \f
  89 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90
  91
  92 (defvar ebnf-empty-rule-list nil
  93   "List of empty rule name.")
  94
  95
  96 (defun ebnf-add-empty-rule-list (rule)
  97   "Add empty RULE in `ebnf-empty-rule-list'."
  98   (and ebnf-ignore-empty-rule
  99        (eq (ebnf-node-kind (ebnf-node-production rule))
 100            'ebnf-generate-empty)
 101        (setq ebnf-empty-rule-list (cons (ebnf-node-name rule)
 102                                         ebnf-empty-rule-list))))
 103
 104
 105 (defun ebnf-otz-initialize ()
 106   "Initialize optimizer."
 107   (setq ebnf-empty-rule-list nil))
 108
 109 \f
 110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 111 ;; Eliminate empty rules
 112
 113
 114 (defun ebnf-eliminate-empty-rules (syntax-list)
 115   "Eliminate empty rules."
 116   (while ebnf-empty-rule-list
 117     (let ((ebnf-total (length syntax-list))
 118           (ebnf-nprod 0)
 119           (prod-list syntax-list)
 120           new-list before)
 121       (while prod-list
 122         (ebnf-message-info "Eliminating empty rules")
 123         (let ((rule (car prod-list)))
 124           ;; if any non-terminal pertains to ebnf-empty-rule-list
 125           ;; then eliminate non-terminal from rule
 126           (if (ebnf-eliminate-empty rule)
 127               (setq before prod-list)
 128             ;; eliminate empty rule from syntax-list
 129             (setq new-list (cons (ebnf-node-name rule) new-list))
 130             (if before
 131                 (setcdr before (cdr prod-list))
 132               (setq syntax-list (cdr syntax-list)))))
 133         (setq prod-list (cdr prod-list)))
 134       (setq ebnf-empty-rule-list new-list)))
 135   syntax-list)
 136
 137
 138 ;; [production   width-func entry height width name production action]
 139 ;; [sequence     width-func entry height width list]
 140 ;; [alternative  width-func entry height width list]
 141 ;; [non-terminal width-func entry height width name default]
 142 ;; [empty        width-func entry height width]
 143 ;; [terminal     width-func entry height width name default]
 144 ;; [special      width-func entry height width name default]
 145
 146 (defun ebnf-eliminate-empty (rule)
 147   (let ((kind (ebnf-node-kind rule)))
 148     (cond
 149      ;; non-terminal
 150      ((eq kind 'ebnf-generate-non-terminal)
 151       (if (member (ebnf-node-name rule) ebnf-empty-rule-list)
 152           nil
 153         rule))
 154      ;; sequence
 155      ((eq kind 'ebnf-generate-sequence)
 156       (let ((seq    (ebnf-node-list rule))
 157             (header (ebnf-node-list rule))
 158             before elt)
 159         (while seq
 160           (setq elt (car seq))
 161           (if (ebnf-eliminate-empty elt)
 162               (setq before seq)
 163             (if before
 164                 (setcdr before (cdr seq))
 165               (setq header (cdr header))))
 166           (setq seq (cdr seq)))
 167         (when header
 168           (ebnf-node-list rule header)
 169           rule)))
 170      ;; alternative
 171      ((eq kind 'ebnf-generate-alternative)
 172       (let ((seq    (ebnf-node-list rule))
 173             (header (ebnf-node-list rule))
 174             before elt)
 175         (while seq
 176           (setq elt (car seq))
 177           (if (ebnf-eliminate-empty elt)
 178               (setq before seq)
 179             (if before
 180                 (setcdr before (cdr seq))
 181               (setq header (cdr header))))
 182           (setq seq (cdr seq)))
 183         (when header
 184           (if (= (length header) 1)
 185               (car header)
 186             (ebnf-node-list rule header)
 187             rule))))
 188      ;; production
 189      ((eq kind 'ebnf-generate-production)
 190       (let ((prod (ebnf-eliminate-empty (ebnf-node-production rule))))
 191         (when prod
 192           (ebnf-node-production rule prod)
 193           rule)))
 194      ;; terminal, special and empty
 195      (t
 196       rule)
 197      )))
 198
 199 \f
 200 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 201 ;; Optimizations
 202
 203
 204 ;; *To be implemented*:
 205 ;;    left recursion:
 206 ;;    A = B | A C B | A C D.   ==>   A = B {C (B | D)}*.
 207
 208 ;;    right recursion:
 209 ;;    A = B | C A.             ==>   A = {C}* B.
 210 ;;    A = B | D | C A | E A.   ==>   A = { C | E }* ( B | D ).
 211
 212 ;;    optional:
 213 ;;    A = B | C B.             ==>   A = [C] B.
 214 ;;    A = B | B C.             ==>   A = B [C].
 215 ;;    A = D | B D | B C D.     ==>   A = [B [C]] D.
 216
 217
 218 ;; *Already implemented*:
 219 ;;    left recursion:
 220 ;;    A = B | A C.             ==>   A = B {C}*.
 221 ;;    A = B | A B.             ==>   A = {B}+.
 222 ;;    A =   | A B.             ==>   A = {B}*.
 223 ;;    A = B | A C B.           ==>   A = {B || C}+.
 224 ;;    A = B | D | A C | A E.   ==>   A = ( B | D ) { C | E }*.
 225
 226 ;;    optional:
 227 ;;    A = B | .                ==>   A = [B].
 228 ;;    A =   | B .              ==>   A = [B].
 229
 230 ;;    factorization:
 231 ;;    A = B C | B D.           ==>   A = B (C | D).
 232 ;;    A = C B | D B.           ==>   A = (C | D) B.
 233 ;;    A = B C E | B D E.       ==>   A = B (C | D) E.
 234
 235 ;;    none:
 236 ;;    A = B | C | .            ==>   A = B | C | .
 237 ;;    A = B | C A D.           ==>   A = B | C A D.
 238
 239 (defun ebnf-optimize (syntax-list)
 240   "Syntactic chart optimizer."
 241   (if (not ebnf-optimize)
 242       syntax-list
 243     (let ((ebnf-total (length syntax-list))
 244           (ebnf-nprod 0)
 245           new)
 246       (while syntax-list
 247         (setq new (cons (ebnf-optimize1 (car syntax-list)) new)
 248               syntax-list (cdr syntax-list)))
 249       (nreverse new))))
 250
 251
 252 ;; left recursion:
 253 ;; 1.  A = B | A C.             ==>   A = B {C}*.
 254 ;; 2.  A = B | A B.             ==>   A = {B}+.
 255 ;; 3.  A =   | A B.             ==>   A = {B}*.
 256 ;; 4.  A = B | A C B.           ==>   A = {B || C}+.
 257 ;; 5.  A = B | D | A C | A E.   ==>   A = ( B | D ) { C | E }*.
 258
 259 ;; optional:
 260 ;; 6.  A = B | .                ==>   A = [B].
 261 ;; 7.  A =   | B .              ==>   A = [B].
 262
 263 ;; factorization:
 264 ;; 8.  A = B C | B D.           ==>   A = B (C | D).
 265 ;; 9.  A = C B | D B.           ==>   A = (C | D) B.
 266 ;; 10. A = B C E | B D E.       ==>   A = B (C | D) E.
 267
 268 (defun ebnf-optimize1 (prod)
 269   (ebnf-message-info "Optimizing syntactic chart")
 270   (let ((production (ebnf-node-production prod)))
 271     (and (eq (ebnf-node-kind production) 'ebnf-generate-alternative)
 272          (let* ((hlist (ebnf-split-header-prefix
 273                         (ebnf-node-list production)
 274                         (ebnf-node-name prod)))
 275                 (nlist (car hlist))
 276                 (zlist (cdr hlist))
 277                 (elist (ebnf-split-header-suffix nlist zlist)))
 278            (ebnf-node-production
 279             prod
 280             (cond
 281              ;; cases 2., 4.
 282              (elist
 283               (and (eq elist t)
 284                    (setq elist nil))
 285               (setq elist (or (ebnf-prefix-suffix elist)
 286                               elist))
 287               (let* ((nl (ebnf-extract-empty nlist))
 288                      (el (or (ebnf-prefix-suffix (cdr nl))
 289                              (ebnf-create-alternative (cdr nl)))))
 290                 (if (car nl)
 291                     (ebnf-make-zero-or-more el elist)
 292                   (ebnf-make-one-or-more el elist))))
 293              ;; cases 1., 3., 5.
 294              (zlist
 295               (let* ((xlist (cdr (ebnf-extract-empty zlist)))
 296                      (znode (ebnf-make-zero-or-more
 297                              (or (ebnf-prefix-suffix xlist)
 298                                  (ebnf-create-alternative xlist))))
 299                      (nnode (ebnf-map-list-to-optional nlist)))
 300                 (and nnode
 301                      (setq nlist (list nnode)))
 302                 (if (or (null nlist)
 303                         (and (= (length nlist) 1)
 304                              (eq (ebnf-node-kind (car nlist))
 305                                  'ebnf-generate-empty)))
 306                     znode
 307                   (ebnf-make-sequence
 308                    (list (or (ebnf-prefix-suffix nlist)
 309                              (ebnf-create-alternative nlist))
 310                          znode)))))
 311              ;; cases 6., 7.
 312              ((ebnf-map-node-to-optional production)
 313               )
 314              ;; cases 8., 9., 10.
 315              ((ebnf-prefix-suffix nlist)
 316               )
 317              ;; none
 318              (t
 319               production)
 320              ))))
 321     prod))
 322
 323
 324 (defun ebnf-split-header-prefix (node-list header)
 325   (let* ((hlist (ebnf-split-header-prefix1 node-list header))
 326          (nlist (car hlist))
 327          zlist empty-p)
 328     (while (setq hlist (cdr hlist))
 329       (let ((elt (car hlist)))
 330         (if (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
 331             (setq zlist (cons
 332                          (let ((seq (cdr (ebnf-node-list elt))))
 333                            (if (= (length seq) 1)
 334                                (car seq)
 335                              (ebnf-node-list elt seq)
 336                              elt))
 337                          zlist))
 338           (setq empty-p t))))
 339     (and empty-p
 340          (setq zlist (cons (ebnf-make-empty)
 341                            zlist)))
 342     (cons nlist (nreverse zlist))))
 343
 344
 345 (defun ebnf-split-header-prefix1 (node-list header)
 346   (let (hlist nlist)
 347     (while node-list
 348       (if (ebnf-node-equal-header (car node-list) header)
 349           (setq hlist (cons (car node-list) hlist))
 350         (setq nlist (cons (car node-list) nlist)))
 351       (setq node-list (cdr node-list)))
 352     (cons (nreverse nlist) (nreverse hlist))))
 353
 354
 355 (defun ebnf-node-equal-header (node header)
 356   (let ((kind (ebnf-node-kind node)))
 357     (cond
 358      ((eq kind 'ebnf-generate-sequence)
 359       (ebnf-node-equal-header (car (ebnf-node-list node)) header))
 360      ((eq kind 'ebnf-generate-non-terminal)
 361       (string= (ebnf-node-name node) header))
 362      (t
 363       nil)
 364      )))
 365
 366
 367 (defun ebnf-map-node-to-optional (node)
 368   (and (eq (ebnf-node-kind node) 'ebnf-generate-alternative)
 369        (ebnf-map-list-to-optional (ebnf-node-list node))))
 370
 371
 372 (defun ebnf-map-list-to-optional (nlist)
 373   (and (= (length nlist) 2)
 374        (let ((first  (nth 0 nlist))
 375              (second (nth 1 nlist)))
 376          (cond
 377           ;; empty second
 378           ((eq (ebnf-node-kind first) 'ebnf-generate-empty)
 379            (ebnf-make-optional second))
 380           ;; first empty
 381           ((eq (ebnf-node-kind second) 'ebnf-generate-empty)
 382            (ebnf-make-optional first))
 383           ;; first second
 384           (t
 385            nil)
 386           ))))
 387
 388
 389 (defun ebnf-extract-empty (elist)
 390   (let ((now elist)
 391         before empty-p)
 392     (while now
 393       (if (not (eq (ebnf-node-kind (car now)) 'ebnf-generate-empty))
 394           (setq before now)
 395         (setq empty-p t)
 396         (if before
 397             (setcdr before (cdr now))
 398           (setq elist (cdr elist))))
 399       (setq now (cdr now)))
 400     (cons empty-p elist)))
 401
 402
 403 (defun ebnf-split-header-suffix (nlist zlist)
 404   (let (new empty-p)
 405     (and (cond
 406           ((= (length nlist) 1)
 407            (let ((ok t)
 408                  (elt (car nlist)))
 409              (while (and ok zlist)
 410                (setq ok    (ebnf-split-header-suffix1 elt (car zlist))
 411                      zlist (cdr zlist))
 412                (if (eq ok t)
 413                    (setq empty-p t)
 414                  (setq new (cons ok new))))
 415              ok))
 416           ((= (length nlist) (length zlist))
 417            (let ((ok t))
 418              (while (and ok zlist)
 419                (setq ok    (ebnf-split-header-suffix1 (car nlist) (car zlist))
 420                      nlist (cdr nlist)
 421                      zlist (cdr zlist))
 422                (if (eq ok t)
 423                    (setq empty-p t)
 424                  (setq new (cons ok new))))
 425              ok))
 426           (t
 427            nil)
 428           )
 429          (let* ((lis (ebnf-unique-list new))
 430                 (len (length lis)))
 431            (cond
 432             ((zerop len)
 433              t)
 434             ((= len 1)
 435              (setq lis (car lis))
 436              (if empty-p
 437                  (ebnf-make-optional lis)
 438                lis))
 439             (t
 440              (and empty-p
 441                   (setq lis (cons (ebnf-make-empty) lis)))
 442              (ebnf-create-alternative (nreverse lis)))
 443             )))))
 444
 445
 446 (defun ebnf-split-header-suffix1 (ne ze)
 447   (cond
 448    ((eq (ebnf-node-kind ne) 'ebnf-generate-sequence)
 449     (and (eq (ebnf-node-kind ze) 'ebnf-generate-sequence)
 450          (let ((nl (ebnf-node-list ne))
 451                (zl (ebnf-node-list ze))
 452                len z)
 453            (and (>= (length zl) (length nl))
 454                 (let ((ok t))
 455                   (setq len (- (length zl) (length nl))
 456                         z   (nthcdr len zl))
 457                   (while (and ok z)
 458                     (setq ok (ebnf-node-equal (car z) (car nl))
 459                           z  (cdr z)
 460                           nl (cdr nl)))
 461                   ok)
 462                 (if (zerop len)
 463                     t
 464                   (setcdr (nthcdr (1- len) zl) nil)
 465                   ze)))))
 466    ((eq (ebnf-node-kind ze) 'ebnf-generate-sequence)
 467     (let* ((zl  (ebnf-node-list ze))
 468            (len (length zl)))
 469       (and (ebnf-node-equal ne (car (nthcdr (1- len) zl)))
 470            (cond
 471             ((= len 1)
 472              t)
 473             ((= len 2)
 474              (car zl))
 475             (t
 476              (setcdr (nthcdr (- len 2) zl) nil)
 477              ze)
 478             ))))
 479    (t
 480     (ebnf-node-equal ne ze))
 481    ))
 482
 483
 484 (defun ebnf-prefix-suffix (lis)
 485   (and lis (listp lis)
 486        (let* ((prefix (ebnf-split-prefix lis))
 487               (suffix (ebnf-split-suffix (cdr prefix)))
 488               (middle (cdr suffix)))
 489          (setq prefix (car prefix)
 490                suffix (car suffix))
 491          (and (or prefix suffix)
 492               (ebnf-make-sequence
 493                (nconc prefix
 494                       (and middle
 495                            (list (or (ebnf-map-list-to-optional middle)
 496                                      (ebnf-create-alternative middle))))
 497                       suffix))))))
 498
 499
 500 (defun ebnf-split-prefix (lis)
 501   (let* ((len  (length lis))
 502          (tail lis)
 503          (head (if (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence)
 504                    (ebnf-node-list (car lis))
 505                  (list (car lis))))
 506          (ipre (1+ len)))
 507     ;; determine prefix length
 508     (while (and (> ipre 0) (setq tail (cdr tail)))
 509       (let ((cur head)
 510             (this (if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence)
 511                       (ebnf-node-list (car tail))
 512                     (list (car tail))))
 513             (i 0))
 514         (while (and cur this
 515                     (ebnf-node-equal (car cur) (car this)))
 516           (setq cur  (cdr cur)
 517                 this (cdr this)
 518                 i    (1+ i)))
 519         (setq ipre (min ipre i))))
 520     (if (or (zerop ipre) (> ipre len))
 521         ;; no prefix at all
 522         (cons nil lis)
 523       (let* ((tail   (nthcdr ipre head))
 524              ;; get prefix
 525              (prefix (progn
 526                        (and tail
 527                             (setcdr (nthcdr (1- ipre) head) nil))
 528                        head))
 529              empty-p before)
 530         ;; adjust first element
 531         (if (or (not (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence))
 532                 (null tail))
 533             (setq lis     (cdr lis)
 534                   tail    lis
 535                   empty-p t)
 536           (if (= (length tail) 1)
 537               (setcar lis (car tail))
 538             (ebnf-node-list (car lis) tail))
 539           (setq tail (cdr lis)))
 540         ;; eliminate prefix from lis based on ipre
 541         (while tail
 542           (let ((elt (car tail))
 543                 rest)
 544             (if (and (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
 545                      (setq rest (nthcdr ipre (ebnf-node-list elt))))
 546                 (progn
 547                   (if (= (length rest) 1)
 548                       (setcar tail (car rest))
 549                     (ebnf-node-list elt rest))
 550                   (setq before tail))
 551               (setq empty-p t)
 552               (if before
 553                   (setcdr before (cdr tail))
 554                 (setq lis (cdr lis))))
 555             (setq tail (cdr tail))))
 556         (cons prefix (ebnf-unique-list
 557                       (if empty-p
 558                           (nconc lis (list (ebnf-make-empty)))
 559                         lis)))))))
 560
 561
 562 (defun ebnf-split-suffix (lis)
 563   (let* ((len  (length lis))
 564          (tail lis)
 565          (head (nreverse
 566                 (if (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence)
 567                     (ebnf-node-list (car lis))
 568                   (list (car lis)))))
 569          (isuf (1+ len)))
 570     ;; determine suffix length
 571     (while (and (> isuf 0) (setq tail (cdr tail)))
 572       (let* ((cur head)
 573              (tlis (nreverse
 574                     (if (eq (ebnf-node-kind (car tail)) 'ebnf-generate-sequence)
 575                         (ebnf-node-list (car tail))
 576                       (list (car tail)))))
 577              (this tlis)
 578              (i 0))
 579         (while (and cur this
 580                     (ebnf-node-equal (car cur) (car this)))
 581           (setq cur  (cdr cur)
 582                 this (cdr this)
 583                 i    (1+ i)))
 584         (nreverse tlis)
 585         (setq isuf (min isuf i))))
 586     (setq head (nreverse head))
 587     (if (or (zerop isuf) (> isuf len))
 588         ;; no suffix at all
 589         (cons nil lis)
 590       (let* ((n      (- (length head) isuf))
 591              ;; get suffix
 592              (suffix (nthcdr n head))
 593              (tail   (and (> n 0)
 594                           (progn
 595                             (setcdr (nthcdr (1- n) head) nil)
 596                             head)))
 597              before empty-p)
 598         ;; adjust first element
 599         (if (or (not (eq (ebnf-node-kind (car lis)) 'ebnf-generate-sequence))
 600                 (null tail))
 601             (setq lis     (cdr lis)
 602                   tail    lis
 603                   empty-p t)
 604           (if (= (length tail) 1)
 605               (setcar lis (car tail))
 606             (ebnf-node-list (car lis) tail))
 607           (setq tail (cdr lis)))
 608         ;; eliminate suffix from lis based on isuf
 609         (while tail
 610           (let ((elt (car tail))
 611                 rest)
 612             (if (and (eq (ebnf-node-kind elt) 'ebnf-generate-sequence)
 613                      (setq rest (ebnf-node-list elt)
 614                            n    (- (length rest) isuf))
 615                      (> n 0))
 616                 (progn
 617                   (if (= n 1)
 618                       (setcar tail (car rest))
 619                     (setcdr (nthcdr (1- n) rest) nil)
 620                     (ebnf-node-list elt rest))
 621                   (setq before tail))
 622               (setq empty-p t)
 623               (if before
 624                   (setcdr before (cdr tail))
 625                 (setq lis (cdr lis))))
 626             (setq tail (cdr tail))))
 627         (cons suffix (ebnf-unique-list
 628                       (if empty-p
 629                           (nconc lis (list (ebnf-make-empty)))
 630                         lis)))))))
 631
 632
 633 (defun ebnf-unique-list (nlist)
 634   (let ((current nlist)
 635         before)
 636     (while current
 637       (let ((tail (cdr current))
 638             (head (car current))
 639             remove-p)
 640         (while tail
 641           (if (not (ebnf-node-equal head (car tail)))
 642               (setq tail (cdr tail))
 643             (setq remove-p t
 644                   tail     nil)
 645             (if before
 646                 (setcdr before (cdr current))
 647               (setq nlist (cdr nlist)))))
 648         (or remove-p
 649             (setq before current))
 650         (setq current (cdr current))))
 651     nlist))
 652
 653
 654 (defun ebnf-node-equal (A B)
 655   (let ((kindA (ebnf-node-kind A))
 656         (kindB (ebnf-node-kind B)))
 657     (and (eq kindA kindB)
 658          (cond
 659           ;; empty
 660           ((eq kindA 'ebnf-generate-empty)
 661            t)
 662           ;; non-terminal, terminal, special
 663           ((memq kindA '(ebnf-generate-non-terminal
 664                          ebnf-generate-terminal
 665                          ebnf-generate-special))
 666            (string= (ebnf-node-name A) (ebnf-node-name B)))
 667           ;; alternative, sequence
 668           ((memq kindA '(ebnf-generate-alternative ; any order
 669                          ebnf-generate-sequence)) ; order is important
 670            (let ((listA (ebnf-node-list A))
 671                  (listB (ebnf-node-list B)))
 672              (and (= (length listA) (length listB))
 673                   (let ((ok t))
 674                     (while (and ok listA)
 675                       (setq ok    (ebnf-node-equal (car listA) (car listB))
 676                             listA (cdr listA)
 677                             listB (cdr listB)))
 678                     ok))))
 679           ;; production
 680           ((eq kindA 'ebnf-generate-production)
 681            (and (string= (ebnf-node-name A) (ebnf-node-name B))
 682                 (ebnf-node-equal (ebnf-node-production A)
 683                                  (ebnf-node-production B))))
 684           ;; otherwise
 685           (t
 686            nil)
 687           ))))
 688
 689
 690 (defun ebnf-create-alternative (alt)
 691   (if (> (length alt) 1)
 692       (ebnf-make-alternative alt)
 693     (car alt)))
 694
 695 \f
 696 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 697
 698
 699 (provide 'ebnf-otz)
 700
 701
 702 ;;; arch-tag: 7ef2249d-9e8b-4bc1-999f-95d784690636
 703 ;;; ebnf-otz.el ends here