Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / common-lisp / regexp / regexp-emacs.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               regexp-emacs.lisp
4 ;;;;LANGUAGE:           common-lisp
5 ;;;;SYSTEM:             UNIX
6 ;;;;USER-INTERFACE:     UNIX
7 ;;;;NOWEB:              t
8 ;;;;DESCRIPTION
9 ;;;;
10 ;;;;    Posix Regexp implemented in Common-Lisp.
11 ;;;;
12 ;;;;    See specifications at:
13 ;;;;    http://www.opengroup.org/onlinepubs/007904975/basedefs/xbd_chap09.html
14 ;;;;
15 ;;;;    This is a strict implementation that will work both in clisp
16 ;;;;    (Common-Lisp) and emacs (with cl and pjb-cl Common-Lisp extensions).
17 ;;;;
18 ;;;;    This implementation is entirely in lisp, contrarily to what regexp
19 ;;;;    packages are available under clisp or emacs.  Thus it as the advantage
20 ;;;;    of portability and availability (you don't have to compile or link
21 ;;;;    a lisp system written in some barbarous language, and you get the same
22 ;;;;    regexp features in all programs including this module).
23 ;;;;
24 ;;;;USAGE
25 ;;;;    
26 ;;;;AUTHORS
27 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
28 ;;;;MODIFICATIONS
29 ;;;;    2002-11-16 <PJB> Created.
30 ;;;;BUGS
31 ;;;;LEGAL
32 ;;;;    AGPL3
33 ;;;;    
34 ;;;;    Copyright Pascal J. Bourguignon 2002 - 2002
35 ;;;;    
36 ;;;;    This program is free software: you can redistribute it and/or modify
37 ;;;;    it under the terms of the GNU Affero General Public License as published by
38 ;;;;    the Free Software Foundation, either version 3 of the License, or
39 ;;;;    (at your option) any later version.
40 ;;;;    
41 ;;;;    This program is distributed in the hope that it will be useful,
42 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
43 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
44 ;;;;    GNU Affero General Public License for more details.
45 ;;;;    
46 ;;;;    You should have received a copy of the GNU Affero General Public License
47 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
48 ;;;;****************************************************************************
49
50 (in-package "COMMON-LISP-USER")
51 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.REGEXP.REGEXP-EMACS"
52   (:use "COMMON-LISP"
53         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
54         "COM.INFORMATIMAGO.COMMON-LISP.PICTURE.TREE-TO-ASCII")
55   (:export "REGEXP-MATCH" "REGEXP-QUOTE" "MATCH-STRING" "MATCH-END"
56            "MATCH-START" "MATCH")
57   (:documentation
58    "This package implement REGEXP in COMMON-LISP,
59     which is interesting because then it's available on any COMMON-LISP platform
60     whether the external C regexp library is available or not, and moreover,
61     it's the same (that is, it's compatible) on all COMMON-LIST platforms.
62
63     NOT COMPLETE YET.
64
65     Copyright Pascal J. Bourguignon 2002 - 2002
66     This package is provided under the GNU General Public License.
67     See the source file for details."))
68 (in-package "COM.INFORMATIMAGO.COMMON-LISP.REGEXP.REGEXP-EMACS")
69
70
71
72
73 ;;; (DEFUN EMACS-STRING-MATCH (REGEXP STRING &OPTIONAL START)
74 ;;;   "
75 ;;; DO:      Plain emacs string-match
76 ;;;          just returning same result as match.
77 ;;; "
78 ;;;   (LET* ((START (STRING-MATCH REGEXP STRING START))
79 ;;;          (MD    (MATCH-DATA T))
80 ;;;          (COUNT (1+ (LOOP FOR START = 0 THEN (+ 2 MATCH)
81 ;;;                           FOR MATCH = (STRING-MATCH "\\\\(" REGEXP START)
82 ;;;                           WHILE MATCH
83 ;;;                           SUM 1 INTO COUNT
84 ;;;                           FINALLY (RETURN COUNT)))) )
85 ;;;     (VALUES-LIST 
86 ;;;      (LOOP FOR I FROM 0 BELOW COUNT
87 ;;;            FOR DATA = MD  THEN (CDDR DATA)
88 ;;;            FOR S = (CAR DATA)
89 ;;;            FOR E = (CADR DATA)
90 ;;;            COLLECT (IF (AND S E)
91 ;;;                        (MAKE-MATCH :START S :END E)
92 ;;;                      (MAKE-MATCH :START NIL :END NIL))
93 ;;;            INTO VALUES
94 ;;;            FINALLY (RETURN VALUES)))
95 ;;;     )) ;;emacs-string-match
96
97
98
99 (defun pjb-re-split-string (string &optional separators)
100   "
101 DO:         Splits STRING into substrings where there are matches
102             for SEPARATORS.
103 RETURNS:    A list of substrings.
104 separators: A regexp matching the sub-string separators.
105             Defaults to \"[ \f\t\n\r\v]+\".
106 NOTE:       Current implementation only accepts as separators
107             a literal string containing only one character.
108 "
109   (let ((sep (aref separators 0))
110         (chunks  '())
111         (position 0)
112         (nextpos  0)
113         (strlen   (length string)))
114     (loop :while (< position strlen)
115           :do (loop :while (and (< nextpos strlen)
116                                 (char/= sep (aref string nextpos)))
117                     :do (setq nextpos (1+ nextpos)))
118               (push (subseq string position nextpos) chunks)
119               (setq position (1+ nextpos))
120               (setq nextpos  position))
121     (nreverse chunks)))
122
123
124
125
126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
127 ;; regexp module
128 ;; -------------
129 ;; string scanner:
130 ;;
131
132 (defun make-sc (string)
133   (let ((sc (make-array '(3))))
134     (setf (aref sc 0) string)
135     (setf (aref sc 1) 0)
136     (setf (aref sc 2) (length string))
137     sc))
138
139
140 (defun sc-string (sc)
141   "
142 RETURN:  The string being scanned.
143 "
144   (aref sc 0))
145
146
147 (defun sc-position (sc)
148   "
149 RETURN:  The current position.
150 "
151   (aref sc 1))
152
153
154 (defun sc-curr-char (sc)
155   "
156 RETURN:  The current character, or nil if EOS.
157 "
158   (if (< (aref sc 1) (aref sc 2))
159       (char (aref sc 0) (aref sc 1))
160       nil))
161
162
163 (defun sc-next-char (sc)
164   "
165 RETURN:  The next character, or nil if EOS.
166 "
167   (if (< (1+ (aref sc 1)) (aref sc 2))
168       (char (aref sc 0) (1+ (aref sc 1)))
169       nil))
170
171
172 (defun sc-advance (sc)
173   "
174 PRE:     (= p      (sc-position sc))
175 POST:    (= (1+ p) (sc-position sc))
176 RETURN:  The character at position 1+p.
177 "
178   (if (< (aref sc 1) (aref sc 2))
179       (setf (aref sc 1) (1+ (aref sc 1))))
180   (sc-curr-char sc))
181
182
183 (defun sc-scan-to-char (sc char)
184   "
185 RETURN:  the substring of (sc-string sc) starting from current position
186          to the position just before the first character equal to `char'
187          found from this position.
188
189 PRE:     (= p      (sc-position sc))
190 POST:    (and (<=  p (sc-position sc))
191               (or (and (< (sc-position sc) (length (sc-string sc)))
192                        (char= char (sc-curr-char sc)))
193                   (= (sc-position sc) (length (sc-string sc))))
194               (forall i between p and (1- (sc-position sc))
195                   (char/= char (char (sc-string sc) i))))
196 "
197   (let ((s (aref sc 0))
198         (p (aref sc 1))
199         (l (aref sc 2)))
200     (loop :while (and (< p l) (char/= char (char s p)))
201           :do (setq p (1+ p)))
202     (prog1 (subseq s (aref sc 1) p)
203       (setf (aref sc 1) p))))
204           
205
206
207
208
209 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
210 ;; parsing regular expression strings
211 ;; ----------------------------------
212 ;; This produces a syntactical tree.
213 ;;
214
215 (defun pjb-re-parse-simple (sc)
216   "
217 DO:     Parses a regexp simple.
218 RETURN: A parse tree.
219
220 simple ::= '\\('   regexp '\\)' .    (:group     regexp)
221 simple ::= '\\(?:' regexp '\\)' .    (:shy-group regexp)
222 simple ::= '\\0' |'\\1' |'\\2' |'\\3' | '\\4'
223           |'\\5' |'\\6' |'\\7' |'\\8' | '\\9' .
224                                    (:reference number)
225 simple ::= regular-character .     regular-character
226 simple ::= '.' | '\\w' | '\\W' | '\\sC' | '\\SC' | '\\cC' | '\\CC' .
227                                    :any-character
228                                    :any-word-character
229                                    :any-not-word-character
230                                    (:any-syntax-class     class)
231                                    (:any-not-syntax-class class)
232                                    (:any-category         category)
233                                    (:any-not-category     category)
234
235 simple ::= '\\=' | '\\b' | '\\B' | '\\<' | '\\>' .
236                                    :empty-at-point    NEVER MATCH IN STRING!
237                                    :empty-at-limit-of-word
238                                    :empty-not-at-limit-of-word
239                                    :empty-at-beginning-of-word
240                                    :empty-at-end-of-word
241
242 simple ::= '^' | '\\`' .
243                                    :empty-at-beginning-of-line
244                                    :empty-at-beginning-of-string
245 simple ::= '$' | '\\'' .
246                                    :empty-at-end-of-line
247                                    :empty-at-end-of-string
248
249 simple ::= '\\$' | '\\^' | '\\.' | '\\*' | '\\+'
250          | '\\?' | '\\[' | '\\]' | '\\\\' .
251                                    regular-character
252
253 simple ::= '[' '^' character-set ']' .
254                                    (:inverse-char-set char-or-char-interval )
255 simple ::= '['     character-set ']' .
256                                    (:char-set         char-or-char-interval )
257 "
258   (let ((tree nil)
259         curr-char token)
260     (setq curr-char (sc-curr-char sc))
261     (cond
262       ((null curr-char)
263        (setq tree '(:error "EOS")))
264
265       ((setq token
266              (cdr (assoc curr-char
267                          (list
268                           (cons (character '\.) :any-character)
269                           (cons (character '\^) :empty-at-beginning-of-line)
270                           (cons (character '\$) :empty-at-end-of-line)
271                           )
272                          :test (function eq))))
273        (sc-advance sc)
274        (setq tree token))
275
276       ((eq (character '\[) curr-char)
277        ;; simple ::= '[' '^' character-set ']' .
278        ;; (:inverse-char-set char-or-char-interval )
279        ;; simple ::= '['     character-set ']' .
280        ;; (:char-set         char-or-char-interval )
281        ;;
282        ;; charset ::= '[:alnum:]' | '[:cntrl:]' | '[:lower:]' | '[:space:]'
283        ;;           | '[:alpha:]' | '[:digit:]' | '[:print:]' | '[:upper:]'
284        ;;           | '[:blank:]' | '[:graph:]' | '[:punct:]' | '[:xdigit:]' .
285        ;;
286        ;; charset ::= '[' ['^'] [']'|'-']
287        ;;              [ any-but-dorb
288        ;;              | any-but-dorb '-' any-but-dorb [ '-' ] ]*  [ '-' ] ']' .
289        ;;
290        ;; any-but-dorb ::= <any character but dash or right bracket> .
291        ;;
292        ;; [x-]]  could be:     { x to ] }
293        ;;        but that's:   { x , - } ]
294        ;;
295        ;; So, after the optional initial ']', we can search for the next ']'
296        ;; and parse then. A missing closing ']' is an error.
297
298        (error "[charset] Not implemented yet.")
299 ;;; (let ((set nil)
300 ;;;             (min nil)
301 ;;;             max)
302 ;;;         (setq curr-char (sc-advance sc))
303 ;;;         (if (char= (character '\^) curr-char)
304 ;;;             (progn
305 ;;;               (setq token :inverse-char-set)
306 ;;;               (setq curr-char (sc-advance sc)))
307 ;;;           (setq token :char-set ))
308
309 ;;;         (if (char= (character '\]) curr-char)
310 ;;;             (progn
311 ;;;               (sc-advance sc)
312 ;;;               (setq charsetstr (concatenate 'string
313 ;;;                                  "]" (sc-scan-to-char sc (character '\]))))
314 ;;;               )
315 ;;;           (setq charsetstr (sc-scan-to-char sc (character '\]))))
316
317 ;;; (string-match "[[:digit:][:punct:]]" "ABC123abc")
318
319 ;;;         (setq charsetstr (sc-scan-to-char sc (character '\]))
320
321 ;;;         (loop while (char/= curr-char (character '\]))
322 ;;;               do
323 ;;;               (if (char= (character '\-) curr-char)
324 ;;;                   (if min
325 ;;;                       (progn
326 ;;;                         (setq curr-char (sc-advance sc))
327 ;;;                         (if (char/= curr-char (character '\]))
328 ;;;                             (progn
329 ;;;                               (push min set)
330 ;;;                               (push (character '\-) set))
331 ;;;                           (push (cons min curr-char) set))
332 ;;;                         (setq min nil))
333 ;;;                     (push (character '\-) set))
334 ;;;                 (setq min curr-char)
335        
336
337        
338 ;;;                 ))))
339        )
340
341
342       ((eq (character '\\) curr-char)
343        (unless (or (eq (sc-next-char sc) (character '\|))
344                    (eq (sc-next-char sc) (character ")")))
345          (sc-advance sc)
346          (setq curr-char (sc-curr-char sc))
347          (if (setq token
348                    (cdr
349                     (assoc curr-char
350                            (list
351                             (cons (character '\w) :any-word-character)
352                             (cons (character '\W) :any-not-word-character)
353                             (cons (character '\=) :empty-at-point)
354                             (cons (character '\b) :empty-at-limit-of-word)
355                             (cons (character '\B) :empty-not-at-limit-of-word)
356                             (cons (character '\<) :empty-at-beginning-of-word)
357                             (cons (character '\>) :empty-at-end-of-word)
358                             (cons (character '\`) :empty-at-beginning-of-string)
359                             (cons (character '\') :empty-at-end-of-string)
360                             (cons (character '\$) (character '\$))
361                             (cons (character '\^) (character '\^))
362                             (cons (character '\.) (character '\.))
363                             (cons (character '\*) (character '\*))
364                             (cons (character '\+) (character '\+))
365                             (cons (character '\?) (character '\?))
366                             (cons (character '\[) (character '\[))
367                             (cons (character '\]) (character '\]))
368                             (cons (character '\\) (character '\\))
369                             (cons (character '\0) '(:reference 0))
370                             (cons (character '\1) '(:reference 1))
371                             (cons (character '\2) '(:reference 2))
372                             (cons (character '\3) '(:reference 3))
373                             (cons (character '\4) '(:reference 4))
374                             (cons (character '\5) '(:reference 5))
375                             (cons (character '\6) '(:reference 6))
376                             (cons (character '\7) '(:reference 7))
377                             (cons (character '\8) '(:reference 8))
378                             (cons (character '\9) '(:reference 9))
379                             )
380                            :test (function eq))))
381              (progn
382                (setq tree token)
383                (sc-advance sc))
384
385              (cond
386                ((eq (character "(") curr-char)
387                 ;; simple ::= '\('   regexp '\)' .    (:group     regexp)
388                 ;; simple ::= '\(?:' regexp '\)' .    (:shy-group regexp)
389                 (sc-advance sc)
390                 (if (and (eq (character '\?) (sc-curr-char sc))
391                          (eq (character '\:) (sc-next-char sc)))
392                     (progn
393                       (sc-advance sc)
394                       (sc-advance sc)
395                       (setq token :shy-group)
396                       )
397                     (setq token :group))
398                 (setq tree (list token (pjb-re-parse-regexp sc)))
399                 (if (and (eq (character '\\) (sc-curr-char sc))
400                          (eq (character ")") (sc-next-char sc)))
401                     (progn
402                       (sc-advance sc)
403                       (sc-advance sc))
404                     (setq tree
405                           (list :error
406                                 (format
407                                     nil
408                                   "Invalid character at ~D '~A~A' expected '\\)'."
409                                   (sc-position sc)
410                                   (sc-curr-char sc)
411                                   (if (sc-next-char sc)
412                                       (sc-next-char sc)  ""))
413                                 tree))) )
414
415                ((setq token
416                       (cdr (assoc curr-char
417                                   (list
418                                    (cons (character '\s) :any-syntax-class)
419                                    (cons (character '\S) :any-not-syntax-class)
420                                    (cons (character '\c) :any-category)
421                                    (cons (character '\C) :any-not-category))
422                                   :test (function eq))))
423                 (sc-advance sc)
424                 (setq curr-char (sc-curr-char sc))
425                 (if curr-char
426                     (progn
427                       (setq tree (list token curr-char))
428                       (sc-advance sc))
429                     (setq tree '(:error "EOS"))))
430                ((eq (character '\|) (sc-next-char sc))
431
432                 )))))
433
434       (t
435        (setq tree curr-char)
436        (sc-advance sc)))
437
438     tree))
439
440
441 (defun pjb-re-parse-element (sc)
442   "
443 DO:      Parses a regexp element.
444 RETURNS: A parse tree.
445
446 element ::= simple .               simple
447 element ::= simple '*' .           (:zero-or-more simple)
448 element ::= simple '+' .           (:one-or-more  simple)
449 element ::= simple '?' .           (:optional     simple)
450
451 element ::= simple '*?' .          (:non-greedy-zero-or-more simple)
452 element ::= simple '+?' .          (:non-greedy-one-or-more  simple)
453 element ::= simple '??' .          (:non-greedy-optional     simple)
454
455 element ::= simple '\{' number '\}' .
456                                    (:repeat-exact   simple number)
457 element ::= simple '\{' number ',' [ number ] '\}' .
458                                    (:repeat-between simple number [number])
459 "
460   (let (tree simple curr-char)
461     (setq simple (pjb-re-parse-simple sc))
462     (setq curr-char (sc-curr-char sc))
463     (cond
464       ((null curr-char)  (setq tree simple))
465
466       ((eq (character '\?) curr-char)
467        (sc-advance sc)
468        (if (eq (character '\?) (sc-curr-char sc))
469            (progn
470              (sc-advance sc)
471              (setq tree (list :non-greedy-optional  simple)))
472            (setq tree (list :optional simple))))
473
474       ((eq (character '\*) curr-char)
475        (sc-advance sc)
476        (if (eq (character '\?) (sc-curr-char sc))
477            (progn
478              (sc-advance sc)
479              (setq tree (list :non-greedy-zero-or-more  simple)))
480            (setq tree (list :zero-or-more simple)))) 
481
482       ((eq (character '\+) curr-char)
483        (sc-advance sc)
484        (if (eq (character '\?) (sc-curr-char sc))
485            (progn
486              (sc-advance sc)
487              (setq tree (list :non-greedy-one-or-more  simple)))
488            (setq tree (list :one-or-more simple))))
489
490       ((and (eq (character '\\) curr-char)
491             (eq (character '\{) (sc-next-char sc)))
492        (sc-advance sc)
493        (sc-advance sc)
494        (setq tree '(:error "\{...\} not implemented yet.")))
495
496       (t                 (setq tree simple)))
497     tree))
498
499
500 (defun pjb-re-collapse-strings (tree)
501   "
502 RETURNS: A new list where all sequences of characters are collapsed
503          into strings. Signle characters are not collapsed.
504 NOTE:    Does not works recursively because recursive sequences are built
505          bottom-up.
506 "
507   (loop
508     :with result = nil
509     :with string = nil
510     :for item :in tree
511     :do (if (characterp item)
512             (push item string)
513             (progn
514               (when string
515                 (if (= 1 (length string))
516                     (push (car string) result)
517                     (push (implode-string (nreverse string)) result))
518                 (setq string nil))
519               (push item result)))
520     :finally (when string
521                (if (= 1 (length string))
522                    (push (car string) result)
523                    (push (implode-string (nreverse string)) result))
524                (setq string nil))
525              (return (nreverse result))))
526
527
528 (defun pjb-re-parse-sequence (sc)
529   "
530 DO:      Parses a regexp sequence.
531 RETURNS: A parse tree.
532
533 sequence ::= element sequence  .  (:sequence element element ...)
534 sequence ::= element .             element
535 sequence ::= .                     nil
536 "
537   (let ((tree nil))
538     (loop
539       :while (and (sc-curr-char sc)
540                   (not (and (eq (character '\\) (sc-curr-char sc))
541                             (or (eq (sc-next-char sc) (character '\|))
542                                 (eq (sc-next-char sc) (character ")") )))))
543       :do (push (pjb-re-parse-element sc) tree))
544     (cons :sequence (pjb-re-collapse-strings (nreverse tree)))
545 ;;;     (if (<= (length tree) 1)
546 ;;;         (car tree)
547 ;;;       (progn
548 ;;;         (setq tree (pjb-re-collapse-strings (nreverse tree)))
549 ;;;         (if (<= (length tree) 1)
550 ;;;             (car tree)
551 ;;;           tree)))
552     ))
553
554
555 (defun pjb-re-parse-regexp (sc)
556   "
557 DO:      Parses a regexp.
558 RETURNS: A parse tree.
559 NOTE:    The result may contain the symbol :error followed by a string.
560
561 regexp ::= sequence '\|' regexp .   (:alternative sequence sequence...)
562 regexp ::= sequence .               sequence
563 "
564   (let (tree)
565     (setq tree (list (pjb-re-parse-sequence sc)))
566     (loop :while (and (eq (character '\\) (sc-curr-char sc))
567                       (eq (character '\|) (sc-next-char sc)))
568           :do (sc-advance sc)
569               (sc-advance sc)
570               (push (pjb-re-parse-sequence sc) tree))
571     (if (= 1 (length tree))
572         (car tree)
573         (cons :alternative (nreverse tree)))))
574
575
576 (defun pjb-re-parse-whole-regexp (sc)
577   (let ((tree (pjb-re-parse-regexp sc))
578         (curr-char (sc-curr-char sc)))
579     (if curr-char
580         (setq tree
581               (list :error (format nil "Syntax error at ~D (~A ~A)."
582                                    (sc-position sc)
583                                    curr-char
584                                    (if (sc-next-char sc)
585                                        (sc-next-char sc)  ""))
586                     tree)))
587     tree))
588
589
590
591 ;; $^.*+?[]\
592
593 ;; regexp ::= sequence '\|' regexp .   (:alternative sequence sequence...)
594 ;; regexp ::= sequence .               sequence
595
596
597 ;; sequence ::= element sequence  .  (:sequence element element ...)
598 ;; sequence ::= element .             element
599 ;; sequence ::= .                     nil
600
601 ;;                                An element can be a string, corresponding to
602 ;;                                a concatenated sequence of regular-character.
603
604 ;; element ::= simple .               simple
605 ;; element ::= simple '*' .           (:zero-or-more simple)
606 ;; element ::= simple '+' .           (:one-or-more  simple)
607 ;; element ::= simple '?' .           (:optional     simple)
608
609 ;; element ::= simple '*?' .          (:non-greedy-zero-or-more simple)
610 ;; element ::= simple '+?' .          (:non-greedy-one-or-more  simple)
611 ;; element ::= simple '??' .          (:non-greedy-optional     simple)
612
613 ;; element ::= simple '\{' number '\}' .
614 ;;                                    (:repeat-exact   simple number)
615 ;; element ::= simple '\{' number ',' [ number ] '\}' .
616 ;;                                    (:repeat-between simple number [number])
617
618 ;; simple ::= '\('   regexp '\)' .    (:group     regexp)
619 ;; simple ::= '\(?:' regexp '\)' .    (:shy-group regexp)
620 ;; simple ::= '\0' |'\1' |'\2' |'\3' |'\4' |'\5' |'\6' |'\7' |'\8' | '\9' .
621 ;;                                    (:reference number)
622 ;; simple ::= regular-character .     regular-character
623 ;; simple ::= '.' | '\w' | '\W' | '\sC' | '\SC' | '\cC' | '\CC' .
624 ;;                                    :any-character
625 ;;                                    :any-word-character
626 ;;                                    :any-not-word-character
627 ;;                                    (:any-syntax-class     class)
628 ;;                                    (:any-not-syntax-class class)
629 ;;                                    (:any-category         category)
630 ;;                                    (:any-not-category     category)
631
632 ;; simple ::= '\=' | '\b' | '\B' | '\<' | '\>' .
633 ;;                                    :empty-at-point   # NEVER MATCH IN STRING!
634 ;;                                    :empty-at-limit-of-word
635 ;;                                    :empty-not-at-limit-of-word
636 ;;                                    :empty-at-beginning-of-word
637 ;;                                    :empty-at-end-of-word
638
639 ;; simple ::= '^' | '\`' .
640 ;;                                    :empty-at-beginning-of-line
641 ;;                                    :empty-at-beginning-of-string
642 ;; simple ::= '$' | '\'' .
643 ;;                                    :empty-at-end-of-line
644 ;;                                    :empty-at-end-of-string
645
646 ;; simple ::= '\$' | '\^' | '\.' | '\*' | '\+' | '\?' | '\[' | '\]' | '\\' .
647 ;;                                    regular-character
648
649 ;; simple ::= '[' '^' character-set ']' .
650 ;;                                    (:inverse-char-set char-or-char-interval )
651 ;; simple ::= '['     character-set ']' .
652 ;;                                    (:char-set         char-or-char-interval )
653
654 ;; char-or-char-interval is a sequence of regular-character
655 ;;                                        or (cons min-char max-char).
656
657 ;; character-set ::= initial-c-set rest-c-set .
658 ;; initial-c-set ::= ']' | '-' .
659 ;; initial-c-set ::= .
660 ;; rest-c-set ::= .
661 ;; rest-c-set ::= c-set-char rest-c-set .
662 ;; rest-c-set ::= c-set-char '-' c-set-char rest-c-set .
663 ;; rest-c-set ::= c-set-char '-' c-set-char '-' rest-c-set .
664 ;; c-set-char ::= any-but-right-bracket-or-dash .
665
666
667
668
669
670 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
671 ;; matching a regexp tree to a string
672 ;; ----------------------------------
673 ;; 
674
675
676
677 (defvar pjb-re-new-line (code-char 10) "A new-line.")
678
679
680 (defmacro pjb-re-slot-node        (obj)        `(aref ,obj 0))
681 (defmacro pjb-re-slot-match       (obj)        `(aref ,obj 1))
682 (defmacro pjb-re-slot-string      (obj)        `(aref ,obj 2))
683 (defmacro pjb-re-slot-begin       (obj)        `(aref ,obj 3))
684 (defmacro pjb-re-slot-end         (obj)        `(aref ,obj 4))
685 (defmacro pjb-re-slot-try         (obj)        `(aref ,obj 5))
686 (defmacro pjb-re-slot-private     (obj)        `(aref ,obj 6))
687 (defmacro pjb-re-slot-children    (obj)        `(aref ,obj 7))
688
689 ;;; (DEFMACRO PJB-RE-SLOT-BEGIN-SET   (OBJ VALUE) `(SETF (AREF ,OBJ 3) ,VALUE))
690 ;;; (DEFMACRO PJB-RE-SLOT-END-SET     (OBJ VALUE) `(SETF (AREF ,OBJ 4) ,VALUE))
691 ;;; (DEFMACRO PJB-RE-SLOT-TRY-SET     (OBJ VALUE) `(SETF (AREF ,OBJ 5) ,VALUE))
692 ;;; (DEFMACRO PJB-RE-SLOT-PRIVATE-SET (OBJ VALUE) `(SETF (AREF ,OBJ 6) ,VALUE))
693 ;;; (DEFSETF  PJB-RE-SLOT-BEGIN       PJB-RE-SLOT-BEGIN-SET)
694 ;;; (DEFSETF  PJB-RE-SLOT-END         PJB-RE-SLOT-END-SET)
695 ;;; (DEFSETF  PJB-RE-SLOT-TRY         PJB-RE-SLOT-TRY-SET)
696 ;;; (DEFSETF  PJB-RE-SLOT-PRIVATE     PJB-RE-SLOT-PRIVATE-SET)
697
698 (declaim (type (function (array) (function (array) t)) pjb-re-slot-match))
699
700 (defmacro pjb-re-init (node position)
701   `(let ((node ,node)
702          (position ,position))
703      (setf (pjb-re-slot-begin node) position)
704      (setf (pjb-re-slot-try node) nil)
705      (setf (pjb-re-slot-end node) nil)
706      (values)))
707   
708
709 (defmacro pjb-re-match (node)
710   `(let ((node ,node))
711      (funcall (pjb-re-slot-match node) node)))
712
713
714
715
716
717 (defun pjb-re-character-match (node)
718   "Matches a character.
719 RETURNS: nil when no match,
720          or the next unmatched position when there's a match.
721 "
722   (let ((p  (pjb-re-slot-begin node)) )
723     (if (pjb-re-slot-try   node)
724         ;; already tested. no more match:
725         nil
726         ;; first test, let's see:
727         (progn
728           (setf (pjb-re-slot-try node) t)
729           (if (char= (pjb-re-slot-node node) (char (pjb-re-slot-string node) p))
730               (progn
731                 (setq p (1+ p))
732                 (setf (pjb-re-slot-end node) p)
733                 p)
734               nil)))))
735
736
737
738 (defun pjb-re-string-match (node)
739   "Matches a string.
740 RETURNS: nil when no match,
741          or the next unmatched position when there's a match.
742 "
743   (let ((p  (pjb-re-slot-begin node)) )
744     (if (pjb-re-slot-try   node)
745         ;; already tested. no more match:
746         nil
747         ;; first test, let's see:
748         (let* ((m   (pjb-re-slot-node node))
749                (len (length m))
750                (e   (+ p len))
751                (s   (pjb-re-slot-string node)) )
752           (setf (pjb-re-slot-try node) t)
753           (unless (and (< e (length s))
754                        (string= m s :start2 p :end2 e))
755             (setq e nil))
756           (setf (pjb-re-slot-end node) e)
757           e))))
758
759
760
761 (defun pjb-re-null-match (node)
762   "Matches a null.
763 RETURNS: nil when no match,
764          or the next unmatched position when there's a match.
765 "
766   (if (pjb-re-slot-try   node)
767       ;; already tested. no more match:
768       nil
769       ;; first test, let's see:
770       (progn
771         (setf (pjb-re-slot-try node) t)
772         t ;; yes! we match.
773         )))
774
775
776 (defun pjb-re-alternative-match (node)
777   "Matches a alternative.
778 RETURNS: nil when no match,
779          or the next unmatched position when there's a match.
780 "
781   (let ((p         (pjb-re-slot-begin node))
782         (n         (pjb-re-slot-try   node))
783         (children  (pjb-re-slot-children node))
784         (found nil) )
785     (when (null n) (setq n 0))
786     (loop :while (and (< n (length children))
787                       (not found))
788           :do (pjb-re-init (aref children n) p)
789               (setq found (pjb-re-match (aref children n)))
790           :finally (setf (pjb-re-slot-end node) found)
791                    (setf (pjb-re-slot-try node) (1+ n))
792           :finally (return found))))
793
794
795 (defun pjb-re-any-category-match (node)
796   "Matches a any-category.
797 RETURNS: nil when no match,
798          or the next unmatched position when there's a match.
799 "
800   (let ((p         (pjb-re-slot-begin node))
801         (n         (pjb-re-slot-try   node))
802         (children  (pjb-re-slot-children node)) )
803     (declare (ignore p n children))
804     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
805
806
807 (defun pjb-re-any-character-match (node)
808   "Matches a any-character.  That is, anything but a NEW-LINE!
809 RETURNS: nil when no match,
810          or the next unmatched position when there's a match.
811
812 A period ( '.' ), when used outside a bracket expression, is a BRE
813 that shall match any character in the supported character set except
814 NUL.
815
816 "
817   (let ((p         (pjb-re-slot-begin node)) )
818     (if (pjb-re-slot-try   node)
819         ;; already tested. no more match:
820         nil
821         (progn ;; first test, let's see:
822           (setf (pjb-re-slot-try node) t)
823           (if (< p (length (pjb-re-slot-string node)))
824               (progn
825                 (setq p (1+ p))
826                 (setf (pjb-re-slot-end node) p))
827               (setf  (pjb-re-slot-end node) nil))))))
828
829
830 (defun pjb-re-any-not-category-match (node)
831   "Matches a any-not-category.
832 RETURNS: nil when no match,
833          or the next unmatched position when there's a match.
834 "
835   (let ((p         (pjb-re-slot-begin node))
836         (n         (pjb-re-slot-try   node))
837         (children  (pjb-re-slot-children node)) )
838     (declare (ignore p n children))
839     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
840
841
842 (defun pjb-re-any-not-syntax-class-match (node)
843   "Matches a any-not-syntax-class.
844 RETURNS: nil when no match,
845          or the next unmatched position when there's a match.
846 "
847   (let ((p         (pjb-re-slot-begin node))
848         (n         (pjb-re-slot-try   node))
849         (children  (pjb-re-slot-children node)) )
850     (declare (ignore p n children))
851     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
852
853
854 (defun pjb-re-any-not-word-character-match (node)
855   "Matches a any-not-word-character.
856 RETURNS: nil when no match,
857          or the next unmatched position when there's a match.
858 "
859   (let ((p         (pjb-re-slot-begin node))
860         (n         (pjb-re-slot-try   node))
861         (children  (pjb-re-slot-children node)) )
862     (declare (ignore p n children))
863     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
864
865
866 (defun pjb-re-any-syntax-class-match (node)
867   "Matches a any-syntax-class.
868 RETURNS: nil when no match,
869          or the next unmatched position when there's a match.
870 "
871   (let ((p         (pjb-re-slot-begin node))
872         (n         (pjb-re-slot-try   node))
873         (children  (pjb-re-slot-children node)) )
874     (declare (ignore p n children))
875     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
876
877
878 (defun pjb-re-any-word-character-match (node)
879   "Matches a any-word-character.
880 RETURNS: nil when no match,
881          or the next unmatched position when there's a match.
882 "
883   (let ((p         (pjb-re-slot-begin node))
884         (n         (pjb-re-slot-try   node))
885         (children  (pjb-re-slot-children node)) )
886     (declare (ignore p n children))
887     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
888
889
890 (defun pjb-re-char-set-match (node)
891   "Matches a char-set.
892 RETURNS: nil when no match,
893          or the next unmatched position when there's a match.
894 "
895   (let ((p         (pjb-re-slot-begin node))
896         (n         (pjb-re-slot-try   node))
897         (children  (pjb-re-slot-children node)) )
898     (declare (ignore p n children))    
899     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
900
901
902 (defun pjb-re-empty-at-beginning-of-line-match (node)
903   "Matches a empty-at-beginning-of-line.
904 RETURNS: nil when no match,
905          or the next unmatched position when there's a match.
906 "
907   (let ((p         (pjb-re-slot-begin node))
908         (n         (pjb-re-slot-try   node))
909         (children  (pjb-re-slot-children node)) )
910     (declare (ignore p n children))
911     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
912
913
914 (defun pjb-re-empty-at-beginning-of-string-match (node)
915   "Matches a empty-at-beginning-of-string.
916 RETURNS: nil when no match,
917          or the next unmatched position when there's a match.
918 "
919   (let ((p  (pjb-re-slot-begin  node)) )
920     (if (pjb-re-slot-try  node)
921         ;; already tested. no more match:
922         nil
923         ;; first test, let's see:
924         (progn
925           (setf (pjb-re-slot-try node) t)
926           (if (=  0 p) ;; TODO use a :start / :end for the string!
927               (progn
928                 (setf (pjb-re-slot-end node) p)
929                 p)
930               nil)))))
931
932
933 (defun pjb-re-empty-at-beginning-of-word-match (node)
934   "Matches a empty-at-beginning-of-word.
935 RETURNS: nil when no match,
936          or the next unmatched position when there's a match.
937 "
938   (let ((p         (pjb-re-slot-begin node))
939         (n         (pjb-re-slot-try   node))
940         (children  (pjb-re-slot-children node)) )
941     (declare (ignore p n children))
942     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
943
944
945 (defun pjb-re-empty-at-end-of-line-match (node)
946   "Matches a empty-at-end-of-line.
947 RETURNS: nil when no match,
948          or the next unmatched position when there's a match.
949 "
950   (let ((p         (pjb-re-slot-begin node))
951         (n         (pjb-re-slot-try   node))
952         (children  (pjb-re-slot-children node)) )
953     (declare (ignore p n children))
954     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
955
956
957 (defun pjb-re-empty-at-end-of-string-match (node)
958   "Matches a empty-at-end-of-string.
959 RETURNS: nil when no match,
960          or the next unmatched position when there's a match.
961 "
962   (let ((p  (pjb-re-slot-begin  node)) )
963     (if (pjb-re-slot-try  node)
964         ;; already tested. no more match:
965         nil
966         ;; first test, let's see:
967         (progn
968           (setf (pjb-re-slot-try node) t)
969           (if (=  (length (pjb-re-slot-string node)) p) ;; TODO use a :start / :end for the string!
970               (progn
971                 (setf (pjb-re-slot-end node) p)
972                 p)
973               nil)))))
974
975
976 (defun pjb-re-empty-at-end-of-word-match (node)
977   "Matches a empty-at-end-of-word.
978 RETURNS: nil when no match,
979          or the next unmatched position when there's a match.
980 "
981   (let ((p         (pjb-re-slot-begin node))
982         (n         (pjb-re-slot-try   node))
983         (children  (pjb-re-slot-children node)) )
984     (declare (ignore p n children))
985     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
986
987
988 (defun pjb-re-empty-at-limit-of-word-match (node)
989   "Matches a empty-at-limit-of-word.
990 RETURNS: nil when no match,
991          or the next unmatched position when there's a match.
992 "
993   (let ((p         (pjb-re-slot-begin node))
994         (n         (pjb-re-slot-try   node))
995         (children  (pjb-re-slot-children node)) )
996     (declare (ignore p n children))
997     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
998
999
1000 (defun pjb-re-empty-at-point-match (node)
1001   "Matches a empty-at-point.
1002 RETURNS: nil when no match,
1003          or the next unmatched position when there's a match.
1004 "
1005   (let ((p         (pjb-re-slot-begin node))
1006         (n         (pjb-re-slot-try   node))
1007         (children  (pjb-re-slot-children node)) )
1008     (declare (ignore p n children))
1009     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1010
1011
1012 (defun pjb-re-empty-not-at-limit-of-word-match (node)
1013   "Matches a empty-not-at-limit-of-word.
1014 RETURNS: nil when no match,
1015          or the next unmatched position when there's a match.
1016 "
1017   (let ((p         (pjb-re-slot-begin node))
1018         (n         (pjb-re-slot-try   node))
1019         (children  (pjb-re-slot-children node)) )
1020     (declare (ignore p n children))
1021     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1022
1023
1024 (defun pjb-re-error-match (node)
1025   "Matches a error.
1026 RETURNS: nil when no match,
1027          or the next unmatched position when there's a match.
1028 "
1029   (let ((p         (pjb-re-slot-begin node))
1030         (n         (pjb-re-slot-try   node))
1031         (children  (pjb-re-slot-children node)) )
1032     (declare (ignore p n children))
1033     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1034
1035
1036 (defun pjb-re-group-match (node)
1037   "Matches a group.
1038 RETURNS: nil when no match,
1039          or the next unmatched position when there's a match.
1040 "
1041   (let ((p         (pjb-re-slot-begin node))
1042         (child     (aref (pjb-re-slot-children node) 0)) )
1043     (if (pjb-re-slot-try   node)
1044         ;; already tested. no more match:
1045         nil
1046         ;; first test, let's see:
1047         (progn
1048           (setf (pjb-re-slot-try node) t)
1049           (pjb-re-init child p)
1050           (setq p (pjb-re-match child))
1051           (when p
1052             (setf (pjb-re-slot-end node) p))
1053           p))))
1054
1055
1056 (defun pjb-re-inverse-char-set-match (node)
1057   "Matches a inverse-char-set.
1058 RETURNS: nil when no match,
1059          or the next unmatched position when there's a match.
1060 "
1061   (let ((p         (pjb-re-slot-begin node))
1062         (n         (pjb-re-slot-try   node))
1063         (children  (pjb-re-slot-children node)) )
1064     (declare (ignore p n children))
1065     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1066
1067
1068 (defun pjb-re-non-greedy-one-or-more-match (node)
1069   "Matches a non-greedy-one-or-more.
1070 RETURNS: nil when no match,
1071          or the next unmatched position when there's a match.
1072 "
1073   (let ((n      (pjb-re-slot-try   node))
1074         (p      (pjb-re-slot-begin node))
1075         (child  (aref (pjb-re-slot-children  node) 0)) )
1076     (cond
1077       ((null n) ;; first time
1078        (pjb-re-init child p)
1079        (setq p (pjb-re-match child))
1080        (setf (pjb-re-slot-end node) p)
1081        (setf (pjb-re-slot-try node) (if p :more :over))
1082        p)
1083       ((eq :more n)
1084        (setq p (pjb-re-slot-end node))
1085        (pjb-re-init child p)
1086        (setq p (pjb-re-match child))
1087        (setf (pjb-re-slot-end node) p)
1088        (setf (pjb-re-slot-try node) (if p :more :over))
1089        p)
1090       (t
1091        nil))))
1092
1093
1094 (defun pjb-re-non-greedy-optional-match (node)
1095   "Matches a non-greedy-optional.
1096 RETURNS: nil when no match,
1097          or the next unmatched position when there's a match.
1098 "
1099   (let ((p         (pjb-re-slot-begin node))
1100         (n         (pjb-re-slot-try   node))
1101         (child     (aref (pjb-re-slot-children node) 0)) )
1102     (cond
1103       ((null n) ;; first time, let's be non greedy: match nothing.
1104        (setf (pjb-re-slot-end node) p)
1105        (setf (pjb-re-slot-try node) :second) )
1106       ((eq n :second) ;; second time, we expect the child.
1107        (pjb-re-init child p)
1108        (setq p (pjb-re-match child))
1109        (setf (pjb-re-slot-end node) p)
1110        (setf (pjb-re-slot-try node) :last) )
1111       (t ;; too late we don't match anything.
1112        (setq p nil)
1113        (setf (pjb-re-slot-end node) p) ))
1114     p))
1115
1116
1117 (defun pjb-re-non-greedy-zero-or-more-match (node)
1118   "Matches a non-greedy-zero-or-more.
1119 RETURNS: nil when no match,
1120          or the next unmatched position when there's a match.
1121 "
1122   (let ((n      (pjb-re-slot-try  node))
1123         (s      (pjb-re-slot-string  node))
1124         (child  (aref (pjb-re-slot-children  node) 0)) )
1125     (cond
1126       ((null n) ;; case zero
1127        (setq n (pjb-re-slot-begin node))
1128        (setf (pjb-re-slot-end node) n)
1129        (setf (pjb-re-slot-try node) n)
1130        )
1131       ((eq t n) ;; no more match
1132        )
1133       ((= n (length s))
1134        ;; match end of string with any number, but no more.
1135        (setf (pjb-re-slot-end node) n)
1136        (setf (pjb-re-slot-try node) t))
1137       (t
1138        (pjb-re-init child n)
1139        (setq n (pjb-re-match child))
1140        (if n
1141            (progn
1142              (setf (pjb-re-slot-end node) n)
1143              (setf (pjb-re-slot-try node) n))
1144            (progn
1145              (setf (pjb-re-slot-end node) nil)
1146              (setf (pjb-re-slot-try node) t)))))
1147     n))
1148
1149
1150 (defun pjb-re-optional-match (node)
1151   "Matches a optional.
1152 RETURNS: nil when no match,
1153          or the next unmatched position when there's a match.
1154 "
1155   (let ((p         (pjb-re-slot-begin node))
1156         (n         (pjb-re-slot-try   node))
1157         (child     (aref (pjb-re-slot-children node) 0)) )
1158     (cond
1159       ((null n) ;; first time, we expect the child.
1160        (pjb-re-init child p)
1161        (setq p (pjb-re-match child))
1162        (setf (pjb-re-slot-end node) p)
1163        (setf (pjb-re-slot-try node) :second) )
1164       ((eq n :second) ;; second time,  let's be non greedy: match nothing.
1165        (setf (pjb-re-slot-end node) p)
1166        (setf (pjb-re-slot-try node) :last) )
1167       (t ;; too late we don't match anything.
1168        (setq p nil)
1169        (setf (pjb-re-slot-end node) p) ))
1170     p))
1171
1172
1173 (defun pjb-re-one-or-more-match (node)
1174   "Matches a one-or-more.
1175 RETURNS: nil when no match,
1176          or the next unmatched position when there's a match.
1177 "
1178   (let ((p         (pjb-re-slot-begin node))
1179         (n         (pjb-re-slot-try   node))
1180         (children  (pjb-re-slot-children node)) )
1181     (declare (ignore p n children))
1182     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1183
1184
1185 (defun pjb-re-reference-match (node)
1186   "Matches a reference.
1187 RETURNS: nil when no match,
1188          or the next unmatched position when there's a match.
1189 "
1190   (let ((p         (pjb-re-slot-begin node))
1191         (n         (pjb-re-slot-try   node))
1192         (children  (pjb-re-slot-children node)) )
1193     (declare (ignore p n children))
1194     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1195
1196
1197 (defun pjb-re-repeat-between-match (node)
1198   "Matches a repeat-between.
1199 RETURNS: nil when no match,
1200          or the next unmatched position when there's a match.
1201 "
1202   (let ((p         (pjb-re-slot-begin node))
1203         (n         (pjb-re-slot-try   node))
1204         (children  (pjb-re-slot-children node)) )
1205     (declare (ignore p n children))
1206     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1207
1208
1209 (defun pjb-re-repeat-exact-match (node)
1210   "Matches a repeat-exact.
1211 RETURNS: nil when no match,
1212          or the next unmatched position when there's a match.
1213 "
1214   (let ((p         (pjb-re-slot-begin node))
1215         (n         (pjb-re-slot-try   node))
1216         (children  (pjb-re-slot-children node)) )
1217     (declare (ignore p n children))
1218     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1219
1220
1221 (defun pjb-re-sequence-match (node)
1222   "Matches a sequence.
1223 RETURNS: nil when no match,
1224          or the next unmatched position when there's a match.
1225 "
1226   (let ((p         (pjb-re-slot-begin node))
1227         (n         (pjb-re-slot-try   node))
1228         (children  (pjb-re-slot-children node)) )
1229     (when children
1230       (unless n
1231         (setq n 0)
1232         (pjb-re-init (aref children n) p))
1233       (setq p (pjb-re-match (aref children n)))
1234       (loop :while (or (and p (< (1+ n) (length children)))
1235                        (and (not p) (<= 0 (1- n))))
1236             :do (if p
1237                     (progn
1238                       (setq n (1+ n))
1239                       (pjb-re-init (aref children n) p))
1240                     (setq n (1- n)))
1241                 (setq p (pjb-re-match (aref children n))))
1242       ;; p       ==> (= (1+ n) (length children)) ==> 0 <= n < (length children)
1243       ;; (not p) ==>    (= -1 (1- n)) ==>  n=0    ==> 0 <= n < (length children)
1244       (setf (pjb-re-slot-try node) n)
1245       (setf (pjb-re-slot-end node) p))
1246     p))
1247
1248
1249 (defun pjb-re-shy-group-match (node)
1250   "Matches a shy-group.
1251 RETURNS: nil when no match,
1252          or the next unmatched position when there's a match.
1253 "
1254   (let ((p         (pjb-re-slot-begin node))
1255         (n         (pjb-re-slot-try   node))
1256         (children  (pjb-re-slot-children node)) )
1257     (declare (ignore p n children))
1258     (error "Not Implemented Yet: ~S~%" (pjb-re-slot-node node))))
1259
1260
1261 (defun pjb-re-zero-or-more-match (node)
1262   "Matches a zero-or-more.
1263 RETURNS: nil when no match,
1264          or the next unmatched position when there's a match.
1265 "
1266   (let ((n      (pjb-re-slot-try     node))
1267         (s      (pjb-re-slot-string  node))
1268         (p      (pjb-re-slot-begin   node))
1269         (child  (aref (pjb-re-slot-children  node) 0)) )
1270     ;; Note: we should try to save all the previous matches (from zero to n)
1271     ;;       to backtrack faster, but we would need to save possibly a lot
1272     ;;       of recursive state for all the child subtree...
1273     (cond
1274       ((null n) ;; first time: match all we can.
1275        (setq n (loop :with p = (pjb-re-slot-begin   node)
1276                      :for n = 0 :then (1+ n)
1277                      :while (and p (< p (length s)))
1278                      :do (pjb-re-init child p)
1279                          (setq p (pjb-re-match child))
1280                      :finally (return n)))
1281        ;; oops we did one too many.
1282        ;; let's redo it till the limit
1283        (setf (pjb-re-slot-try node) n)
1284        (pjb-re-zero-or-more-match node))
1285       ((< n 0) ;; we tried everything.
1286        (setf (pjb-re-slot-end node) nil))
1287       (t ;; match n-1 times.
1288        (loop :for i :from 1 :below n
1289              :do (pjb-re-init child p)
1290                  (setq p (pjb-re-match child)))
1291        (setf (pjb-re-slot-end node) p)
1292        (setf (pjb-re-slot-try node) (1- n))
1293        p))))
1294
1295
1296
1297 (defun pjb-re-make-pjb-re-symbol (key ext)
1298   "
1299 RETURN:     A symbol corresponding to one of the pjb-re-*-{init,match} 
1300             functions defined here.
1301 ext:        A string, either \"init\" or \"match\".
1302 key:        A keyword, one of those used in the regexp syntactic trees.
1303
1304 NOTE:
1305                                        emacs      Common-Lisp
1306             ----------------------  ------------  ------------
1307             (symbol-name 'key)        ''key''        ''KEY''
1308             (symbol-name :key)        '':key''       ''KEY''
1309             (eq 'key 'KEY)              nil             T
1310 URL:        http://www.informatimago.com/local/lisp/HyperSpec/Body/02_cd.htm
1311             http://www.informatimago.com/local/lisp/HyperSpec/Body/f_intern.htm#intern
1312 "
1313   (if (string= "emacs" (lisp-implementation-type))
1314       (intern (string-downcase (format nil "pjb-re-~s-~s"
1315                                        (subseq (symbol-name key) 1) ext)))
1316       (intern (string-upcase (format nil "pjb-re-~a-~a" (symbol-name key) ext))
1317               (find-package "PJB-REGEXP"))))
1318
1319
1320 (defun pjb-re-decorate-tree (tree string)
1321   "
1322 RETURN:  A decorated tree that can be used for the matching the string.
1323 "
1324   (tree-decorate
1325    tree
1326    (lambda (node children)
1327      (let ((obj (make-array '(9)))
1328            key)
1329        (cond
1330          ((null       node) (setq key :null))
1331          ((characterp node) (setq key :character))
1332          ((stringp    node) (setq key :string))
1333          ((listp      node) (setq key :list))
1334          ((member node '(
1335                          :alternative :any-category :any-character
1336                          :any-not-category :any-not-syntax-class
1337                          :any-not-word-character :any-syntax-class
1338                          :any-word-character :char-set
1339                          :empty-at-beginning-of-line
1340                          :empty-at-beginning-of-string
1341                          :empty-at-beginning-of-word
1342                          :empty-at-end-of-line :empty-at-end-of-string
1343                          :empty-at-end-of-word :empty-at-limit-of-word
1344                          :empty-at-point :empty-not-at-limit-of-word
1345                          :error :group :inverse-char-set
1346                          :non-greedy-one-or-more :non-greedy-optional
1347                          :non-greedy-zero-or-more :optional :one-or-more
1348                          :reference :repeat-between :repeat-exact
1349                          :sequence :shy-group :zero-or-more)
1350                   :test (function eq))
1351           (setq key node))
1352          (t (error "INTERNAL: Unexpected node in match tree: ~S !"
1353                    node)))
1354        (setf (aref obj 0) node)
1355        (setf (aref obj 1) (pjb-re-make-pjb-re-symbol key "match"))
1356        (setf (aref obj 2) string)
1357        (setf (aref obj 3) 0) ;; beg (start)
1358        (setf (aref obj 4) 0) ;; end
1359        (setf (aref obj 5) nil) ;; try
1360        (setf (aref obj 6) nil) ;; private
1361        (setf (aref obj 7) (when children
1362                             (make-array (list (length children))
1363                                         :initial-contents children)))
1364        obj))))
1365
1366
1367 (defun pjb-re-collect-groups (dec-tree &optional groups)
1368   (let ((make-groups-flag (not groups)))
1369     (unless groups
1370       (setq groups (cons :groups nil)))
1371     (if (eq :group (pjb-re-slot-node dec-tree))
1372         (push dec-tree (cdr groups)))
1373     (loop :with children = (pjb-re-slot-children dec-tree)
1374           :for i :from 0 :below (length children)
1375           :for child = (aref children i)
1376           :do (pjb-re-collect-groups child groups))
1377     (if make-groups-flag
1378         (nreverse (cdr groups))
1379         nil)))
1380
1381
1382
1383 (defstruct match
1384   "This structure stores a (start,end) couple specifying the range matched
1385 by a group (or the whole regexp)."
1386   (start nil :type (or null integer))
1387   (end   nil :type (or null integer)))
1388
1389
1390 (defun match-string (string match)
1391   "Extracts the substring of STRING corresponding to a given pair of
1392 start and end indices. The result is shared with STRING.
1393 If you want a freshly consed string, use copy-string
1394 or (coerce (match-string ...) 'simple-string)."
1395   (subseq string (match-start match) (match-end match)))
1396
1397
1398 (defun regexp-quote (string)
1399   (declare (ignore string))
1400   (error "Not Implemented Yet: REGEXP-QUOTE~%" ))
1401  
1402
1403 (defun match (regexp string &optional start end)
1404   "Common-Lisp: This function returns as first value a match structure
1405 containing the indices of the start and end of the first match for the
1406 regular expression REGEXP in STRING, or nil if there is no match.
1407 If START is non-nil, the search starts at that index in STRING.
1408 If END is non-nil, only (subseq STRING START END) is considered.
1409 The next values are match structures for every '\(...\)' construct in REGEXP,
1410 in the order that the open parentheses appear in REGEXP.
1411
1412
1413 start:   the first character of STRING to be considered (defaults to 0)
1414 end:     the after last character of STRING to be considered
1415          (defaults to (length string)).
1416 RETURN:  index of start of first match for REGEXP in STRING, nor nil.
1417 "
1418   (unless start (setq start 0))
1419   (unless end   (setq end (length string)))
1420   (when (< end start) (setq end start))
1421   ;; TODO: What to do when start or end are out of bounds ?
1422   (let* ((syn-tree
1423           (pjb-re-parse-whole-regexp
1424            (make-sc (concatenate 'string "\\`.*?\\(" regexp "\\).*?\\'"))))
1425          (dec-tree (pjb-re-decorate-tree syn-tree string))
1426          (groups  (pjb-re-collect-groups dec-tree)) )
1427     (pjb-re-init dec-tree start)
1428     (pjb-re-match dec-tree) 
1429     ;; there's nowhere to backtrack at the top level...
1430     (values-list (mapcar (lambda (g)
1431                            (let ((s (pjb-re-slot-begin g))
1432                                  (e (pjb-re-slot-end g)) )
1433                              (if (and s e)
1434                                  (make-match :start s :end e)
1435                                  (make-match :start nil :end nil))))
1436                          groups))))
1437
1438 ;;;; THE END ;;;;