scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
scsh-0.6/scsh/rx/posixstr.scm

633 lines
22 KiB
Scheme
Raw Blame History

;;; Regexp-ADT -> Posix-string translator.
;;; Olin Shivers January 1997, May 1998.
;;; - If the regexp value contains nul character constants, or character sets
;;; that contain the nul character, they will show up in the Posix string
;;; we produce. Spencer's C regexp engine can handle regexp strings that
;;; contain nul bytes, but this might blow up other implementations -- that
;;; is, the nul byte might prematurely terminate the C string passed to the
;;; regexp engine.
;;;
;;; - The code is ASCII-specific in only one place: the expression for
;;; a regexp that matches nothing is the 6-char pattern "[^\000-\177]",
;;; which assumes a 7-bit character code. Note that the static simplifier
;;; can remove *all* occurences of this "empty regexp" except for the
;;; un-simplifiable case of a single, top-level empty regexp, e.g.
;;; (rx (in))
;;; We can handle this one special case specially, so we shouldn't *ever*
;;; have to produce this ASCII-specific pattern.
;;; Exports: regexp->posix-string
;;; Todo: A dumb, simple char-set renderer.
;;; These functions translate static regular expressions into Posix regexp
;;; strings. They generally return four values:
;;; - string (regexp)
;;;
;;; - syntax level: 0 parenthesized exp, 1 piece, 2 branch, 3 top
;;; ("piece", "branch" and "top" are Spencer's terms):
;;; + A parenthesized exp is syntactically equivalent to a piece.
;;; (But it's useful to know when an exp is parenthesized for
;;; eliminating redundant submatch-generated parens.)
;;; + A piece is something that would bind to a following *
;;; ("a" but not "aa").
;;; + A branch is a sequence of pieces -- something that would bind to a |
;;; ("ab*d" but not "ab*|d"). That is, a branch is not allowed to contain
;;; top-level |'s.
;;; + Top is for a sequence of branches -- "a|b*c|d".
;;;
;;; - paren count in the returned string.
;;;
;;; [This is a newer description; is it correct?]
;;; - A vector mapping submatches (vector index 0 is submatch 1)
;;; to the paren for that submatch (the first paren is paren #1).
;;;
;;; [This is my original description.]
;;; - Vector of parens numbers used for submatching. The first paren is
;;; numbered 1. #F means a dead submatch -- one we can tell statically
;;; will never match anything.
;;; Non-R4RS imports:
;;; ? = COND
;;; Multiple-value return: VALUES RECEIVE CALL-WITH-VALUES
;;; SORT-LIST
;;; Useful little utility -- pad vector V with
;;; PRE initial and POST following #f's.
(define (pad-vector pre post v)
(if (= pre post 0) v
(let* ((vlen (vector-length v))
(alen (+ pre post vlen))
(ans (make-vector alen #f)))
(do ((from (- vlen 1) (- from 1))
(to (+ pre vlen -1) (- to 1)))
((< from 0))
(vector-set! ans to (vector-ref v from)))
ans)))
(define (n-falses n) (make-vector n #f))
;;; There's no representation for regexps that never match anything (e.g.,
;;; (|)) in strict Posix notation. When we get one of these, we treat it
;;; specially, producing [#f #f #f #f].
;;;
;;; We can always detect these empty regexps, because they always simplify
;;; to one of these two values:
;;; - (make-re-char-set char-set:empty)
;;; - (dsm m n (make-re-char-set char-set:empty))
(define (simple-empty-re? re)
(or (and (re-char-set? re)
(char-set-empty? (re-char-set:cset re)))
(and (re-dsm? re)
(simple-empty-re? (re-dsm:body re)))))
;;; Top-level
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (regexp->posix-string re)
;; We *must* simplify, to guarantee correct translation.
(let ((re (simplify-regexp re)))
(if (simple-empty-re? re) (values #f #f #f #f)
(translate-regexp re))))
(define (translate-regexp re)
(cond
((re-string? re) (translate-string (re-string:chars re)))
((re-repeat? re) (translate-repeat re))
((re-choice? re) (translate-choice re))
((re-seq? re) (translate-seq re))
((re-char-set? re) (translate-char-set (re-char-set:cset re)))
((re-submatch? re) (translate-submatch re))
((re-bos? re) (values "^" 1 0 '#()))
((re-eos? re) (values "$" 1 0 '#()))
((re-bol? re) (error "Beginning-of-line regexp not supported in this implementation."))
((re-eol? re) (error "End-of-line regexp not supported in this implementation."))
((re-dsm? re) (let ((pre-dsm (re-dsm:pre-dsm re))
(body (re-dsm:body re)))
(translate-dsm body pre-dsm
(- (re-dsm:tsm re)
(+ pre-dsm (re-tsm body))))))
(else (error "Illegal regular expression" re))))
;;; Translate reloc-elt ELT = (N . RE) from a sequence or choice
;;; into a Posix string.
;;; - Relocate the submatch indices by PREV-PCOUNT.
;;; (That is, assume rendering preceding elts used PREV-PCOUNT parens.)
;;; - Assume preceding elements allocated PREV-SMCOUNT submatches
;;; (we may have to pad our returned submatches string with some
;;; initial #F's to account for dead submatches PREV-SMCOUNT through N.)
;;; - If SUB-LEV3? is true, the result string is guaranteed to be < level 3.
;;; This is used by the & and | translators.
;;; - Returns the usual 4 values plus the final submatch count including
;;; this regexp.
(define (translate-elt elt prev-pcount prev-smcount sub-lev3?)
(let ((offset (car elt))
(re (cdr elt)))
(receive (s level pcount submatches) (translate-regexp re)
;; Relocate submatch indices by OFFSET and force level <3, if needed:
(receive (s level pcount submatches)
(if (and sub-lev3? (= level 3))
(values (string-append "(" s ")")
0
(+ pcount 1)
(mapv (lambda (sm) (and sm (+ prev-pcount 1 sm)))
submatches))
(values s level pcount
(mapv (lambda (sm) (and sm (+ prev-pcount sm)))
submatches)))
;; Tack onto submatches as many initial #F's as needed to bump
;; the previous submatches count from PREV-SMCOUNT to OFFSET.
(values s level pcount
(pad-vector (- offset prev-smcount) 0 submatches)
(+ offset (re-tsm re)))))))
;;; Force the string to be level < 3 by parenthesizing it if necessary.
(define (paren-if-necessary s lev pcount submatches)
(if (< lev 3)
(values s lev pcount submatches)
(values (string-append "(" s ")")
0
(+ pcount 1)
(mapv (lambda (sm) (and sm (+ 1 sm)))
submatches))))
;;; (: re1 ... ren)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translate-seq re)
(let ((elts (re-seq:elts re))
(tsm (re-seq:tsm re)))
(let recur ((elts elts) (prev-pcount 0) (prev-smcount 0))
;; Render a sequence tail ELTS, assuming the previous elements translated
;; to a string with PREV-PCOUNT parens, and allocated PREV-SMCOUNT
;; submatches.
(if (pair? elts)
(let* ((elt (car elts))
(elts (cdr elts)))
(receive (s1 level1 pcount1 submatches1)
(translate-regexp elt)
(receive (s1 level1 pcount1 submatches1)
(paren-if-necessary s1 level1 pcount1 submatches1)
(receive (s level pcount submatches)
(recur elts
(+ pcount1 prev-pcount)
(+ prev-smcount (re-tsm elt)))
(values (string-append s1 s)
2
(+ pcount1 pcount)
(vector-append (mapv (lambda (p) (and p (+ p prev-pcount)))
submatches1)
submatches))))))
(values "" 2 0 '#()))))) ; Empty seq
;;; (| re1 ... ren)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translate-choice re)
(let ((elts (re-choice:elts re))
(tsm (re-choice:tsm re)))
(if (pair? elts)
(let recur ((elts elts) (prev-pcount 0) (prev-smcount 0))
;; ELTS is a non-empty choice tail. Render it, assuming the
;; previous elements translated to a string with PREV-PCOUNT parens,
;; and allocated PREV-SMCOUNT submatches.
(let ((elt (car elts)) (tail (cdr elts)))
(receive (s1 level1 pcount1 submatches1) (translate-regexp elt)
(let ((submatches1 (mapv (lambda (sm) (and sm (+ sm prev-pcount)))
submatches1)))
(if (pair? tail)
(receive (s level pcount submatches)
(recur tail
(+ pcount1 prev-pcount)
(+ prev-smcount (re-tsm elt)))
(values (string-append s1 "|" s) 3
(+ pcount1 pcount)
(vector-append submatches1 submatches)))
(values s1 level1 pcount1 submatches1))))))
(values "[^\000-\377]" 1 0 (n-falses tsm))))) ; Empty choice.
;;; Repeated cases: * + ? and {n,m} ranges.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translate-repeat re)
(let ((from (re-repeat:from re))
(to (re-repeat:to re))
(body (re-repeat:body re))
(tsm (re-repeat:tsm re)))
(cond
((and to (> from to)) ; Unsatisfiable
(values "[^\000-\377]" 1 0 (n-falses tsm)))
((and to (= from to 1)) (translate-seq body)) ; RE{1,1} => RE
((and to (= to 0)) ; RE{0,0} => ""
(values "" 2 0 (n-falses tsm)))
(else ; General case
(receive (s level pcount submatches) (translate-regexp body)
(receive (s level pcount submatches) ; Coerce S to level <2.
(if (> level 1)
(values (string-append "(" s ")")
0
(+ pcount 1)
(mapv (lambda (i) (and i (+ i 1))) submatches))
(values s level pcount submatches))
(values (if to
(cond ((and (= from 0) (= to 1)) (string-append s "?"))
((= from to)
(string-append s "{" (number->string to) "}"))
(else
(string-append s "{" (number->string from)
"," (number->string to) "}")))
(cond ((= from 0) (string-append s "*"))
((= from 1) (string-append s "+"))
(else (string-append s "{" (number->string from) ",}"))))
1 pcount submatches)))))))
;;; Submatch
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (translate-submatch re)
(let ((body (re-submatch:body re))
(pre-dsm (re-submatch:pre-dsm re)))
;; Translate the body, along with any leading or trailing dead submatches.
(receive (s level pcount submatches)
(translate-dsm body
pre-dsm
(- (re-submatch:tsm re)
(+ 1 pre-dsm (re-tsm body))))
;; If the whole expression isn't already wrapped in a paren, wrap it.
;; This outer paren becomes the new submatch -- add to submatches list.
(if (= level 0)
(values s 0 pcount (vector-append '#(1) submatches))
(values (string-append "(" s ")")
0
(+ pcount 1)
(mapv! (lambda (i) (and i (+ i 1))) ; Excuse me.
(vector-append '#(0) submatches)))))))
;;; Translating DSM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Translate the body, and paste enough #F's before and after the submatches
;;; list to account for extra dead submatches.
(define (translate-dsm body pre-dsm post-dsm)
(receive (s level pcount submatches) (translate-regexp body)
(values s level pcount (pad-vector pre-dsm post-dsm submatches))))
;;; Constant regexps
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert a string into a regexp pattern that matches that string exactly --
;;; quote the special chars with backslashes.
(define translate-string
(let ((specials (string->char-set "{}[.*?()|\\$^+")))
(lambda (s)
(let ((len (string-length s)))
(if (zero? len)
(values "()" 0 1 '#()) ; Special case ""
(let* ((len2 (string-fold (lambda (c len) ; Length of answer str
(+ len (if (char-set-contains? specials c) 2 1)))
0 s))
(s2 (make-string len2))) ; Answer string
;; Copy the chars over to S2.
(string-fold (lambda (c i)
;; Write char C at index I, return the next index.
(let ((i (cond ((char-set-contains? specials c)
(string-set! s2 i #\\)
(+ i 1))
(else i))))
(string-set! s2 i c)
(+ i 1)))
0 s)
(values s2 (if (= len 1) 1 2)
0 '#())))))))
;;; Translating char-sets to [...] strings
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is the nastiest code in the system. We make an effort to return
;;; succinct encodings of the char-sets, in the event these encodings are
;;; being shown to humans.
;;; - A singleton set is rendered as that char.
;;; - A full set is rendered as "."
;;; - An empty set is rendered as [^\000-\177].
;;; - Otherwise, render it both as a [...] and as a [^...] spec, and
;;; take whichever is shortest.
;;; Take a char set, and return the standard
;;; [regexp-string, level, pcount, submatches]
;;; quadruple.
;;;
(define *nul* (ascii->char 0))
(define (translate-char-set cset)
(if (char-set-full? cset)
(values "." 1 0 '#()) ; Full set
(let* ((cset (char-set-delete cset *nul*))
(nchars (char-set-size cset))
(->bracket-string (lambda (cset in?)
(receive (loose ranges) (char-set->in-pair cset)
(hack-bracket-spec loose ranges in?)))))
(cond
((= 0 nchars) (values "[^\000-\177]" 1 0 '#())) ; Empty set
((= 1 nchars) ; Singleton set
(translate-string (string (car (char-set->list cset)))))
;; General case. Try both [...] and [^...].
(else (let ((s- (->bracket-string cset #t))
(s+ (->bracket-string
(char-set-delete (char-set-complement cset) *nul*)
#f)))
(values (if (< (string-length s-) (string-length s+))
s- s+)
1 0 '#())))))))
;;; Commentary
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Hacking special chars in character-class strings:
;;; ] - ^ ]...^-
;;; ] - ]...-
;;; ] ^ ]...^
;;; ] ]...
;;; - ^ ...^- (or doubleton screw-case)
;;; - ...-
;;; ^ ...^ (or singleton screw-case)
;;;
;;; Two screw cases:
;;; "^-" must be converted to "-^" for IN.
;;; "^" must be converted to non-class "^" for IN.
;;; Rendering a general char-set into a correct Posix [...] bracket expression
;;; is a complete mess.
;;;
;;; The rules on bracket expressions:
;;; - ] terminates the exp unless it is the first char
;;; (after an optional leading ^).
;;; - .*[\ are not special in bracket expressions.
;;; - However, [. [= and [: *are* special, so you can't follow an
;;; open bracket by one of .=: -- argh. See below.
;;; - ^ isn't special unless it's the first char.
;;; - - is special unless it's first (after an optional ^), last,
;;; or as the ending char in a range (e.g., a--).
;;; This means:
;;; - You must ensure that ] doesn't begin or terminate a range.
;;; - You must ensure that .=: don't follow [
;;; + This can happen in the loose char list;
;;; + This can happen in the range list -- consider the pair of
;;; ranges "x-[.-%" Handle this by prohibiting [ as a range-terminator.
;;; + It can happen at the loose/range boundary: %[:-?
;;; First, run-length encode the set into loose and range-pairs.
;;; If the set is a singleton set, then punt the whole [...] effort,
;;; and do it as a simple char.
;;; Repeat until stable:
;;; - Sort the ranges in this order:
;;; 1. other ranges;
;;; 2. ranges that begin with ^ (not priority)
;;; 3. ranges that begin with .=: (priority)
;;; 4. ranges that end with [ (priority)
;;; This eliminates [. [= [: problems in the ranges, and
;;; minimises the chances of the problem at the loose/range boundary.
;;; and problems with initial ^ chars.
;;; - Sort the loose chars so that ] is first, then -, then .=:, then [,
;;; then others, then ^. This eliminates [. [= [: problems in the loose
;;; chars, and minimises the chances of the problem at the loose/range
;;; boundary.
;;; - Shrink ranges by moving an opening or closing range char into the
;;; loose-char set:
;;; + If ] opens or closes a range, shrink it out.
;;; + If any range opens with -, shrink it out.
;;; + If the first range opens with .=:, and the last loose char is [,
;;; shrink it out.
;;; + If there are no loose chars, the first range begins with ^, and
;;; we're doing an IN range, shrink out the ^.
;;; + Shrinking a range down to <3 chars means move it's elts into the
;;; loose char set.
;;; - If both [ and - are in the loose char set,
;;; pull - out as special end-hypen.
;;; Finally, we have to hack things so that ^ doesn't begin an IN sequence.
;;; - If it's a NOT-IN sequence, no worries.
;;; - If ^ is the opening loose char, then it's the only loose char.
;;; If there are ranges, move it to the end of the string.
;;; If there are no ranges, then just punt the char-class and convert
;;; it to a singleton ^. In fact, do this up-front, for any singleton
;;; set.
;;;
;;; If the special end-hyphen flag is set, add - to the end of the string.
;;; This general approach -- starting out with maximal ranges, and then
;;; shrinking them to avoid other syntax violations -- has the advantage
;;; of not relying on the details of the ASCII encodings.
;;; Ordering ranges:
;;; 1. other ranges (ordered by start char)
;;; 2. ranges that begin with ^ (not priority)
;;; 3. ranges that begin with .=:
;;; 4. ranges that end with [ (priority over #2 & #3)
(define (range< r1 r2)
(let ((r1-start (car r1)) (r1-end (cdr r1))
(r2-start (car r2)) (r2-end (cdr r2)))
(or (char=? r2-end #\[) ; Range ending with [ comes last.
(and (not (char=? r1-end #\[))
;; Range begin with one of .=: comes next-to-last
(or (char=? r2-start #\.) (char=? r2-start #\=) (char=? r2-start #\:)
(and (not (char=? r1-start #\.))
(not (char=? r1-start #\=))
(not (char=? r1-start #\:))
;; Range beginning with ^ comes before that.
(or (char=? r1-start #\^)
(and (not (char=? r2-start #\^))
;; Other ranges are ordered by start char.
(< (char->ascii r1-start)
(char->ascii r2-start))))))))))
;;; Order loose chars:
;;; ] is first,
;;; - is next,
;;; .=: are next,
;;; [ is next,
;;; then others (ordered by ascii val)
;;; ^ is last.
(define (loose<= c1 c2)
(or (char=? c1 #\]) ; ] is first,
(and (not (char=? c2 #\]))
(or (char=? c1 #\-) ; - is next,
(and (not (char=? c2 #\-))
;; .=: are next,
(or (char=? c1 #\.) (char=? c1 #\=) (char=? c1 #\:)
(and (not (char=? c2 #\.))
(not (char=? c2 #\=))
(not (char=? c2 #\:))
(or (char=? c1 #\[) ; [ is next,
(and (not (char=? c2 #\[))
(or (char=? c2 #\^) ; ^ is last,
(and (not (char=? c1 #\^))
;; other chars by ASCII.
(<= (char->ascii c1)
(char->ascii c2)))))))))))))
;;; Returns (1) a list of 0-3 loose chars, (2) a list of 0 or 1 ranges.
(define (shrink-range-start r)
(let ((start (char->ascii (car r)))
(end (char->ascii (cdr r))))
(shrink-range-finish-up start (+ start 1) end)))
(define (shrink-range-end r)
(let ((start (char->ascii (car r)))
(end (char->ascii (cdr r))))
(shrink-range-finish-up end start (- end 1))))
(define (shrink-range-finish-up c start end)
(cond
((> start end) (values (list (ascii->char c)) '())) ; Empty range
((= start end) ; Collapse singleton range.
(values (list (ascii->char c) (ascii->char start))
'()))
((= (+ start 1) end) ; Collapse doubleton range.
(values (list (ascii->char c) (ascii->char start) (ascii->char end))
'()))
(else (values (list (ascii->char c))
(list (cons (ascii->char start) (ascii->char end)))))))
;;; We assume the bracket-spec is not a singleton, not empty, and not complete.
;;; (These cases get rendered as the letter, [^\000-\177], and ".",
;;; respectively.) We assume the loose chars and the ranges are all disjoint.
(define (hack-bracket-spec loose ranges in?)
(let lp ((loose0 loose) (ranges0 ranges) (end-hyphen? #f))
;; Repeat until stable:
(let ((loose (sort-list loose0 loose<=)) ; Sort loose chars and ranges.
(ranges (sort-list ranges0 range<)))
;; If ] opens or closes a range, shrink it out.
;; If - opens a range, shrink it out.
(receive (loose ranges)
(let recur ((ranges ranges))
(if (pair? ranges)
(let* ((range (car ranges))
(start (car range))
(end (cdr range))
(ranges (cdr ranges)))
(receive (new-loose new-ranges) (recur ranges)
(receive (new-loose0 new-ranges0)
(cond ((char=? #\] start)
(shrink-range-start range))
((char=? #\] end)
(shrink-range-end range))
((char=? #\- start)
(shrink-range-start range))
(else (values '() (list range))))
(values (append new-loose0 new-loose)
(append new-ranges0 new-ranges)))))
(values loose '())))
(let ((loose (sort-list loose loose<=)) ; Sort loose chars and ranges.
(ranges (sort-list ranges range<)))
(cond
((or (not (equal? loose0 loose)) ; Loop if anything changed.
(not (equal? ranges0 ranges)))
(lp loose ranges end-hyphen?))
;; If the first range opens with .=:, and the last loose char is [,
;; shrink it out & loop.
((and (pair? ranges)
(memv (caar ranges) '(#\. #\= #\:))
(pair? loose)
(char=? #\[ (car (reverse loose))))
(receive (new-loose new-ranges)
(shrink-range-start (car ranges))
(lp (append new-loose loose) (append new-ranges (cdr ranges)) end-hyphen?)))
;; If there are no loose chars, the first range begins with ^, and
;; we're doing an IN range, shrink out the ^.
((and in? (null? loose) (pair? ranges) (char=? #\^ (caar ranges)))
(receive (new-loose new-ranges) (shrink-range-start (car ranges))
(lp (append new-loose loose) (append new-ranges ranges) end-hyphen?)))
;; If both [ and - are in the loose char set,
;; pull - out as special end-hypen.
((and (pair? loose)
(pair? (cdr loose))
(char=? (car loose) #\[)
(char=? (car loose) #\-))
(lp (cons (car loose) (cddr loose)) ranges #t))
;; No change! Build the answer...
(else (string-append (if in? "[" "[^")
(list->string loose)
(apply string-append
(map (lambda (r) (string (car r) #\- (cdr r)))
ranges))
"]"))))))))
Reference in New Issue View Git Blame Copy Permalink