release

original commit: 4f5174e44c16d3f1dbc92757f59fce5eb28fd0c5

collects/mzlib/match.ss

@@ -170,441 +170,98 @@ val))]
 ((debug-info-handler))
 val))]))
 
-(define match:syntax-err (lambda (obj msg) (error 'match (string-append msg " ~a") obj)))
+(define match:syntax-err (lambda (obj msg) (error 'match
-(define match:set-error (lambda (v) (set! match:error v)))
+(string-append msg " ~a") obj))) (define match:set-error (lambda (v)
-(define match:error-control-param
+(set! match:error v))) (define match:error-control-param (case-lambda
-(case-lambda
+[() match:error-control] [(v) (match:set-error-control v)])) (define
-[() match:error-control]
+match:error-control 'error) (define match:set-error-control (lambda
-[(v) (match:set-error-control v)]))
+(v) (if (memq v '(unspecified fail error match)) (set!
-(define match:error-control 'error)
+match:error-control v) (error 'match:set-error-control "invalid
-(define match:set-error-control
+setting: ~s" v)))) (define match:disjoint-predicates (cons 'null
-(lambda (v) 
+'(pair?  symbol?  boolean?  number?  string?  char?  procedure?
-(if (memq v '(unspecified fail error match))
+vector?  box?)))  (define match:vector-structures '()) (define
-(set! match:error-control v)
+match:expanders (letrec ((genmatch (lambda (x clauses match-expr)
-(error 'match:set-error-control "invalid setting: ~s" v))))
+(let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist
-(define match:disjoint-predicates
+(car eb-errf)) (plist (map (lambda (c) (let* ((x (bound
-(cons 'null
+(validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings
-'(pair?
+(caddr x)) (code (gensym)) (fail (and (pair?  (cdr c)) (pair?  (cadr
-symbol?
+c)) (eq? (caadr c) '=>) (symbol?  (cadadr c)) (pair?  (cdadr c))
-boolean?
+(null?  (cddadr c)) (pair?  (cddr c)) (cadadr c))) (bv2 (if fail (cons
-number?
+fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons
-string?
+`(,code (lambda ,bv2 ,@body)) (append bindings blist))) (list p code
-char?
+bv (and fail (gensym)) #f))) clauses)) (code (gen x '() plist (cdr
-procedure?
+eb-errf) length>= (gensym)))) (unreachable plist match-expr)
-vector?
+(inline-let `(let ((,length>= (lambda (n) (lambda (l) (>= (length l)
-box?)))
+n)))) ,@blist) ,code))))) (genletrec (lambda (pat exp body match-expr)
-(define match:vector-structures '())
+(let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x
-(define match:expanders
+(bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings
-(letrec ((genmatch (lambda (x clauses match-expr)
+(caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x
-(let* ((length>= (gensym))
+(gensym)) (m (gen x '() plist (cdr eb-errf) length>= (gensym))) (gs
-(eb-errf (error-maker match-expr))
+(map (lambda (_) (gensym)) bv))) (unreachable plist match-expr)
-(blist (car eb-errf))
+`(letrec ((,length>= (lambda (n) (lambda (l) (>= (length l) n))))
-(plist (map (lambda (c)
+,@(map (lambda (v) `(,v #f)) bv) (,x ,exp) (,code (lambda ,gs ,@(map
-(let* ((x (bound
+(lambda (v g) `(set! ,v ,g)) bv gs) ,@body)) ,@bindings ,@(car
-(validate-pattern
+eb-errf)) ,m)))) (gendefine (lambda (pat exp match-expr) (let*
-(car c))))
+((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound
-(p (car x))
+(validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr
-(bv (cadr x))
+x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym))
-(bindings (caddr x))
+(m (gen x '() plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda
-(code (gensym))
+(_) (gensym)) bv))) (unreachable plist match-expr) `(begin ,@(map
-(fail (and (pair?
+(lambda (v) `(define ,v #f)) bv) ,(inline-let `(let ((,length>=
-(cdr c))
+(lambda (n) (lambda (l) (>= (length l) n)))) (,x ,exp) (,code (lambda
-(pair?
+,gs ,@(map (lambda (v g) `(set! ,v ,g)) bv gs) (cond (#f #f))))
-(cadr c))
+,@bindings ,@(car eb-errf)) ,m)))))) (pattern-var? (lambda (x) (and
-(eq? (caadr
+(symbol? x) (not (dot-dot-k? x)) (not (memq x '(quasiquote quote
-c)
+unquote unquote-splicing ?  _ $ and or not set!  get!  ...  ___))))))
-'=>)
+(dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s '(... ___)) 0
-(symbol?
+(let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n)
-(cadadr
+(memq (string-ref s 0) '(#\. #\_)) (memq (string-ref s 1) '(#\. #\_))
-c))
+(andmap char-numeric?  (string->list (substring s 2 n)))
-(pair?
+(string->number (substring s 2 n)))))))) (error-maker (lambda
-(cdadr
+(match-expr) (cond ((eq? match:error-control 'unspecified) (cons '()
-c))
+(lambda (x) `(cond (#f #f))))) ((memq match:error-control '(error
-(null?
+fail)) (cons '() (lambda (x) `((#%global-defined-value 'match:error)
-(cddadr
+,x)))) ((eq? match:error-control 'match) (let ((errf (gensym)) (arg
-c))
+(gensym))) (cons `((,errf (lambda (,arg) ((#%global-defined-value
-(pair?
+'match:error) ,arg ',match-expr)))) (lambda (x) `(,errf ,x))))) (else
-(cddr c))
+(match:syntax-err '(unspecified error fail match) "invalid value for
-(cadadr
+match:error-control, legal values are"))))) (unreachable (lambda
-c)))
+(plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x)))
-(bv2 (if fail
+(begin (display "Warning: unreachable pattern ") (display (car x))
-(cons fail
+(display " in ") (display match-expr) (newline)))) plist)))
-bv)
+(validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or
-bv))
+(string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary
-(body (if fail
+(lambda (p) (let ((g204 (lambda (x y) (cons (ordinary x) (ordinary
-(cddr c)
+y))))) (if (simple? p) ((lambda (p) p) p) (if (equal?  p '_) ((lambda
-(cdr c))))
+() '_)) (if (pattern-var?  p) ((lambda (p) p) p) (if (pair?  p) (if
-(set! blist
+(equal?  (car p) 'quasiquote) (if (and (pair?  (cdr p)) (null?  (cddr
-(cons `(,code
+p))) ((lambda (p) (quasi p)) (cadr p)) (g204 (car p) (cdr p))) (if
-(lambda ,bv2
+(equal?  (car p) 'quote) (if (and (pair?  (cdr p)) (null?  (cddr p)))
-,@body))
+((lambda (p) p) p) (g204 (car p) (cdr p))) (if (equal?  (car p) '?)
-(append
+(if (and (pair?  (cdr p)) (list?  (cddr p))) ((lambda (pred ps) `(?
-bindings
+,pred ,@(map ordinary ps))) (cadr p) (cddr p)) (g204 (car p) (cdr p)))
-blist)))
+(if (equal?  (car p) 'and) (if (and (list?  (cdr p)) (pair?  (cdr p)))
-(list p
+((lambda (ps) `(and ,@(map ordinary ps))) (cdr p)) (g204 (car p) (cdr
-code
+p))) (if (equal?  (car p) 'or) (if (and (list?  (cdr p)) (pair?  (cdr
-bv
+p))) ((lambda (ps) `(or ,@(map ordinary ps))) (cdr p)) (g204 (car p)
-(and fail
+(cdr p))) (if (equal?  (car p) 'not) (if (and (list?  (cdr p)) (pair?
-(gensym))
+(cdr p))) ((lambda (ps) `(not ,@(map ordinary ps))) (cdr p)) (g204
-#f)))
+(car p) (cdr p))) (if (equal?  (car p) '$) (if (and (pair?  (cdr p))
-clauses))
+(symbol?  (cadr p)) (list?  (cddr p))) ((lambda (r ps) `($ ,r ,@(map
-(code (gen x
+ordinary ps))) (cadr p) (cddr p)) (g204 (car p) (cdr p))) (if (equal?
-'()
+(car p) 'set!)  (if (and (pair?  (cdr p)) (pattern-var?  (cadr p))
-plist
+(null?  (cddr p))) ((lambda (p) p) p) (g204 (car p) (cdr p))) (if
-(cdr eb-errf)
+(equal?  (car p) 'get!)  (if (and (pair?  (cdr p)) (pattern-var?
-length>=
+(cadr p)) (null?  (cddr p))) ((lambda (p) p) p) (g204 (car p) (cdr
-(gensym))))
+p))) (if (equal?  (car p) 'unquote) (g204 (car p) (cdr p)) (if (equal?
-(unreachable plist match-expr)
+(car p) 'unquote-splicing) (g204 (car p) (cdr p)) (if (and (pair?
-(inline-let
+(cdr p)) (dot-dot-k?  (cadr p)) (null?  (cddr p))) ((lambda (p ddk)
-`(let ((,length>= (lambda (n)
+`(,(ordinary p) ,ddk)) (car p) (cadr p)) (g204 (car p) (cdr
-(lambda (l)
+p)))))))))))))) (if (vector?  p) ((lambda (p) (let* ((pl (vector->list
-(>= (length l) n))))
+p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl))
-,@blist)
+(dot-dot-k?  (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr
-,code)))))
+rpl)))) (map ordinary pl))))) p) (if (box? p) ((lambda (p) (box
-(genletrec (lambda (pat exp body match-expr)
+(ordinary (unbox p)))) p)
-(let* ((length>= (gensym))
-(eb-errf (error-maker match-expr))
-(x (bound (validate-pattern pat)))
-(p (car x))
-(bv (cadr x))
-(bindings (caddr x))
-(code (gensym))
-(plist (list (list p code bv #f #f)))
-(x (gensym))
-(m (gen x
-'()
-plist
-(cdr eb-errf)
-length>=
-(gensym)))
-(gs (map (lambda (_) (gensym)) bv)))
-(unreachable plist match-expr)
-`(letrec ((,length>= (lambda (n)
-(lambda (l)
-(>= (length l) n))))
-,@(map (lambda (v) `(,v #f)) bv)
-(,x ,exp)
-(,code (lambda ,gs
-,@(map (lambda (v g)
-`(set! ,v ,g))
-bv
-gs)
-,@body))
-,@bindings
-,@(car eb-errf))
-,m))))
-(gendefine (lambda (pat exp match-expr)
-(let* ((length>= (gensym))
-(eb-errf (error-maker match-expr))
-(x (bound (validate-pattern pat)))
-(p (car x))
-(bv (cadr x))
-(bindings (caddr x))
-(code (gensym))
-(plist (list (list p code bv #f #f)))
-(x (gensym))
-(m (gen x
-'()
-plist
-(cdr eb-errf)
-length>=
-(gensym)))
-(gs (map (lambda (_) (gensym)) bv)))
-(unreachable plist match-expr)
-`(begin ,@(map (lambda (v) `(define ,v #f))
-bv)
-,(inline-let
-`(let ((,length>= (lambda (n)
-(lambda (l)
-(>= (length
-l)
-n))))
-(,x ,exp)
-(,code (lambda ,gs
-,@(map (lambda (v
-g)
-`(set! ,v
-,g))
-bv
-gs)
-(cond (#f #f))))
-,@bindings
-,@(car eb-errf))
-,m))))))
-(pattern-var? (lambda (x)
-(and (symbol? x)
-(not (dot-dot-k? x))
-(not (memq x
-'(quasiquote
-quote
-unquote
-unquote-splicing
-?
-_
-$
-and
-or
-not
-set!
-get!
-...
-___))))))
-(dot-dot-k? (lambda (s)
-(and (symbol? s)
-(if (memq s '(... ___))
-0
-(let* ((s (symbol->string s))
-(n (string-length s)))
-(and (<= 3 n)
-(memq (string-ref s 0)
-'(#\. #\_))
-(memq (string-ref s 1)
-'(#\. #\_))
-(andmap
-char-numeric?
-(string->list
-(substring s 2 n)))
-(string->number
-(substring s 2 n))))))))
-(error-maker (lambda (match-expr)
-(cond
-((eq? match:error-control 'unspecified) (cons '()
-(lambda (x)
-`(cond
-(#f #f)))))
-((memq match:error-control '(error fail)) (cons '()
-(lambda (x)
-`((#%global-defined-value 'match:error)
-,x))))
-((eq? match:error-control 'match) (let ((errf (gensym))
-(arg (gensym)))
-(cons `((,errf
-(lambda (,arg)
-((#%global-defined-value 'match:error)
-,arg
-',match-expr))))
-(lambda (x)
-`(,errf
-,x)))))
-(else (match:syntax-err
-'(unspecified error fail match)
-"invalid value for match:error-control, legal values are")))))
-(unreachable (lambda (plist match-expr)
-(for-each
-(lambda (x)
-(if (not (car (cddddr x)))
-(begin (display
-"Warning: unreachable pattern ")
-(display (car x))
-(display " in ")
-(display match-expr)
-(newline))))
-plist)))
-(validate-pattern (lambda (pattern)
-(letrec ((simple? (lambda (x)
-(or (string? x)
-(boolean? x)
-(char? x)
-(number? x)
-(null? x))))
-(ordinary (lambda (p)
-(let ((g204 (lambda (x
-y)
-(cons (ordinary
-x)
-(ordinary
-y)))))
-(if (simple? p)
-((lambda (p)
-p)
-p)
-(if (equal?
-p
-'_)
-((lambda ()
-'_))
-(if (pattern-var?
-p)
-((lambda (p)
-p)
-p)
-(if (pair?
-p)
-(if (equal?
-(car p)
-'quasiquote)
-(if (and (pair?
-(cdr p))
-(null?
-(cddr p)))
-((lambda (p)
-(quasi
-p))
-(cadr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'quote)
-(if (and (pair?
-(cdr p))
-(null?
-(cddr p)))
-((lambda (p)
-p)
-p)
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'?)
-(if (and (pair?
-(cdr p))
-(list?
-(cddr p)))
-((lambda (pred
-ps)
-`(? ,pred
-,@(map ordinary
-ps)))
-(cadr p)
-(cddr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'and)
-(if (and (list?
-(cdr p))
-(pair?
-(cdr p)))
-((lambda (ps)
-`(and ,@(map ordinary
-ps)))
-(cdr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'or)
-(if (and (list?
-(cdr p))
-(pair?
-(cdr p)))
-((lambda (ps)
-`(or ,@(map ordinary
-ps)))
-(cdr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'not)
-(if (and (list?
-(cdr p))
-(pair?
-(cdr p)))
-((lambda (ps)
-`(not ,@(map ordinary
-ps)))
-(cdr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'$)
-(if (and (pair?
-(cdr p))
-(symbol?
-(cadr p))
-(list?
-(cddr p)))
-((lambda (r
-ps)
-`($ ,r
-,@(map ordinary
-ps)))
-(cadr p)
-(cddr p))
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'set!)
-(if (and (pair?
-(cdr p))
-(pattern-var?
-(cadr p))
-(null?
-(cddr p)))
-((lambda (p)
-p)
-p)
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'get!)
-(if (and (pair?
-(cdr p))
-(pattern-var?
-(cadr p))
-(null?
-(cddr p)))
-((lambda (p)
-p)
-p)
-(g204 (car p)
-(cdr p)))
-(if (equal?
-(car p)
-'unquote)
-(g204 (car p)
-(cdr p))
-(if (equal?
-(car p)
-'unquote-splicing)
-(g204 (car p)
-(cdr p))
-(if (and (pair?
-(cdr p))
-(dot-dot-k?
-(cadr p))
-(null?
-(cddr p)))
-((lambda (p
-ddk)
-`(,(ordinary
-p)
-,ddk))
-(car p)
-(cadr p))
-(g204 (car p)
-(cdr p))))))))))))))
-(if (vector?
-p)
-((lambda (p)
-(let* ((pl (vector->list
-p))
-(rpl (reverse
-pl)))
-(apply
-vector
-(if (dot-dot-k?
-(car rpl))
-(reverse
-(cons (car rpl)
-(map ordinary
-(cdr rpl))))
-(map ordinary
-pl)))))
-p)
-(if (box? p)
-((lambda (p)
-(box (ordinary
-(unbox
-p))))
-p)
 
 ((lambda ()
 (match:syntax-err