[functional-tests] more work on the regex engine
This commit is contained in:
Joe Thornber
parent
ca16f0eac8
commit
59a77ee44a
@ -1,7 +1,14 @@
|
||||
(library
|
||||
(regex)
|
||||
(export compile-rx)
|
||||
(export lit
|
||||
cat
|
||||
alt
|
||||
opt
|
||||
star
|
||||
plus
|
||||
compile-rx)
|
||||
(import (chezscheme)
|
||||
(loops)
|
||||
(matchable))
|
||||
|
||||
;; Simple regex library, because it's friday and I'm bored.
|
||||
@ -16,7 +23,7 @@
|
||||
;; (star rx)
|
||||
;; (plus rx)
|
||||
;;
|
||||
;; The expressions get compile-rxd into a vector of vm instructions.
|
||||
;; The expressions get compiled into a vector of vm instructions.
|
||||
;; (char c)
|
||||
;; (match)
|
||||
;; (jmp x)
|
||||
@ -25,67 +32,115 @@
|
||||
;; instructions are closures that manipulate the thread
|
||||
|
||||
;; FIXME: slow
|
||||
(define (append-instr code . i)
|
||||
(append code i))
|
||||
|
||||
(define (label-instr l)
|
||||
`(label ,l))
|
||||
|
||||
(define (jmp-instr l)
|
||||
`(jmp ,l))
|
||||
|
||||
(define (char-instr c)
|
||||
`(char ,c))
|
||||
|
||||
(define (split-instr l1 l2)
|
||||
`(split ,l1 ,l2))
|
||||
|
||||
(define (match-instr)
|
||||
'(match))
|
||||
(define (append-instr code . i) (append code i))
|
||||
(define (label-instr l) `(label ,l))
|
||||
(define (jmp-instr l) `(jmp ,l))
|
||||
(define (char-instr c) `(char ,c))
|
||||
(define (split-instr l1 l2) `(split ,l1 ,l2))
|
||||
(define (match-instr) '(match))
|
||||
(define (match-instr? instr) (equal? '(match) instr))
|
||||
|
||||
(define (label-code label code)
|
||||
(cons (label-instr label) code))
|
||||
|
||||
;; Compiles to a list of labelled instructions that can later be flattened
|
||||
;; into a linear sequence.
|
||||
(define (compile-rx exp)
|
||||
(match exp
|
||||
(('lit str)
|
||||
(map char-instr (string->list str)))
|
||||
(define (lit str)
|
||||
(map char-instr (string->list str)))
|
||||
|
||||
(('cat rx1 rx2)
|
||||
(append (compile-rx rx1) (compile-rx rx2)))
|
||||
(define (cat rx1 rx2)
|
||||
(append rx1 rx2))
|
||||
|
||||
(('alt rx1 rx2)
|
||||
(let ((label1 (gensym))
|
||||
(label2 (gensym)))
|
||||
(let ((c1 (label-code label1 (compile-rx rx1)))
|
||||
(c2 (label-code label2 (compile-rx rx2))))
|
||||
(cons (split-instr label1 label2)
|
||||
(append c1 c2)))))
|
||||
(define (alt rx1 rx2)
|
||||
(let ((label1 (gensym))
|
||||
(label2 (gensym))
|
||||
(tail (gensym)))
|
||||
(let ((c1 (label-code label1
|
||||
(append-instr rx1 (jmp-instr tail))))
|
||||
(c2 (label-code label2 rx2)))
|
||||
(cons (split-instr label1 label2)
|
||||
(append-instr (append c1 c2) (label-instr tail))))))
|
||||
|
||||
(('opt rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(cons (split-instr head tail)
|
||||
(label-code head (append-instr (compile-rx rx)
|
||||
(label-instr tail))))))
|
||||
(define (opt rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(cons (split-instr head tail)
|
||||
(label-code head
|
||||
(append-instr rx (label-instr tail))))))
|
||||
|
||||
(('star rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(cons (split-instr head tail)
|
||||
(label-code head (append-instr (compile-rx rx)
|
||||
(jmp-instr head)
|
||||
(label-instr tail))))))
|
||||
(define (star rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(cons (split-instr head tail)
|
||||
(label-code head
|
||||
(append-instr rx
|
||||
(jmp-instr head)
|
||||
(label-instr tail))))))
|
||||
|
||||
(('plus rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(label-code head
|
||||
(append-instr (compile-rx rx)
|
||||
(split-instr head tail)
|
||||
(label-instr tail)))))))
|
||||
(define (plus rx)
|
||||
(let ((head (gensym))
|
||||
(tail (gensym)))
|
||||
(label-code head
|
||||
(append-instr rx
|
||||
(split-instr head tail)
|
||||
(label-instr tail)))))
|
||||
|
||||
(define (label-locations code)
|
||||
(let ((locs (make-eq-hashtable)))
|
||||
(let loop ((pc 0)
|
||||
(code code))
|
||||
(if (null? code)
|
||||
locs
|
||||
(match (car code)
|
||||
(('label l)
|
||||
(begin
|
||||
(hashtable-set! locs l pc)
|
||||
(loop pc (cdr code))))
|
||||
(instr
|
||||
(loop (+ 1 pc) (cdr code))))))))
|
||||
|
||||
(define (remove-labels code locs)
|
||||
(let loop ((pc 0)
|
||||
(code code)
|
||||
(acc '()))
|
||||
(if (null? code)
|
||||
(reverse acc)
|
||||
(match (car code)
|
||||
(('label l)
|
||||
(loop pc (cdr code) acc))
|
||||
|
||||
(('jmp l)
|
||||
(loop (+ 1 pc) (cdr code)
|
||||
(cons `(jmp ,(hashtable-ref locs l #f)) acc)))
|
||||
|
||||
(('split l1 l2)
|
||||
(loop (+ 1 pc) (cdr code)
|
||||
(cons `(split ,(hashtable-ref locs l1 #f)
|
||||
,(hashtable-ref locs l2 #f))
|
||||
acc)))
|
||||
|
||||
(instr (loop (+ 1 pc) (cdr code) (cons instr acc)))))))
|
||||
|
||||
(define (optimise-jumps! code)
|
||||
(upto (n (vector-length code))
|
||||
(match (vector-ref code n)
|
||||
(('jmp l)
|
||||
(when (match-instr? (vector-ref code l))
|
||||
(vector-set! code n (match-instr))))
|
||||
|
||||
(('split l1 l2)
|
||||
(when (or (match-instr? (vector-ref code l1))
|
||||
(match-instr? (vector-ref code l2)))
|
||||
(vector-set! code n (match-instr))))
|
||||
|
||||
(_ _)))
|
||||
code)
|
||||
|
||||
(define (compile-rx rx)
|
||||
(let ((rx (append-instr rx (match-instr))))
|
||||
(optimise-jumps!
|
||||
(list->vector
|
||||
(remove-labels rx (label-locations rx))))))
|
||||
|
||||
;; A 'thread' consists of an index into the instructions. A 'bundle' holds
|
||||
;; the current threads. Note there cannot be more threads than instructions,
|
||||
|
||||
Loading…
Reference in New Issue
Block a user