6 (defvar automata-never-fail (make-symbol "automata-never-fail"))
7 (defvar automata-state-var (make-symbol "automata-state"))
9 (defmacro automata (in-var start-tag &rest clauses)
10 (let* ((org-len (length clauses))
11 (org-graph (make-vector org-len nil))
12 (tag-to-org-alist nil)
13 forest org-to-forest forest-to-org
18 (setq tag-to-org-alist (cons (cons (caar tmp) i) tag-to-org-alist)
24 (setq trans (cddr (cdar tmp)))
26 (setq j (cdr (assoc (cadr (car trans)) tag-to-org-alist)))
27 (if (not (member j (aref org-graph i)))
28 (aset org-graph i (cons j (aref org-graph i))))
29 (setq trans (cdr trans)))
32 ;;(error "%s" org-graph)
33 (setq tmp (digraph-split-as-forest org-graph)
35 org-to-forest (aref tmp 1)
36 forest-to-org (aref tmp 2))
51 (lambda (tr) (if (equal (cadr tr) next) (car tr) (natset-empty)))
54 (natset-enum (apply 'natset-single (mapcar 'cadr trs)))))
55 (cons tag (cons action (cons fail trs)))))
57 `(let ((,automata-state-var ,(cdr (assoc start-tag tag-to-org-alist))))
62 (list (cdr (assoc start-tag tag-to-org-alist)))
64 (aref org-to-forest (cdr (assoc start-tag tag-to-org-alist)))
65 forest org-to-forest forest-to-org)))))
67 (defun automata-gen-state (in-var clauses
71 forest-state forest org-to-forest forest-to-org)
72 (let* ((org-states (aref forest-to-org forest-state))
73 (forest-states (digraph-descents forest forest-state))
74 (branch-length (+ (length org-states) (length forest-states)))
77 (mapcar 'list org-states)
78 (mapcar (lambda (forest-state)
79 (aref forest-to-org forest-state))
82 (let ((org-to-branch (make-vector org-len nil))
84 (while (< i branch-length)
85 (setq tmp (aref branch-to-org i))
87 (aset org-to-branch (car tmp) i)
93 (make-list (length org-states) nil)
97 (mapcar 'natset-single org-states)
98 (mapcar (lambda (forest-state)
100 (aref forest-to-org forest-state)))
104 (mapcar (lambda (org-state)
105 (let* ((c (nth org-state clauses))
110 (cdr (assoc (cadr tr) tag-to-org-alist))))
113 (mapcar (lambda (forest-state) ())
115 (all-descents (apply 'natset-union (append branch-descents ())))
117 (let* ((branch-ascents (make-vector branch-length 0))
119 (while (< i branch-length)
121 (while (< j branch-length)
122 (if (natset-has-intersection-p (aref branch-state-range i)
123 (aref branch-descents j))
124 (aset branch-ascents i
125 (1+ (aref branch-ascents i))))
131 (let* ((branch-inline (make-vector branch-length nil))
132 (start-ns (apply 'natset-single start-states))
134 (while (< i branch-length)
135 (if (natset-has-intersection-p (aref branch-state-range i) start-ns)
136 (if (and (= (length start-states) 1)
137 (= (aref branch-ascents i) 0))
139 (setq start-inline i)
140 (aset branch-inline i t))
142 (if (= (aref branch-ascents i) 1)
143 (aset branch-inline i t)))
154 `(,(natset-single org-state)
155 nil ; don't duplicate.
156 ,@(let* ((c (nth org-state clauses)))
159 (if (null (nthcdr 3 c))
162 ,in-var ; input variable
163 ,(natset-full) ; input is unpredictable.
164 ,(nth 2 c) ; fail action
165 ,@(let ((trs (nthcdr 3 c)))
167 (lambda (next-branch)
172 (if (member (cdr (assoc (cadr tr) tag-to-org-alist))
173 (aref branch-to-org next-branch))
177 `(,input-range ; input range
178 ,(not (aref branch-inline next-branch)) ; duplicatable unless inlining.
179 ,(let ((goto-list (apply
183 (let ((range (natset-intersection (car tr) input-range)))
190 ,(cdr (assoc (cadr tr) tag-to-org-alist)))))
193 (if (= (length goto-list) 1)
194 (car (cddr (car goto-list)))
200 ,@(if (aref branch-inline next-branch)
202 `(progn ,@(cddr (funcall (car (aref branch-gen next-branch))
203 (cdr (aref branch-gen next-branch))))))
211 (cdr (assoc (cadr tr) tag-to-org-alist)))))
217 (lambda (forest-state)
219 (lambda (forest-state)
220 `(,(natset-intersection
221 (apply 'natset-single (aref forest-to-org forest-state))
222 all-descents) ; state range
223 nil ; don't duplicate.
228 (aref forest-to-org forest-state)
230 forest-state forest org-to-forest forest-to-org))))
238 (if (not (aref branch-inline i))
241 (funcall (car (aref branch-gen i))
242 (cdr (aref branch-gen i)))
250 `(progn ,@(cddr (funcall (car (aref branch-gen start-inline))
251 (cdr (aref branch-gen start-inline)))))
254 ((null (cdr branches))
255 (cddr (car branches)))
259 ,automata-state-var ,(natset-full) ,automata-never-fail
261 (if (= (length branches) 1)
262 `(while t ,@(cddr (car branches)))
263 `(while t ; ,branch-inline ,branch-state-range ,branch-descents ,branch-ascents
265 ,automata-state-var ,(natset-full) ,automata-never-fail
268 (defun automata-seq-exp (&rest seq)
278 (lambda (exp) (if (and (consp exp) (eq (car exp) 'progn))
282 (let ((rseq (reverse seq)))
289 (lambda (exp) (if (null exp) () (list exp)))
290 (nreverse (cdr rseq))))
291 (list (list (car rseq)))))))))
293 (defun automata-exp-seq (&rest seq)
294 (let ((exp (apply 'automata-seq-exp seq)))
295 (if (and (consp exp) (eq (car exp) 'progn))
299 (defmacro automata-goto (var curr next)
304 (defmacro automata-branch (var range fail &rest clauses)
305 (when (eq fail automata-never-fail)
306 (setq range (natset-intersection
307 (apply 'natset-union (mapcar 'car clauses))
309 (let ((len (length clauses))
310 ns-list dup-list body-list tmp ns)
312 ns (natset-negate range))
314 (setq ns-list (cons (natset-sub (caar tmp) ns) ns-list)
315 dup-list (cons (cadr (car tmp)) dup-list)
316 body-list (cons (cddr (car tmp)) body-list)
317 ns (natset-union ns (caar tmp))
319 (if (natset-empty-p (car ns-list))
320 (setq ns-list (cdr ns-list)
321 dup-list (cdr dup-list)
322 body-list (cdr body-list))))
323 (setq ns-list (nreverse ns-list)
324 dup-list (nreverse dup-list)
325 body-list (nreverse body-list))
326 (automata-branch-i var range fail ns-list dup-list body-list)))
328 (defun automata-branch-i (var range fail ns-list dup-list body-list)
330 ((null ns-list) fail)
331 ((null (cdr ns-list))
332 (if (natset-include-p (car ns-list) range)
333 (apply 'automata-seq-exp (car body-list))
334 `(if ,(natset-gen-pred-exp (car ns-list) var range)
335 ,(apply 'automata-seq-exp (car body-list))
338 (let (tmp tmpn tmpd cut)
342 (setq cut (natset-union cut (natset-boundary-set (car tmpn)))
348 (setq tmp (natset-minmax (car tmpn))
349 tmp (natset-sub tmp (natset-start-set tmp))
350 cut (natset-sub cut tmp)))
351 (setq tmpn (cdr tmpn)
353 (setq cut (natset-sub cut (natset-boundary-set (natset-minmax range))))
354 (if (null (setq cut (natset-enum cut)))
355 `(if ,(natset-gen-pred-exp (car ns-list) var range)
356 ,(apply 'automata-seq-exp (car body-list))
357 ,(automata-branch-i var
358 (natset-sub range (car ns-list))
363 (let* ((mid (nth (/ (length cut) 2) cut))
364 (lower (natset-seg 0 (1- mid)))
365 (higher (natset-seg mid))
366 ns-list1 dup-list1 body-list1
367 ns-list2 dup-list2 body-list2
370 (if (natset-has-intersection-p lower (car ns-list))
371 (setq ns-list1 (cons (natset-intersection (car ns-list) lower) ns-list1)
372 dup-list1 (cons (car dup-list) dup-list1)
373 body-list1 (cons (car body-list) body-list1)))
374 (if (natset-has-intersection-p higher (car ns-list))
375 (setq ns-list2 (cons (natset-intersection (car ns-list) higher) ns-list2)
376 dup-list2 (cons (car dup-list) dup-list2)
377 body-list2 (cons (car body-list) body-list2)))
378 (setq ns-list (cdr ns-list)
379 dup-list (cdr dup-list)
380 body-list (cdr body-list)))
381 ;;(if (or (null ns-list1) (null ns-list2)) (error "divide fail"))
383 ,(automata-branch-i var
384 (natset-intersection range lower)
385 fail ns-list1 dup-list1 body-list1)
386 ,(automata-branch-i var
387 (natset-intersection range higher)
388 fail ns-list2 dup-list2 body-list2))))))))
397 (lex-scan-unibyte-save))
402 (lex-scan-unibyte-save))
406 (lex-scan-unibyte-read pc))
408 ((9 10) 5) ((32 33) 5))
412 (lex-scan-unibyte-save)
413 (lex-scan-unibyte-read pc))
416 ((0 9) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
421 (lex-scan-unibyte-save)
422 (lex-scan-unibyte-read pc))
424 ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
430 (lex-scan-unibyte-save)
431 (lex-scan-unibyte-read pc))
433 ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
435 ((9 10) 1) ((32 33) 1)))))
442 (lex-scan-unibyte-save)
443 (lex-scan-unibyte-read pc))
445 ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
447 ((9 10) 1) ((32 33) 1))
451 (lex-scan-unibyte-save))
456 (lex-scan-unibyte-save)
457 (lex-scan-unibyte-read pc))
460 ((0 9) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
465 (lex-scan-unibyte-save)
466 (lex-scan-unibyte-read pc))
468 ((0 9) 3) ((10 11) 3) ((11 13) 3) ((14 32) 3) ((33) 3)
473 (lex-scan-unibyte-read pc))
475 ((9 10) 5) ((32 33) 5))
479 (lex-scan-unibyte-save))
486 '((0 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((9 10 32 33) 1) ((13 14) 2) ((0 9 10 13 14 32 33) 3))
487 (1 (progn (lex-match 1) (lex-scan-unibyte-save)) (lex-fail))
488 (2 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((13 14) 2) ((0 9 11 13 14 32 33) 3) ((10 11) 4))
489 (3 (progn (lex-match 3) (lex-scan-unibyte-save) (lex-scan-unibyte-read pc)) (lex-fail) ((13 14) 2) ((0 9 10 13 14 32 33) 3))
490 (4 (progn (lex-scan-unibyte-read pc)) (lex-fail) ((9 10 32 33) 5))
491 (5 (progn (lex-match 2) (lex-scan-unibyte-save)) (lex-fail)))
494 '((5 . 5) (4 . 4) (3 . 3) (2 . 2) (1 . 1) (0 . 0))
496 [(4 1) (2) (3) nil nil]
498 [(0) (3 2) (4) (5) (1)]))