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

Remove the Olinist CONDITITIONALS package, also fixing some atrocious 

uses of whitespace, newline, and indentation.
This saves another 60k or so in scsh.image, actually getting us below
the level of 0.6.2.
This commit is contained in:
sperber 2002-10-30 12:33:51 +00:00
parent 20b65e6bfa
commit 4290ccae21
10 changed files with 628 additions and 755 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile.in
View File

@ -797,8 +797,6 @@ SCHEME =scsh/awk.scm \
scsh/pty.scm \
scsh/rdelim.scm \
scsh/rw.scm \
scsh/rx/packages.scm \
scsh/rx/cond-package.scm \
scsh/scsh-condition.scm \
scsh/scsh-interfaces.scm \
scsh/scsh-package.scm \
@ -816,7 +814,6 @@ SCHEME =scsh/awk.scm \
scsh/tty.scm \
scsh/utilities.scm \
scsh/weaktables.scm \
scsh/rx/cond-package.scm \
scsh/rx/packages.scm \
scsh/rx/re-match-syntax.scm \
scsh/rx/rx-lib.scm \
@ -856,7 +853,6 @@ bs: build/build-scsh-image
loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
$(srcdir)/scsh/machine/packages.scm \
$(srcdir)/scsh/rx/packages.scm \
$(srcdir)/scsh/rx/cond-package.scm \
$(srcdir)/scsh/scsh-package.scm \
$(srcdir)/scsh/lib/ccp-pack.scm \
$(srcdir)/scsh/lib/char-package.scm

160
scsh/rx/cond-package.scm
View File

@ -1,160 +0,0 @@
(define-structure conditionals
(export (define-simple-syntax :syntax)
(when :syntax)
(unless :syntax)
(? :syntax)
(switchq :syntax)
(switch :syntax)
(prog0 :syntax)
(land* :syntax))
(open scheme)
(begin
;;; (define-simple-syntax (name subforms ...) expansion)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax define-simple-syntax
(syntax-rules ()
((define-simple-syntax (name subforms ...) expansion)
(define-syntax name (syntax-rules () ((name subforms ...) expansion))))))
;;; ? = COND
;;; (WHEN test body ...) (SWITCHQ = key clause ...)
;;; (UNLESS test body ...) (SWITCH = key clause ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Handy conditional forms. ? is so short that it renders WHEN pretty
;;; much useless.
(define-simple-syntax (when test body ...)
(if test (begin body ...)))
(define-simple-syntax (unless test body ...)
(if (not test) (begin body ...)))
;;; ? is synonym for COND.
(define-simple-syntax (? clause ...) (cond clause ...))
;;; (PROG0 val-exp exp ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-simple-syntax (prog0 val-exp exp ...)
(let ((v val-exp)) exp ... v))
;;; (land* (clause ...) body ...) -*- Scheme -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Evaluate each clause. If any clause returns false, land* stops and
;;; returns false. If all the clauses evaluate to a true value, return
;;; the value of the body.
;;;
;;; The difference between LAND* and AND is that LAND* binds names to
;;; the values of its clauses, which may be used by subsequent clauses.
;;; Clauses are of the form
;;; (var exp) ; binds VAR to the value of EXP.
;;; (exp) ; No binding.
;;; var ; Reference -- no binding.
;;;
;;; Example:
;;; (land* ((probe (assq key alist)))
;;; (cdr probe))
;;;
;;; LAND* is due to Oleg Kiselyov (http://pobox.com/~oleg); I wrote this
;;; simple implementation as a high-level R5RS DEFINE-SYNTAX macro.
;;; Olin 98/9/29
(define-syntax land*
(syntax-rules ()
((land* () body ...) (begin body ...))
((land* ((var exp) clause ...) body ...)
(let ((var exp)) (and var (land* (clause ...) body ...))))
((land* ((#f exp) clause ...) body ...)
(and exp (land* (clause ...) body ...)))
((land* ((exp) clause ...) body ...)
(and exp (land* (clause ...) body ...)))
((land* (var clause ...) body ...)
(and var (land* (clause ...) body ...)))))
;;; Like CASE, but you specify the key-comparison procedure.
;;; SWITCH evaluates its keys each time through the conditional.
;;; SWITCHQ keys are not evaluated -- are simply constants.
;;; (switchq string=? (vector-ref vec i)
;;; (("plus" "minus") ...)
;;; (("times" "div") ...)
;;; (else ...))
(define-simple-syntax (switchq compare key clause ...)
(let ((k key) ; Eval KEY and COMPARE
(c compare)) ; just once, then call %switch.
(%switchq c k clause ...))) ; C, K are vars, hence replicable.
(define-syntax %switchq
(syntax-rules (else)
((%switchq compare key ((key1 ...) body1 body2 ...) rest ...)
(if (or (compare key 'key1) ...)
(begin body1 body2 ...)
(%switchq compare key rest ...)))
((%switchq compare key ((key1 ...)) rest ...) ; Null body.
(if (not (or (compare key 'key1) ...))
(%switchq compare key rest ...)))
((%switchq compare key (else body ...))
(begin body ...))
((%switchq compare key) '#f)))
(define-simple-syntax (switch compare key clause ...)
(let ((k key) ; Eval KEY and COMPARE
(c compare)) ; just once, then call %switch.
(%switch c k clause ...))) ; C, K are vars, hence replicable.
(define-syntax %switch
(syntax-rules (else)
((%switch compare key ((key1 ...) body1 body2 ...) rest ...)
(if (or (compare key key1) ...)
(begin body1 body2 ...)
(%switch compare key rest ...)))
((%switch compare key ((key1 ...)) rest ...) ; Null body.
(if (not (or (compare key key1) ...))
(%switch compare key rest ...)))
((%switch compare key (else body ...))
(begin body ...))
((%switch compare key) '#f)))
;;; I can't get this to work -- S48 complains "too many ...'s".
;(define-syntax switchq
; (syntax-rules (else)
; ((switchq compare key clause ...)
; (letrec-syntax ((%switchq (syntax-rules (else)
; ((%switchq compare key
; ((key1 ...) body1 body2 ...) rest ...)
; (if (or (compare key 'key1) ...)
; (begin body1 body2 ...)
; (%switchq compare key rest ...)))
;
; ; Null body.
; ((%switchq compare key ((key1 ...)) rest ...)
; (if (not (or (compare key 'key1) ...))
; (%switchq compare key rest ...)))
;
; ((%switchq compare key (else body ...))
; (begin body ...))
;
; ((%switchq compare key) '#f))))
;
; (let ((k key) ; Eval KEY and COMPARE
; (c compare)) ; just once, then call %switch.
; (%switchq c k clause ...)))))); C, K are vars, hence replicable.
))

4
scsh/rx/packages.scm
View File

@ -231,7 +231,6 @@
;; re-posix-parsers ; regexp->posix-string
let-opt
sort ; Posix renderer
conditionals
define-record-types
defrec-package
receiving
@ -275,7 +274,6 @@
(define-structure rx-lib rx-lib-interface
(open re-internals
conditionals
re-level-0
(subset srfi-1 (fold))
srfi-14
@ -342,7 +340,7 @@
(define-structure re-folders re-folders-interface
(open re-level-0 let-opt conditionals error-package scheme)
(open re-level-0 let-opt error-package scheme)
(files re-fold)
; (optimize auto-integrate)
)

82
scsh/rx/parse.scm
View File

@ -22,8 +22,6 @@
;;; is the char-set parsing and unparsing, which deal with ranges of
;;; characters. We assume an 8-bit ASCII superset.
;;; Imports:
;;; ? for COND, and SWITCHQ conditional form.
;;; every
;;; This code is much hairier than it would otherwise be because of the
@ -52,7 +50,8 @@
;;; in the form of embedded code in some of the regexp's fields?
(define (static-regexp? re)
(? ((re-seq? re) (every static-regexp? (re-seq:elts re)))
(cond
((re-seq? re) (every static-regexp? (re-seq:elts re)))
((re-choice? re) (every static-regexp? (re-choice:elts re)))
((re-char-set? re) (char-set? (re-char-set:cset re))) ; Might be code.
@ -149,7 +148,8 @@
(re-repeat from to seq)
`(,(r 're-repeat) ',from ',to ,(regexp->scheme seq r)))))
(? ((char? sre) (parse-char-re sre case-sensitive? cset?))
(cond
((char? sre) (parse-char-re sre case-sensitive? cset?))
((string? sre) (parse-string-re sre case-sensitive? cset?))
((c sre %bos) (non-cset) re-bos)
@ -171,7 +171,7 @@
((hygn-eq? '?)
(non-cset)
(build-re-repeat 0 1 (cdr sre)))
((hygn-eq? '=) ; ####
((hygn-eq? '=)
(non-cset)
(let ((n (cadr sre)))
(build-re-repeat n n (cddr sre))))
@ -198,7 +198,8 @@
((or (hygn-eq? ':)
(hygn-eq? 'seq))
(non-cset) (parse-seq (cdr sre)))
(non-cset)
(parse-seq (cdr sre)))
((hygn-eq? 'submatch)
(non-cset)
@ -206,7 +207,9 @@
(if (static-regexp? seq)
(re-submatch seq)
`(,(r 're-submatch) ,(regexp->scheme seq r)))))
((hygn-eq? 'dsm) (non-cset) (re-dsm (parse-seq (cdddr sre))
((hygn-eq? 'dsm)
(non-cset)
(re-dsm (parse-seq (cdddr sre))
(cadr sre)
(caddr sre)))
@ -241,7 +244,8 @@
`(,%coerce-dynamic-charset ,exp)
`(,%coerce-dynamic-regexp ,exp))))
((hygn-eq? '~) (let* ((cs (assoc-cset-op char-set-union 'char-set-union
((hygn-eq? '~)
(let* ((cs (assoc-cset-op char-set-union 'char-set-union
(map parse-char-class (cdr sre))
r))
(cs (if (char-set? cs)
@ -249,12 +253,14 @@
`(,(r 'char-set-complement) ,cs))))
(if cset? cs (make-re-char-set cs))))
((hygn-eq? '&) (let ((cs (assoc-cset-op char-set-intersection 'char-set-intersection
((hygn-eq? '&)
(let ((cs (assoc-cset-op char-set-intersection 'char-set-intersection
(map parse-char-class (cdr sre))
r)))
(if cset? cs (make-re-char-set cs))))
((hygn-eq? '-) (if (pair? (cdr sre))
((hygn-eq? '-)
(if (pair? (cdr sre))
(let* ((cs1 (parse-char-class (cadr sre)))
(cs2 (assoc-cset-op char-set-union 'char-set-union
(map parse-char-class (cddr sre))
@ -271,8 +277,11 @@
(if cset? cs (make-re-char-set cs)))
(error "SRE set-difference operator (- ...) requires at least one argument")))
((hygn-eq? '/) (let ((cset (range-class->char-set (cdr sre) case-sensitive?)))
(if cset? cset (make-re-char-set cset))))
((hygn-eq? '/)
(let ((cset (range-class->char-set (cdr sre) case-sensitive?)))
(if cset?
cset
(make-re-char-set cset))))
((hygn-eq? 'posix-string)
(if (and (= 1 (length (cdr sre)))
@ -280,7 +289,8 @@
(posix-string->regexp (cadr sre))
(error "Illegal (posix-string ...) SRE body." sre)))
(else (if (every string? sre) ; A set spec -- ("wxyz").
(else
(if (every string? sre) ; A set spec -- ("wxyz").
(let* ((cs (apply char-set-union
(map string->char-set sre)))
(cs (if case-sensitive? cs (uncase-char-set cs))))
@ -343,7 +353,8 @@
(define (assoc-cset-op op op-name elts r)
(receive (csets code-chunks) (partition char-set? elts)
(if (pair? code-chunks)
(? ((pair? csets)
(cond
((pair? csets)
`(,(r op-name) ,(char-set->scheme (apply op csets) r)
. ,code-chunks))
((pair? (cdr code-chunks)) `(,(r op-name) . ,code-chunks))
@ -484,17 +495,17 @@
(if a
(if biga
(if space
(and one (switch char-set= cs
((char-set:full) full)
((nonl-chars) nonl)
((char-set:printing) print)
((char-set:ascii) ascii)
(and one (cond
((char-set= cs char-set:full) full)
((char-set= cs nonl-chars) nonl)
((char-set= cs char-set:printing) print)
((char-set= cs char-set:ascii) ascii)
(else #f)))
(if one
(switch char-set= cs
((char-set:letter+digit) alphanum)
((char-set:graphic) graph)
((char-set:hex-digit) hex)
(cond
((char-set= cs char-set:letter+digit) alphanum)
((char-set= cs char-set:graphic) graph)
((char-set= cs char-set:hex-digit) hex)
(else #f))
(and (char-set= cs char-set:letter) alpha)))
(and (char-set= cs char-set:lower-case) lower)) ; a, not A
@ -504,13 +515,13 @@
(if one
(and (not space) (char-set= cs char-set:digit) num)
(if space
(switch char-set= cs
((char-set:whitespace) white)
((char-set:blank) blank)
(cond
(( char-set= cs char-set:whitespace) white)
(( char-set= cs char-set:blank) blank)
(else #f))
(switch char-set= cs
((char-set:punctuation) punct)
((char-set:iso-control) ctl)
(cond
((char-set= cs char-set:punctuation) punct)
((char-set= cs char-set:iso-control) ctl)
(else #f))))))))
@ -525,7 +536,8 @@
'char-set:printing 'char-set:iso-control
'char-set:hex-digit 'char-set:blank
'char-set:ascii))))
(? ((not (char-set? cs)) cs) ; Dynamic -- *already* Scheme code.
(cond
((not (char-set? cs)) cs) ; Dynamic -- *already* Scheme code.
((char-set-empty? cs) (r 'char-set:empty))
((try cs) => r)
((try (char-set-complement cs)) =>
@ -557,13 +569,14 @@
'hex-digit 'blank
'ascii)))
(nchars (char-set-size cs)))
(? ((zero? nchars) `(,(r '|)))
(cond
((zero? nchars) `(,(r '|)))
((= 1 nchars) (apply string (char-set->list cs)))
((try cs) => r)
((try (char-set-complement cs)) =>
(lambda (name) `(,(r '~) ,name)))
(else (receive (cs rp comp?) (char-set->in-sexp-spec cs)
(let ((args (append (? ((string=? cs "") '())
(let ((args (append (cond ((string=? cs "") '())
((= 1 (string-length cs)) `(,cs))
(else `((,cs))))
(if (string=? rp "") '()
@ -592,7 +605,8 @@
(define (regexp->sre/renamer re r)
(let recur ((re re))
(? ((re-string? re) (re-string:chars re))
(cond
((re-string? re) (re-string:chars re))
((re-seq? re) `(,(r ':) . ,(regexp->sres/renamer re r)))
@ -610,7 +624,7 @@
(let ((from (re-repeat:from re))
(to (re-repeat:to re))
(bodies (regexp->sres/renamer (re-repeat:body re) r)))
(? ((and (eqv? from 0) (not to)) `(,(r '*) . ,bodies))
(cond ((and (eqv? from 0) (not to)) `(,(r '*) . ,bodies))
((and (eqv? from 0) (eqv? to 1)) `(,(r '?) . ,bodies))
((and (eqv? from 1) (not to)) `(,(r '+) . ,bodies))
((eqv? from to) `(,(r '=) ,to . bodies))

21
scsh/rx/posixstr.scm
View File

@ -98,7 +98,8 @@
(define (translate-regexp re)
(? ((re-string? re) (translate-string (re-string:chars re)))
(cond
((re-string? re) (translate-string (re-string:chars re)))
((re-repeat? re) (translate-repeat re))
((re-choice? re) (translate-choice re))
@ -248,7 +249,8 @@
(body (re-repeat:body re))
(tsm (re-repeat:tsm re)))
(? ((and to (> from to)) ; Unsatisfiable
(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
@ -267,13 +269,13 @@
(values s level pcount submatches))
(values (if to
(? ((and (= from 0) (= to 1)) (string-append s "?"))
(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) "}")))
(? ((= from 0) (string-append s "*"))
(cond ((= from 0) (string-append s "*"))
((= from 1) (string-append s "+"))
(else (string-append s "{" (number->string from) ",}"))))
1 pcount submatches)))))))
@ -372,7 +374,8 @@
(receive (loose ranges) (char-set->in-pair cset)
(hack-bracket-spec loose ranges in?)))))
(? ((= 0 nchars) (values "[^\000-\177]" 1 0 '#())) ; Empty set
(cond
((= 0 nchars) (values "[^\000-\177]" 1 0 '#())) ; Empty set
((= 1 nchars) ; Singleton set
(translate-string (string (car (char-set->list cset)))))
@ -539,7 +542,8 @@
(shrink-range-finish-up end start (- end 1))))
(define (shrink-range-finish-up c start end)
(? ((> start end) (values (list (ascii->char c)) '())) ; Empty range
(cond
((> start end) (values (list (ascii->char c)) '())) ; Empty range
((= start end) ; Collapse singleton range.
(values (list (ascii->char c) (ascii->char start))
@ -573,7 +577,7 @@
(ranges (cdr ranges)))
(receive (new-loose new-ranges) (recur ranges)
(receive (new-loose0 new-ranges0)
(? ((char=? #\] start)
(cond ((char=? #\] start)
(shrink-range-start range))
((char=? #\] end)
@ -590,7 +594,8 @@
(let ((loose (sort-list loose loose<=)) ; Sort loose chars and ranges.
(ranges (sort-list ranges range<)))
(? ((or (not (equal? loose0 loose)) ; Loop if anything changed.
(cond
((or (not (equal? loose0 loose)) ; Loop if anything changed.
(not (equal? ranges0 ranges)))
(lp loose ranges end-hyphen?))

12
scsh/rx/re-fold.scm
View File

@ -45,7 +45,8 @@
(error "Illegal START parameter"
regexp-fold re kons knil s finish start))
(let lp ((i start) (val knil))
(? ((regexp-search re s i) =>
(cond
((regexp-search re s i) =>
(lambda (m)
(let ((next-i (match:end m 0)))
(if (= next-i (match:start m 0))
@ -79,11 +80,13 @@
(error "Illegal START parameter" regexp-fold-right re kons knil s
finish start))
(? ((regexp-search re s start) =>
(cond
((regexp-search re s start) =>
(lambda (m)
(finish (match:start m 0)
(let recur ((last-m m))
(? ((regexp-search re s (match:end last-m 0)) =>
(cond
((regexp-search re s (match:end last-m 0)) =>
(lambda (m)
(let ((i (match:start m 0)))
(if (= i (match:end m 0))
@ -104,7 +107,8 @@
(if (> start (string-length s))
(apply error "Illegal START parameter" regexp-for-each re proc s start)
(let lp ((i start))
(? ((regexp-search re s i) =>
(cond
((regexp-search re s i) =>
(lambda (m)
(let ((next-i (match:end m 0)))
(if (= (match:start m 0) next-i)

3
scsh/rx/re-high.scm
View File

@ -17,7 +17,8 @@
(set re cre) ; cache it,
cre))))) ; and return it.
(? ((re-seq? re)
(cond
((re-seq? re)
(check-cache re-seq:posix set-re-seq:posix))
((re-choice? re)
(check-cache re-choice:posix set-re-choice:posix))

23
scsh/rx/re.scm
View File

@ -103,7 +103,7 @@
(if (pair? res)
(let* ((re (car res))
(tail (recur (cdr res))))
(? ((re-seq? re) ; Flatten nested seqs
(cond ((re-seq? re) ; Flatten nested seqs
(append (recur (re-seq:elts re)) tail))
((re-trivial? re) tail) ; Drop trivial elts
(else (cons re tail))))
@ -158,7 +158,7 @@
(if (pair? res) ; & drop empty re's.
(let* ((re (car res))
(tail (recur (cdr res))))
(? ((re-choice? re) ; Flatten nested choices
(cond ((re-choice? re) ; Flatten nested choices
(append (recur (re-choice:elts re)) tail))
((re-empty? re) tail) ; Drop empty re's.
(else (cons re tail))))
@ -254,7 +254,8 @@
dsm0)))
(values from to body dsm0)))))
(? ((and (eqv? from 1) (eqv? to 1)) ; re{1,1} => re
(cond
((and (eqv? from 1) (eqv? to 1)) ; re{1,1} => re
(values body1 pre-dsm))
((and (eqv? from 0) (eqv? to 0)) ; re{0,0} => ""
@ -410,7 +411,8 @@
;;; Return the total number of submatches bound in RE.
(define (re-tsm re)
(? ((re-seq? re) (re-seq:tsm re))
(cond
((re-seq? re) (re-seq:tsm re))
((re-choice? re) (re-choice:tsm re))
((re-repeat? re) (re-repeat:tsm re))
((re-dsm? re) (re-dsm:tsm re))
@ -426,7 +428,8 @@
;;; stripped out -- (= 0 (re-tsm (flush-submatches re))).
(define (flush-submatches re)
(? ((zero? (re-tsm re)) re) ; RE has no submatches.
(cond
((zero? (re-tsm re)) re) ; RE has no submatches.
((re-seq? re) (re-seq (map flush-submatches (re-seq:elts re))))
((re-choice? re) (re-choice (map flush-submatches (re-choice:elts re))))
@ -464,7 +467,8 @@
(define (uncase re)
(receive (new-re changed?)
(let recur ((re re))
(? ((re-seq? re)
(cond
((re-seq? re)
(let ((elts (re-seq:elts re)))
(receive (new-elts elts-changed?)
(map/changed recur elts)
@ -537,8 +541,11 @@
(define (uncase-string s)
;; SEQ is a list of chars and doubleton char-sets.
(let* ((seq (string-fold-right (lambda (c lis)
(cons (? ((char-lower-case? c) (char-set c (char-upcase c)))
((char-upper-case? c) (char-set c (char-downcase c)))
(cons (cond
((char-lower-case? c)
(char-set c (char-upcase c)))
((char-upper-case? c)
(char-set c (char-downcase c)))
(else c))
lis))
'() s))

6
scsh/rx/rx-lib.scm
View File

@ -4,7 +4,8 @@
;;; char-set, or regexp value. Coerce one of these to a regexp value.
(define (coerce-dynamic-regexp x)
(? ((string? x) (make-re-string x))
(cond
((string? x) (make-re-string x))
((char? x) (make-re-string (string x)))
((char-set? x) (make-re-char-set x))
((regexp? x) x)
@ -14,7 +15,8 @@
;;; a ,<exp> or form must be coercable to a char-set.
(define (coerce-dynamic-charset x)
(? ((string? x)
(cond
((string? x)
(if (= 1 (string-length x)) (string->char-set x)
(error "Multi-char string not allowed as ,<exp> or ,@<exp> SRE in char-class context."
x)))

20
scsh/rx/simp.scm
View File

@ -39,7 +39,8 @@
re))
(define (simp-re re)
(? ((re-string? re) (values re 0))
(cond
((re-string? re) (values re 0))
((re-seq? re) (simp-seq re))
((re-choice? re) (simp-choice re))
@ -122,7 +123,8 @@
(define (simp-seq1 elts abort tsm)
(let recur ((elt (car elts)) (elts (cdr elts)))
(receive (elt pre-dsm) (open-dsm elt)
(? ((re-seq? elt) ; Flatten nested seqs.
(cond
((re-seq? elt) ; Flatten nested seqs.
(let ((sub-elts (re-seq:elts elt)))
(recur (re-dsm (car sub-elts) pre-dsm 0)
(append (cdr sub-elts) elts))))
@ -150,7 +152,8 @@
(values (+ pre-dsm next-pre-dsm) elt tail)
(no-simp)))
(? ((re-trivial? elt) ; Drop trivial re's.
(cond
((re-trivial? elt) ; Drop trivial re's.
(values (+ pre-dsm next-pre-dsm) next tail))
;; Coalesce adjacent strings
@ -241,7 +244,8 @@
(tail (if (and eol? (not prev-eol?)) (cons re-eol tail) tail))
(tail (if (and bol? (not prev-bol?)) (cons re-bol tail) tail))
(tail (if (and bos? (not prev-bos?)) (cons re-bos tail) tail))
(tail (? ((zero? numchars) tail) ; Drop empty char set.
(tail (cond
((zero? numchars) tail) ; Drop empty char set.
((= 1 numchars) ; {c} => "c"
(cons (make-re-string (string (car (char-set->list cset))))
tail))
@ -281,7 +285,8 @@
;; Simplify the tail, then think about the head.
(receive (tail-pre-dsm cset bos? eos? bol? eol? tail)
(recur elts
(? ((and (re-string? elt)
(cond
((and (re-string? elt)
(= 1 (string-length (re-string:chars elt))))
(char-set-union prev-cset
(string->char-set (re-string:chars elt))))
@ -334,7 +339,8 @@
cset bos? eos? bol? eol?
(cons elt tail))))
(? ((and (re-char-set? elt)
(cond
((and (re-char-set? elt)
(char-set? (re-char-set:cset elt))) ; Might be Scheme code
(values (+ pre-dsm tail-pre-dsm)
(char-set-union cset (re-char-set:cset elt))
@ -378,7 +384,7 @@
(define (has-live-submatches? re)
(or (re-submatch? re)
(? ((re-seq? re) (every has-live-submatches? (re-seq:elts re)))
(cond ((re-seq? re) (every has-live-submatches? (re-seq:elts re)))
((re-choice? re) (every has-live-submatches? (re-choice:elts re)))
((re-repeat? re) (has-live-submatches? (re-repeat:body re)))
((re-dsm? re) (has-live-submatches? (re-dsm:body re)))