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

View File

@ -797,8 +797,6 @@ SCHEME =scsh/awk.scm \
scsh/pty.scm \ scsh/pty.scm \
scsh/rdelim.scm \ scsh/rdelim.scm \
scsh/rw.scm \ scsh/rw.scm \
scsh/rx/packages.scm \
scsh/rx/cond-package.scm \
scsh/scsh-condition.scm \ scsh/scsh-condition.scm \
scsh/scsh-interfaces.scm \ scsh/scsh-interfaces.scm \
scsh/scsh-package.scm \ scsh/scsh-package.scm \
@ -816,7 +814,6 @@ SCHEME =scsh/awk.scm \
scsh/tty.scm \ scsh/tty.scm \
scsh/utilities.scm \ scsh/utilities.scm \
scsh/weaktables.scm \ scsh/weaktables.scm \
scsh/rx/cond-package.scm \
scsh/rx/packages.scm \ scsh/rx/packages.scm \
scsh/rx/re-match-syntax.scm \ scsh/rx/re-match-syntax.scm \
scsh/rx/rx-lib.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 \ loads = $(srcdir)/scsh/let-opt.scm $(srcdir)/scsh/scsh-interfaces.scm \
$(srcdir)/scsh/machine/packages.scm \ $(srcdir)/scsh/machine/packages.scm \
$(srcdir)/scsh/rx/packages.scm \ $(srcdir)/scsh/rx/packages.scm \
$(srcdir)/scsh/rx/cond-package.scm \
$(srcdir)/scsh/scsh-package.scm \ $(srcdir)/scsh/scsh-package.scm \
$(srcdir)/scsh/lib/ccp-pack.scm \ $(srcdir)/scsh/lib/ccp-pack.scm \
$(srcdir)/scsh/lib/char-package.scm $(srcdir)/scsh/lib/char-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.
))

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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