cgit.sxemacs.org Git - packages/blob - mule-packages/mule-base/mule-trex.el

   1 ;; TREX: Tools for Regluar EXpressions
   2 ;;
   3 ;; Regular Expression Compiler
   4 ;;
   5 ;; Coded by S.Tomura <tomura@etl.go.jp>
   6
   7 ;; Copyright (C) 1992 Free Software Foundation, Inc.
   8
   9 ;; This file is part of XEmacs.
  10 ;; This file contains Japanese characters
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 (defvar TREX-version "0.41")
  28 ;;; Last modified date: Thu Jun 15 13:07:39 1995
  29
  30 ;;; 95.6.15 modified by S.Tomura <tomura@etl.go.jp>
  31 ;;;
  32 ;;; \e$BFbB"$N\e(Bre_compile_pattern \e$B$HF1MM$K\e(B case-fold-search \e$B$K$h$C$F!"\e(B
  33 ;;; translate \e$B$9$k$h$&$KJQ99$7$?!#\e(B
  34 ;;;
  35 ;;; 95.6.14 modified by S.Tomura <tomura@etl.go.jp>
  36 ;;; print-translate \e$B$rDI2C!#\e(B<0.38>
  37 ;;; print-fastmap \e$B$rDI2C!#\e(B
  38 ;;;
  39 ;;; start_memory, end_memory \e$B$NBh\e(B2\e$B0z?t$r@8@.$9$k$?$a$K!"\e(B:mark \e$B$NFbIt9=\e(B
  40 ;;; \e$BB$$rJQ99$7$?!#\e(B
  41 ;;;
  42 ;;; re-compile-and-dump, regexp-compile-and-dump \e$B$rDI2C!#\e(B
  43 ;;;
  44 ;;; 95.6.13
  45 ;;; regexp19.c \e$B$KBP1~$7$F\e(B start_memory, end_memory \e$B$N\e(B dump \e$B%k!<%A%s$r=$@5\e(B
  46 ;;;
  47 ;;; \e$B$9$Y$-$3$H!'\e(B
  48 ;;;
  49 ;;; (1) \(\)*
  50 ;;; (2) \e$B;^$N=gHV\e(B
  51 ;;; (3) \e$B0UL#$N$J$$%0%k!<%W;2>H$N8!=P\e(B "\(a\\)\\2"\e$B$J$I\e(B
  52
  53 (defmacro TREX-inc (symbol &optional delta)
  54   (list 'setq symbol (if delta (list '+ symbol delta)
  55                        (list '1+ symbol))))
  56
  57 (defmacro TREX-dec (symbol &optional delta)
  58   (list 'setq symbol (if delta (list '- symbol delta)
  59                        (list '1- symbol))))
  60
  61 (defmacro num (sym)
  62   (list 'num* (list 'quote sym)))
  63
  64 (defun num* (sym)
  65   (TREX-read-hexa (substring (symbol-name sym) 2)))
  66
  67 (defun TREX-read-hexa (str)
  68   (let ((result 0) (i 0) (max (length str)))
  69     (while (< i max)
  70       (let ((ch (aref str i)))
  71         (cond((and (<= ?0 ch) (<= ch ?9))
  72               (setq result (+ (* result 16) (- ch ?0))))
  73              ((and (<= ?a ch) (<= ch ?f))
  74               (setq result (+ (* result 16) (+ (- ch ?a) 10))))
  75              ((and (<= ?A ch) (<= ch ?F))
  76               (setq result (+ (* result 16) (+ (- ch ?A) 10)))))
  77         (TREX-inc i)))
  78     result))
  79
  80 ;;; 1 bytes : 0x00 <= C11 <= 0x7F
  81 ;;; n bytes : 0x80 == LCCMP
  82 ;;;           2 bytes 0xA0 <= LC <= 0xAF
  83 ;;;           3 bytes 0xB0 <= LC <= 0xBB
  84 ;;;           4 bytes 0xBC <= LC <= 0xBE
  85 ;;; 2 bytes : 0x81 <= LC  <= 0x8F
  86 ;;; 3 bytes : 0x90 <= LC  <= 0x9B
  87 ;;; 4 bytes : 0x9C <= LC  <= 0x9E
  88
  89
  90 (defun TREX-char-octets (str index)
  91   (let ((max (length str)))
  92     (if (or (< index 0) (<= max index)) 0
  93       (let ((ch (aref str index))
  94             (bytes))
  95         (setq bytes
  96               (cond ((<= ch (num 0x7f)) 1)
  97                     ((= ch (num 0x80))
  98                      (let ((max (length str))
  99                            (i index))
 100                        (while (and (< i max)
 101                                    (<= (num 0xa0) (aref str i))
 102                                    (<= (aref str i) (num 0xbe)))
 103                          (setq ch (aref str i))
 104                          (cond ((<= ch (num 0xaf)) (TREX-inc i 2))
 105                                ((<= ch (num 0xbb)) (TREX-inc i 3))
 106                                ((<= ch (num 0xbe)) (TREX-inc i 4))))
 107                        (- i index)))
 108                     ((<= ch (num 0x8f)) 2)
 109                     ((<= ch (num 0x9b)) 3)
 110                     ((<= ch (num 0x9e)) 4)
 111                     (t 1)))
 112         (if (<= (+ index bytes) max) bytes 1)))))
 113
 114 (defun TREX-comp-charp (str index)
 115   (= (aref str index) (num 0x80)))
 116
 117 ;;; 0x00 <= C11 <= 0x7F  : 1 bytes
 118 ;;;      Type 1-1 C11
 119 ;;; 0x80 == LCCMP        : n bytes
 120 ;;;      Type N  LCCMP LCN1 C11 ... LCN2 C21 ...  LCNn Cn1 ...
 121 ;;;             0xA0 <= LCN* <= 0xBE
 122 ;;;                 LCN* = LC + 0x20
 123 ;;;                 LCN* = 0xA0  (ASCII)
 124 ;;; 0x81 <= LC1  <= 0x8F : 2 bytes
 125 ;;;      Type 1-2 LC1 C11 :
 126 ;;;             0xA0 <= C11  <= 0xFF
 127 ;;; 0x90 <= LC2 <= 0x99  : 3 bytes
 128 ;;;      Type 2-3 LC2 C21 C22
 129 ;;;             0xA0 <= C21 <= 0xFF
 130 ;;;             0xA0 <= C22 <= 0xFF
 131 ;;; 0x9A == LCPRV1       : 3 bytes
 132 ;;;      Type 1-3 LCPRV1 LC12 C11
 133 ;;;             0xA0 <= LC12 <= 0xB7
 134 ;;;             0xA0 <= C11  <= 0xFF
 135 ;;; 0x9B == LCPRV1       : 3 bytes
 136 ;;;      Type 1-3 LCPRV1 LC12 C11
 137 ;;;             0xB8 <= LC12 <= 0xBF
 138 ;;;             0xA0 <= C11  <= 0xFF
 139 ;;; 0x9C == LCPRV2       : 4 bytes
 140 ;;;      Type 2-4 LCPRV2 LC22 C21 C22
 141 ;;;             0xC0 <= LC22 <= 0xC7
 142 ;;;             0xA0 <= C21  <= 0xFF
 143 ;;;             0xA0 <= C22  <= 0xFF
 144 ;;; 0x9D == LCPRV2       : 4 bytes
 145 ;;;      Type 2-4 LCPRV2 LC22 C21 C22
 146 ;;;             0xC8 <= LC22 <= 0xDF
 147 ;;;             0xA0 <= C21  <= 0xFF
 148 ;;;             0xA0 <= C22  <= 0xFF
 149 ;;; 0x9E == LCPRV3       : 4 bytes
 150 ;;;      Type 3-4 LCPRV3 C31 C32 C33
 151 ;;;             0xA0 <= C31 <= 0xBF
 152 ;;;             0xA0 <= C32 <= 0xFF
 153 ;;;             0xA0 <= C33 <= 0xFF
 154 ;;; char = [0x00-0x7f]\|
 155 ;;;        0x80
 156 ;;;           \(0xa0[0xa0-0xff]\|
 157 ;;;             [0xa1-0xaf][0xa0-0xff]\|
 158 ;;;             [0xb0-0xb9][0xa0-0xff][0xa0-0xff]\|
 159 ;;;             0xba[0xa0-0xb7][0xa0-0xff]\|
 160 ;;;             0xbb[0xb8-0xbf][0xa0-0xff]\|
 161 ;;;             0xbc[0xc0-0xc7][0xa0-0xff][0xa0-0xff]\|
 162 ;;;             0xbd[0xc8-0xdf][0xa0-0xff][0xa0-0xff]\|
 163 ;;;             0xbe[0xa0-0xbf][0xa0-0xff][0xa0-0xff]
 164 ;;;           \)*\|
 165 ;;;        [0x81-0x8f][0xa0-0xff]\|
 166 ;;;        [0x90-0x99][0xa0-0xff][0xa0-0xff]\|
 167 ;;;        0x9a[0xa0-0xb7][0xa0-0xff]\|
 168 ;;;        0x9b[0xb8-0xbf][0xa0-0xff]\|
 169 ;;;        0x9c[0xc0-0xc7][0xa0-0xff][0xa0-0xff]\|
 170 ;;;        0x9d[0xc8-0xdf][0xa0-0xff][0xa0-0xff]\|
 171 ;;;        0x9e[0xa0-0xbf][0xa0-0xff][0xa0-0xff]
 172
 173 (defun regexp-make-or (&rest body)
 174   (cons ':or body))
 175
 176 (defun regexp-make-seq (&rest body)
 177   (cons ':seq body))
 178
 179 (defun regexp-make-star (regexp)
 180   (list ':star regexp))
 181
 182 (defun regexp-make-range (from to)
 183   (list 'CHARSET (list ':range from to)))
 184
 185
 186 (defvar regexp-allchar-regexp
 187   (regexp-make-or
 188    (regexp-make-range 0 (num 0x7f))
 189    (regexp-make-seq
 190     (num 0x80)
 191     (regexp-make-star
 192      (regexp-make-or
 193       (regexp-make-seq
 194        (num 0xa0)
 195        (regexp-make-range (num 0xa0) (num 0xff)))
 196       (regexp-make-seq
 197        (regexp-make-range (num 0xa1) (num 0xaf))
 198        (regexp-make-range (num 0xa0) (num 0xff)))
 199       (regexp-make-seq
 200        (regexp-make-range (num 0xb0) (num 0xb9))
 201        (regexp-make-range (num 0xa0) (num 0xff))
 202        (regexp-make-range (num 0xa0) (num 0xff)))
 203       (regexp-make-seq
 204        (num 0xba)
 205        (regexp-make-range (num 0xa0) (num 0xb7))
 206        (regexp-make-range (num 0xa0) (num 0xff)))
 207       (regexp-make-seq
 208        (num 0xbb)
 209        (regexp-make-range (num 0xb8) (num 0xbf))
 210        (regexp-make-range (num 0xa0) (num 0xff)))
 211       (regexp-make-seq
 212        (num 0xbc)
 213        (regexp-make-range (num 0xc0) (num 0xc7))
 214        (regexp-make-range (num 0xa0) (num 0xff))
 215        (regexp-make-range (num 0xa0) (num 0xff)))
 216       (regexp-make-seq
 217        (num 0xbd)
 218        (regexp-make-range (num 0xc8) (num 0xdf))
 219        (regexp-make-range (num 0xa0) (num 0xff))
 220        (regexp-make-range (num 0xa0) (num 0xff)))
 221       (regexp-make-seq
 222        (num 0xbe)
 223        (regexp-make-range (num 0xa0) (num 0xbf))
 224        (regexp-make-range (num 0xa0) (num 0xff))
 225        (regexp-make-range (num 0xa0) (num 0xff))))))
 226    (regexp-make-seq
 227     (regexp-make-range (num 0x81) (num 0x8f))
 228     (regexp-make-range (num 0xa0) (num 0xff)))
 229    (regexp-make-seq
 230     (regexp-make-range (num 0x90) (num 0x99))
 231     (regexp-make-range (num 0xa0) (num 0xff))
 232     (regexp-make-range (num 0xa0) (num 0xff)))
 233    (regexp-make-seq
 234     (num 0x9a)
 235     (regexp-make-range (num 0xa0) (num 0xb7))
 236     (regexp-make-range (num 0xa0) (num 0xff)))
 237    (regexp-make-seq
 238     (num 0x9b)
 239     (regexp-make-range (num 0xb8) (num 0xbf))
 240     (regexp-make-range (num 0xa0) (num 0xff)))
 241    (regexp-make-seq
 242     (num 0x9c)
 243     (regexp-make-range (num 0xc0) (num 0xc7))
 244     (regexp-make-range (num 0xa0) (num 0xff))
 245     (regexp-make-range (num 0xa0) (num 0xff)))
 246    (regexp-make-seq
 247     (num 0x9d)
 248     (regexp-make-range (num 0xc8) (num 0xdf))
 249     (regexp-make-range (num 0xa0) (num 0xff))
 250     (regexp-make-range (num 0xa0) (num 0xff)))
 251    (regexp-make-seq
 252     (num 0x9e)
 253     (regexp-make-range (num 0xa0) (num 0xbf))
 254     (regexp-make-range (num 0xa0) (num 0xff))
 255     (regexp-make-range (num 0xa0) (num 0xff)))))
 256
 257 ;;;;
 258 ;;;;
 259 ;;;;
 260
 261 (defun TREX-string-reverse (str)
 262   (if (<= (length str) 1) str
 263     (let ((result (make-string (length str) 0))
 264           (i 0)
 265           (j (1- (length str))))
 266       (while (<= 0 j)
 267         (aset result i (aref str j))
 268         (TREX-inc i)
 269         (TREX-dec j))
 270       result)))
 271
 272 (defun TREX-string-forward-anychar (str start)
 273   (and (stringp str) (numberp start)
 274        (let ((max (length str)))
 275          (and (<= 0 start)
 276               (< start max)
 277               (+ start (TREX-char-octets str start))))))
 278
 279 (defmacro TREX-init (symbol value)
 280   (` (if (null (, symbol))
 281          (setq (, symbol) (, value)))))
 282
 283 (defmacro TREX-push (val symbol)
 284   (list 'setq symbol (list 'cons val symbol)))
 285
 286 (defun TREX-member (elm list pred)
 287   (while (and list (not (funcall pred elm (car list))))
 288     (setq list (cdr list)))
 289   list)
 290
 291 (defun TREX-memequal (elm list)
 292   (while (and list (not (equal elm (car list))))
 293     (setq list (cdr list)))
 294   list)
 295
 296 (defun TREX-find (elm list)
 297   (let ((pos 0))
 298     (while (and list (not (equal elm (car list))))
 299       (setq list (cdr list))
 300       (TREX-inc pos))
 301     (if list pos
 302       nil)))
 303
 304 (defun TREX-find-if (pred list)
 305   (let ((pos 0))
 306     (while (and list (not (funcall pred (car list))))
 307       (TREX-inc pos)
 308       (setq list (cdr list)))
 309     (if list pos
 310       nil)))
 311
 312 (defun TREX-firstn (list n)
 313   (if (or (<= n 0) (null list)) nil
 314     (cons (car list) (TREX-firstn (cdr list) (1- n)))))
 315
 316 (defun TREX-delete-duplicate (list)
 317   (let ((result nil))
 318     (while list
 319       (let ((elm (car list)))
 320         (if (not (TREX-memequal elm result))
 321             (TREX-push elm result)))
 322       (setq list (cdr list)))
 323     (nreverse result)))
 324
 325 (defun TREX-delete (elm list)
 326   (let ((result nil))
 327     (while list
 328       (if (not (equal elm (car list)))
 329           (TREX-push (car list) result))
 330       (setq list (cdr list)))
 331     (nreverse result)))
 332
 333 (defun TREX-string-to-list (str)
 334   (let ((result nil)
 335         (i 0)
 336         (max (length str)))
 337     (while (< i max)
 338       (TREX-push (aref str i) result)
 339       (TREX-inc i))
 340     (nreverse result)))
 341
 342 (defun TREX-sort (list lessp &optional key)
 343   (if (null key)
 344       (sort list lessp)
 345     (sort list (function (lambda (x y) (funcall lessp (funcall key x) (funcall key y)))))))
 346
 347 (defun TREX-key-lessp (x y)
 348   (cond((symbolp x)
 349         (cond ((symbolp y)
 350                (string-lessp x y))
 351               (t;; (not (symbolp))
 352                t)))
 353        ((numberp x)
 354         (cond ((numberp y)
 355                (< x y))
 356               ((and (consp y) (eq (car y) ':range))
 357                (< x (nth 1 y)))
 358               (t nil)))
 359        ((and (consp x) (eq (car x) ':range))
 360         (cond ((and (consp y) (eq (car y) ':range))
 361                (< (nth 2 x) (nth 1 y)))
 362               ((numberp y)
 363                (< (nth 2 x) y))
 364               (t nil)))
 365        (t nil)))
 366
 367 (defun TREX-lessp-car (x y)
 368   (let ((x (car x))
 369         (y (car y)))
 370     (TREX-key-lessp x y)))
 371
 372 (defmacro TREX-define-enum (&rest list)
 373   (list 'TREX-define-enum* (list 'quote list)))
 374
 375 (defun TREX-define-enum* (list)
 376   (let ((i 0))
 377     (while list
 378       (set (car list) i)
 379       (TREX-inc i)
 380       (setq list (cdr list)))))
 381
 382 ;;;
 383 ;;; regexp-parse
 384 ;;;
 385
 386 ;;;
 387 ;;; \e$B@55,I=8=\e(B(regular expression)
 388 ;;;
 389 ;;;  .    single character except a newline
 390 ;;;  REG* more than zero
 391 ;;;  REG+ at least once
 392 ;;;  REG? once or not at all
 393 ;;;  [...] character set
 394 ;;;  [^...]  character not set
 395 ;;;  ^    beginning of line
 396 ;;;  $    end of line
 397 ;;;  \    quote
 398 ;;;  \|   alternative
 399 ;;;  \( ... \) group and mark
 400 ;;;  \DIGIT
 401 ;;;  \`   beginning of buffer
 402 ;;;  \'   end of buffer
 403 ;;;  \b   beginning of word or end of word
 404 ;;;  \B   not \b
 405 ;;;  \<   beginning of word
 406 ;;;  \>   end of word
 407 ;;;
 408 ;;;  \w   word-constituent character
 409 ;;;  \W   not \w
 410 ;;;  \sCODE  syntax CODE character
 411 ;;;  \SCODE  not \sCODE
 412
 413 ;;;
 414 ;;; REG0 ::= REG1 |
 415 ;;;          REG1 "\\|" REG0
 416 ;;;
 417 ;;; REG1 ::= REG2 |
 418 ;;;          REG2 REG1
 419 ;;;
 420 ;;; REG2 ::= REG3  |
 421 ;;;          REG2 "*" |
 422 ;;;          REG2 "+" |
 423 ;;;          REG2 "?" |
 424 ;;;
 425 ;;; REG3 ::= "." |
 426 ;;;          "[" ... "]" |
 427 ;;;          "[" "^" ... "]" |
 428 ;;;          "^" |
 429 ;;;          "$" |
 430 ;;;          "\\" DIGIT |
 431 ;;;          "\\(" REG0 "\\)"
 432
 433 ;;; \e$B>H9g$O@55,I=8=$N:8$+$i1&$X9T$o$l$k!%\e(B
 434
 435 (defvar *regexp-parse-translate* nil
 436   "\e$B@55,I=8=$rFI$_9~$_Cf$K;HMQ$9$k\e(B translate table.\n
 437 case-fold-search \e$B$NCM$K$h$C$F\e(B downcasetable \e$B$r@_Dj$9$k!#\e(B")
 438
 439 (defun regexp-parse-translate-char-string (str)
 440   (if (and *regexp-parse-translate*
 441            (= (length str) 1))
 442       ;;; \e$BK\Ev$O\e(B destructive \e$B$G$b\e(B OK
 443       (char-to-string (aref *regexp-parse-translate* (aref str 0)))
 444     str))
 445
 446 (defvar *regexp-word-definition* nil)
 447
 448 (defvar *regexp-parse-index*  nil)
 449 (defvar *regexp-parse-end*    nil)
 450 (defvar *regexp-parse-str*    nil)
 451 (defvar *regexp-parse-regno*  1)
 452
 453 (defun regexp-error (&optional reason)
 454   (if (null reason) (setq reason "Bad regexp"))
 455     (error "Regexp-parse::%s \"%s\" * \"%s\"" reason (substring *regexp-parse-str* 0 *regexp-parse-index*)
 456            (substring *regexp-parse-str* *regexp-parse-index*)))
 457
 458 (defun word-parse (pattern)
 459   (let ((*regexp-word-definition* t))
 460     (regexp-parse pattern)))
 461
 462 (defun regexp-parse (pattern)
 463   (let*((*regexp-parse-str* pattern)
 464         (*regexp-parse-index*  0)
 465         (*regexp-parse-end*    (length pattern))
 466         (*regexp-parse-regno* 1)
 467         (result (regexp-parse-0)))
 468     (if (<= *regexp-parse-end* *regexp-parse-index*)
 469         result
 470       (regexp-error))))
 471
 472 (defun regexp-parse-0 ()
 473   (let* ((result (regexp-parse-1)))
 474     (cond((<= *regexp-parse-end* *regexp-parse-index*)
 475           result)
 476          ((and (< (1+ *regexp-parse-index*) *regexp-parse-end*)
 477                (= (aref *regexp-parse-str* *regexp-parse-index*) ?\\)
 478                (= (aref *regexp-parse-str* (1+ *regexp-parse-index*)) ?|))
 479           (TREX-inc *regexp-parse-index* 2)
 480           (list ':or result (regexp-parse-0)))
 481          (t result))))
 482
 483 (defun regexp-parse-1 ()
 484   (let ((results nil)
 485         (result2 nil))
 486     (while (setq result2 (regexp-parse-2))
 487       (TREX-push result2 results))
 488     (if results
 489         (if (cdr results)
 490             (cons ':seq (nreverse results))
 491           (car results))
 492       nil)))
 493
 494 (defun regexp-parse-2 ()
 495   (let ((result (regexp-parse-3)))
 496     (while (and (< *regexp-parse-index* *regexp-parse-end*)
 497                 (TREX-memequal (aref *regexp-parse-str* *regexp-parse-index*)
 498                                '(?* ?+ ??)))
 499       (let ((ch (aref *regexp-parse-str* *regexp-parse-index*)))
 500         (TREX-inc *regexp-parse-index*)
 501         (setq result
 502               (cond((= ch ?*) (list ':star result))
 503                    ((= ch ?+) (list ':plus result))
 504                    ((= ch ??) (list ':optional result))))))
 505     result))
 506
 507 (defun regexp-parse-3 ()
 508   (if (<= *regexp-parse-end* *regexp-parse-index*)
 509       nil
 510     (let* ((start *regexp-parse-index*)
 511            (i *regexp-parse-index*)
 512            (end *regexp-parse-end*)
 513            (ch (aref *regexp-parse-str* i)))
 514       (TREX-inc *regexp-parse-index*)
 515       (cond ((= ch ?.) '(ANYCHAR))
 516             ((= ch ?^) '(BEGLINE))
 517             ((= ch ?$) '(ENDLINE))
 518             ((= ch ?\[)
 519              (regexp-parse-charset))
 520             ((= ch ?\])
 521              (setq *regexp-parse-index* start)
 522              nil)
 523             ((= ch ?*)
 524              (setq *regexp-parse-index* start)
 525              nil)
 526             ((= ch ?+)
 527              (setq *regexp-parse-index* start)
 528              nil)
 529             ((= ch ??)
 530              (setq *regexp-parse-index* start)
 531              nil)
 532             ((and (= ch ?\\) (< (1+ i) end))
 533              (setq ch (aref *regexp-parse-str* (1+ i)))
 534              (TREX-inc i)
 535              (TREX-inc *regexp-parse-index*)
 536              (cond ((= ch ?| )
 537                     (setq *regexp-parse-index* start)
 538                     nil)
 539                    ((= ch ?\( )
 540                     (if (< 9 *regexp-parse-regno*)
 541                         (regexp-error "Too many parenth"))
 542                     (let ((regexp-parse-regno *regexp-parse-regno*))
 543                       (TREX-inc *regexp-parse-regno*)
 544                       (let ((result (regexp-parse-0)))
 545
 546                         (cond((and (< (1+ *regexp-parse-index*) *regexp-parse-end*)
 547                                    (= (aref *regexp-parse-str* *regexp-parse-index*) ?\\ )
 548                                    (= (aref *regexp-parse-str* (1+ *regexp-parse-index*)) ?\) ))
 549                               (TREX-inc *regexp-parse-index* 2)
 550                               (if *regexp-word-definition*
 551                                   result
 552                                 (list ':mark regexp-parse-regno
 553                                       (- *regexp-parse-regno* regexp-parse-regno 1)
 554                                       result)))
 555                              (t
 556                               (regexp-error))))))
 557                    ((= ch ?\) )
 558                     (setq *regexp-parse-index* start)
 559                     nil)
 560                    ((= ch ?` ) '(BEGBUF))
 561                    ((= ch ?' ) '(ENDBUF))
 562                    ((= ch ?b )
 563                     (if *regexp-word-definition* (regexp-error) '(WORDBOUND)))
 564                    ((= ch ?B )
 565                     (if *regexp-word-definition* (regexp-error) '(NOTWORDBOUND)))
 566                    ((= ch ?< )
 567                     (if *regexp-word-definition* (regexp-error) '(WORDBEG)))
 568                    ((= ch ?> )
 569                     (if *regexp-word-definition* (regexp-error) '(WORDEND)))
 570                    ((= ch ?w ) (list 'SYNTAXSPEC
 571                                      (syntax-spec-code ?w))) ;;;WORDCHAR
 572                    ((= ch ?W ) (list 'NOTSYNTAXSPEC
 573                                      (syntax-spec-code ?w))) ;;;NOTWORDCHAR
 574                    ;;; ((= ch ?=)  'AT_DOT)
 575                    ((and (<= ?1 ch)
 576                          (<= ch ?9))
 577                     (if *regexp-word-definition*
 578                         (regexp-error) (list 'DUPLICATE (- ch ?0))))
 579                    ((= ch ?0)
 580                     (regexp-error))
 581                    ((and (= ch ?s )
 582                          (< (1+ i) end))
 583                     (TREX-inc *regexp-parse-index*)
 584                     (list 'SYNTAXSPEC (syntax-spec-code (aref *regexp-parse-str* (1+ i)))))
 585                    ((and (= ch ?S )
 586                          (< (1+ i) end))
 587                     (TREX-inc *regexp-parse-index*)
 588                     (list 'NOTSYNTAXSPEC (syntax-spec-code (aref *regexp-parse-str* (1+ i)))))
 589                    ((and (= ch ?c )
 590                          (< (1+ i) end))
 591                     (TREX-inc *regexp-parse-index*)
 592                     (list 'CATEGORYSPEC (aref *regexp-parse-str* (1+ i))))
 593                    ((and (= ch ?C )
 594                          (< (1+ i) end))
 595                     (TREX-inc *regexp-parse-index*)
 596                     (list 'NOTCATEGORYSPEC (aref *regexp-parse-str* (1+ i))))
 597                    (t
 598                     (regexp-parse-translate-char-string
 599                      (substring *regexp-parse-str* (1+ i) (+ i 2))))))
 600             (t
 601              (let ((nextpos (TREX-string-forward-anychar *regexp-parse-str* i)))
 602                (cond(nextpos
 603                      (setq *regexp-parse-index* nextpos)
 604                      (regexp-parse-translate-char-string
 605                      (substring *regexp-parse-str* i nextpos)))
 606                     (t (regexp-error)))))))))
 607
 608 (defun regexp-parse-charset ()
 609   (if (< *regexp-parse-index* *regexp-parse-end*)
 610       (cond((eq (aref *regexp-parse-str* *regexp-parse-index*) ?^)
 611             (TREX-inc *regexp-parse-index*)
 612             (regexp-parse-charset0 'CHARSET_NOT nil))
 613            (t (regexp-parse-charset0 'CHARSET ;;  ':or
 614                                      nil)))
 615     (regexp-error)))
 616
 617 (defun regexp-parse-charset0 (op list)
 618   (if (< *regexp-parse-index* *regexp-parse-end*)
 619       (cond ((eq (aref *regexp-parse-str* *regexp-parse-index*) ?\])
 620              (TREX-inc *regexp-parse-index*)
 621              (regexp-parse-charset1 op '("\]")))
 622             (t
 623              (regexp-parse-charset1 op nil)))
 624     (regexp-error)))
 625
 626 (defun regexp-parse-charset1 (op list)
 627   (if (< *regexp-parse-index* *regexp-parse-end*)
 628       (let* ((pos0 *regexp-parse-index*)
 629              (pos1 (TREX-string-forward-anychar *regexp-parse-str* pos0))
 630              (pos2 (TREX-string-forward-anychar *regexp-parse-str* pos1))
 631              (pos3 (TREX-string-forward-anychar *regexp-parse-str* pos2)))
 632         (if pos0
 633                  ;;; ]
 634             (cond((eq (aref *regexp-parse-str* pos0) ?\])
 635                   (setq *regexp-parse-index* pos1)
 636                   ;;; returns charset form
 637                   (cons op (sort (nreverse list) 'TREX-charset-lessp)))
 638                  ;;; [^]] - [^]]
 639                  ((and pos1 pos2 pos3
 640                        (eq (aref *regexp-parse-str* pos1) ?-)
 641                        (not (eq (aref *regexp-parse-str* pos2) ?\])))
 642                   (let ((from (substring *regexp-parse-str* pos0 pos1))
 643                         (to   (substring *regexp-parse-str* pos2 pos3)))
 644                     (if (and (= (length from) (length to))
 645                              (not (TREX-comp-charp from 0))
 646                              (not (TREX-comp-charp to   0))
 647                              (or (= (length from) 1)
 648                                  (= (aref from 0) (aref to 0)))
 649                              (or (string-equal from to)  ;;; by Enami 93.08.08
 650                                  (string-lessp from to)))
 651                         (if (string-equal from to)
 652                             (TREX-push from list)
 653                           (TREX-push (list ':range from to) list))
 654                       (regexp-error)))
 655                   (setq *regexp-parse-index* pos3)
 656                   (regexp-parse-charset1 op list))
 657                  ;;; [^]] - ] ;;; by Enami 93.08.08
 658                  ((and pos1 pos2
 659                        (eq (aref *regexp-parse-str* pos1) ?-)
 660                        (eq (aref *regexp-parse-str* pos2) ?\]))
 661                   (TREX-push (substring *regexp-parse-str* pos0 pos1) list)
 662                   (TREX-push (substring *regexp-parse-str* pos1 pos2) list)
 663                   (setq *regexp-parse-index* pos2)
 664                   (regexp-parse-charset1 op list))
 665                  (t
 666                   (TREX-push (substring *regexp-parse-str* pos0 pos1)  list)
 667                   (setq *regexp-parse-index* pos1)
 668                   (regexp-parse-charset1 op list)))
 669           (regexp-error)))
 670     (regexp-error)))
 671
 672 (defun TREX-charset-lessp (ch1 ch2)
 673   (cond((and (stringp ch1) (stringp ch2))
 674         (string-lessp ch1 ch2))
 675        ((and (consp ch1) (consp ch2))
 676         (string-lessp (nth 2 ch1) (nth 1 ch2)))
 677        ((consp ch1)
 678         (string-lessp (nth 2 ch1) ch2))
 679        ((consp ch2)
 680         (string-lessp ch1 (nth 1 ch2)))))
 681
 682 ;;;
 683 ;;; define-regexp
 684 ;;;
 685
 686 (defmacro define-regexp (name &rest forms)
 687   (` (define-regexp* '(, name) '(, forms))))
 688
 689 (defun define-regexp* (name forms)
 690   (put name ':regexp-has-definition t)
 691   (put name ':regexp-definition
 692        (if (= (length forms) 1)
 693            (nth 0 forms)
 694          (` (:seq (,@ forms))))))
 695
 696 (defun regexp-get-definition (name)
 697   (get name ':regexp-definition))
 698
 699 (defun regexp-define-specials (names)
 700   (mapcar (function (lambda (name)
 701                       (put name ':regexp-special t)))
 702                     names))
 703
 704 (defun regexp-has-definition (name)
 705   (get name ':regexp-has-definition))
 706
 707 (defun regexp-specialp (name)
 708   (get name ':regexp-special))
 709
 710 (defun regexp-expand-definition (regexp &optional callers)
 711   (cond
 712    ((consp regexp)
 713     (let ((op (car regexp)))
 714       (cond((eq op ':mark)
 715             (` (:mark (, (nth 1 regexp))
 716                       (, (nth 2 regexp))
 717                       (, (regexp-expand-definition (nth 3 regexp))))))
 718            ((eq op ':or)
 719             (` (:or (,@ (mapcar 'regexp-expand-definition (cdr regexp))))))
 720            ((eq op ':seq)
 721             (` (:seq (,@ (mapcar 'regexp-expand-definition (cdr regexp))))))
 722            ((eq op ':optional)
 723             (` (:optional (, (regexp-expand-definition (nth 1 regexp))))))
 724            ((eq op ':star)
 725             (` (:star (, (regexp-expand-definition (nth 1 regexp))))))
 726            ((eq op ':plus)
 727             (` (:plus (, (regexp-expand-definition (nth 1 regexp))))))
 728            ;;;;****
 729            ((eq op ':range)
 730             regexp)
 731            ((regexp-specialp op)
 732             regexp)
 733            ((memq op callers)
 734             (error "regexp defs(%s)" op))
 735            ((regexp-has-definition op)
 736             (regexp-expand-definition (regexp-get-definition op)
 737                                       (cons op callers)))
 738            (t
 739             (error "undefined regexp(%s)" op)))))
 740    ((stringp regexp)
 741     regexp)
 742    ((null regexp)
 743     regexp)
 744    (t
 745     regexp)))
 746
 747 ;;;
 748 ;;;  regexp-*-lessp
 749 ;;;  \e$B@55,7A<0$NA4=g=x$rDj5A$9$k!%\e(B
 750 ;;;
 751
 752 ;;; nil < number < string < symbol < cons
 753
 754 (defun regexp-lessp (exp1 exp2)
 755   (cond((equal exp1 exp2)
 756         nil)
 757        ((null exp1) t)
 758        ((numberp exp1)
 759         (cond((null exp2) nil)
 760              ((numberp exp2)
 761               (< exp1 exp2))
 762              (t t)))
 763        ((stringp exp1)
 764         (cond((or (null exp2)
 765                   (numberp exp2))
 766               nil)
 767              ((stringp exp2)
 768               (string< exp1 exp2))
 769              (t t)))
 770        ((symbolp exp1)
 771         (cond((or (null exp2)
 772                   (numberp exp2)
 773                   (stringp exp2))
 774               nil)
 775              ((symbolp exp2)
 776               (string< exp1 exp2))
 777              (t t)))
 778        ((consp exp1)
 779         (cond ((not (consp exp2))
 780                nil)
 781               ((< (length exp1) (length exp2))
 782                t)
 783               ((= (length exp1) (length exp2))
 784                (regexp-lessp-list exp1 exp2))
 785               (t nil)))))
 786
 787 (defun regexp-lessp-list (exp1 exp2)
 788   (cond((null exp1) nil)
 789        ((regexp-lessp (car exp1) (car exp2))
 790         t)
 791        ((equal (car exp1) (car exp2))
 792         (regexp-lessp-list (cdr exp1) (cdr exp2)))
 793        (t nil)))
 794
 795 ;;;
 796 ;;; item = list of seq-body(== list of regexp)
 797 ;;; nil < cons
 798 ;;;
 799
 800 (defun regexp-item-lessp (item1 item2)
 801   (cond((equal item1 item2)
 802         nil)
 803        ((null item2) t)
 804        ((consp item1)
 805         (cond((consp item2)
 806               (cond ((regexp-key-lessp (car item1) (car item2))
 807                      t)
 808                     ((equal (car item1) (car item2))
 809                      (regexp-item-lessp (cdr item1) (cdr item2)))
 810                     (t nil)))
 811              (t nil)))))
 812
 813
 814 (defun regexp-key-lessp-list (sym1 sym2 list)
 815   (< (TREX-find sym1 list) (TREX-find sym2 list)))
 816
 817 (defun regexp-key-lessp (key1 key2)
 818   (cond ((regexp-key-class0 key1)
 819          (cond((regexp-key-class0 key2)
 820                (regexp-key-lessp-list (car key1) (car key2) *regexp-key-class0*))
 821               (t t)))
 822         ((regexp-key-class1 key1)
 823          (cond((regexp-key-class1 key2)
 824                (regexp-key-lessp-list key1 key2 *regexp-key-class1*))
 825               ((or (regexp-key-class2 key2)
 826                    (regexp-key-class3 key2)
 827                    (regexp-key-class4 key2)
 828                    (null key2))
 829                t)))
 830         ((regexp-key-class2 key1)
 831          (cond((regexp-key-class2 key2)
 832                (regexp-key-lessp-list key1 key2 *regexp-key-class2*))
 833               ((or (regexp-key-class3 key2)
 834                    (regexp-key-class4 key2)
 835                    (null key2))
 836                t)))
 837         ((regexp-key-class3 key1)
 838          (cond((regexp-key-class3 key2)
 839                (regexp-key-lessp-list (car key1) (car key2) *regexp-key-class3*))
 840               ((or (regexp-key-class4 key2)
 841                    (null key2))
 842                t)))
 843         ((regexp-key-class4 key1)
 844          (or (null key2)
 845              (and (regexp-key-class4 key2) (< key1 key2))))
 846         (t nil)))
 847
 848 (defun regexp-alist-lessp (pair1 pair2)
 849   (regexp-key-lessp (car pair1) (car pair2)))
 850
 851 ;;;
 852 ;;;
 853 ;;;
 854
 855 (defvar *regexp-key-class0* '(START_MEMORY STOP_MEMORY))
 856
 857 (defvar *regexp-key-class1* '(BEGLINE ENDLINE
 858                                 ;;; BEFORE_DOT AT_DOT AFTER_DOT
 859                                 BEGBUF ENDBUF
 860                                 WORDBEG WORDEND
 861                                 WORDBOUND NOTWORDBOUND))
 862
 863 (defvar *regexp-key-class2* '(ANYCHAR
 864                               CHARSET
 865                               CHARSET_NOT
 866                                 ;;;WORDCHAR NOTWORDCHAR
 867                                 ))
 868
 869 (defvar *regexp-key-class3* '(DUPLICATE
 870                                 SYNTAXSPEC NOTSYNTAXSPEC
 871                                 CATEGORYSPEC NOTCATEGORYSPEC
 872 ))
 873
 874 (regexp-define-specials *regexp-key-class0*)
 875 (regexp-define-specials *regexp-key-class1*)
 876 (regexp-define-specials *regexp-key-class2*)
 877 (regexp-define-specials *regexp-key-class3*)
 878
 879 (defun regexp-key-class0 (key)
 880   (and (consp key) (TREX-memequal (car key) *regexp-key-class0*)))
 881
 882 (defun regexp-key-class1 (key)
 883   (and (consp key)
 884        (TREX-memequal (car key) *regexp-key-class1*)))
 885
 886 (defun regexp-key-class2 (key)
 887   (and (consp key) (TREX-memequal (car key) *regexp-key-class2*)))
 888
 889 (defun regexp-key-class3 (key)
 890   (and (consp key)
 891        (TREX-memequal (car key) *regexp-key-class3*)))
 892
 893 (defun regexp-key-class4 (key)
 894   (or (and (consp key) (eq (car key) ':range))
 895       (numberp key) (symbolp key)))
 896
 897 (defun regexp-item-key-class0 (item)
 898   (regexp-key-class0 (car item)))
 899
 900 (defun regexp-item-key-class1 (item)
 901   (regexp-key-class1 (car item)))
 902
 903 (defun regexp-item-key-class2 (item)
 904   (regexp-key-class2 (car item)))
 905
 906 (defun regexp-item-key-class3 (item)
 907   (regexp-key-class3 (car item)))
 908
 909 (defun regexp-item-key-class4 (item)
 910   (regexp-key-class4 (car item)))
 911
 912 ;;;
 913 ;;; regexp-sort
 914 ;;; \e$B@55,I=8=$NI8=`7A<0$r5a$a$k$?$a$K@0Ns$r9T$&!%\e(B
 915 ;;;
 916
 917 (defvar *regexp-sort-flag* t)
 918 (defvar *regexp-debug* nil)
 919
 920 (defun regexp-sort (list pred)
 921   (if *regexp-sort-flag*
 922       (progn
 923         (if *regexp-debug* (princ (format "(regexp-sort %s %s)\n" list pred)))
 924         (let ((result (sort list pred)))
 925           (if *regexp-debug* (princ (format "<== %s\n" result)))
 926           result))
 927     list))
 928
 929 ;;;
 930 ;;; regexp-inverse
 931 ;;;
 932
 933 (defun regexp-inverse (regexp)
 934   (if (consp regexp)
 935       (let ((op (car regexp)))
 936         (cond((eq op ':mark)
 937               (list ':mark (nth 1 regexp) (nth 2 regexp)
 938                     (regexp-inverse (nth 3 regexp))))
 939              ((eq op 'DUPLICATE)
 940               regexp)
 941              ((eq op ':or)
 942               (cons ':or (mapcar 'regexp-inverse (cdr regexp))))
 943              ((eq op ':seq)
 944               (cons ':seq (nreverse (mapcar 'regexp-inverse (cdr regexp)))))
 945              ((eq op ':optional)
 946               (list ':optional (regexp-inverse (nth 1 regexp))))
 947              ((eq op ':star)
 948               (list ':star (regexp-inverse (nth 1 regexp))))
 949              ((eq op ':plus)
 950               (list ':plus (regexp-inverse (nth 1 regexp))))
 951              (t regexp)))
 952     (if (stringp regexp)
 953         (TREX-string-reverse regexp)
 954       regexp)))
 955
 956 ;;;
 957 ;;; regexp-remove-infinite-loop
 958 ;;;
 959
 960 (defun regexp-remove-infinite-loop (regexp)
 961   (cond((consp regexp)
 962         (let ((op (car regexp)))
 963           (cond((eq op ':mark)
 964                 )
 965                ((eq op 'DUPLICATE)
 966                 regexp)
 967                ((eq op ':or)
 968                 )
 969                ((eq op ':seq)
 970                 )
 971                ((eq op ':optional)
 972                 )
 973                ((eq op ':star)
 974                 )
 975                ((eq op ':plus)
 976                 )
 977                (t regexp))))
 978        ((stringp regexp)
 979         )
 980        ((null regexp)
 981         )
 982        (t
 983         regexp)))
 984
 985
 986 ;;;
 987 ;;; regexp-reform
 988 ;;;
 989
 990 (defvar *regexp-register-definitions* nil)
 991 (defvar *regexp-registers* nil)
 992
 993 (defun regexp-reform-duplication (regexp)
 994   (let* ((*regexp-register-definitions* nil)
 995          (newregexp (regexp-reform-duplication-1 regexp)))
 996     (let ((*regexp-registers* nil))
 997       (regexp-reform-duplication-2 newregexp))))
 998
 999 (defun regexp-reform-duplication-1 (regexp)
1000   (if (not (consp regexp)) regexp
1001     (let ((mop (car regexp)))
1002       (cond((eq mop ':or)
1003             (cons ':or (mapcar 'regexp-reform-duplication-1
1004                                (cdr regexp))))
1005            ((eq mop ':seq)
1006             (cons ':seq (mapcar 'regexp-reform-duplication-1
1007                                 (cdr regexp))))
1008            ((TREX-memequal mop '(:star :plus :optional))
1009             (list mop (regexp-reform-duplication-1 (nth 1 regexp))))
1010            ((eq mop ':mark)
1011             (TREX-push (cdr regexp)
1012                        *regexp-register-definitions*)
1013             (list 'DUPLICATE (nth 1 regexp)))
1014            (t regexp)))))
1015
1016 (defun regexp-reform-duplication-2 (regexp)
1017   (if (not (consp regexp)) regexp
1018     (let ((mop (car regexp)))
1019       (cond((eq mop ':or)
1020             (let ((registers *regexp-registers*)
1021                   (newregisters nil)
1022                   (result nil)
1023                   (or-body (cdr regexp)))
1024               (while or-body
1025                 (setq *regexp-registers* registers)
1026                 (TREX-push (regexp-reform-duplication-2 (car or-body)) result)
1027                 (setq newregisters (TREX-delete-duplicate (append *regexp-registers* newregisters)))
1028                 (setq or-body (cdr or-body)))
1029               (setq *regexp-registers* newregisters)
1030               (cons ':or (nreverse result))))
1031            ((eq mop ':seq)
1032             (cons ':seq (mapcar 'regexp-reform-duplication-2
1033                                 (cdr regexp))))
1034            ((TREX-memequal mop '(:star :plus :optional))
1035             (list mop (regexp-reform-duplication-2 (nth 1 regexp))))
1036            ((eq mop 'DUPLICATE)
1037             (let ((regno (nth 1 regexp)))
1038               (if (TREX-memequal regno *regexp-registers*)
1039                   regexp
1040                 (let ((def (assoc regno *regexp-register-definitions*)))
1041                   (TREX-push regno *regexp-registers*)
1042                   ;;; \e$BBg>fIW!)\e(B
1043                   (if def
1044                       (cons ':mark def)
1045                     regexp)))))
1046            (t regexp)))))
1047
1048 ;;;
1049 ;;; regexp-expand
1050 ;;;
1051
1052 ;;;
1053 ;;; <ISLAND> ::= ( <ITEM> ...)
1054 ;;; <ITEM>   ::= ( <SEQ-BODY> ... )
1055 ;;;
1056
1057 (defun regexp-expand-regexp (regexp)
1058   ;;; returns island
1059   (if (consp regexp)
1060       (let ((mop (car regexp)))
1061         (cond
1062       ;;;((eq mop 'CHARSET)
1063       ;;; (regexp-expand-charset t (cdr regexp)))
1064       ;;;((eq mop 'CHARSET_NOT)
1065       ;;; (regexp-expand-charset nil (cdr regexp)))
1066          ((eq mop ':or)
1067           (regexp-expand-or (cdr regexp)))
1068          ((eq mop ':seq)
1069           (regexp-expand-seq (cdr regexp)))
1070          ((eq mop ':star)
1071           (let ((arg (nth 1 regexp)))
1072             (if arg
1073                 (append  (regexp-expand-seq (list arg regexp)) (list nil))
1074               (list nil))))
1075          ((eq mop ':plus)
1076           (let ((arg (nth 1 regexp)))
1077             (if arg
1078                 (regexp-expand-seq (list arg (list ':star arg)))
1079               (list nil))))
1080          ((eq mop ':optional)
1081           (append (regexp-expand-regexp (nth 1 regexp)) (list nil)))
1082          ((eq mop ':mark)
1083           (let ((regno (nth 1 regexp))
1084                 (groups (nth 2 regexp))
1085                 (arg (nth 3 regexp)))
1086             (if arg
1087                 (list (list (list 'START_MEMORY regno groups)
1088                             arg
1089                             (list 'STOP_MEMORY  regno groups)))
1090               (list (list (list 'START_MEMORY regno groups)
1091                           (list 'STOP_MEMORY regno groups))))))
1092          (t (list (list regexp)))))
1093     (cond((null regexp) (list nil))
1094          ((symbolp regexp) (list (list regexp)))
1095          ((numberp regexp) (list (list regexp)))
1096          ((stringp regexp)
1097           (let ((result nil))
1098             (let ((i 0) (max (length regexp)))
1099               (while (< i max)
1100                 (TREX-push  (aref regexp i) result)
1101                 (TREX-inc i))
1102               (list (nreverse result)))))
1103          (t (list (list regexp))))))
1104
1105 ;;;
1106 ;;; (CHARSET "abc" ... ) == (:or (:seq "a" "b" "c") .... )
1107 ;;;
1108 ;;;  (:range "abc" "ade") == (:seq "a" (:range "bc" "de"))
1109 ;;;  (:range "bc"  "de" ) == (:or  (:seq "b" (:range "c" 0xFF))
1110 ;;;                                (:seq (:range "b"+1 "d"-1) (:range 0xA0 0xFF))
1111 ;;;                                (:seq "d" (:range 0xA0 "e")))
1112 ;;;
1113
1114 ;;; charset::
1115
1116 (defun charset-member-elt (ch elt)
1117   (if (consp elt)
1118       (if (eq (nth 0 elt) ':range)
1119           (and (<= ch (nth 1 elt))
1120                (<= (nth 2 elt) ch))
1121         nil)
1122     (equal ch elt)))
1123
1124 (defun charset-member-P (ch or-form)
1125   (let ((result) (l (cdr or-form)))
1126     (while (and l (null result))
1127       (if (charset-membership-elt ch (car l))
1128           (setq result t))
1129       (setq l (cdr l)))
1130     result))
1131
1132 (defun charset-member-N (ch nor-form)
1133   (not (charset-member+ ch nor-form)))
1134
1135 (defun charset-norp (form)
1136   (and (consp form) (eq (car form) 'CHARSET_NOT)))
1137
1138 (defun charset-and (form1 form2)
1139   (if (charset-norp form1)
1140       (if (charset-norp form2)
1141           (cons ':or (charset-or-PP (cdr form1) (cdr form2)))
1142         (charset-and-PN form2 form1))
1143     (if (charset-norp form2)
1144         (charset-and-pn form1 form2)
1145       (charset-and-PP form1 form2))))
1146
1147 (defun charset-or-PP (or-body1 or-body2)
1148   (append or-body1 or-body2))
1149
1150
1151
1152
1153 (defun regexp-charset-to-regexp (charsets)
1154   (cons ':or (mapcar 'regexp-charset-to-regexp* charsets)))
1155
1156 (defun regexp-charset-to-regexp* (elm)
1157   (cond((consp elm) (regexp-charset-range-to-regexp (nth 1 elm) (nth 2 elm)))
1158        ((stringp elm) (cons ':seq (TREX-string-to-list elm)))
1159        (t elm)))
1160
1161 (defun regexp-charset-range-to-regexp (str1 str2)
1162   (let ((result (regexp-charset-range-to-regexp* (TREX-string-to-list str1)
1163                                                  (TREX-string-to-list str2))))
1164     (if (= (length result) 1) (car result) (cons ':seq result))))
1165
1166
1167 (defun regexp-charset-range-to-regexp* (nums1 nums2)
1168   (let ((len (length (cdr nums1)))
1169         (ch1 (car nums1))
1170         (ch2 (car nums2)))
1171     (if (= len 0)
1172         (if (= ch1 ch2) (list ch1)
1173           (list (regexp-charset-range-1 ch1 ch2)))
1174       (if (= ch1 ch2)
1175           (cons ch1 (regexp-charset-range-to-regexp* (cdr nums1) (cdr nums2)))
1176         (let ((part1 (cons ch1 (regexp-charset-range-to-regexp* (cdr nums1) (make-list (length (cdr nums1)) 255))))
1177               (part2 (if (<= (1+ ch1) (1- ch2))
1178                          (cons (regexp-charset-range-1 (1+ ch1) (1- ch2))
1179                                (regexp-charset-range-to-regexp* (make-list len 160) (make-list len 255)))
1180                        nil))
1181               (part3 (cons ch2 (regexp-charset-range-to-regexp* (make-list len 160) (cdr nums2)))))
1182           (if part2
1183               (list (list ':or (cons ':seq part1) (cons ':seq part2) (cons ':seq part3)))
1184             (list (list ':or (cons ':seq part1) (cons ':seq part3)))))))))
1185
1186 (defun regexp-charset-range-1 (from to)
1187   (let ((result nil))
1188     (while (<= from to)
1189       (TREX-push to result)
1190       (TREX-dec to))
1191     (cons ':or result)))
1192
1193 (defun regexp-charset-range-1* (from to)
1194   (if (not (<= from to)) nil
1195     (cons from (regexp-charset-range-1* (1+ from) to))))
1196
1197 (defvar *regexp-charset-vector* nil)
1198
1199 (defun regexp-expand-charset (mode charsets)
1200   (TREX-init *regexp-charset-vector* (make-vector 256 nil))
1201   (let ((i 0))
1202     (while (< i 256)
1203       (aset *regexp-charset-vector* i nil)
1204       (TREX-inc i)))
1205   (while charsets
1206     (cond((numberp (car charsets))
1207           (aset *regexp-charset-vector* (car charsets) t))
1208          ((stringp (car charsets))
1209           (if (= (length (car charsets)) 1)
1210               (aset *regexp-charset-vector* (aref (car charsets) 0) t)
1211             (let ((list (TREX-string-to-list (car charsets))))
1212               (aset *regexp-charset-vector* (car list)
1213                     (regexp-expand-charset-set-mark (cdr list)
1214                                                     (aref *regexp-charset-vector* (car list)))))))
1215          ((and (consp (car charsets))
1216                (eq (car (car charsets)) ':range))
1217           (let ((from (aref (nth 1 (car charsets)) 0))
1218                 (to   (aref (nth 2 (car charsets)) 0)))
1219             (if (<= from to)
1220                 (if (< to 128)
1221                     (let ((char from))
1222                       (while (<= char to)
1223                         (aset *regexp-charset-vector* char t)
1224                         (TREX-inc char)))
1225                   (let ((from-list (TREX-string-to-list (nth 1 (car charsets))))
1226                         (to-list   (TREX-string-to-list (nth 2 (car charsets)))))
1227                     ;;; \e$B$I$&$9$s$N!*\e(B
1228                     ))))))
1229     (setq charsets (cdr charsets)))
1230   (let ((result nil)
1231         (i 0))
1232     (while (< i 256)
1233       (if (eq (aref *regexp-charset-vector* i) mode)
1234           (TREX-push (list i) result))
1235       (TREX-inc i))
1236     (nreverse result)))
1237
1238
1239 (defun regexp-expand-charset-set-mark (chars alist)
1240   (if (null chars) t
1241     (let ((place (assoc (car chars) alist)))
1242       (cond((null place)
1243             (cons
1244              (cons (car chars)
1245                    (regexp-expand-charset-set-mark (cdr chars) nil))
1246              alist))
1247            (t
1248             (setcdr place
1249                     (regexp-expand-charset-set-mark (cdr chars) (cdr place)))
1250             alist)))))
1251
1252 (defun regexp-expand-or (regexps)
1253   (if regexps
1254       (append (regexp-expand-regexp (car regexps))
1255               (regexp-expand-or (cdr regexps)))
1256     nil))
1257
1258 (defun regexp-expand-seq (regexps)
1259   (if (null regexps)
1260       (list nil)
1261     (let ((result (regexp-expand-regexp (car regexps))))
1262       (if (TREX-memequal nil result)
1263           (let ((newresult (regexp-expand-seq (cdr regexps))))
1264             (setq result (TREX-delete nil result))
1265             (while result
1266               (TREX-push (append (car result) (cdr regexps)) newresult)
1267               (setq result (cdr result)))
1268             newresult)
1269         (let ((newresult nil))
1270           (while result
1271             (TREX-push (append (car result) (cdr regexps)) newresult)
1272             (setq result (cdr result)))
1273           newresult)))))
1274
1275 (defun regexp-expand-items (items)
1276   (if items
1277       (append (regexp-expand-seq (car items))
1278               (regexp-expand-items (cdr items)))
1279     nil))
1280
1281 ;;;
1282 ;;; regexp-
1283 ;;;
1284
1285 (defun regexp-make-island (items)
1286   (let ((result (TREX-delete-duplicate (regexp-expand-items items))))
1287     (let ((l result))
1288       (while l
1289         (cond((null (car l))
1290               (setcdr l nil)
1291               (setq l nil))
1292              (t (setq l (cdr l))))))
1293     result))
1294
1295 (defun regexp-make-island-parallel (items)
1296     (regexp-sort (TREX-delete-duplicate (regexp-expand-items items))
1297                  'regexp-item-lessp))
1298
1299
1300 ;;; Finate state Automaton:
1301 ;;;
1302 ;;;    FA : Non-deterministic FA
1303 ;;;  EFFA : Epsilon Free FA
1304 ;;;   DFA : Deterministic FA
1305 ;;;
1306 ;;;
1307 ;;;  DFA-optimize <- DFA <- EFFA <- NDFA <- regexp
1308
1309
1310 ;;;
1311 ;;; Table structure
1312 ;;;  <FA>     ::= ( <START> . <TransTables> )
1313 ;;;  <TransTables> ::= ( <Node> . <TransTable> ) ...
1314 ;;;  <TransTable> ::= ( <Key> . <Next> ) ...
1315 ;;;  <Key>    ::= <Char> | <Condition> | :epsilon
1316 ;;;
1317
1318 (defvar *regexp-node-to-transtable* nil)
1319 (defvar *regexp-island-to-node* nil)
1320 (defvar *regexp-counter* 0)
1321
1322 (defun FA-make (regexp)
1323   (setq *regexp-island-to-node* nil)
1324   (let ((*regexp-node-to-transtable* nil)
1325 ;;;     (*regexp-island-to-node*  nil)
1326         (*regexp-counter* 0))
1327     (let ((island (regexp-make-island (regexp-expand-regexp regexp))))
1328       (cons (FA-make-closure island) (nreverse *regexp-node-to-transtable*)))))
1329
1330 (defun FA-make-closure (island)
1331   (if *regexp-debug*  (princ (format "FA-make-closure %s\n" island)))
1332   (if (null island) nil
1333     (let ((place (assoc island *regexp-island-to-node*))
1334           (pos nil))
1335       (cond(place (cdr place))
1336            ;;; START_MEMORY and STOP_MEMORY \e$B!JL5>r7o!$:GM%@h$GA+0\$9$k$b$N!K\e(B
1337            ((setq pos (TREX-find-if 'regexp-item-key-class0 island))
1338             (let ((pre (TREX-firstn island pos))
1339                   (item (nth pos island))
1340                   (post (nthcdr (1+ pos) island)))
1341               (let* ((number (TREX-inc *regexp-counter*))
1342                      (pair (cons (car item) nil))
1343                      (alist (list pair))
1344                      (place (cons number alist)))
1345                 (TREX-push (cons island number) *regexp-island-to-node*)
1346                 (TREX-push place *regexp-node-to-transtable*)
1347                 (setcdr pair
1348                         (FA-make-closure
1349                          (regexp-make-island (append pre (list (cdr item)) post))))
1350                 number)))
1351            ;;; BEGLINE, ENDLINE, WORDBEG, ....\e$B!JD9$5#0$N$b$N!K\e(B
1352            ;;; \e$BA+0\$O\e(B
1353            ;;;   KEY  --> TRUE+FALSE
1354            ;;;  :epsilon --> FALSE \e$B$H$J$k!%\e(B
1355            ((setq pos (TREX-find-if 'regexp-item-key-class1 island))
1356             (let((key (car (nth pos island)))
1357                  (items island)
1358                  (result-true nil)
1359                  (result-false nil))
1360               (while items
1361                 (let ((item (car items)))
1362                   (if (equal key (car item))
1363                       (TREX-push (cdr item) result-true)
1364                     (progn
1365                       (TREX-push item result-true)
1366                       (TREX-push item result-false))))
1367                 (setq items (cdr items)))
1368               (setq result-true (nreverse result-true)
1369                     result-false (nreverse result-false))
1370               (if (null result-false)
1371                   (let* ((number (TREX-inc *regexp-counter*))
1372                          (pair-true (cons key nil))
1373                          (alist (list pair-true))
1374                          (place (cons number alist)))
1375                     (TREX-push (cons island number) *regexp-island-to-node*)
1376                     (TREX-push place *regexp-node-to-transtable*)
1377                     (setcdr pair-true (FA-make-closure (regexp-make-island result-true)))
1378                     number)
1379                 (let* ((number (TREX-inc *regexp-counter*))
1380                        (pair-true (cons key nil))
1381                        (pair-false (cons ':epsilon nil))
1382                        (alist (list pair-true pair-false))
1383                        (place (cons number alist)))
1384                   (TREX-push (cons island number) *regexp-island-to-node*)
1385                   (TREX-push place *regexp-node-to-transtable*)
1386                   (setcdr pair-true (FA-make-closure (regexp-make-island result-true)))
1387                   (setcdr pair-false (FA-make-closure (regexp-make-island result-false)))
1388                   number))))
1389            (t
1390             (FA-make-closure* island (FA-make-pre-alist island)))))))
1391
1392 ;;;
1393 ;;; \e$B$3$3$G07$&$N$O\e(B class2,3,4 \e$B$N$_\e(B
1394 ;;;
1395 (defun FA-make-closure* (island pre-alist)
1396   (if *regexp-debug* (princ (format "\nregexp-make-clousre* %s" pre-alist)))
1397   (let* ((number (TREX-inc *regexp-counter*))
1398          (place (cons number pre-alist)))
1399     (TREX-push (cons island number) *regexp-island-to-node*)
1400     (TREX-push place *regexp-node-to-transtable*)
1401     (while pre-alist
1402       (let ((pair (car pre-alist)))
1403         (setcdr pair
1404                 (FA-make-closure (regexp-make-island (cdr pair)))))
1405       (setq pre-alist (cdr pre-alist)))
1406     number))
1407
1408 ;;;
1409 ;;; PRE-ALIST ::= ( (key . items) ... )
1410 ;;;
1411
1412 (defun FA-make-pre-alist (items)
1413   (let ((pre-alist nil))
1414     (while items
1415       (let ((item (car items)))
1416         (cond((or (regexp-key-class2 (car item))
1417                   (regexp-key-class3 (car item)))
1418               (let ((key (car item))
1419                     (newitems nil))
1420                 (while (and items (equal key (car (car items))))
1421                   (TREX-push (cdr (car items)) newitems)
1422                   (setq items (cdr items)))
1423                 (setq newitems (nreverse newitems))
1424                 (TREX-push (cons key newitems) pre-alist)))
1425              ((null item)
1426               (TREX-push (list nil) pre-alist)
1427               (setq items (cdr items)))
1428              ((regexp-key-class4 (car item))
1429               (let((alist nil))
1430                 (while (and items (regexp-key-class4 (car (car items))))
1431                   (let* ((newitem (car items))
1432                          (place (assoc (car newitem) alist)))
1433                     (if place
1434                         (setcdr place
1435                                 (cons (cdr newitem) (cdr place)))
1436                       (TREX-push (cons (car newitem) (list (cdr newitem))) alist)))
1437                   (setq items (cdr items)))
1438                 (setq alist (sort alist 'TREX-lessp-car))
1439                 (let ((list alist))
1440                   (while list
1441                     (setcdr (car list) (nreverse (cdr (car list))))
1442                     (setq list (cdr list)))
1443                   (setq pre-alist (append alist pre-alist))
1444                   )))
1445              (t (error "undefined items(%s)" item)))))
1446     (nreverse pre-alist)))
1447
1448 ;;;
1449 ;;; FA-inverse
1450 ;;;
1451
1452 (defun FA-inverse (FA)
1453   (let ((invFA nil)
1454         (start (car FA))
1455         (table (cdr FA))
1456         (minnode 10000)
1457         (maxnode 0)
1458         (newtable nil)
1459         (newstart nil)
1460         (newfinal nil))
1461     (let ((l table))
1462       (while l
1463         (let ((n (car (car l))))
1464           (if (< n minnode) (setq minnode n))
1465           (if (< maxnode n) (setq maxnode n)))
1466         (setq l (cdr l))))
1467     (setq newstart (1- minnode))
1468     (setq newfinal (1+ maxnode))
1469     (setq newtable (FA-link newfinal nil nil newtable))
1470     (while table
1471       (let* ((Snode (car table))
1472              (Snumber (car Snode))
1473              (Salist (cdr Snode)))
1474         (while Salist
1475           (let* ((pair (car Salist))
1476                  (key  (car pair))
1477                  (Tnumber (cdr pair)))
1478             (cond((null key)
1479                   (setq newtable (FA-link newstart ':epsilon Snumber newtable)))
1480                  (t
1481                   (setq newtable (FA-link Tnumber key Snumber newtable))))
1482             (setq Salist (cdr Salist)))))
1483       (setq table (cdr table)))
1484     (setq newtable (FA-link start ':epsilon newfinal newtable))
1485     ;;;; FA \e$B$N\e(B final \e$B$X\e(B invFA \e$B$N\e(B start \e$B$+$i\e(B :epsilon link \e$B$rD%$k!%\e(B
1486     (let ((l newtable))
1487       (while l
1488         (setcdr (car l)  (reverse (cdr(car l))))
1489         (setq l (cdr l))))
1490     (setq newtable (sort newtable 'TREX-lessp-car))
1491     (cons newstart newtable)))
1492
1493 (defun FA-link (from key to table)
1494   (let ((place (assoc from table)))
1495     (cond ((null place )
1496            (setq place (cons from nil))
1497            (TREX-push place table)))
1498     (setcdr place (cons (cons key to) (cdr place)))
1499     table))
1500
1501 ;;;
1502 ;;; FA-dump
1503 ;;;
1504
1505 (defun FA-dump (table)
1506   (let ((start (car table))
1507         (l (cdr table)))
1508     (princ (format "\nstart = %d\n" start))
1509     (while l
1510       (princ (format "%3d: " (car (car l))))
1511       (let ((alist (cdr (car l))))
1512           (cond ((numberp (car (car alist)))
1513                  (princ (format "%c -> %s\n" (car (car alist)) (cdr (car alist)))))
1514                 ((and (consp (car (car alist))) (TREX-memequal (car (car (car alist))) '(CATEGORYSPEC NOTCATEGORYSPEC)))
1515                  (princ (format "(%s %c) -> %s\n" (car (car (car alist))) (nth 1 (car (car alist))) (cdr (car alist)))))
1516                 (t
1517                  (princ (format "%s -> %s\n" (car (car alist)) (cdr (car alist))))))
1518           (setq alist (cdr alist))
1519         (while alist
1520           (cond ((numberp (car (car alist)))
1521                  (princ (format "     %c -> %s\n" (car (car alist)) (cdr (car alist)))))
1522                 ((and (consp (car (car alist))) (TREX-memequal (car (car (car alist))) '(CATEGORYSPEC NOTCATEGORYSPEC)))
1523                  (princ (format "     (%s %c) -> %s\n" (car (car (car alist))) (nth 1 (car (car alist))) (cdr (car alist)))))
1524                 (t
1525                  (princ (format "     %s -> %s\n" (car (car alist)) (cdr (car alist))))))
1526           (setq alist (cdr alist))))
1527       (setq l (cdr l)))))
1528
1529 ;;;
1530 ;;; EFFA:  Epsilon Free Finate Automaton
1531 ;;;
1532
1533 (defvar *FA-table* nil)
1534 (defvar *EFFA-table* nil)
1535
1536 (defun EFFA-make (FA)
1537   (let* ((start (car FA))
1538          (*FA-table* (cdr FA))
1539          (newstart start)
1540          (*EFFA-table* nil))
1541     (cons newstart (reverse (EFFA-make* start)))))
1542
1543 (defun EFFA-make* (node)
1544   (let ((place (assoc node *EFFA-table*)))
1545     (cond((null place)
1546           (let ((place (cons node nil)))
1547             (TREX-push place *EFFA-table*)
1548             (setcdr place
1549                     (reverse (EFFA-make-alist nil (cdr (assoc node *FA-table*))
1550                                                      (list node))))
1551             (let ((alist (cdr place)))
1552               (while alist
1553                 (cond((car (car alist))
1554                       (EFFA-make* (cdr (car alist)))))
1555                 (setq alist (cdr alist))))))))
1556   *EFFA-table*)
1557
1558 (defun EFFA-make-alist (newalist alist set)
1559   (while alist
1560     (let ((node (cdr (car alist))))
1561       (cond((eq (car (car alist)) ':epsilon)
1562             (cond((not (TREX-memequal node set))
1563                   (TREX-push node set)
1564                   (setq newalist
1565                         (EFFA-make-alist newalist (cdr (assoc node *FA-table*)) set)))))
1566            (t
1567             (TREX-push (car alist) newalist))))
1568     (setq alist (cdr alist)))
1569   newalist)
1570
1571 ;;;
1572 ;;;  DFA:  Deterministic Finate Automata
1573 ;;;
1574
1575 (defvar *DFA-node-counter* nil)
1576
1577 (defvar *DFA-node-definitions* nil
1578   "List of FD-nodes to node number")
1579
1580 (defvar *DFA-table* nil
1581   "node number to alist")
1582
1583 (defun DFA-make (EFFA)
1584   (let ((start (car EFFA))
1585         (*EFFA-table* (cdr EFFA))
1586         (*DFA-node-counter* 0)
1587         (*DFA-node-definitions* nil )
1588         (*DFA-table* nil))
1589     (DFA-make-1 (list start))
1590     (cons (cdr (assoc (list start) *DFA-node-definitions*)) *DFA-table*)))
1591
1592 (defun DFA-make-1 (states)
1593   (let ((place (assoc states *DFA-node-definitions*)))
1594     (cond((null place)
1595           (TREX-inc *DFA-node-counter*)
1596           (setq place (cons states *DFA-node-counter*))
1597           (TREX-push place *DFA-node-definitions*)
1598           (let ((pair (cons *DFA-node-counter* nil)))
1599             (TREX-push pair *DFA-table*)
1600             (setcdr pair (DFA-make-pre-alist (DFA-collect-alist states)))
1601             (let ((alist (cdr pair)))
1602               (while alist
1603                 (let ((top (car alist)))
1604                   (if (car top)
1605                       (setcdr top
1606                               (DFA-make-1 (cdr top)))))
1607                 (setq alist (cdr alist))))
1608             )))
1609     (cdr place)))
1610
1611 (defun DFA-collect-alist (states)
1612   (let ((result nil))
1613     (while states
1614       (setq result (append (cdr (assoc (car states) *EFFA-table*)) result))
1615       (setq states (cdr states)))
1616     result))
1617
1618 (defun DFA-make-pre-alist (oldAlist)
1619   (let ((pre-alist nil))
1620     (while oldAlist
1621       (let ((oldKey (car (car oldAlist))))
1622         (cond((or (regexp-key-class0 oldKey)
1623                   (regexp-key-class1 oldKey)
1624                   (regexp-key-class2 oldKey)
1625                   (regexp-key-class3 oldKey))
1626               (let ((key oldKey)
1627                     (newAlist nil))
1628                 (while (and oldAlist (equal key (car (car oldAlist))))
1629                   (TREX-push (cdr (car oldAlist)) newAlist)
1630                   (setq oldAlist (cdr oldAlist)))
1631                 (setq newAlist (nreverse newAlist))
1632                 (TREX-push (cons key newAlist) pre-alist)))
1633              ((regexp-key-class4 oldKey)
1634               (let((alist nil))
1635                 (while (and oldAlist (regexp-key-class4 (car (car oldAlist))))
1636                   (let ((place (assoc (car (car oldAlist)) alist)))
1637                     (if place
1638                         (setcdr place
1639                                 (cons (cdr (car oldAlist)) (cdr place)))
1640                       (TREX-push (cons (car (car oldAlist)) (list(cdr (car oldAlist)))) alist)))
1641                   (setq oldAlist (cdr oldAlist)))
1642                 (setq alist (sort alist 'TREX-lessp-car))
1643                 (let ((list alist))
1644                   (while list
1645                     (setcdr (car list) (reverse (cdr (car list))))
1646                     (setq list (cdr list)))
1647                   (setq pre-alist (append alist pre-alist))
1648                   )))
1649              ((null oldKey)
1650               (TREX-push (list nil) pre-alist)
1651               (setq oldAlist (cdr oldAlist)))
1652              (t
1653               (setq oldAlist (cdr oldAlist))))))
1654     (nreverse pre-alist)))
1655
1656 ;;;
1657 ;;; DFA-optimize
1658 ;;; \e$B$3$3$G$N:GE,2=$O>H9g=g=x$rJ]B8$9$k!%\e(B
1659 ;;; longer match \e$B$J$I$r$9$k>l9g$OJQ99$9$kI,MW$,$"$k!%\e(B
1660
1661 (defvar *DFA-optimize-debug* nil)
1662
1663 (defvar *DFA-optimize-groups* nil)
1664 (defvar *DFA-optimize-node*    1)
1665
1666 (defun DFA-optimize (FA)
1667   (if *DFA-optimize-debug* (terpri))
1668   (let* ((start (car FA))
1669          (table (cdr FA))
1670          (*DFA-optimize-node* 1)
1671          (*DFA-optimize-groups*
1672           (list (cons *DFA-optimize-node*  (mapcar 'car table)))))
1673     (while
1674         (catch 'DFA-optimize-changed
1675           (let ((groups *DFA-optimize-groups*))
1676             (while groups
1677               (if *DFA-optimize-debug*
1678                   (princ (format "\nGroups to be checked: %s\n" groups)))
1679               (let* ((Sgroup (car groups))
1680                      (Sgroup-number (car Sgroup))
1681                      (oldgroup (cdr Sgroup))
1682                      (newgroup nil)
1683                      (Smembers oldgroup))
1684                 (if *DFA-optimize-debug*
1685                     (princ (format " Sgroup-number: %s = %s\n" Sgroup-number Smembers)))
1686                 (while Smembers
1687                   (let* ((Snumber (car Smembers))
1688                          (Salist (cdr (assoc Snumber table))))
1689                     (if *DFA-optimize-debug*
1690                         (princ (format "  Snumber: %s\n" Snumber)))
1691                     (let ((Tmembers (cdr Smembers)))
1692                       (while Tmembers
1693                         (if (not (eq Snumber (car Tmembers)))
1694                             (let* ((Tnumber (car Tmembers))
1695                                    (Talist (cdr (assoc Tnumber table)))
1696                                    (Salist Salist))
1697                               (if *DFA-optimize-debug*
1698                                   (princ (format "   Tnumber: %s\n" Tnumber)))
1699                               (while (and Talist Salist
1700                                           (equal (car (car Talist))
1701                                                  (car (car Salist))) ;;; key
1702                                           (equal (DFA-optimize-group-number
1703                                                   (cdr (car Talist)))
1704                                                  (DFA-optimize-group-number
1705                                                   (cdr (car Salist))) ;;; next group
1706                                                  ))
1707                                 (if *DFA-optimize-debug*
1708                                     (progn
1709                                       (princ (format "   Skey: %s -> %s(%s)\n"
1710                                                      (car (car Salist))
1711                                                      (cdr (car Salist))
1712                                                      (DFA-optimize-group-number (cdr (car Salist)))))
1713                                       (princ (format "   Tkey: %s -> %s(%s)\n"
1714                                                      (car (car Talist))
1715                                                      (cdr (car Talist))
1716                                                      (DFA-optimize-group-number (cdr (car Talist)))))))
1717                                 (setq Talist (cdr Talist)
1718                                       Salist (cdr Salist)))
1719                               (cond((or Talist Salist)
1720                                     (setq newgroup (cons Tnumber newgroup)
1721                                           oldgroup (TREX-delete Tnumber oldgroup))
1722                                     (if *DFA-optimize-debug*
1723                                         (princ(format "     oldGroup : %s\n     newGroup : %s\n" oldgroup newgroup)))))
1724                               ))
1725                         (setq Tmembers (cdr Tmembers)))))
1726                   (cond (newgroup
1727                          (if *DFA-optimize-debug*
1728                              (princ (format "Changed :%s --> " Sgroup)))
1729                          (setcdr Sgroup oldgroup)
1730                          (if *DFA-optimize-debug*
1731                              (princ (format "%s" Sgroup)))
1732                          (TREX-inc *DFA-optimize-node*)
1733                          (if *DFA-optimize-debug*
1734                              (princ (format "+%s\n" (cons *DFA-optimize-node* newgroup))))
1735                          (TREX-push (cons *DFA-optimize-node* newgroup) *DFA-optimize-groups*)
1736                          (throw 'DFA-optimize-changed t)))
1737                   (setq Smembers (cdr Smembers))))
1738               (setq groups (cdr groups))))))
1739     ;;;
1740     ;;;
1741     (if *DFA-optimize-debug*
1742         (princ (format "table: %s\n" table)))
1743     (if *DFA-optimize-debug*
1744         (princ (format "groups: %s\n" *DFA-optimize-groups*)))
1745     (let ((newtable nil)
1746           (newstart nil)
1747           (groups *DFA-optimize-groups*))
1748
1749       ;;; start node \e$B$rC5$9\e(B
1750       (let ((l *DFA-optimize-groups*))
1751         (while l
1752           (cond((TREX-memequal start (cdr (car l)))
1753                 (setq newstart (car (car l)))
1754                 (setq l nil))
1755                (t
1756                 (setq l (cdr l))))))
1757
1758       ;;; \e$B?7$7$$\e(B transTable \e$B$r:n$k!%\e(B
1759       (while groups
1760         (let* ((group (car groups))
1761                (group-number (car group))
1762                (member-number (car (cdr group)))
1763                (member-alist (cdr (assoc member-number table))))
1764           (TREX-push (cons group-number
1765                                 (let ((group-alist nil))
1766                                   (while member-alist
1767                                     (let ((Mkey (car (car member-alist)))
1768                                           (Mnext (cdr (car member-alist))))
1769                                       (TREX-push  (cons Mkey (DFA-optimize-group-number Mnext))
1770                                                   group-alist))
1771                                     (setq member-alist (cdr member-alist)))
1772                                   (nreverse group-alist)))
1773                      newtable)
1774           (setq groups (cdr groups))))
1775       (cons newstart newtable))))
1776
1777 (defun DFA-optimize-group-number (node)
1778   (let ((l *DFA-optimize-groups*) (result nil))
1779     (while l
1780       (cond((TREX-memequal node (cdr (car l)))
1781             (setq result (car (car l))
1782                   l nil))
1783            (t (setq l (cdr l)))))
1784     result))
1785
1786 (defun DFA-optimize-parallel (FA)
1787   (if *DFA-optimize-debug* (terpri))
1788   (let* ((start (car FA))
1789          (table (cdr FA))
1790          (*DFA-optimize-node* 1)
1791          (*DFA-optimize-groups*
1792           (list (cons *DFA-optimize-node*  (mapcar 'car table)))))
1793     (while
1794         (catch 'DFA-optimize-changed
1795           (let ((groups *DFA-optimize-groups*))
1796             (while groups
1797               (if *DFA-optimize-debug*
1798                   (princ (format "\nGroups to be checked: %s\n" groups)))
1799               (let* ((Sgroup (car groups))
1800                      (Sgroup-number (car Sgroup))
1801                      (oldgroup (cdr Sgroup))
1802                      (newgroup nil)
1803                      (Smembers oldgroup))
1804                 (if *DFA-optimize-debug*
1805                     (princ (format " Sgroup-number: %s = %s\n" Sgroup-number Smembers)))
1806                 (while Smembers
1807                   (let* ((Snumber (car Smembers))
1808                          (Salist (cdr (assoc Snumber table))))
1809                     (if *DFA-optimize-debug*
1810                         (princ (format "  Snumber: %s\n" Snumber)))
1811                     (while Salist
1812                       (let* ((Spair (car Salist))
1813                              (Skey (car Spair))
1814                              (Snext (cdr Spair))
1815                              (Snext-group (DFA-optimize-group-number Snext))
1816                              (Tmembers oldgroup))
1817                         (if *DFA-optimize-debug*
1818                             (princ (format "   Skey: %s -> %s(%s)\n" Skey Snext-group Snext)))
1819                         (while Tmembers
1820                           (if (not (eq Snumber (car Tmembers)))
1821                               (let* ((Tnumber (car Tmembers))
1822                                      ;;; \e$BMW:F8!F$\e(B
1823                                      (Tpair (assoc Skey (cdr (assoc Tnumber table))))
1824                                      (Tnext (cdr Tpair))
1825                                      (Tnext-group (DFA-optimize-group-number (cdr Tpair))))
1826                                 (if *DFA-optimize-debug*
1827                                     (princ (format "    Tnumber: %s :  %s -> %s(%s)\n" Tnumber (car Tpair)
1828                                                    (DFA-optimize-group-number (cdr Tpair))(cdr Tpair))))
1829                                 (cond((and (equal Spair '(nil))
1830                                            (equal Tpair '(nil))))
1831                                      ((and Skey (equal Snext-group Tnext-group)))
1832                                      (t
1833                                       (TREX-push Tnumber newgroup)
1834                                       (setq oldgroup (TREX-delete Tnumber oldgroup))
1835                                       (if *DFA-optimize-debug*
1836                                           (princ(format (format "     oldGroup : %s\n     newGroup : %s\n" oldgroup newgroup))))
1837                                       ))))
1838                           (setq Tmembers (cdr Tmembers)))
1839                         (cond (newgroup
1840                                (if *DFA-optimize-debug*
1841                                    (princ (format "Changed :%s --> " Sgroup)))
1842                                (setcdr Sgroup oldgroup)
1843                                (if *DFA-optimize-debug*
1844                                    (princ (format "%s" Sgroup)))
1845                                (TREX-inc *DFA-optimize-node*)
1846                                (if *DFA-optimize-debug*
1847                                    (princ (format "+%s\n" (cons *DFA-optimize-node* newgroup))))
1848                                (TREX-push (cons *DFA-optimize-node* newgroup) *DFA-optimize-groups*)
1849                                (throw 'DFA-optimize-changed t))))
1850                       (setq Salist (cdr Salist))))
1851                   (setq Smembers (cdr Smembers))))
1852               (setq groups (cdr groups))))))
1853     ;;;
1854     ;;;
1855     (if *DFA-optimize-debug*
1856         (princ (format "table: %s\n" table)))
1857     (if *DFA-optimize-debug*
1858         (princ (format "groups: %s\n" *DFA-optimize-groups*)))
1859     (let ((newtable nil)
1860           (newstart nil)
1861           (groups *DFA-optimize-groups*))
1862
1863       ;;; start node \e$B$rC5$9\e(B
1864       (let ((l *DFA-optimize-groups*))
1865         (while l
1866           (cond((TREX-memequal start (cdr (car l)))
1867                 (setq newstart (car (car l)))
1868                 (setq l nil))
1869                (t
1870                 (setq l (cdr l))))))
1871
1872       ;;; \e$B?7$7$$\e(B transTable \e$B$r:n$k!%\e(B
1873       (while groups
1874         (let* ((group (car groups))
1875                (group-number (car group))
1876                (member-number (car (cdr group)))
1877                (member-alist (cdr (assoc member-number table))))
1878           (TREX-push   (cons group-number
1879                                 (let ((group-alist nil))
1880                                   (while member-alist
1881                                     (let ((Mkey (car (car member-alist)))
1882                                           (Mnext (cdr (car member-alist))))
1883                                       (TREX-push  (cons Mkey
1884                                                         (if (consp Mnext)
1885                                                             (cons (DFA-optimize-group-number (car Mnext))
1886                                                                   (DFA-optimize-group-number (cdr Mnext)))
1887                                                           (DFA-optimize-group-number Mnext)))
1888                                                   group-alist))
1889                                     (setq member-alist (cdr member-alist)))
1890                                   group-alist))
1891                        newtable)
1892           (setq groups (cdr groups))))
1893       (cons newstart newtable))))
1894
1895
1896
1897 ;;;
1898 ;;; Non Empty Finite Automata
1899 ;;;
1900
1901 (defun NEFA-make (EFFA)
1902   (let* ((start (car EFFA))
1903          (table (cdr EFFA))
1904          (Salist (cdr (assoc start table))))
1905     (cond((equal Salist '((nil)))
1906           nil)
1907          ((and (assoc nil Salist)
1908                (progn
1909                  (while (and Salist (not (equal start (cdr (car Salist)))))
1910                    (setq Salist (cdr Salist)))
1911                  Salist))
1912           (let ((min 10000)
1913                 (max -10000)
1914                 (l table))
1915             (while l
1916               (if (< (car (car l)) min)
1917                   (setq min (car (car l))))
1918               (if (< max (car (car l)))
1919                   (setq max (car (car l))))
1920               (setq l (cdr l)))
1921             (let* ((newstart (1- min))
1922                    (newtable (copy-alist table))
1923                    (oldSalist (cdr (assoc start table)))
1924                    (newSalist (TREX-delete '(nil) (copy-alist  oldSalist))))
1925               (cons newstart
1926                     (cons (cons newstart newSalist) newtable)))))
1927          (t
1928           EFFA))))
1929
1930 ;;;
1931 ;;; Simplify FA
1932 ;;;
1933
1934 (defvar *FA-simplify-table* nil)
1935
1936 (defun FA-simplify (FA)
1937   (let ((start (car FA))
1938         (table (cdr FA))
1939         (newtable nil)
1940         (*FA-simplify-table* nil))
1941     (FA-simplify-mark start table)
1942     (while *FA-simplify-table*
1943       (TREX-push  (assoc (car *FA-simplify-table*) table) newtable)
1944       (setq *FA-simplify-table* (cdr *FA-simplify-table*)))
1945     (cons start newtable)))
1946
1947 (defun FA-simplify-mark (node table)
1948   (cond ((not (TREX-memequal node *FA-simplify-table*))
1949          (TREX-push node *FA-simplify-table*)
1950          (let ((alist (cdr (assoc node table))))
1951            (while alist
1952              (cond((car (car alist))
1953                    (FA-simplify-mark (cdr (car alist)) table)))
1954              (setq alist (cdr alist)))))))
1955
1956 ;;;
1957 ;;;  Shortest match DFA
1958 ;;;
1959
1960 (defun DFA-shortest-match (DFA)
1961   (let ((start (car DFA))
1962         (table (cdr DFA))
1963         (newtable nil))
1964     (while table
1965       (cond ((assoc nil (cdr (car table)))
1966              (TREX-push  (cons (car (car table)) '((nil))) newtable))
1967             (t
1968              (TREX-push (car table) newtable)))
1969       (setq table (cdr table)))
1970     (cons start newtable)))
1971
1972 ;;;
1973 ;;;  Fastmap computation
1974 ;;;
1975
1976 (defvar *DFA-fastmap-chars*    nil)
1977 (defvar *DFA-fastmap-syntax*   nil)
1978 (defvar *DFA-fastmap-category* nil)
1979 (defvar *DFA-fastmap-init* 0 )
1980 (defvar *DFA-fastmap-pos*  1 ) ;;; SYNTAXSPEC or CATEGORYSPEC
1981 (defvar *DFA-fastmap-neg*  2 ) ;;; NOTSYNTAXSPEC or NOTCATEGORYSPEC
1982
1983 ;;;; \e$B$9$Y$F$N\e(B char \e$B$OB~0l$D$N\e(B syntaxspec \e$B$KB0$9$k\e(B
1984 ;;;; ==> syntaxspec(ch) and notsyntaxspec(ch) --> all char
1985 ;;;; ==> notsyntaxspec(ch1) and notsyntaxspec(ch2) --> all char
1986 ;;;; ==> notsyntaxspec(ch1) and syntaxspec(ch2) == notsyntaxspec(ch1)
1987 ;;;; \e$B$D$^$j\e(B notsyntaxspec \e$B$O9b!9#1$D$7$+$J$$!%\e(B
1988
1989 ;;; Returns [ CODE FASTMAP SYNTAX-FASTMAP CATEGOY-FASTMAP ]
1990
1991 (defun DFA-code-with-fastmap (DFA)
1992   (TREX-init *DFA-fastmap-chars* (make-vector 256 nil))
1993   (TREX-init *DFA-fastmap-syntax* (make-vector 256 nil))
1994   (TREX-init *DFA-fastmap-category* (make-vector 256 nil))
1995   (let ((code (regexp-code-gen DFA))
1996         (start (car DFA))
1997         (*DFA-fastmap-table* (cdr DFA))
1998         (*DFA-fastmap-mark* nil)
1999         (*DFA-fastmap-special* nil))
2000     (let ((i 0))
2001       (while (< i 256)
2002         (aset *DFA-fastmap-chars* i    nil)
2003         (aset *DFA-fastmap-syntax* i   nil)
2004         (aset *DFA-fastmap-category* i nil)
2005         (TREX-inc i)))
2006     (DFA-fastmap-collect start)
2007     (let ((fastmap (if *DFA-fastmap-special*
2008                        nil ;;;(make-string 256 1)
2009                      (make-string 256 0)))
2010           (fastmap-entries 0)
2011           (syntax (if *DFA-fastmap-special*
2012                       nil
2013                     (make-string 256 0)))
2014           (syntax-entries 0)
2015           (notsyntax-entries 0)
2016           (category (if *DFA-fastmap-special*
2017                         nil
2018                       (make-string 256 0)))
2019           (category-entries 0))
2020       (let ((result (make-vector 4 nil)))
2021         (aset result 0 code)
2022         (if *DFA-fastmap-special*
2023             (progn
2024               (aset result 1 fastmap)
2025               (aset result 2 syntax)
2026               (aset result 3 category))
2027           (progn
2028             (let ((i 0))
2029               (while (< i 256)
2030                 (if (aref *DFA-fastmap-chars* i)
2031                     (progn
2032                       (TREX-inc fastmap-entries)
2033                       (aset fastmap i 1)))
2034                 (aset syntax i
2035                       (cond((null (aref *DFA-fastmap-syntax* i))
2036                             *DFA-fastmap-init*)
2037                            ((eq (aref *DFA-fastmap-syntax* i) 'SYNTAXSPEC)
2038                             (TREX-inc syntax-entries)
2039                             *DFA-fastmap-pos*)
2040                            ((eq (aref *DFA-fastmap-syntax* i) 'NOTSYNTAXSPEC)
2041                             (TREX-inc notsyntax-entries)
2042                             (TREX-inc syntax-entries)
2043                             *DFA-fastmap-neg*)))
2044                 (aset category i
2045                       (cond((null (aref *DFA-fastmap-category* i))
2046                             *DFA-fastmap-init*)
2047                            ((eq (aref *DFA-fastmap-category* i) 'CATEGORYSPEC)
2048                             (TREX-inc category-entries)
2049                             *DFA-fastmap-pos*)
2050                            ((eq (aref *DFA-fastmap-category* i) 'NOTCATEGORYSPEC)
2051                             (TREX-inc category-entries)
2052                             *DFA-fastmap-neg*)))
2053                 (TREX-inc i)))
2054
2055             (cond((<= 2 notsyntax-entries)
2056                   (setq fastmap (make-string 256 1)
2057                         syntax nil
2058                         category nil))
2059                  ((= 1 notsyntax-entries)
2060                   (let ((ch 0))
2061                     (while (< ch 256)
2062                       (if (= (aref syntax ch) *DFA-fastmap-neg*)
2063                           (aset syntax ch *DFA-fastmap-init*)
2064                         (aset syntax ch *DFA-fastmap-pos*))
2065                       (TREX-inc ch)))))
2066             (aset result 1 fastmap)
2067             (aset result 2 syntax)
2068             (aset result 3 category)))
2069         result))))
2070
2071 (defun DFA-fastmap-collect (node)
2072   (if (TREX-memequal node *DFA-fastmap-mark*) nil
2073     (let ((alist (cdr (assoc node *DFA-fastmap-table*))))
2074       (TREX-push node *DFA-fastmap-mark*)
2075       (while alist
2076         (let ((key (car (car alist))))
2077           (cond((numberp key)
2078                 (aset *DFA-fastmap-chars* key t))
2079                ((symbolp key);;; can be null
2080                 (setq *DFA-fastmap-special* t))
2081                (t
2082                 (let ((op (car key)))
2083                   (cond
2084                    ((TREX-memequal op '(START_MEMORY STOP_MEMORY))
2085                     (DFA-fastmap-collect (cdr (car alist))))
2086                    ((TREX-memequal op '(SYNTAXSPEC NOTSYNTAXSPEC))
2087                     (let ((specch (syntax-code-spec (nth 1 key))))
2088                       (cond((null (aref *DFA-fastmap-syntax* (nth 1 key)))
2089                             (aset *DFA-fastmap-syntax* specch op))
2090                            ((not (eq (aref *DFA-fastmap-syntax* specch) op))
2091                             (setq *DFA-fastmap-special* t)))))
2092                    ((TREX-memequal op '(CATEGORYSPEC NOTCATEGORYSPEC))
2093                     (let ((specch (nth 1 key)))
2094                       (cond((null (aref *DFA-fastmap-category* specch))
2095                             (aset *DFA-fastmap-category* specch op))
2096                            ((not (eq (aref *DFA-fastmap-category* specch) op))
2097                             (setq *DFA-fastmap-special* t)))))
2098                    ((TREX-memequal op '(CHARSET CHARSET_NOT))
2099                     (let ((list (cdr key)))
2100                       (while list
2101                         (let ((from nil) (to nil))
2102                           (cond((stringp (car list))
2103                                 (setq from (aref (car list) 0)
2104                                       to   (aref (car list) 0)))
2105                                (t ;;; :range
2106                                 (setq from (aref (nth 1 (car list)) 0)
2107                                       to   (aref (nth 2 (car list)) 0))))
2108                           (while (<= from to)
2109                             (cond((null (aref *DFA-fastmap-chars* from))
2110                                   (aset *DFA-fastmap-chars* from
2111                                         (if (eq op 'CHARSET_NOT) 'CHARSET_NOT
2112                                           t))))
2113                             (TREX-inc from)))
2114                         (setq list (cdr list))))
2115                     (if (eq op 'CHARSET_NOT)
2116                         (let ((i 0))
2117                           (while (< i 256)
2118                             (cond((null (aref *DFA-fastmap-chars* i))
2119                                   (aset *DFA-fastmap-chars* i t))
2120                                  ((eq (aref *DFA-fastmap-chars* i) 'CHARSET_NOT)
2121                                   (aset *DFA-fastmap-chars* i nil)))
2122                             (TREX-inc i)))))
2123                    (t
2124                     (setq *DFA-fastmap-special* t)))))))
2125         (setq alist (cdr alist))))))
2126
2127 ;;;
2128 ;;; \e$B@55,I=8=%3!<%I$NL?NaI=\e(B
2129 ;;;
2130
2131 (if (= regexp-version 19)
2132     (TREX-define-enum
2133      UNUSED           ;;; 18
2134      EXACTN           ;;; 18
2135      ANYCHAR          ;;; 18
2136      CHARSET          ;;; 18
2137      CHARSET_NOT      ;;; 18
2138      START_MEMORY     ;;; 18*
2139      STOP_MEMORY      ;;; 18*
2140      DUPLICATE        ;;; 18
2141      BEGLINE          ;;; 18
2142      ENDLINE          ;;; 18
2143      BEGBUF           ;;; 18
2144      ENDBUF           ;;; 18
2145      JUMP             ;;; 18
2146      JUMP_PAST_ALT    ;;; 19
2147      ON_FAILURE_JUMP  ;;; 18
2148      ON_FAILURE_KEEP_STRING_JUMP ;;; 19
2149      ;;;; finalize_jump
2150      ;;;; maybe_finalize_jump
2151      POP_FAILURE_JUMP   ;;; 19
2152      MAYBE_POP_JUMP     ;;; 19
2153      DUMMY_FAILURE_JUMP   ;;; 18
2154      PUSH_DUMMY_FAILURE  ;;; 19
2155      SUCCEED_N ;;; 19
2156      JUMP_N    ;;; 19
2157      SET_NUMBER_AT ;;; 19
2158      WORDCHAR          ;;; 18
2159      NOTWORDCHAR       ;;; 18
2160      WORDBEG           ;;; 18
2161      WORDEND           ;;; 18
2162      WORDBOUND         ;;; 18
2163      NOTWORDBOUND      ;;; 18
2164      BEFORE_DOT        ;;; 18
2165      AT_DOT            ;;; 18
2166      AFTER_DOT         ;;; 18
2167      SYNTAXSPEC        ;;; 18
2168      NOTSYNTAXSPEC     ;;; 18
2169      ;;; TREX code
2170      EXACT1
2171      EXACT2
2172      EXACT3
2173      CHARSET_M
2174      CHARSET_M_NOT
2175      CASEN
2176      SUCCESS_SHORT
2177      SUCCESS
2178      POP
2179      EXCEPT0
2180      EXCEPT1
2181      CATEGORYSPEC
2182      NOTCATEGORYSPEC
2183      RANGE
2184      RANGE_A
2185      )
2186   ;; else regexp-version == 18.
2187   (TREX-define-enum
2188    UNUSED
2189    EXACTN
2190    BEGLINE
2191    ENDLINE
2192    JUMP
2193    ON_FAILURE_JUMP
2194    FINALIZE_JUMP
2195    MAYBE_FINALIZE_JUMP
2196    DUMMY_FAILURE_JUMP
2197    ANYCHAR
2198    CHARSET
2199    CHARSET_NOT
2200    START_MEMORY
2201    STOP_MEMORY
2202    DUPLICATE
2203    BEFORE_DOT  ;;; not used
2204    AT_DOT      ;;; not used
2205    AFTER_DOT   ;;; not used
2206    BEGBUF
2207    ENDBUF
2208    WORDCHAR    ;;; not used
2209    NOTWORDCHAR ;;; not used
2210    WORDBEG
2211    WORDEND
2212    WORDBOUND
2213    NOTWORDBOUND
2214    SYNTAXSPEC
2215    NOTSYNTAXSPEC
2216 ;;;
2217 ;;; extended instructions
2218 ;;;
2219    EXACT1
2220    EXACT2
2221    EXACT3
2222    CHARSET_M
2223    CHARSET_M_NOT
2224    CASEN
2225    SUCCESS_SHORT ;;; == ON_FAILURE_SUCCESS
2226    SUCCESS
2227    POP
2228    EXCEPT0 ;;; ALLCHAR
2229    EXCEPT1
2230    CATEGORYSPEC
2231    NOTCATEGORYSPEC
2232    ))
2233
2234 (defvar ON_FAILURE_SUCCESS SUCCESS_SHORT)
2235
2236 ;;;
2237 ;;; ANYCHAR = EXCEPT1 \n
2238 ;;; ALLCHAR = EXCEPT0
2239
2240
2241 ;;;
2242 ;;;  \e$B@55,I=8=>H9g4o$NL?NaBN7O\e(B
2243 ;;;
2244 ;;;  UNUSED
2245 ;;;  EXACTN n ch1 ch2 ... chn
2246 ;;;  BEGLINE
2247 ;;;  ENDLINE
2248 ;;;  JUMP disp[2]
2249 ;;; +JUMP_PAST_ALT disp[2]
2250 ;;;  ON_FAILURE_JUMP disp[2]
2251 ;;; +ON_FAILURE_KEEP_STRING_JUMP disp[2]
2252 ;;; -FINALIZE_JUMP disp[2]
2253 ;;; -MAYBE_FINALIZE_JUMP disp[2]
2254 ;;; +POP_FAILURE_JUMP disp[2]
2255 ;;; +MAYBE_POP_JUMP disp[2]
2256 ;;;  DUMMY_FAILURE_JUMP disp[2]
2257 ;;; +PUSH_DUMMY_FAILURE
2258 ;;; +SUCCEED_N disp[2] n[2]
2259 ;;; +JUMP_N disp[2] n[2]
2260 ;;; +SET_NUMBER_AT disp[2] n[2]
2261 ;;;  ANYCHAR
2262 ;;;  CHARSET n b1 b2 ... bn
2263 ;;;**CHARSET 0xff l1 l2 cf1 ct1 cf2 ct2 ... cfn ctn
2264 ;;;  CHARSET_NOT n b1 b2 ... bn
2265 ;;;**CHARSET_NOT 0xff l1 l2 cf1 ct1 cf2 ct2 ... cfn ctn
2266 ;;; \e$B0J2<$O$($J$_;a$NDs0F$K$h$k?7$?$J%;%^%s%F%#%C%/%9\e(B
2267 ;;
2268 ;;;  CHARSET n      b1 b2 ... bn  (n < 0x80)
2269 ;;;  CHARSET n+0x80 b1 b2 ...     bn
2270 ;;;                |<-- n bytes -->|
2271 ;;;         lh lo CHARF1 CHART1 ....  CHARFm CHARTm
2272 ;;;               |<-  lh << 8 + lo bytes         ->|
2273 ;;      CHARSET n b1 b2 ... bn lh lo cf1 ct1 cf2 ct2 ... cfn ctn
2274 ;;               |<- bitmap ->|     |<-     range table       ->|
2275 ;;      CHARSET_NOT n b1 b2 ... bn lh lo cf1 ct1 cf2 ct2 ... cfn ctn
2276 ;;      CHARSETM m n b1 b2 ... bn lh lo cf1 ct1 cf2 ct2 ... cfn ctn
2277 ;;      CHARSETM_NOT m n b1 b2 ... bn lh lo cf1 ct1 cf2 ct2 ... cfn ctn
2278 ;;
2279 ;;        o cfx, ctx \e$B0J30$O$9$Y$F\e(B 1byte.  cfx, ctx \e$B$O\e(B multi byte
2280 ;;          character.
2281 ;;
2282 ;;        o CHARSET(_NOT) \e$B$H\e(B CHARSETM(_NOT) \e$B$H$N0c$$$O\e(B, CHARSETM(_NOT)
2283 ;;          \e$B$N>l9g$K$O\e(B bitmap \e$B$N@hF,$N\e(B m bytes \e$B$,>J$+$l$F$$$kE@\e(B.
2284 ;;
2285 ;;        o b1 ... bn (\e$B$D$^$j\e(B bitmap\e$B$ND9$5\e(B)\e$B$O\e(B, (n & 0x7f) bytes.  n \e$B$N\e(B
2286 ;;          \e$BJ,\e(B 1byte \e$B$O4^$^$J$$\e(B.
2287 ;;
2288 ;;        o lh \e$B0J2<$O\e(B n & 0x80 \e$B$,\e(B 0 \e$B$J$iB8:_$7$J$$\e(B.
2289 ;;
2290 ;;        o lh \e$B$+$i\e(B ctn \e$B$^$G$ND9$5\e(B(\e$B$D$^$j\e(B range table \e$B$ND9$5\e(B) \e$B$O\e(B ((lh
2291 ;;          << 8) + lo) byte.  lh \e$B$H\e(B lo \e$B$N\e(B 2byte \e$B$r4^$`\e(B.  (\e$B>e$N\e(B n \e$B$N>l\e(B
2292 ;;          \e$B9g$H0c$$$^$9$,\e(B, \e$BE}0l$7$?$[$&$,$$$$$+$J\e(B?).
2293 ;;
2294 ;;        o cfx \e$B$O\e(B multi byte character \e$B$G\e(B, cfx \e$B$H\e(B ctx \e$B$N\e(B leading char
2295 ;;          \e$B$OF1$8$G$J$$$H$$$1$J$$\e(B.  \e$B$^$?\e(B, cfx \e$B$N\e(B leading char \e$B$O\e(B 0 \e$B$G\e(B
2296 ;;          \e$B$"$C$F$O$$$1$J$$\e(B(range table \e$B$K\e(B leading char \e$B$,\e(B 0 (ASCII\e$B$H\e(B
2297 ;;          \e$B$+\e(B) \e$B$NJ8;z$,$"$C$F$b\e(B, \e$B8=:_$O\e(B fastmap \e$B$KH?1G$5$l$J$$$+$i\e(B).
2298 ;;
2299 ;;;  START_MEMORY regno
2300 ;;;  STOP_MEMORY regno
2301 ;;;       o emacs 19 \e$B$N\e(B regex.c \e$B$G$O\e(B,
2302 ;;;         START_MEMORY regno groupno
2303 ;;;         STOP_MEMORY regno groupno
2304 ;;;         groupno \e$B$O<+J,$h$j2<$N%l%Y%k$N%0%k!<%W$N?t\e(B
2305 ;;;
2306 ;;;  DUPLICATE regno
2307 ;;;  BEFORE_DOT   ;;; not used
2308 ;;;  AT_DOT       ;;; not used
2309 ;;;  AFTER_DOT    ;;; not used
2310 ;;;  BEGBUF
2311 ;;;  ENDBUF
2312 ;;;  WORDCHAR     ;;; not used
2313 ;;;  NOTWORDCHAR  ;;; not used
2314 ;;;  WORDBEG
2315 ;;;  WORDEND
2316 ;;;  WORDBOUND
2317 ;;;  NOTWORDBOUND
2318 ;;;  SYNTAXSPEC ch
2319 ;;;  NOTSYNTAXSPEC ch
2320
2321 ;;;
2322 ;;;  \e$B3HD%L?Na!J\e(BTREX\e$B$G;HMQ$9$k$b$N!K\e(B
2323 ;;;
2324 ;;;  EXACT1 ch
2325 ;;;  EXACT2 ch1 ch2
2326 ;;;  EXACT3 ch1 ch2 ch3
2327 ;;;  CHARSETM m n b1 b2 .. bn
2328 ;;;    charset \e$B$N\e(B bitmaps \e$B$N$&$A@hF,$N\e(B m bytes \e$B$r>J$$$?$b$N\e(B
2329 ;;;  CHARSETM_NOT m n b1 b2 .. bn
2330 ;;;    charset_not \e$B$N\e(B bitmaps \e$B$N$&$A@hF,$N\e(B m bytes \e$B$r>J$$$?$b$N\e(B
2331 ;;;  CASEN n disp[1] disp[2] ... disp[n] l u ind[l] ... ind[u]
2332 ;;;    \e$B:G=i$K\e(B n \e$B8D$N\e(B jump relative address(2bytes) \e$B$,B3$-!$\e(B
2333 ;;;    \e$B<!$K\e(Bcharacter code l \e$B$+$i\e(B m \e$B$^$G$NJ,$N\e(Bindex(1byte)\e$B$,B3$/!%\e(B
2334 ;;;  ON_FAILURE_SUCCESS
2335 ;;;    alternative stack \e$B$r6u$K$7!$\e(Bpend \e$B$r\e(B push \e$B$9$k!%\e(B
2336 ;;;  SUCCESS
2337 ;;;    pend \e$B$X%8%c%s%W$9$k!%\e(B
2338 ;;;  POP
2339 ;;;    alternative stack \e$B$r\e(B pop \e$B$9$k!%\e(B
2340
2341 ;;;  RANGE ch1 ch2
2342 ;;;  RANGE_A == RANGE 0xA0 0xFF
2343
2344
2345 ;;;  [^\e$B&A\e(B]\e$B&B\e(B\|\e$B&C\e(B \e$B$N0UL#!'\e(B
2346 ;;;     on_failure_jump L1
2347 ;;;     on_failure_jump L2
2348 ;;;     \e$B&A\e(B
2349 ;;;     pop
2350 ;;;     fail
2351 ;;; L1: ALLCHAR
2352 ;;;     \e$B&B\e(B
2353 ;;; L2: pop
2354 ;;;     \e$B&C\e(B
2355
2356 ;;;
2357 ;;;  regexp-code-*
2358 ;;;
2359
2360 (defvar *regexp-code-buffer* (get-buffer-create " *regexp-code-buffer*"))
2361
2362 (defun regexp-code-gen (FA)
2363   (let ((start (car FA))
2364         (table (cdr FA))
2365         (*table* (cdr FA))
2366         (*labels* nil)
2367         (*final* nil)
2368         (*counter* 0))
2369     (let ((list table))
2370       (while (and list (null *final*))
2371         (if (equal '((nil)) (cdr (car list)))
2372             (setq *final* (car (car list))))
2373         (setq list (cdr list))))
2374     (cond((null *final*)
2375           (setq *final* (1+ (length table)))
2376           (setq *counter* (1+ *final*)))
2377          (t
2378           (setq *counter* (1+ (length table)))))
2379     (save-excursion
2380       (set-buffer *regexp-code-buffer*)
2381       (let ((kanji-flag nil)
2382             (mc-flag nil))
2383         (erase-buffer)
2384         (regexp-code-gen* start)
2385         (buffer-substring (point-min) (point-max)))
2386       )))
2387
2388 (defun regexp-code-gen* (node)
2389   (cond((= node *final*)
2390         (if (null (assoc node *labels*))
2391             (TREX-push  (cons node (point)) *labels*))
2392         (insert SUCCESS))
2393        ((null (assoc node *labels*))
2394         (TREX-push (cons node (point)) *labels*)
2395         (let ((alist (cdr (assoc node *table*))))
2396           (cond((equal '((nil)) alist)
2397                 (insert SUCCESS))
2398                (t (regexp-code-gen-alist alist)))))
2399        (t
2400         (let ((disp (- (cdr (assoc node *labels*)) (+ (point) 3))))
2401           (insert JUMP
2402                   (logand disp 255)
2403                   (/ (logand disp (* 255 256)) 256))))))
2404
2405 (defvar *regexp-charset-table* nil)
2406 (defvar *regexp-case-table* nil)
2407
2408 (defun regexp-code-gen-alist (alist)
2409   (TREX-init *regexp-charset-table* (make-vector 256 nil))
2410   (TREX-init *regexp-case-table* (make-vector 256 nil))
2411   (if (eq (car (car alist)) nil)
2412       nil
2413     (let ((nextalist alist)
2414           (numberkey nil)
2415           (point nil)
2416           (min 256) (max -1) (nexts nil) (nodealist nil))
2417       (cond((numberp (car (car alist)))
2418             (setq numberkey t)
2419             (let ((i 0))
2420               (while (< i 256)
2421                 (aset *regexp-case-table* i nil)
2422                 (TREX-inc i)))
2423
2424             (while (and nextalist
2425                         (numberp (car (car nextalist))))
2426               (let ((ch (car (car nextalist)))
2427                     (next (cdr (car nextalist))))
2428                 (let ((place (assoc next nodealist)))
2429                   (if place
2430                       (setcdr place
2431                               (cons ch (cdr place)))
2432                     (TREX-push  (cons ch (list next)) nodealist)))
2433                 (aset *regexp-case-table* ch next)
2434                 (if (< ch min) (setq min ch))
2435                 (if (< max ch) (setq max ch))
2436                 (if (not (TREX-memequal next nexts))
2437                     (TREX-push next nexts)))
2438               (setq nextalist (cdr nextalist))))
2439            (t (setq nextalist (cdr alist))))
2440
2441       (if nextalist
2442           (cond((eq (car (car nextalist)) nil)
2443                 (insert ON_FAILURE_SUCCESS )) ;;; SUCCESS_SHORT
2444                (t
2445                 (insert ON_FAILURE_JUMP 0 0)
2446                 (setq point (point)))))
2447
2448       (cond(numberkey
2449             (cond((= min max)
2450                 ;;; exact1
2451                   (regexp-code-gen-exact (list min) (car nexts)))
2452
2453                  ((= (length nexts) 1)
2454                 ;;; charset or charset_not
2455                   (if (= (length alist) 256)
2456                       (insert EXCEPT0)  ;92.10.26 by T.Saneto
2457                     (let ((not_min 256)
2458                           (not_max -1)
2459                           (ch 0)
2460                           (mode (car nexts)))
2461                       (while (< ch 256)
2462                         (cond((null (aref *regexp-case-table* ch))
2463                               (if (< ch not_min) (setq not_min ch))
2464                               (if (< not_max ch) (setq not_max ch))))
2465                         (TREX-inc ch))
2466                       (if (<= (- not_max not_min) (- max min))
2467                           (setq min not_min
2468                                 max not_max
2469                                 mode nil))
2470                       (let ((minb (/ min 8))
2471                             (maxb (1+ (/ max 8))))
2472                         (insert (if mode CHARSET_M CHARSET_M_NOT) minb (- maxb minb))
2473                         (let ((b minb))
2474                           (while (< b maxb)
2475                             (let ((i 7) (bits 0))
2476                               (while (<= 0 i)
2477                                 (if (eq (aref *regexp-case-table* (+ (* 8 b) i))
2478                                         mode)
2479                                     ;;;; bits table\e$B$N=g=x$O<!$NDL$j\e(B
2480                                     (TREX-inc bits (aref [1 2 4 8 16 32 64 128] i)))
2481                                 (TREX-dec i))
2482                               (insert bits))
2483                             (TREX-inc b))))))
2484                   (regexp-code-gen* (car nexts)))
2485                  (t
2486                 ;;; case
2487                   (let ((point nil))
2488                     (insert CASEN)
2489                     (insert (length nexts))
2490                     (setq point (point))
2491                     (let ((list nexts))
2492                       (while list
2493                         (insert 0 0)
2494                         (setq list (cdr list))))
2495                     (insert min max)
2496                     (let ((ch min))
2497                       (while (<= ch max)
2498                         (if (aref *regexp-case-table* ch)
2499                             (insert (1+ (TREX-find (aref *regexp-case-table* ch) nexts)))
2500                           (insert 0))
2501                         (TREX-inc ch)))
2502                     (let ((list nexts))
2503                       (while list
2504                         (if (null (assoc (car list) *labels*))
2505                             (regexp-code-gen* (car list)))
2506                         (setq list (cdr list))))
2507                     (save-excursion
2508                       (goto-char point)
2509                       (let ((list nexts))
2510                         (while list
2511                           (delete-char 2)
2512                           (let ((disp (- (cdr (assoc (car list) *labels*)) (+ (point) 2))))
2513                             (insert (logand disp 255)
2514                                     (/ (logand disp (* 255 256)) 256)))
2515                           (setq list (cdr list)))))
2516                     ))))
2517            ((eq (car (car alist)) ':epsilon)
2518             (regexp-code-gen* (cdr (car alist))))
2519            (t
2520             (let ((key (car (car alist)))
2521                   (next (cdr (car alist))))
2522               (cond ((symbolp key)
2523                      (insert (eval key)))
2524                     ((TREX-memequal (car key) '(CHARSET CHARSET_NOT))
2525                      (let ((charset (cdr key))
2526                            (min 128) (max -1)
2527                            (mcbytes 0)
2528                            (mcchars nil))
2529                        (let ((i 0))
2530                          (while (< i 256)
2531                            (aset *regexp-charset-table* i nil)
2532                            (TREX-inc i)))
2533                        (while charset
2534                          (cond((stringp (car charset))
2535                                (cond((eq (length (car charset)) 1)
2536                                      (aset *regexp-charset-table* (aref (car charset) 0) t)
2537                                      (if (< (aref (car charset) 0) min)
2538                                          (setq min (aref (car charset) 0)))
2539                                      (if (< max (aref (car charset) 0))
2540                                          (setq max (aref (car charset) 0)))
2541                                      )
2542                                     (t
2543                                      (TREX-inc mcbytes  (* 2 (length (car charset))))
2544                                      (if (null mcchars) (setq mcchars charset))
2545                                      )))
2546                               ((consp (car charset)) ;;; range
2547                                (cond ((eq (length (nth 1 (car charset))) 1)
2548                                       (let ((from (aref (nth 1 (car charset)) 0))
2549                                             (to   (aref (nth 2 (car charset)) 0)))
2550                                         (if (< from min) (setq min from))
2551                                         (if (< max to) (setq max to))
2552                                         (while (<= from to)
2553                                           (aset *regexp-charset-table* from t)
2554                                           (TREX-inc from)))
2555                                       )
2556                                      (t
2557                                       (TREX-inc mcbytes
2558                                                 (+ (length (nth 1 (car charset))) (length (nth 2 (car charset)))))
2559                                       (if (null mcchars) (setq mcchars charset))))))
2560                          (setq charset (cdr charset)))
2561                        (cond ((< max min)
2562                               (insert (if (eq (car key) 'CHARSET) CHARSET CHARSET_NOT)
2563                                       (if (< 0 mcbytes) 128 0)))
2564                              (t
2565                               (let ((minb (/ min 8))
2566                                     (maxb (1+ (/ max 8))))
2567                                 (insert (if (eq (car key) 'CHARSET) CHARSET_M CHARSET_M_NOT)
2568                                         minb (+ (if (< 0 mcbytes) 128 0)  (- maxb minb)))
2569                                 (let ((b minb))
2570                                   (while (< b maxb)
2571                                     (let ((i 7) (bits 0))
2572                                       (while (<= 0 i)
2573                                         (if (aref *regexp-charset-table* (+ (* 8 b) i))
2574                                             ;;;; bits table\e$B$N=g=x$O<!$NDL$j\e(B
2575                                             (TREX-inc bits (aref [1 2 4 8 16 32 64 128] i)))
2576                                         (TREX-dec i))
2577                                       (insert bits))
2578                                     (TREX-inc b))))))
2579
2580                        (cond( (< 0 mcbytes)
2581                               (TREX-inc mcbytes 2)
2582                               (insert (/ mcbytes 256) (mod mcbytes 256))
2583                               (while mcchars
2584                                 (cond((stringp (car mcchars))
2585                                       (insert (car mcchars) (car mcchars)))
2586                                      ((consp (car mcchars))
2587                                       (insert (nth 1 (car mcchars)) (nth 2 (car mcchars)))))
2588                                 (setq mcchars (cdr mcchars)))))
2589                        ))
2590                     ((= (length key) 1)
2591                      (insert (eval (car key))))
2592                     ((= (length key) 2)
2593                      (insert (eval (car key)) (nth 1 key)))
2594                     ((= (length key) 3)
2595                      (insert (eval (car key)) (nth 1 key) (nth 2 key)))
2596                     (t
2597                      (regexp-error)))
2598               (regexp-code-gen* next))))
2599       (if point
2600           (let ((disp (- (point) point)))
2601             (save-excursion
2602               (goto-char point)
2603               (delete-char -2)
2604               (insert (logand disp 255)
2605                       (/ (logand disp (* 255 256)) 256)))
2606             (regexp-code-gen-alist nextalist))))))
2607
2608 (defun regexp-code-gen-exact (chars node)
2609   (let ((alist (cdr (assoc node *table*))))
2610     (cond((and (null (assoc node *labels*))
2611                (= (length alist) 1)
2612                (numberp (car (car alist))))
2613           (regexp-code-gen-exact (cons (car (car alist)) chars)
2614                                  (cdr (car alist))))
2615          (t
2616           (regexp-code-gen-exact* (reverse chars))
2617           (regexp-code-gen* node)))))
2618
2619 (defun regexp-code-gen-exact* (chars)
2620   (cond((= (length chars) 1)
2621         (insert EXACT1 (car chars)))
2622        ((= (length chars) 2)
2623         (insert EXACT2 (car chars) (nth 1 chars)))
2624        ((= (length chars) 3)
2625         (insert EXACT3 (car chars) (nth 1 chars) (nth 2 chars)))
2626        (t
2627         (insert EXACTN (length chars))
2628         (let ((list chars))
2629           (while list
2630             (insert (car list))
2631             (setq list (cdr list)))))))
2632
2633 ;;;
2634 ;;; regexp-code-dump
2635 ;;; \e$B@55,I=8=$N%3!<%I$rI=<($9$k!%\e(B
2636 ;;;
2637
2638 (defvar *regexp-code-dump* nil)
2639 (defvar *regexp-code-index* nil)
2640
2641 (defun regexp-code-dump (*regexp-code-dump*)
2642   (terpri)
2643   (let ((*regexp-code-index* 0)
2644         (max (length *regexp-code-dump*)))
2645     (while (< *regexp-code-index* max)
2646       (princ (format "%4d:" *regexp-code-index*))
2647       (let((op (aref *regexp-code-dump* *regexp-code-index*)))
2648         (cond((= op UNUSED) (regexp-code-dump-0 "unused"))
2649              ((= op EXACTN)
2650               (princ (format "exactn(%d) " (aref *regexp-code-dump* (1+ *regexp-code-index*))))
2651               (let ((j (+ *regexp-code-index* 2))
2652                     (max (+ *regexp-code-index* 2 (aref *regexp-code-dump* (1+ *regexp-code-index*)))))
2653                 (while (< j max)
2654                   (princ (format "%c" (aref *regexp-code-dump* j)))
2655                   (TREX-inc j))
2656                 (setq *regexp-code-index* j))
2657               (terpri)
2658               )
2659              ((= op BEGLINE) (regexp-code-dump-0 "begline"))
2660              ((= op ENDLINE) (regexp-code-dump-0 "endline"))
2661              ((= op JUMP) (regexp-code-dump-jump "jump"))
2662              ((and (= regexp-version 19)
2663                    (= op JUMP_PAST_ALT))
2664               (regexp-code-dump-jump "jump_past_alt"))
2665              ((= op ON_FAILURE_JUMP ) (regexp-code-dump-jump "on_failure_jump"))
2666              ((and (= regexp-version 19)
2667                    (= op ON_FAILURE_KEEP_STRING_JUMP))
2668                (regexp-code-dump-jump "on_failure_keep_string_jump"))
2669              ((and (= regexp-version 18)
2670                    (= op FINALIZE_JUMP))
2671               (regexp-code-dump-jump "finalize_jump"))
2672              ((and (= regexp-version 18)
2673                    (= op MAYBE_FINALIZE_JUMP))
2674               (regexp-code-dump-jump "maybe_finalize_jump"))
2675              ((and (= regexp-version 19)
2676                    (= op POP_FAILURE_JUMP))
2677               (regexp-code-dump-jump "pop_failure_jump"))
2678              ((and (= regexp-version 19)
2679                    (= op MAYBE_POP_JUMP))
2680               (regexp-code-dump-jump "maybe_pop_jump"))
2681              ((= op DUMMY_FAILURE_JUMP) (regexp-code-dump-jump "dummy_failure_jump"))
2682              ((and (= regexp-version 19)
2683                    (= op PUSH_DUMMY_FAILURE))
2684               (regexp-code-dump-0 "push_dummy_failure"))
2685              ((and (= regexp-version 19)
2686                    (= op SUCCEED_N))
2687               (regexp-code-dump-jump-2 "succeed_n"))
2688              ((and (= regexp-version 19)
2689                    (= op JUMP_N))
2690               (regexp-code-dump-jump-2 "jump_n"))
2691              ((and (= regexp-version 19)
2692                    (= op SET_NUMBER_AT))
2693               (regexp-code-dump-jump-2 "SET_NUMBER_AT"))
2694              ((= op ANYCHAR) (regexp-code-dump-0 "anychar"))
2695              ((= op CHARSET) (regexp-code-dump-charset "charset"))
2696              ((= op CHARSET_NOT) (regexp-code-dump-charset "charset_not"))
2697              ((= op START_MEMORY)
2698               (if (= regexp-version 19)
2699                   (regexp-code-dump-2 "start_memory")
2700                 (regexp-code-dump-1 "start_memory")))
2701              ((= op STOP_MEMORY)
2702               (if (= regexp-version 19)
2703                   (regexp-code-dump-2 "stop_memory")
2704                 (regexp-code-dump-1 "stop_memory")))
2705              ((= op DUPLICATE) (regexp-code-dump-1 "duplicate"))
2706              ((= op BEFORE_DOT) (regexp-code-dump-0 "before_dot"))
2707              ((= op AT_DOT) (regexp-code-dump-0 "at_dot"))
2708              ((= op AFTER_DOT) (regexp-code-dump-0 "after_dot"))
2709              ((= op BEGBUF) (regexp-code-dump-0 "begbuf"))
2710              ((= op ENDBUF) (regexp-code-dump-0 "endbuf"))
2711              ((= op WORDCHAR) (regexp-code-dump-0 "wordchar"))
2712              ((= op NOTWORDCHAR) (regexp-code-dump-0 "notwordchar"))
2713              ((= op WORDBEG) (regexp-code-dump-0 "wordbeg"))
2714              ((= op WORDEND) (regexp-code-dump-0 "wordend"))
2715              ((= op WORDBOUND) (regexp-code-dump-0 "wordbound"))
2716              ((= op NOTWORDBOUND) (regexp-code-dump-0 "notwordbound"))
2717              ((= op SYNTAXSPEC) (regexp-code-dump-syntax "syntaxspec"))
2718              ((= op NOTSYNTAXSPEC) (regexp-code-dump-syntax "notsyntaxspec"))
2719              ((= op EXACT1) (regexp-code-dump-1ch "EXACT1"))
2720              ((= op EXACT2)
2721               (princ (format "EXACT2 %c%c\n" (aref *regexp-code-dump* (1+ *regexp-code-index*))
2722                              (aref *regexp-code-dump* (+ *regexp-code-index* 2))))
2723               (TREX-inc *regexp-code-index* 3))
2724              ((= op EXACT3)
2725               (princ (format "EXACT3 %c%c%c\n"
2726                              (aref *regexp-code-dump* (1+ *regexp-code-index*))
2727                              (aref *regexp-code-dump* (+ *regexp-code-index* 2))
2728                              (aref *regexp-code-dump* (+ *regexp-code-index* 3))))
2729               (TREX-inc *regexp-code-index* 4))
2730              ((= op CHARSET_M) (regexp-code-dump-charset-m "CHARSET_M"))
2731              ((= op CHARSET_M_NOT) (regexp-code-dump-charset-m "CHARSET_M_NOT"))
2732              ((= op CASEN)
2733               (princ (format "CASEN %d\n" (aref *regexp-code-dump* (1+ *regexp-code-index*))))
2734               (let ((j (+ *regexp-code-index* 2))
2735                     (max (+ *regexp-code-index* 2 (* 2 (aref *regexp-code-dump* (1+ *regexp-code-index*))))))
2736                 (while (< j max)
2737                   (princ (format "[%d]::%d\n" (1+ (/ (- j (+ *regexp-code-index* 2)) 2))
2738                                  (regexp-get-absolute-address
2739                                   (+ j 2) (aref *regexp-code-dump* j)
2740                                   (aref *regexp-code-dump* (1+ j)))))
2741                   (TREX-inc j 2))
2742                 (let ((ch (aref *regexp-code-dump* j)) (chmax (aref *regexp-code-dump* (1+ j))))
2743                   (princ (format "%c::%c\n" ch chmax))
2744                   (TREX-inc j 2)
2745                   (while (<= ch chmax)
2746                     (princ (format "%c=>[%d]\n" ch (aref *regexp-code-dump* j)))
2747                     (TREX-inc j)
2748                     (TREX-inc ch)))
2749                 (setq *regexp-code-index* j)))
2750              ((= op ON_FAILURE_SUCCESS) (regexp-code-dump-0 "ON_FAILURE_SUCCESS"))
2751              ((= op SUCCESS) (regexp-code-dump-0 "SUCCESS"))
2752              ((= op POP) (regexp-code-dump-0 "POP"))
2753              ((= op EXCEPT0) (regexp-code-dump-0 "EXCEPT0"))
2754              ((= op EXCEPT1) (regexp-code-dump-1ch "EXCEPT1"))
2755              ((= op CATEGORYSPEC) (regexp-code-dump-1ch "CATEGORYSPEC"))
2756              ((= op NOTCATEGORYSPEC) (regexp-code-dump-1ch "NOTCATEGORYSPEC"))
2757              (t (princ (format "unknown op=%d\n" op))
2758                 (TREX-inc *regexp-code-index*)))))
2759     (princ (format "%4d:\n" *regexp-code-index*)))
2760   nil
2761   )
2762
2763 (defun regexp-code-dump-0 (op)
2764   (princ op) (terpri)
2765   (TREX-inc *regexp-code-index*))
2766
2767 (defun regexp-code-dump-1 (op)
2768   (princ (format "%s %d\n" op (aref *regexp-code-dump* (1+ *regexp-code-index*))))
2769   (TREX-inc *regexp-code-index* 2))
2770
2771 (defun regexp-code-dump-2 (op)
2772   (princ (format "%s %d %d\n"
2773                  op
2774                  (aref *regexp-code-dump* (1+ *regexp-code-index*))
2775                  (aref *regexp-code-dump* (+ *regexp-code-index* 2))
2776                  ))
2777   (TREX-inc *regexp-code-index* 3))
2778
2779 (defun regexp-code-dump-syntax (op)
2780   (princ (format "%s %c\n" op (syntax-code-spec (aref *regexp-code-dump* (1+ *regexp-code-index*)))))
2781   (TREX-inc *regexp-code-index* 2))
2782
2783 (defun regexp-code-dump-1ch (op)
2784   (princ (format "%s %c\n" op (aref *regexp-code-dump* (1+ *regexp-code-index*))))
2785   (TREX-inc *regexp-code-index* 2))
2786
2787 (defun regexp-get-absolute-address (point b1 b2)
2788   (cond ((< b2 128)
2789          (+ point (+ (* 256 b2) b1)))
2790         (t
2791          (+ point (logior (logxor -1 (+ (* 255 256) 255)) (* 256 b2) b1)))))
2792
2793 (defun regexp-code-dump-jump (op)
2794   (let* ((b1 (aref *regexp-code-dump* (1+ *regexp-code-index*)))
2795          (b2 (aref *regexp-code-dump* (+ *regexp-code-index* 2)))
2796         (p (regexp-get-absolute-address (+ *regexp-code-index* 3) b1 b2)))
2797     (princ (format "%s %d\n" op p)))
2798   (TREX-inc *regexp-code-index* 3))
2799
2800 (defun regexp-code-dump-jump-2 (op)
2801   (let* ((b1 (aref *regexp-code-dump* (1+ *regexp-code-index*)))
2802          (b2 (aref *regexp-code-dump* (+ *regexp-code-index* 2)))
2803         (p (regexp-get-absolute-address (+ *regexp-code-index* 3) b1 b2)))
2804     (princ (format "%s %d %d\n" op p
2805                    (+
2806                     (* 256 (aref *regexp-code-dump* (+ *regexp-code-index* 3)))
2807                     (aref *regexp-code-dump* (+ *regexp-code-index* 4))))))
2808   (TREX-inc *regexp-code-index* 5))
2809
2810 (defun regexp-code-dump-charset (op)
2811   (let ((n (aref *regexp-code-dump* (1+ *regexp-code-index*))))
2812     (princ (format "%s %d " op n))
2813     (let ((j (+ *regexp-code-index* 2))
2814           (max (+ *regexp-code-index* 2 (if (<= 128 n) (- n 128) n))))
2815       (while (< j max)
2816         (princ (format "0x%2x " (aref *regexp-code-dump* j)))
2817         (TREX-inc j))
2818       (cond((<= 128 n)
2819             (let* ((len (+ (* 256 (aref *regexp-code-dump* j))
2820                            (aref *regexp-code-dump* (1+ j))))
2821                    (last (+ j len)))
2822               (princ (format "\n      range list[%d-2 bytes]" len))
2823               (TREX-inc j 2)
2824               (while (< j last)
2825                 (let ((ch (sref *regexp-code-dump* j)))
2826                   (princ (format " %c" ch))
2827                   (TREX-inc j (char-octets ch))
2828                   (setq ch (sref *regexp-code-dump* j))
2829                   (princ (format "-%c" ch))
2830                   (TREX-inc j (char-octets ch))))
2831               )))
2832       (setq *regexp-code-index* j)
2833       (terpri))
2834     ))
2835
2836 (defun regexp-code-dump-charset-m (op)
2837   (let ((m (aref *regexp-code-dump* (1+ *regexp-code-index*)))
2838         (n (aref *regexp-code-dump* (+ *regexp-code-index* 2))))
2839     (princ (format "%s %d %d " op m n))
2840     (let ((j (+ *regexp-code-index* 3))
2841           (max (+ *regexp-code-index* 3 (if (<= 128 n) (- n 128) n))))
2842       (while (< j max)
2843         (princ (format "0x%02x " (aref *regexp-code-dump* j)))
2844         (TREX-inc j))
2845       (cond((<= 128 n)
2846             (let* ((len (+ (* 256 (aref *regexp-code-dump* j))
2847                            (aref *regexp-code-dump* (1+ j))))
2848                    (last (+ j len)))
2849               (princ (format "\n      range list[%d-2 bytes]" len))
2850               (TREX-inc j 2)
2851               (while (< j last)
2852                 (let ((ch (sref *regexp-code-dump* j)))
2853                   (princ (format " %c" ch))
2854                   (TREX-inc j (char-octets ch))
2855                   (setq ch (sref *regexp-code-dump* j))
2856                   (princ (format "-%c" ch))
2857                   (TREX-inc j (char-octets ch))))
2858               )))
2859       (setq *regexp-code-index* j)
2860       (terpri)
2861       )))
2862
2863 ;;;
2864 ;;; Compile functions
2865 ;;;
2866
2867 (defun TREX-simple-test1 ()
2868   (regexp-word-compile
2869             "\\cA+\\cH*\\|\\cK+\\cH*\\|\\cC+\\cH*\\|\\cH+\\|\\sw+"))
2870
2871 (defun TREX-test1 (pattern)
2872   (let* ((regexp (regexp-parse pattern))
2873          (fFA (EFFA-make (FA-make regexp)))
2874          (bFA (EFFA-make (FA-inverse fFA)))
2875          (l (cdr fFA))
2876          (result nil))
2877     (TREX-push  (cons (DFA-optimize (DFA-make fFA))
2878                              (DFA-optimize (DFA-make bFA)))
2879                 result)
2880     (while l
2881       (let* ((forward  (NEFA-make (EFFA-make (cons (car (car l)) (cdr fFA)))))
2882              (backward (NEFA-make (EFFA-make (cons (car (car l)) (cdr bFA))))))
2883                (cond((and forward backward)
2884                      (TREX-push  (cons (DFA-optimize (FA-simplify (DFA-shortest-match (DFA-make forward))))
2885                                             (DFA-optimize (FA-simplify (DFA-shortest-match (DFA-make backward)))))
2886                                  result))))
2887       (setq l (cdr l)))
2888     (setq result (reverse result))
2889     (let ((count 0))
2890       (while result
2891         (princ (format "\nForward[%2d]:" count)) (FA-dump (car (car result)))
2892         (princ (format "\nBackward[%2d]:" count)) (FA-dump (cdr (car result)))
2893         (TREX-inc count)
2894         (setq result (cdr result))))))
2895
2896 (defun TREX-test2 (pattern)
2897   (let* ((regexp (regexp-parse pattern))
2898          (fFA (EFFA-make (FA-make regexp)))
2899          (l (cdr fFA))
2900          (result nil))
2901     (regexp-code-dump (setq result (regexp-code-gen (DFA-optimize (DFA-make fFA)))))
2902     result))
2903
2904 ;;;###autoload
2905 (defun regexp-compile (pattern)
2906   (regexp-compile-internal pattern nil))
2907
2908 ;;;###autoload
2909 (defun regexp-word-compile (pattern)
2910   (regexp-compile-internal pattern t))
2911
2912 ;;;
2913 ;;; Returns a list of pair of forward-code and backward-code
2914 ;;;
2915
2916
2917 (defun regexp-compile-internal (pattern &optional word)
2918   (let* ((*regexp-word-definition* word)
2919          (*regexp-parse-translate*
2920           (if case-fold-search
2921               ;;; DOWNCASE or CANONICAL?
2922               (nth 2 (current-case-table))
2923             nil))
2924          (regexp (regexp-parse pattern))
2925          (fFA (EFFA-make (FA-make (regexp-reform-duplication regexp))))
2926          (bFA (EFFA-make (FA-make (regexp-reform-duplication (regexp-inverse regexp)))))
2927          (result nil))
2928     (let ((ofFA (DFA-optimize (DFA-make fFA)))
2929           (obFA (DFA-optimize (DFA-make bFA))))
2930       (TREX-push (cons (DFA-code-with-fastmap ofFA)
2931                        (let* ((START_MEMORY STOP_MEMORY)
2932                               (STOP_MEMORY START_MEMORY))
2933                          (DFA-code-with-fastmap obFA)))
2934                  result))
2935     (if word
2936         (let ((l (cdr fFA))
2937               (bFA (EFFA-make (FA-inverse fFA))))
2938           (while l
2939             (let* ((forward  (NEFA-make (EFFA-make (cons (car (car l)) (cdr fFA)))))
2940                    (backward (NEFA-make (EFFA-make (cons (car (car l)) (cdr bFA))))))
2941               (cond((and forward backward)
2942                     (let ((fFA (DFA-optimize (FA-simplify (DFA-shortest-match (DFA-make forward)))))
2943                           (bFA (DFA-optimize (FA-simplify (DFA-shortest-match (DFA-make backward))))))
2944                       (TREX-push  (cons (DFA-code-with-fastmap fFA)
2945                                         (DFA-code-with-fastmap bFA))
2946                                   result)))))
2947             (setq l (cdr l)))
2948           (setq result (nreverse result))))
2949     result))
2950
2951 (defun regexp-compiled-pattern-dump (pattern)
2952   ;;; PATTERN is a vector of [ code fastmap fastmap-syntax fastmap-categoy]
2953   (regexp-code-dump (aref pattern 0))
2954   (print-fastmap (aref pattern 1) " fastmap[char]")
2955   (print-fastmap (aref pattern 2) " fastmap[synt]")
2956   (print-fastmap (aref pattern 3) " fastmap[cate]")
2957   )
2958
2959 (defun regexp-compile-dump (code)
2960   (let ((Fcode (aref (car (car code)) 0))
2961         (Bcode (aref (cdr (car code)) 0))
2962         (words (cdr code)))
2963     (princ (format "\nRegular Expression Compiler Dump:\n"))
2964     (princ (format "Forward Search:"))
2965     (regexp-compiled-pattern-dump (car (car code)))
2966     (princ (format "Backward Search:"))
2967     (if Bcode (regexp-compiled-pattern-dump (cdr (car code)))
2968       (princ (format "\n Use the interpreter\n")))
2969     (if words
2970         (let ((i 1))
2971           (princ (format "In word conditions:\n"))
2972           (while words
2973             (princ (format "Forward[%d]" i))
2974             (regexp-compiled-pattern-dump (car (car words)))
2975             (princ (format "Backward[%d]" i))
2976             (regexp-compiled-pattern-dump (cdr (car words)))
2977             (TREX-inc i)
2978             (setq words (cdr words)))))))
2979
2980 (defun regexp-compile-and-dump (regexp)
2981   (regexp-compile-dump (regexp-compile regexp)))
2982
2983
2984 ;;;###autoload
2985 (defmacro define-word-regexp (name regexp)
2986   (` (defconst (, name) '(, (regexp-word-compile regexp)))))
2987
2988 (put 'define-word-regexp 'byte-hunk-handler ;93.7.16 by S.Tomura
2989      'macroexpand)
2990
2991 ;;;
2992 ;;; Coding system
2993 ;;;
2994
2995 (defmacro define-coding-systems (&rest rest)
2996   (` (define-coding-systems*  '(, rest))))
2997
2998 (defun define-coding-systems* (names)
2999   (let ((systems
3000          (` (:or (,@ (mapcar (function (lambda (name) (` (:seq (, (regexp-get-definition name))
3001                                                       (, name)))))
3002                              names))))))
3003     systems))
3004
3005 (defun oct (str) (aref str 0))
3006
3007 (defvar *TREX-range-from* nil)
3008 (defvar *TREX-range-to* nil)
3009
3010 (defun TREX-range-make-jisjoint (regexp)
3011   (TREX-init *TREX-range-from* (make-vector 256 nil))
3012   (TREX-init *TREX-range-to*   (make-vector 256 nil))
3013   (let ((i 0))
3014     (while (< i 256)
3015       (aset *TREX-range-from* i nil)
3016       (aset *TREX-range-to*   i nil)
3017       (TREX-inc i)))
3018   (aset *TREX-range-from* 0 t)
3019   (aset *TREX-range-to*   255 t)
3020   (TREX-range-mark regexp)
3021   (TREX-range-replace regexp))
3022
3023 (defun TREX-range-mark (regexp)
3024   (cond
3025    ((consp regexp)
3026     (let ((op (car regexp)))
3027       (cond((eq op ':mark)
3028             (TREX-range-mark (nth 3 regexp)))
3029            ((eq op ':or)
3030             (mapcar 'TREX-range-mark (cdr regexp)))
3031            ((eq op ':seq)
3032             (mapcar 'TREX-range-mark (cdr regexp)))
3033            ((eq op ':optional)
3034             (TREX-range-mark (nth 1 regexp)))
3035            ((eq op ':star)
3036             (TREX-range-mark (nth 1 regexp)))
3037            ((eq op ':plus)
3038             (TREX-range-mark (nth 1 regexp)))
3039            ((eq op ':range)
3040             (TREX-range-mark2 (nth 1 regexp) (nth 2 regexp))))))
3041    ((stringp regexp)
3042     (TREX-range-mark2 regexp regexp))
3043    ((numberp regexp)
3044     (TREX-range-mark2 regexp regexp))))
3045
3046 (defun TREX-range-mark2 (from to)
3047   (if (stringp from) (setq from (aref from 0)))
3048   (if (stringp to)   (setq to (aref to 0)))
3049   (if (< 0 from) (aset *TREX-range-to*     (1- from) t))
3050   (if (< to 255) (aset *TREX-range-from*   (1+ to) t))
3051   (aset *TREX-range-from* from t)
3052   (aset *TREX-range-to*   to t))
3053
3054 (defun TREX-range-replace (regexp)
3055   (cond
3056    ((consp regexp)
3057     (let ((op (car regexp)))
3058       (cond((eq op ':mark)
3059             (` (:mark (, (nth 1 regexp))
3060                       (, (nth 2 regexp))
3061                       (, (TREX-range-replace (nth 3 regexp))))))
3062            ((eq op ':or)
3063             (` (:or (,@ (mapcar 'TREX-range-replace (cdr regexp))))))
3064            ((eq op ':seq)
3065             (` (:seq (,@ (mapcar 'TREX-range-replace (cdr regexp))))))
3066            ((eq op ':optional)
3067             (` (:optional (,(TREX-range-replace (nth 1 regexp))))))
3068            ((eq op ':star)
3069             (` (:star (,(TREX-range-replace (nth 1 regexp))))))
3070            ((eq op ':plus)
3071             (` (:plus (,(TREX-range-replace (nth 1 regexp))))))
3072            ((eq op ':range)
3073             (let ((from (nth 1 regexp))
3074                   (to   (nth 2 regexp))
3075                   i j
3076                   (result nil))
3077               (if (stringp from) (setq from (aref from 0)))
3078               (if (stringp to  ) (setq to   (aref to   0)))
3079               (setq i from
3080                     j from)
3081               (while (<= i to)
3082                 (while (not (aref *TREX-range-to* j))
3083                   (TREX-inc j))
3084                 (if (not (= i j)) (TREX-push (` (:range (, i) (, j))) result)
3085                   (TREX-push i result))
3086                 (TREX-inc j)
3087                 (setq i j))
3088               (if (= (length result) 1) (car result)
3089                 (` (:or (,@ (nreverse result))))))))))
3090    ((stringp regexp)
3091     (if (= (length regexp) 1)
3092         (aref regexp 0)
3093       regexp))
3094    ((numberp regexp)
3095     regexp)
3096    (t regexp)))
3097
3098 (defun FA-sort (FA)
3099   (let ((start (car FA))
3100         (alist (cdr FA)))
3101     (setq alist (sort alist 'TREX-lessp-car))
3102     (while alist
3103       (setcdr (car alist) (sort (cdr (car alist)) 'TREX-lessp-car))
3104       (setcdr (car alist ) (TREX-sort (cdr (car alist)) 'TREX-key-lessp 'cdr))
3105       (setq alist (cdr alist)))
3106     FA))
3107
3108 ;;;
3109 ;;; CHARSET functions:
3110 ;;;
3111 ;;;  CHARSET ::= RANGE |
3112 ;;;              (:or RANGE+) |
3113 ;;;              (:nor RANGE+)
3114 ;;;  RANGE+   ::= CHAR |
3115 ;;;              (:range CHAR CHAR)
3116 ;;;
3117
3118 (defun CHARSET-rangep (charset)
3119   (or (numberp charset)
3120       (and (consp charset) (eq (car charset) ':range))))
3121
3122 (defun CHARSET-orp (charset)
3123   (and (consp charset) (eq (car charset) ':or)))
3124
3125 (defun CHARSET-range-from (range)
3126   (if (numberp range) range
3127     (nth 1 range)))
3128
3129 (defun CHARSET-range-to  (range)
3130   (if (numberp range) range
3131     (nth 2 range)))
3132
3133 (defun CHARSET-range-make (from to)
3134   (if (= from to) from
3135     (list ':range from to)))
3136
3137 (defun CHARSET-membership (range charset)
3138   (let ((from (CHARSET-range-from range))
3139         (to   (CHARSET-range-to   range))
3140         (flag nil))
3141     (while (and charset flag1)
3142       (if (< from (CHARSET-range-from (car charset)))
3143           (setq charset (cdr charset))
3144         (setq flag t)))
3145     (and flag1 (<= to (CHARSET-range-to (car charset))))))
3146
3147 (defun CHARSET-not (charset)
3148   (cond((CHARSET-rangep charset)
3149         (list ':nor charset))
3150        ((CHARSET-orp charset)
3151         (cons ':nor (cdr charset)))
3152        (t
3153         (cons ':or (cdr charset)))))
3154
3155 (defun CHARSET-union (charset1 charset2)
3156   (cond((CHARSET-rangep charset1)
3157         (cond ((CHARSET-rangep charset2)
3158                (CHARSET-union-range-range charset1 charset2))
3159               ((CHARSET-orp charset2)
3160                (CHARSET-union-range-or charset1 charset2))
3161               (t
3162                (CHARSET-union-range-nor charset1 charset2))))
3163        ((CHARSET-orp charset1)
3164         (cond ((CHARSET-rangep charset2)
3165                (CHARSET-union-range-or charset2 charset1))
3166               ((CHARSET-orp charset2)
3167                (CHARSET-union-or-or charset1 charset2))
3168               (t
3169                (CHARSET-union-or-nor charset1 charset2))))
3170        (t ;;; (CHARSET-norp charset1)
3171         (cond((CHARSET-rangep charset2)
3172               (CHARSET-union-range-nor charset2 charset1))
3173              ((CHARSET-orp charset2)
3174               (CHARSET-union-or-nor charset2 charset1))
3175              (t
3176               (CHARSET-union-nor-nor charset1 charset2))))))
3177
3178 (defun CHARSET-union-range-range (range1 range2)
3179   (let ((from1  (CHARSET-range-from range1))
3180         (to1    (CHARSET-range-to   range1))
3181         (from2  (CHARSET-range-from range2))
3182         (to2    (CHARSET-range-to   range2)))
3183     (cond((< to1 from2)
3184           (list ':or range1 range2))
3185          (t ;;; (<= from2 (1+ to1))
3186           (cond((<= to1 to2) ;;; (<= from2 to1 to2)
3187                 (CHARSET-range-make (min from1 from2) to2))
3188                ((<= from1 to2) ;;; (<= from1 to2 to1)
3189                 (CHARSET-range-make (min from1 from2) to1))
3190                (t ;;; (<= to2 from1 to1)
3191                 (list ':or range2 range1)))))))
3192
3193 (defun CHARSET-union-range-or (range or)
3194   (cons ':or (CHARSET-union-range-or* range (cdr or))))
3195
3196 (defun CHARSET-union-range-or* (range or-body)
3197   (let ((from (CHARSET-range-from range))
3198         (to   (CHARSET-range-to   range))
3199         (part1 nil))
3200     (let ((flag nil))
3201       (while (and or-body (null flag))
3202         (let ((next (car or-body)))
3203           (if (< (CHARSET-range-from next) from)
3204               ;;; from[i] < from
3205               (if (< (CHARSET-range-to next) from)
3206                   ;;; to[i] < from
3207                   (setq part1 (cons next part1)
3208                         or-body (cdr or-body))
3209                 ;;; from[i] < from <= to[i]
3210                 (setq from (CHARSET-range-from next)
3211                       flag t))
3212             ;;; from <= from[1]
3213             ;;; to[i-1] < from <= from[i]
3214             (setq flag t)))))
3215     ;;; part1 < from <= from[i]
3216     (if (and part1 (<= (1+ (CHARSET-range-to (car part1))) from))
3217         (setq from (CHARSET-range-from (car part1))
3218               part1 (cdr part1)))
3219     ;;; part1 << from <= from[i]
3220     (let ((flag nil))
3221       (while (and or-body (null flag))
3222         (let ((next (car or-body)))
3223           (if (< (CHARSET-range-from next) to)
3224               ;;; from[j] < from
3225               (if (< (CHARSET-range-to next) to)
3226                   ;;; to[j] < to
3227                   (setq or-body (cdr or-body))
3228                 ;;; from[j] < to <= to[j]
3229                 (setq to (CHARSET-range-to next)
3230                       flag t))
3231             ;;; to <= from[1]
3232             ;;; to[j-1] < to <= from[j]
3233             (setq flag t)))))
3234     ;;; part2 < to <= from[j]
3235     (if (and or-body (<= (CHARSET-range-from (car or-body)) (1+ to)))
3236         (setq to (CHARSET-range-to (car or-body))
3237               or-body (cdr or-body)))
3238     ;;; part2 <= to << from[j]
3239     (nconc (reverse part1)
3240            (cons (CHARSET-range-make from to)
3241                  or-body))))
3242
3243
3244 (defun CHARSET-union-range-nor (range nor)
3245   (let ((from (CHARSET-range-from range))
3246         (to   (CHARSET-range-to   range))
3247         (nor-body (cdr nor)))
3248
3249     ))
3250
3251 (defun CHARSET-union-or-or (or1 or2)
3252   (cons ':or (CHARSET-union-or*-or* (cdr or1) (cdr or2))))
3253
3254 (defun CHARSET-union-or*-or* (or1-body or2-body)
3255   (let ((result-body or2-body))
3256     (while or1-body
3257       (setq result-body
3258             (CHARSET-union-range-or* (car or1-body) result-body))
3259       (setq or1-body (cdr or1-body)))
3260     result-body))
3261
3262 (defun CHARSET-union-or-nor (or nor)
3263   )
3264
3265 (defun CHARSET-union-nor-nor (nor1 nor2)
3266   (cons ':nor (CHARSET-intersection-or*-or* (cdr nor1) (cdr nor2))))
3267
3268 (defun CHARSET-intersection (charset1 charset2)
3269   (cond((CHARSET-rangep charset1)
3270         (cond ((CHARSET-rangep charset2)
3271                (CHARSET-intersection-range-range charset1 charset2))
3272               ((CHARSET-orp charset2)
3273                (CHARSET-intersection-range-or charset1 charset2))
3274               (t
3275                (CHARSET-intersection-range-nor charset1 charset2))))
3276        ((CHARSET-orp charset1)
3277         (cond ((CHARSET-rangep charset2)
3278                (CHARSET-intersection-range-or charset2 charset1))
3279               ((CHARSET-orp charset2)
3280                (CHARSET-intersection-or-or charset1 charset2))
3281               (t
3282                (CHARSET-intersection-or-nor charset1 charset2))))
3283        (t ;;; (CHARSET-norp charset1)
3284         (cond((CHARSET-rangep charset2)
3285               (CHARSET-intersection-range-nor charset2 charset1))
3286              ((CHARSET-orp charset2)
3287               (CHARSET-intersection-or-nor charset2 charset1))
3288              (t
3289               (CHARSET-intersection-nor-nor charset1 charset2))))))
3290
3291 (defun CHARSET-intersection-range-or (range or)
3292   (CHARSET-intersection-range-or* range (cdr or)))
3293
3294 (defun CHARSET-intersection-range-or* (range or-body)
3295   (let ((from (CHARSET-range-from range))
3296         (to   (CHARSET-range-to   range))
3297         (part2 nil))
3298     (let ((flag nil))
3299       (while (and or-body (null flag))
3300         (let ((next (car or-body)))
3301           (if (< (CHARSET-range-from next) from)
3302               ;;; from[i] < from
3303               (if (< (CHARSET-range-to next) from)
3304                   ;;; to[i] < from
3305                   (setq or-body (cdr or-body))
3306                 ;;; from[i] < from <= to[i]
3307                 (setq flag t))
3308             ;;; from <= from[1]
3309             ;;; to[i-1] < from <= from[i]
3310             (setq flag t)))))
3311     ;;; from[i] < from <= to[i]
3312     ;;; from <= from[1]
3313     ;;; to[i-1] < from <= from[i]
3314     (let ((flag nil))
3315       (while (and or-body (null flag))
3316         (let ((next (car or-body)))
3317           (if (<= (CHARSET-range-from next) to)
3318               ;;; from[j] <= to
3319               (if (<= (CHARSET-range-to next) to)
3320                   ;;; to[j] <= to
3321                   (setq part2 (cons next part2)
3322                         or-body (cdr or-body))
3323                 ;;; from[j] <= to < to[j]
3324                 (setq part2 (cons next part2)
3325                       or-body (cdr or-body)
3326                       flag t)
3327             ;;; to < from[1]
3328             ;;; to[j-1] <= to < from[j]
3329             (setq flag t)))))
3330     ;;; from[j] <= to < to[j]
3331     ;;;            to < from[1]
3332     ;;; to[j-1] <= to < from[j]
3333       (cond ((null part2) nil)
3334             ((= (length part2) 1)
3335              (list (CHARSET-range-make (max from (CHARSET-range-from (car part2)))
3336                                        (min to   (CHARSET-range-to   (car part2))))))
3337             (t
3338              (setcar part2 (CHARSET-range-make (CHARSET-range-from (car part2))
3339                                                (min to (CHARSET-range-to (car part2)))))
3340              (setq part2 (nreverse part2))
3341              (setcar part2 (CHARSET-range-make (max from (CHARSET-range-from (car part2)))
3342                                                (CHARSET-range-to (car part2))))
3343              part2)))))
3344
3345 (defun CHARSET-intersection-range-nor (range nor)
3346   (CHARSET-intersection-range-nor* range (cdr nor)))
3347
3348 (defun CHARSET-intersecion-range-nor* (range nor-body)
3349   (let ((from (CHARSET-range-from range))
3350         (to   (CHARSET-range-to   range)))
3351     ))
3352
3353 ;;; (and (or a b) c) == (or (and a c) (and b c))
3354
3355 (defun CHARSET-intersection-or-or (or1 or2)
3356   (let ((result nil)
3357         (or1-body (cdr or1))
3358         (or2-body (cdr or2)))
3359     (while or1-body
3360       (setq result (CHARSET-union-or*-or*
3361                     (CHARSET-intersection-range-or* (car or1-body) or2-body)
3362                     result))
3363       (setq or1-body (cdr or1-body)))
3364     (if (= (length result) 1) (car result)
3365       (cons ':or result))))
3366
3367 (defun CHARSET-intersection-or-nor (or nor)
3368   )
3369
3370 ;;; (and (not or1) (not or2)) == (not (or or1 or2))
3371
3372 (defun CHARSET-intersection-nor-nor (nor1 nor2)
3373   (cons ':nor (CHARSET-union-or*-or* (cdr nor1) (cdr nor2))))
3374
3375 (defun FA-compaction (FA)
3376   (let ((start (car FA))
3377         (alist (cdr FA)))
3378     (setq alist (TREX-sort alist 'TREX-key-lessp 'car))
3379     (while alist
3380       (let ((table (cdr (car alist)))
3381             (newtable nil)
3382             (keys nil)  (next nil))
3383         (setq table (TREX-sort table '< 'car))
3384         (while table
3385           (setq next (cdr (car table)))
3386           (TREX-push (car (car table)) keys)
3387           (setq table (cdr table))
3388           (while (and table (eq next (cdr (car table))))
3389             (TREX-push (car (car table)) keys)
3390             (setq table (cdr table)))
3391           (setq keys (reverse (sort keys 'TREX-key-lessp)))
3392           (let ((newkeys nil))
3393             (setq newkeys (car keys)
3394                   keys    (cdr keys))
3395             (while keys
3396               (cond((numberp (car keys))
3397                     (cond((numberp (car newkeys))
3398                           (if (= (1+ (car keys)) (car newkeys))
3399                               (setcar newkeys (list ':range (car keys) (car newkeys)))
3400                             (TREX-push (car keys) newkeys)))
3401                          ((and (consp (car newkeys)) (eq (car (car newkeys)) ':range)))))))))))))
3402
3403
3404
3405 (defun FA-dump2 (table)
3406   (let ((start (car table))
3407         (l (cdr table)))
3408     (princ (format "\nstart = %d\n" start))
3409     (while l
3410       (princ (format "%3d: " (car (car l))))
3411       (let ((alist (cdr (car l))))
3412           (cond ((numberp (car (car alist)))
3413                  (princ (format "\\%03o(%c) -> %s\n" (car (car alist))(car (car alist)) (cdr (car alist)))))
3414                 ((and (consp (car (car alist))) (TREX-memequal (car (car (car alist))) '(CATEGORYSPEC NOTCATEGORYSPEC)))
3415                  (princ (format "(%s %c) -> %s\n" (car (car (car alist))) (nth 1 (car (car alist))) (cdr (car alist)))))
3416                 ((and (consp (car (car alist))) (eq (car (car (car alist))) ':range))
3417                  (princ (format "(:range \\%03o \\%03o) -> %s\n"
3418                                 (nth 1 (car (car alist))) (nth 2 (car (car alist)))
3419                                 (cdr (car alist)))))
3420                 (t
3421                  (princ (format "%s -> %s\n" (car (car alist)) (cdr (car alist))))))
3422           (setq alist (cdr alist))
3423         (while alist
3424           (cond ((numberp (car (car alist)))
3425                  (princ (format "     \\%03o(%c) -> %s\n" (car (car alist))(car (car alist)) (cdr (car alist)))))
3426                 ((and (consp (car (car alist))) (TREX-memequal (car (car (car alist))) '(CATEGORYSPEC NOTCATEGORYSPEC)))
3427                  (princ (format "     (%s %c) -> %s\n" (car (car (car alist))) (nth 1 (car (car alist))) (cdr (car alist)))))
3428                 ((and (consp (car (car alist))) (eq (car (car (car alist))) ':range))
3429                  (princ (format "     (:range \\%03o \\%03o) -> %s\n"
3430                                 (nth 1 (car (car alist))) (nth 2 (car (car alist)))
3431                                 (cdr (car alist)))))
3432                 (t
3433                  (princ (format "     %s -> %s\n" (car (car alist)) (cdr (car alist))))))
3434           (setq alist (cdr alist))))
3435       (setq l (cdr l)))))
3436
3437 ;;;function re-compile REGEXP
3438 ;;;Compile REGEXP by GNU Emacs original regexp compiler,
3439 ;;;and return information of the compiled code by a vector of length 11:
3440 ;;; [ COMPILED-PATTERN (string)
3441 ;;;   RE-NSUB REGS-ALLOCATED CAN-BE-NULL NEWLINE-ANCHOR (integers)
3442 ;;;   NO-SUB NOT-BOL NOT-EOL SYNTAX (integers)
3443 ;;;   FASTMAP TRANSLATE (string) ].
3444 ;;;
3445
3446 (defun print-compiled-pattern (compiled-code)
3447   (let ((compiled-pattern (aref compiled-code 0))
3448         (re-nsub          (aref compiled-code 1))
3449         (regs-allocated   (aref compiled-code 2))
3450         (can-be-null      (aref compiled-code 3))
3451         (newline-anchor   (aref compiled-code 4))
3452         (no-sub           (aref compiled-code 5))
3453         (not-bol          (aref compiled-code 6))
3454         (not-eol          (aref compiled-code 7))
3455         (syntax           (aref compiled-code 8))
3456         (fastmap          (aref compiled-code 9))
3457         (translate        (aref compiled-code 10)))
3458     (regexp-code-dump compiled-pattern)
3459     ;;; fastmap
3460     (if fastmap (print-fastmap fastmap "fastmap"))
3461     (princ (format "re_nsub: %d\n" re-nsub))
3462     (princ (format "regs-alloc: %d\n" regs-allocated))
3463     (princ (format "can-be-null: %d\n" can-be-null))
3464     (princ (format "newline-anchor: %d\n" newline-anchor))
3465     (princ (format "no-sub: %d\n" no-sub))
3466     (princ (format "not-bol: %d\n" not-bol))
3467     (princ (format "not-eol: %d\n" not-eol))
3468     (princ (format "syntax: %d\n" syntax))
3469     (if translate (print-translate translate))
3470     ;;; translate
3471     nil
3472     ))
3473
3474 (defun print-fastmap (fastmap name)
3475   (if fastmap
3476       (progn
3477         (princ (format "%s:[" name))
3478         (let ((max (length fastmap))
3479               (i 0))
3480           (while (< i max)
3481             (if (not (= (aref fastmap i) 0))
3482                 (princ (format "%c" i)))
3483             (setq i (1+ i))))
3484         (princ "]\n"))))
3485
3486 (defun print-translate (trans)
3487   (if trans
3488       (progn
3489         (princ "translate:\n")
3490         (let ((max (length trans))
3491               (i 0))
3492           (while (< i max)
3493             (if (not (= (aref trans i) i))
3494                 (princ (format "  %c --> %c" i (aref trans i))))
3495             (setq i (1+ i))))
3496         (princ "\n"))))
3497
3498 (defun re-compile-and-dump (regexp)
3499   (print-compiled-pattern (re-compile regexp)))
3500
3501
3502
3503
3504
3505