;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pattern Matching Syntactic Extensions for Scheme
;;
(define match:version "Version 1.18, July 17, 1995")
;;
;; Report bugs to wright@research.nj.nec.com.  The most recent version of
;; this software can be obtained by anonymous FTP from ftp.nj.nec.com
;; in file pub/wright/match.tar.Z.  Be sure to set "type binary" when
;; transferring this file.
;;
;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
;; Adapted from code originally written by Bruce F. Duba, 1991.
;; This package also includes a modified version of Kent Dybvig's
;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
;; Prentice-Hall, NJ, 1987).
;;
;; This software is in the public domain.  Feel free to copy,
;; distribute, and modify this software as desired.  No warranties
;; nor guarantees of any kind apply.  Please return any improvements
;; or bug fixes to wright@research.nj.nec.com so that they may be included
;; in future releases.
;;
;; This macro package extends Scheme with several new expression forms.
;; Following is a brief summary of the new forms.  See the associated
;; LaTeX documentation for a full description of their functionality.
;;
;;
;;         match expressions:
;;
;; exp ::= ...
;;       | (match exp clause ...)
;;       | (match-lambda clause ...)
;;       | (match-lambda* clause ...)
;;       | (match-let ((pat exp) ...) body)
;;       | (match-let* ((pat exp) ...) body)
;;       | (match-letrec ((pat exp) ...) body)
;;       | (match-define pat exp)
;;
;; clause ::= (pat body) | (pat => exp)
;;
;;         patterns:                       matches:
;;
;; pat ::= identifier                      anything, and binds identifier
;;       | _                               anything
;;       | ()                              the empty list
;;       | #t                              #t
;;       | #f                              #f
;;       | string                          a string
;;       | number                          a number
;;       | character                       a character
;;       | 'sexp                           an s-expression
;;       | 'symbol                         a symbol (special case of s-expr)
;;       | (pat_1 ... pat_n)               list of n elements
;;       | (pat_1 ... pat_n . pat_{n+1})   list of n or more
;;       | (pat_1 ... pat_n pat_n+1 ooo)   list of n or more, each element
;;                                           of remainder must match pat_n+1
;;       | #(pat_1 ... pat_n)              vector of n elements
;;       | #(pat_1 ... pat_n pat_n+1 ooo)  vector of n or more, each element
;;                                           of remainder must match pat_n+1
;;       | #&pat                           box
;;       | ($ struct-name pat_1 ... pat_n) a structure
;;       | (= field pat)                   a field of a structure
;;       | (and pat_1 ... pat_n)           if all of pat_1 thru pat_n match
;;       | (or pat_1 ... pat_n)            if any of pat_1 thru pat_n match
;;       | (not pat_1 ... pat_n)           if all pat_1 thru pat_n don't match
;;       | (? predicate pat_1 ... pat_n)   if predicate true and all of
;;                                           pat_1 thru pat_n match
;;       | (set! identifier)               anything, and binds setter
;;       | (get! identifier)               anything, and binds getter
;;       | `qp                             a quasi-pattern
;;
;; ooo ::= ...                             zero or more
;;       | ___                             zero or more
;;       | ..k                             k or more
;;       | __k                             k or more
;;
;;         quasi-patterns:                 matches:
;;
;; qp  ::= ()                              the empty list
;;       | #t                              #t
;;       | #f                              #f
;;       | string                          a string
;;       | number                          a number
;;       | character                       a character
;;       | identifier                      a symbol
;;       | (qp_1 ... qp_n)                 list of n elements
;;       | (qp_1 ... qp_n . qp_{n+1})      list of n or more
;;       | (qp_1 ... qp_n qp_n+1 ooo)      list of n or more, each element
;;                                           of remainder must match qp_n+1
;;       | #(qp_1 ... qp_n)                vector of n elements
;;       | #(qp_1 ... qp_n qp_n+1 ooo)     vector of n or more, each element
;;                                           of remainder must match qp_n+1
;;       | #&qp                            box
;;       | ,pat                            a pattern
;;       | ,@pat                           a pattern
;;
;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
;;
;;
;;         structure expressions:
;;
;; exp ::= ...
;;       | (define-structure (id_0 id_1 ... id_n))
;;       | (define-structure (id_0 id_1 ... id_n)
;;                           ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
;;       | (define-const-structure (id_0 arg_1 ... arg_n))
;;       | (define-const-structure (id_0 arg_1 ... arg_n)
;;                                 ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
;;
;; arg ::= id | (! id) | (@ id)
;;
;;
;; match:error-control controls what code is generated for failed matches.
;; Possible values:
;;  'unspecified - do nothing, ie., evaluate (cond [#f #f])
;;  'fail - call match:error, or die at car or cdr
;;  'error - call match:error with the unmatched value
;;  'match - call match:error with the unmatched value _and_
;;             the quoted match expression
;; match:error-control is set by calling match:set-error-control with
;; the new value.
;;
;; match:error is called for a failed match.
;; match:error is set by calling match:set-error with the new value.
;;
;; match:structure-control controls the uniqueness of structures
;; (does not exist for Scheme 48 version).
;; Possible values:
;;  'vector - (default) structures are vectors with a symbol in position 0
;;  'disjoint - structures are fully disjoint from all other values
;; match:structure-control is set by calling match:set-structure-control
;; with the new value.
;;
;; match:runtime-structures controls whether local structure declarations
;; generate new structures each time they are reached
;; (does not exist for Scheme 48 version).
;; Possible values:
;;  #t - (default) each runtime occurrence generates a new structure
;;  #f - each lexical occurrence generates a new structure
;;
;; End of user visible/modifiable stuff.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(when (top-level-bound? 'current-expand)
  (current-expand eps-expand))
(eval-when (compile) (optimize-level 1))
(extend-syntax (defmacro)
  ((defmacro macro args body0 body ...) (symbol? 'args)
   (define-syntax-expander macro
     (lambda (x e)
       (e (let ((args (cdr x))) body0 body ...) e)))))
(eval-when (compile load eval)
  (define match:error
    (lambda (val . args)
      (for-each pretty-print args)
      (error #f "no matching clause for ~s" val)))
  (define match:andmap andmap)
  (define match:syntax-err
    (lambda (obj msg) (error #f (string-append msg " ~a") obj)))
  (define match:structure-property (gensym))
  (define match:structure-tag-format "<~a>")
  (define match:make-structure-tag
    (lambda (name)
      (let ((tag (string->uninterned-symbol
                   (format match:structure-tag-format name))))
        (putprop tag match:structure-property #t)
        tag)))
  (define match:structure?
    (lambda (tag) (getprop tag match:structure-property)))
  (define match:structure-control 'vector)
  (define match:set-structure-control
    (lambda (v) (set! match:structure-control v)))
  (define box-1 unbox)
  (define match:set-error (lambda (v) (set! match:error v)))
  (define match:error-control 'error)
  (define match:set-error-control
    (lambda (v) (set! match:error-control v)))
  (define match:disjoint-predicates
    (cons 'null
          '(pair?
             symbol?
             boolean?
             number?
             string?
             char?
             procedure?
             vector?
             box?)))
  (define match:vector-structures '())
  (define match:expanders
    (letrec ((genmatch (lambda (x clauses match-expr)
                         (let* ((length>= (gensym))
                                (eb-errf (error-maker match-expr))
                                (blist (car eb-errf))
                                (plist (map (lambda (c)
                                              (let* ((x (bound
                                                          (validate-pattern
                                                            (car c))))
                                                     (p (car x))
                                                     (bv (cadr x))
                                                     (bindings (caddr x))
                                                     (code (gensym))
                                                     (fail (and (pair?
                                                                  (cdr c))
                                                                (pair?
                                                                  (cadr c))
                                                                (eq? (caadr
                                                                       c)
                                                                     '=>)
                                                                (symbol?
                                                                  (cadadr
                                                                    c))
                                                                (pair?
                                                                  (cdadr
                                                                    c))
                                                                (null?
                                                                  (cddadr
                                                                    c))
                                                                (pair?
                                                                  (cddr c))
                                                                (cadadr c)))
                                                     (bv2 (if fail
                                                              (cons fail
                                                                    bv)
                                                              bv))
                                                     (body (if fail
                                                               (cddr c)
                                                               (cdr c))))
                                                (set! blist
                                                  (cons `(,code
                                                           (lambda ,bv2
                                                             ,@body))
                                                        (append
                                                          bindings
                                                          blist)))
                                                (list p
                                                      code
                                                      bv
                                                      (and fail (gensym))
                                                      #f)))
                                            clauses))
                                (code (gen x
                                           '()
                                           plist
                                           (cdr eb-errf)
                                           length>=
                                           (gensym))))
                           (unreachable plist match-expr)
                           (inline-let
                             `(let ((,length>= (lambda (n)
                                                 (lambda (l)
                                                   (>= (length l) n))))
                                    ,@blist)
                                ,code)))))
             (genletrec (lambda (pat exp body 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)
                            `(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)
                                                 '(#\. #\_))
                                           (match: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)
                                                                                `(match:error
                                                                                   ,x))))
                              ((eq? match:error-control 'match) (let ((errf (gensym))
                                                                      (arg (gensym)))
                                                                  (cons `((,errf
                                                                            (lambda (,arg)
                                                                              (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 ((g89 (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))
                                                                                (g89 (car p)
                                                                                     (cdr p)))
                                                                            (if (equal?
                                                                                  (car p)
                                                                                  'quote)
                                                                                (if (and (pair?
                                                                                           (cdr p))
                                                                                         (null?
                                                                                           (cddr p)))
                                                                                    ((lambda (p)
                                                                                       p)
                                                                                     p)
                                                                                    (g89 (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))
                                                                                        (g89 (car p)
                                                                                             (cdr p)))
                                                                                    (if (equal?
                                                                                          (car p)
                                                                                          '=)
                                                                                        (if (and (pair?
                                                                                                   (cdr p))
                                                                                                 (pair?
                                                                                                   (cddr p))
                                                                                                 (null?
                                                                                                   (cdddr
                                                                                                     p)))
                                                                                            ((lambda (sel
                                                                                                      p)
                                                                                               `(= ,sel
                                                                                                   ,(ordinary
                                                                                                      p)))
                                                                                             (cadr p)
                                                                                             (caddr
                                                                                               p))
                                                                                            (g89 (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))
                                                                                                (g89 (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))
                                                                                                    (g89 (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))
                                                                                                        (g89 (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))
                                                                                                            (g89 (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)
                                                                                                                (g89 (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)
                                                                                                                    (g89 (car p)
                                                                                                                         (cdr p)))
                                                                                                                (if (equal?
                                                                                                                      (car p)
                                                                                                                      'unquote)
                                                                                                                    (g89 (car p)
                                                                                                                         (cdr p))
                                                                                                                    (if (equal?
                                                                                                                          (car p)
                                                                                                                          'unquote-splicing)
                                                                                                                        (g89 (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))
                                                                                                                            (g89 (car p)
                                                                                                                                 (cdr p)))))))))))))))
                                                                        (if (vector?
                                                                              p)
                                                                            ((lambda (p)
                                                                               (let* ((pl (vector->list
                                                                                            p))
                                                                                      (rpl (reverse
                                                                                             pl)))
                                                                                 (apply
                                                                                   vector
                                                                                   (if (and (not (null?
                                                                                                   rpl))
                                                                                            (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
                                                                                     pattern
                                                                                     "syntax error in pattern"))))))))))))
                                          (quasi (lambda (p)
                                                   (let ((g111 (lambda (x
                                                                        y)
                                                                 (cons (quasi
                                                                         x)
                                                                       (quasi
                                                                         y)))))
                                                     (if (simple? p)
                                                         ((lambda (p) p) p)
                                                         (if (symbol? p)
                                                             ((lambda (p)
                                                                `',p)
                                                              p)
                                                             (if (pair? p)
                                                                 (if (equal?
                                                                       (car p)
                                                                       'unquote)
                                                                     (if (and (pair?
                                                                                (cdr p))
                                                                              (null?
                                                                                (cddr p)))
                                                                         ((lambda (p)
                                                                            (ordinary
                                                                              p))
                                                                          (cadr p))
                                                                         (g111 (car p)
                                                                               (cdr p)))
                                                                     (if (and (pair?
                                                                                (car p))
                                                                              (equal?
                                                                                (caar p)
                                                                                'unquote-splicing)
                                                                              (pair?
                                                                                (cdar p))
                                                                              (null?
                                                                                (cddar
                                                                                  p)))
                                                                         (if (null?
                                                                               (cdr p))
                                                                             ((lambda (p)
                                                                                (ordinary
                                                                                  p))
                                                                              (cadar
                                                                                p))
                                                                             ((lambda (p
                                                                                       y)
                                                                                (append
                                                                                  (ordlist
                                                                                    p)
                                                                                  (quasi
                                                                                    y)))
                                                                              (cadar
                                                                                p)
                                                                              (cdr p)))
                                                                         (if (and (pair?
                                                                                    (cdr p))
                                                                                  (dot-dot-k?
                                                                                    (cadr p))
                                                                                  (null?
                                                                                    (cddr p)))
                                                                             ((lambda (p
                                                                                       ddk)
                                                                                `(,(quasi
                                                                                     p)
                                                                                   ,ddk))
                                                                              (car p)
                                                                              (cadr p))
                                                                             (g111 (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 quasi
                                                                                             (cdr rpl))))
                                                                                (map ordinary
                                                                                     pl)))))
                                                                      p)
                                                                     (if (box? p)
                                                                         ((lambda (p)
                                                                            (box (quasi
                                                                                   (unbox
                                                                                     p))))
                                                                          p)
                                                                         ((lambda ()
                                                                            (match:syntax-err
                                                                              pattern
                                                                              "syntax error in pattern")))))))))))
                                          (ordlist (lambda (p)
                                                     (cond
                                                       ((null? p) '())
                                                       ((pair? p) (cons (ordinary
                                                                          (car p))
                                                                        (ordlist
                                                                          (cdr p))))
                                                       (else (match:syntax-err
                                                               pattern
                                                               "invalid use of unquote-splicing in pattern"))))))
                                   (ordinary pattern))))
             (bound (lambda (pattern)
                      (letrec ((pred-bodies '())
                               (bound (lambda (p a k)
                                        (cond
                                          ((eq? '_ p) (k p a))
                                          ((symbol? p) (if (memq p a)
                                                           (match:syntax-err
                                                             pattern
                                                             "duplicate variable in pattern"))
                                           (k p (cons p a)))
                                          ((and (pair? p)
                                                (eq? 'quote (car p))) (k p
                                                                         a))
                                          ((and (pair? p) (eq? '? (car p))) (cond
                                                                              ((not (null?
                                                                                      (cddr p))) (bound
                                                                                                   `(and (? ,(cadr p))
                                                                                                         ,@(cddr p))
                                                                                                   a
                                                                                                   k))
                                                                              ((or (not (symbol?
                                                                                          (cadr p)))
                                                                                   (memq (cadr p)
                                                                                         a)) (let ((g (gensym)))
                                                                                               (set! pred-bodies
                                                                                                 (cons `(,g ,(cadr p))
                                                                                                       pred-bodies))
                                                                                               (k `(? ,g)
                                                                                                  a)))
                                                                              (else (k p
                                                                                       a))))
                                          ((and (pair? p) (eq? '= (car p))) (cond
                                                                              ((or (not (symbol?
                                                                                          (cadr p)))
                                                                                   (memq (cadr p)
                                                                                         a)) (let ((g (gensym)))
                                                                                               (set! pred-bodies
                                                                                                 (cons `(,g ,(cadr p))
                                                                                                       pred-bodies))
                                                                                               (bound
                                                                                                 `(= ,g
                                                                                                     ,(caddr
                                                                                                        p))
                                                                                                 a
                                                                                                 k)))
                                                                              (else (bound
                                                                                      (caddr
                                                                                        p)
                                                                                      a
                                                                                      (lambda (p2
                                                                                               a)
                                                                                        (k `(= ,(cadr p)
                                                                                               ,p2)
                                                                                           a))))))
                                          ((and (pair? p)
                                                (eq? 'and (car p))) (bound*
                                                                      (cdr p)
                                                                      a
                                                                      (lambda (p
                                                                               a)
                                                                        (k `(and ,@p)
                                                                           a))))
                                          ((and (pair? p)
                                                (eq? 'or (car p))) (bound
                                                                     (cadr p)
                                                                     a
                                                                     (lambda (first-p
                                                                              first-a)
                                                                       (let or* ((plist (cddr p))
                                                                                 (k (lambda (plist)
                                                                                      (k `(or ,first-p
                                                                                              ,@plist)
                                                                                         first-a))))
                                                                         (if (null?
                                                                               plist)
                                                                             (k plist)
                                                                             (bound
                                                                               (car plist)
                                                                               a
                                                                               (lambda (car-p
                                                                                        car-a)
                                                                                 (if (not (permutation
                                                                                            car-a
                                                                                            first-a))
                                                                                     (match:syntax-err
                                                                                       pattern
                                                                                       "variables of or-pattern differ in"))
                                                                                 (or* (cdr plist)
                                                                                      (lambda (cdr-p)
                                                                                        (k (cons car-p
                                                                                                 cdr-p)))))))))))
                                          ((and (pair? p)
                                                (eq? 'not (car p))) (cond
                                                                      ((not (null?
                                                                              (cddr p))) (bound
                                                                                           `(not (or ,@(cdr p)))
                                                                                           a
                                                                                           k))
                                                                      (else (bound
                                                                              (cadr p)
                                                                              a
                                                                              (lambda (p2
                                                                                       a2)
                                                                                (if (not (permutation
                                                                                           a
                                                                                           a2))
                                                                                    (match:syntax-err
                                                                                      p
                                                                                      "no variables allowed in"))
                                                                                (k `(not ,p2)
                                                                                   a))))))
                                          ((and (pair? p)
                                                (pair? (cdr p))
                                                (dot-dot-k? (cadr p))) (bound
                                                                         (car p)
                                                                         a
                                                                         (lambda (q
                                                                                  b)
                                                                           (let ((bvars (find-prefix
                                                                                          b
                                                                                          a)))
                                                                             (k `(,q ,(cadr p)
                                                                                     ,bvars
                                                                                     ,(gensym)
                                                                                     ,(gensym)
                                                                                     ,(map (lambda (_)
                                                                                             (gensym))
                                                                                           bvars))
                                                                                b)))))
                                          ((and (pair? p) (eq? '$ (car p))) (bound*
                                                                              (cddr p)
                                                                              a
                                                                              (lambda (p1
                                                                                       a)
                                                                                (k `($ ,(cadr p)
                                                                                       ,@p1)
                                                                                   a))))
                                          ((and (pair? p)
                                                (eq? 'set! (car p))) (if (memq (cadr p)
                                                                               a)
                                                                         (k p
                                                                            a)
                                                                         (k p
                                                                            (cons (cadr p)
                                                                                  a))))
                                          ((and (pair? p)
                                                (eq? 'get! (car p))) (if (memq (cadr p)
                                                                               a)
                                                                         (k p
                                                                            a)
                                                                         (k p
                                                                            (cons (cadr p)
                                                                                  a))))
                                          ((pair? p) (bound
                                                       (car p)
                                                       a
                                                       (lambda (car-p a)
                                                         (bound
                                                           (cdr p)
                                                           a
                                                           (lambda (cdr-p
                                                                    a)
                                                             (k (cons car-p
                                                                      cdr-p)
                                                                a))))))
                                          ((vector? p) (boundv
                                                         (vector->list p)
                                                         a
                                                         (lambda (pl a)
                                                           (k (list->vector
                                                                pl)
                                                              a))))
                                          ((box? p) (bound
                                                      (unbox p)
                                                      a
                                                      (lambda (p a)
                                                        (k (box p) a))))
                                          (else (k p a)))))
                               (boundv (lambda (plist a k)
                                         (let ((g117 (lambda ()
                                                       (k plist a))))
                                           (if (pair? plist)
                                               (if (and (pair? (cdr plist))
                                                        (dot-dot-k?
                                                          (cadr plist))
                                                        (null?
                                                          (cddr plist)))
                                                   ((lambda ()
                                                      (bound plist a k)))
                                                   (if (null? plist)
                                                       (g117)
                                                       ((lambda (x y)
                                                          (bound
                                                            x
                                                            a
                                                            (lambda (car-p
                                                                     a)
                                                              (boundv
                                                                y
                                                                a
                                                                (lambda (cdr-p
                                                                         a)
                                                                  (k (cons car-p
                                                                           cdr-p)
                                                                     a))))))
                                                        (car plist)
                                                        (cdr plist))))
                                               (if (null? plist)
                                                   (g117)
                                                   (match:error plist))))))
                               (bound* (lambda (plist a k)
                                         (if (null? plist)
                                             (k plist a)
                                             (bound
                                               (car plist)
                                               a
                                               (lambda (car-p a)
                                                 (bound*
                                                   (cdr plist)
                                                   a
                                                   (lambda (cdr-p a)
                                                     (k (cons car-p cdr-p)
                                                        a))))))))
                               (find-prefix (lambda (b a)
                                              (if (eq? b a)
                                                  '()
                                                  (cons (car b)
                                                        (find-prefix
                                                          (cdr b)
                                                          a)))))
                               (permutation (lambda (p1 p2)
                                              (and (= (length p1)
                                                      (length p2))
                                                   (match:andmap
                                                     (lambda (x1)
                                                       (memq x1 p2))
                                                     p1)))))
                        (bound
                          pattern
                          '()
                          (lambda (p a)
                            (list p (reverse a) pred-bodies))))))
             (inline-let (lambda (let-exp)
                           (letrec ((occ (lambda (x e)
                                           (let loop ((e e))
                                             (cond
                                               ((pair? e) (+ (loop (car e))
                                                             (loop (cdr e))))
                                               ((eq? x e) 1)
                                               (else 0)))))
                                    (subst (lambda (e old new)
                                             (let loop ((e e))
                                               (cond
                                                 ((pair? e) (cons (loop (car e))
                                                                  (loop (cdr e))))
                                                 ((eq? old e) new)
                                                 (else e)))))
                                    (const? (lambda (sexp)
                                              (or (symbol? sexp)
                                                  (boolean? sexp)
                                                  (string? sexp)
                                                  (char? sexp)
                                                  (number? sexp)
                                                  (null? sexp)
                                                  (and (pair? sexp)
                                                       (eq? (car sexp)
                                                            'quote)
                                                       (pair? (cdr sexp))
                                                       (symbol?
                                                         (cadr sexp))
                                                       (null?
                                                         (cddr sexp))))))
                                    (isval? (lambda (sexp)
                                              (or (const? sexp)
                                                  (and (pair? sexp)
                                                       (memq (car sexp)
                                                             '(lambda quote
                                                                match-lambda
                                                                match-lambda*))))))
                                    (small? (lambda (sexp)
                                              (or (const? sexp)
                                                  (and (pair? sexp)
                                                       (eq? (car sexp)
                                                            'lambda)
                                                       (pair? (cdr sexp))
                                                       (pair? (cddr sexp))
                                                       (const?
                                                         (caddr sexp))
                                                       (null?
                                                         (cdddr sexp)))))))
                             (let loop ((b (cadr let-exp))
                                        (new-b '())
                                        (e (caddr let-exp)))
                               (cond
                                 ((null? b) (if (null? new-b)
                                                e
                                                `(let ,(reverse new-b) ,e)))
                                 ((isval? (cadr (car b))) (let* ((x (caar b))
                                                                 (n (occ x
                                                                         e)))
                                                            (cond
                                                              ((= 0 n) (loop (cdr b)
                                                                             new-b
                                                                             e))
                                                              ((or (= 1 n)
                                                                   (small?
                                                                     (cadr (car b)))) (loop (cdr b)
                                                                                            new-b
                                                                                            (subst
                                                                                              e
                                                                                              x
                                                                                              (cadr (car b)))))
                                                              (else (loop (cdr b)
                                                                          (cons (car b)
                                                                                new-b)
                                                                          e)))))
                                 (else (loop (cdr b)
                                             (cons (car b) new-b)
                                             e)))))))
             (gen (lambda (x sf plist erract length>= eta)
                    (if (null? plist)
                        (erract x)
                        (let* ((v '())
                               (val (lambda (x) (cdr (assq x v))))
                               (fail (lambda (sf)
                                       (gen x
                                            sf
                                            (cdr plist)
                                            erract
                                            length>=
                                            eta)))
                               (success (lambda (sf)
                                          (set-car!
                                            (cddddr (car plist))
                                            #t)
                                          (let* ((code (cadr (car plist)))
                                                 (bv (caddr (car plist)))
                                                 (fail-sym (cadddr
                                                             (car plist))))
                                            (if fail-sym
                                                (let ((ap `(,code
                                                             ,fail-sym
                                                             ,@(map val
                                                                    bv))))
                                                  `(call-with-current-continuation
                                                     (lambda (,fail-sym)
                                                       (let ((,fail-sym (lambda ()
                                                                          (,fail-sym
                                                                            ,(fail sf)))))
                                                         ,ap))))
                                                `(,code ,@(map val bv)))))))
                          (let next ((p (caar plist))
                                     (e x)
                                     (sf sf)
                                     (kf fail)
                                     (ks success))
                            (cond
                              ((eq? '_ p) (ks sf))
                              ((symbol? p) (set! v (cons (cons p e) v))
                               (ks sf))
                              ((null? p) (emit `(null? ,e) sf kf ks))
                              ((equal? p ''()) (emit `(null? ,e) sf kf ks))
                              ((string? p) (emit `(equal? ,e ,p) sf kf ks))
                              ((boolean? p) (emit `(equal? ,e ,p) sf kf ks))
                              ((char? p) (emit `(equal? ,e ,p) sf kf ks))
                              ((number? p) (emit `(equal? ,e ,p) sf kf ks))
                              ((and (pair? p) (eq? 'quote (car p))) (emit `(equal?
                                                                             ,e
                                                                             ,p)
                                                                          sf
                                                                          kf
                                                                          ks))
                              ((and (pair? p) (eq? '? (car p))) (let ((tst `(,(cadr p)
                                                                              ,e)))
                                                                  (emit tst
                                                                        sf
                                                                        kf
                                                                        ks)))
                              ((and (pair? p) (eq? '= (car p))) (next (caddr
                                                                        p)
                                                                      `(,(cadr p)
                                                                         ,e)
                                                                      sf
                                                                      kf
                                                                      ks))
                              ((and (pair? p) (eq? 'and (car p))) (let loop ((p (cdr p))
                                                                             (sf sf))
                                                                    (if (null?
                                                                          p)
                                                                        (ks sf)
                                                                        (next (car p)
                                                                              e
                                                                              sf
                                                                              kf
                                                                              (lambda (sf)
                                                                                (loop (cdr p)
                                                                                      sf))))))
                              ((and (pair? p) (eq? 'or (car p))) (let ((or-v v))
                                                                   (let loop ((p (cdr p))
                                                                              (sf sf))
                                                                     (if (null?
                                                                           p)
                                                                         (kf sf)
                                                                         (begin (set! v
                                                                                  or-v)
                                                                                (next (car p)
                                                                                      e
                                                                                      sf
                                                                                      (lambda (sf)
                                                                                        (loop (cdr p)
                                                                                              sf))
                                                                                      ks))))))
                              ((and (pair? p) (eq? 'not (car p))) (next (cadr p)
                                                                        e
                                                                        sf
                                                                        ks
                                                                        kf))
                              ((and (pair? p) (eq? '$ (car p))) (let* ((tag (cadr p))
                                                                       (fields (cdr p))
                                                                       (rlen (length
                                                                               fields))
                                                                       (tst `(,(symbol-append
                                                                                 tag
                                                                                 '?)
                                                                               ,e)))
                                                                  (emit tst
                                                                        sf
                                                                        kf
                                                                        (let rloop ((n 1))
                                                                          (lambda (sf)
                                                                            (if (= n
                                                                                   rlen)
                                                                                (ks sf)
                                                                                (next (list-ref
                                                                                        fields
                                                                                        n)
                                                                                      `(,(symbol-append
                                                                                           tag
                                                                                           '-
                                                                                           n)
                                                                                         ,e)
                                                                                      sf
                                                                                      kf
                                                                                      (rloop
                                                                                        (+ 1
                                                                                           n)))))))))
                              ((and (pair? p) (eq? 'set! (car p))) (set! v
                                                                     (cons (cons (cadr p)
                                                                                 (setter
                                                                                   e
                                                                                   p))
                                                                           v))
                               (ks sf))
                              ((and (pair? p) (eq? 'get! (car p))) (set! v
                                                                     (cons (cons (cadr p)
                                                                                 (getter
                                                                                   e
                                                                                   p))
                                                                           v))
                               (ks sf))
                              ((and (pair? p)
                                    (pair? (cdr p))
                                    (dot-dot-k? (cadr p))) (emit `(list?
                                                                    ,e)
                                                                 sf
                                                                 kf
                                                                 (lambda (sf)
                                                                   (let* ((k (dot-dot-k?
                                                                               (cadr p)))
                                                                          (ks (lambda (sf)
                                                                                (let ((bound (list-ref
                                                                                               p
                                                                                               2)))
                                                                                  (cond
                                                                                    ((eq? (car p)
                                                                                          '_) (ks sf))
                                                                                    ((null?
                                                                                       bound) (let* ((ptst (next (car p)
                                                                                                                 eta
                                                                                                                 sf
                                                                                                                 (lambda (sf)
                                                                                                                   #f)
                                                                                                                 (lambda (sf)
                                                                                                                   #t)))
                                                                                                     (tst (if (and (pair?
                                                                                                                     ptst)
                                                                                                                   (symbol?
                                                                                                                     (car ptst))
                                                                                                                   (pair?
                                                                                                                     (cdr ptst))
                                                                                                                   (eq? eta
                                                                                                                        (cadr ptst))
                                                                                                                   (null?
                                                                                                                     (cddr ptst)))
                                                                                                              (car ptst)
                                                                                                              `(lambda (,eta)
                                                                                                                 ,ptst))))
                                                                                                (assm `(match:andmap
                                                                                                         ,tst
                                                                                                         ,e)
                                                                                                      (kf sf)
                                                                                                      (ks sf))))
                                                                                    ((and (symbol?
                                                                                            (car p))
                                                                                          (equal?
                                                                                            (list (car p))
                                                                                            bound)) (next (car p)
                                                                                                          e
                                                                                                          sf
                                                                                                          kf
                                                                                                          ks))
                                                                                    (else (let* ((gloop (list-ref
                                                                                                          p
                                                                                                          3))
                                                                                                 (ge (list-ref
                                                                                                       p
                                                                                                       4))
                                                                                                 (fresh (list-ref
                                                                                                          p
                                                                                                          5))
                                                                                                 (p1 (next (car p)
                                                                                                           `(car ,ge)
                                                                                                           sf
                                                                                                           kf
                                                                                                           (lambda (sf)
                                                                                                             `(,gloop
                                                                                                                (cdr ,ge)
                                                                                                                ,@(map (lambda (b
                                                                                                                                f)
                                                                                                                         `(cons ,(val b)
                                                                                                                                ,f))
                                                                                                                       bound
                                                                                                                       fresh))))))
                                                                                            (set! v
                                                                                              (append
                                                                                                (map cons
                                                                                                     bound
                                                                                                     (map (lambda (x)
                                                                                                            `(reverse
                                                                                                               ,x))
                                                                                                          fresh))
                                                                                                v))
                                                                                            `(let ,gloop
                                                                                               ((,ge ,e)
                                                                                                ,@(map (lambda (x)
                                                                                                         `(,x '()))
                                                                                                       fresh))
                                                                                               (if (null?
                                                                                                     ,ge)
                                                                                                   ,(ks sf)
                                                                                                   ,p1)))))))))
                                                                     (case k
                                                                       ((0) (ks sf))
                                                                       ((1) (emit `(pair?
                                                                                     ,e)
                                                                                  sf
                                                                                  kf
                                                                                  ks))
                                                                       (else (emit `((,length>=
                                                                                       ,k)
                                                                                     ,e)
                                                                                   sf
                                                                                   kf
                                                                                   ks)))))))
                              ((pair? p) (emit `(pair? ,e)
                                               sf
                                               kf
                                               (lambda (sf)
                                                 (next (car p)
                                                       (add-a e)
                                                       sf
                                                       kf
                                                       (lambda (sf)
                                                         (next (cdr p)
                                                               (add-d e)
                                                               sf
                                                               kf
                                                               ks))))))
                              ((and (vector? p)
                                    (>= (vector-length p) 6)
                                    (dot-dot-k?
                                      (vector-ref
                                        p
                                        (- (vector-length p) 5)))) (let* ((vlen (- (vector-length
                                                                                     p)
                                                                                   6))
                                                                          (k (dot-dot-k?
                                                                               (vector-ref
                                                                                 p
                                                                                 (+ vlen
                                                                                    1))))
                                                                          (minlen (+ vlen
                                                                                     k))
                                                                          (bound (vector-ref
                                                                                   p
                                                                                   (+ vlen
                                                                                      2))))
                                                                     (emit `(vector?
                                                                              ,e)
                                                                           sf
                                                                           kf
                                                                           (lambda (sf)
                                                                             (assm `(>= (vector-length
                                                                                          ,e)
                                                                                        ,minlen)
                                                                                   (kf sf)
                                                                                   ((let vloop ((n 0))
                                                                                      (lambda (sf)
                                                                                        (cond
                                                                                          ((not (= n
                                                                                                   vlen)) (next (vector-ref
                                                                                                                  p
                                                                                                                  n)
                                                                                                                `(vector-ref
                                                                                                                   ,e
                                                                                                                   ,n)
                                                                                                                sf
                                                                                                                kf
                                                                                                                (vloop
                                                                                                                  (+ 1
                                                                                                                     n))))
                                                                                          ((eq? (vector-ref
                                                                                                  p
                                                                                                  vlen)
                                                                                                '_) (ks sf))
                                                                                          (else (let* ((gloop (vector-ref
                                                                                                                p
                                                                                                                (+ vlen
                                                                                                                   3)))
                                                                                                       (ind (vector-ref
                                                                                                              p
                                                                                                              (+ vlen
                                                                                                                 4)))
                                                                                                       (fresh (vector-ref
                                                                                                                p
                                                                                                                (+ vlen
                                                                                                                   5)))
                                                                                                       (p1 (next (vector-ref
                                                                                                                   p
                                                                                                                   vlen)
                                                                                                                 `(vector-ref
                                                                                                                    ,e
                                                                                                                    ,ind)
                                                                                                                 sf
                                                                                                                 kf
                                                                                                                 (lambda (sf)
                                                                                                                   `(,gloop
                                                                                                                      (- ,ind
                                                                                                                         1)
                                                                                                                      ,@(map (lambda (b
                                                                                                                                      f)
                                                                                                                               `(cons ,(val b)
                                                                                                                                      ,f))
                                                                                                                             bound
                                                                                                                             fresh))))))
                                                                                                  (set! v
                                                                                                    (append
                                                                                                      (map cons
                                                                                                           bound
                                                                                                           fresh)
                                                                                                      v))
                                                                                                  `(let ,gloop
                                                                                                     ((,ind (- (vector-length
                                                                                                                 ,e)
                                                                                                               1))
                                                                                                      ,@(map (lambda (x)
                                                                                                               `(,x '()))
                                                                                                             fresh))
                                                                                                     (if (> ,minlen
                                                                                                            ,ind)
                                                                                                         ,(ks sf)
                                                                                                         ,p1)))))))
                                                                                    sf))))))
                              ((vector? p) (let ((vlen (vector-length p)))
                                             (emit `(vector? ,e)
                                                   sf
                                                   kf
                                                   (lambda (sf)
                                                     (emit `(equal?
                                                              (vector-length
                                                                ,e)
                                                              ,vlen)
                                                           sf
                                                           kf
                                                           (let vloop ((n 0))
                                                             (lambda (sf)
                                                               (if (= n
                                                                      vlen)
                                                                   (ks sf)
                                                                   (next (vector-ref
                                                                           p
                                                                           n)
                                                                         `(vector-ref
                                                                            ,e
                                                                            ,n)
                                                                         sf
                                                                         kf
                                                                         (vloop
                                                                           (+ 1
                                                                              n)))))))))))
                              ((box? p) (emit `(box? ,e)
                                              sf
                                              kf
                                              (lambda (sf)
                                                (next (unbox p)
                                                      `(unbox ,e)
                                                      sf
                                                      kf
                                                      ks))))
                              (else (display
                                      "FATAL ERROR IN PATTERN MATCHER")
                               (newline)
                               (error #f "THIS NEVER HAPPENS"))))))))
             (emit (lambda (tst sf kf ks)
                     (cond
                       ((in tst sf) (ks sf))
                       ((in `(not ,tst) sf) (kf sf))
                       (else (let* ((e (cadr tst))
                                    (implied (cond
                                               ((eq? (car tst) 'equal?) (let ((p (caddr
                                                                                   tst)))
                                                                          (cond
                                                                            ((string?
                                                                               p) `((string?
                                                                                      ,e)))
                                                                            ((boolean?
                                                                               p) `((boolean?
                                                                                      ,e)))
                                                                            ((char?
                                                                               p) `((char?
                                                                                      ,e)))
                                                                            ((number?
                                                                               p) `((number?
                                                                                      ,e)))
                                                                            ((and (pair?
                                                                                    p)
                                                                                  (eq? 'quote
                                                                                       (car p))) `((symbol?
                                                                                                     ,e)))
                                                                            (else '()))))
                                               ((eq? (car tst) 'null?) `((list?
                                                                           ,e)))
                                               ((vec-structure? tst) `((vector?
                                                                         ,e)))
                                               (else '())))
                                    (not-imp (case (car tst)
                                               ((list?) `((not (null? ,e))))
                                               (else '())))
                                    (s (ks (cons tst (append implied sf))))
                                    (k (kf (cons `(not ,tst)
                                                 (append not-imp sf)))))
                               (assm tst k s))))))
             (assm (lambda (tst f s)
                     (cond
                       ((equal? s f) s)
                       ((and (eq? s #t) (eq? f #f)) tst)
                       ((and (eq? (car tst) 'pair?)
                             (memq match:error-control '(unspecified fail))
                             (memq (car f) '(cond match:error))
                             (guarantees s (cadr tst))) s)
                       ((and (pair? s)
                             (eq? (car s) 'if)
                             (equal? (cadddr s) f)) (if (eq? (car (cadr s))
                                                             'and)
                                                        `(if (and ,tst
                                                                  ,@(cdr (cadr s)))
                                                             ,(caddr s)
                                                             ,f)
                                                        `(if (and ,tst
                                                                  ,(cadr s))
                                                             ,(caddr s)
                                                             ,f)))
                       ((and (pair? s)
                             (equal?
                               (car s)
                               'call-with-current-continuation)
                             (pair? (cdr s))
                             (pair? (cadr s))
                             (equal? (caadr s) 'lambda)
                             (pair? (cdadr s))
                             (pair? (cadadr s))
                             (null? (cdr (cadadr s)))
                             (pair? (cddadr s))
                             (pair? (car (cddadr s)))
                             (equal? (caar (cddadr s)) 'let)
                             (pair? (cdar (cddadr s)))
                             (pair? (cadar (cddadr s)))
                             (pair? (caadar (cddadr s)))
                             (pair? (cdr (caadar (cddadr s))))
                             (pair? (cadr (caadar (cddadr s))))
                             (equal? (caadr (caadar (cddadr s))) 'lambda)
                             (pair? (cdadr (caadar (cddadr s))))
                             (null? (cadadr (caadar (cddadr s))))
                             (pair? (cddadr (caadar (cddadr s))))
                             (pair? (car (cddadr (caadar (cddadr s)))))
                             (pair? (cdar (cddadr (caadar (cddadr s)))))
                             (null? (cddar (cddadr (caadar (cddadr s)))))
                             (null? (cdr (cddadr (caadar (cddadr s)))))
                             (null? (cddr (caadar (cddadr s))))
                             (null? (cdadar (cddadr s)))
                             (pair? (cddar (cddadr s)))
                             (null? (cdddar (cddadr s)))
                             (null? (cdr (cddadr s)))
                             (null? (cddr s))
                             (equal?
                               f
                               (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr
                                                                                      s)))
                                                                            (fail (car (caadar
                                                                                         (cddadr
                                                                                           s))))
                                                                            (s2 (caddar
                                                                                  (cddadr
                                                                                    s))))
                                                                        `(call-with-current-continuation
                                                                           (lambda (,k)
                                                                             (let ((,fail (lambda ()
                                                                                            (,k ,f))))
                                                                               ,(assm tst
                                                                                      `(,fail)
                                                                                      s2))))))
                       ((and #f
                             (pair? s)
                             (equal? (car s) 'let)
                             (pair? (cdr s))
                             (pair? (cadr s))
                             (pair? (caadr s))
                             (pair? (cdaadr s))
                             (pair? (car (cdaadr s)))
                             (equal? (caar (cdaadr s)) 'lambda)
                             (pair? (cdar (cdaadr s)))
                             (null? (cadar (cdaadr s)))
                             (pair? (cddar (cdaadr s)))
                             (null? (cdddar (cdaadr s)))
                             (null? (cdr (cdaadr s)))
                             (null? (cdadr s))
                             (pair? (cddr s))
                             (null? (cdddr s))
                             (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr
                                                                           s))
                                                                   (s2 (caddr
                                                                         s)))
                                                               `(let ((,fail (lambda ()
                                                                               ,f)))
                                                                  ,(assm tst
                                                                         `(,fail)
                                                                         s2))))
                       (else `(if ,tst ,s ,f)))))
             (guarantees (lambda (code x)
                           (let ((a (add-a x)) (d (add-d x)))
                             (let loop ((code code))
                               (cond
                                 ((not (pair? code)) #f)
                                 ((memq (car code) '(cond match:error)) #t)
                                 ((or (equal? code a) (equal? code d)) #t)
                                 ((eq? (car code) 'if) (or (loop (cadr code))
                                                           (and (loop (caddr
                                                                        code))
                                                                (loop (cadddr
                                                                        code)))))
                                 ((eq? (car code) 'lambda) #f)
                                 ((and (eq? (car code) 'let)
                                       (symbol? (cadr code))) #f)
                                 (else (or (loop (car code))
                                           (loop (cdr code)))))))))
             (in (lambda (e l)
                   (or (member e l)
                       (and (eq? (car e) 'list?)
                            (or (member `(null? ,(cadr e)) l)
                                (member `(pair? ,(cadr e)) l)))
                       (and (eq? (car e) 'not)
                            (let* ((srch (cadr e))
                                   (const-class (equal-test? srch)))
                              (cond
                                (const-class (let mem ((l l))
                                               (if (null? l)
                                                   #f
                                                   (let ((x (car l)))
                                                     (or (and (equal?
                                                                (cadr x)
                                                                (cadr srch))
                                                              (disjoint? x)
                                                              (not (equal?
                                                                     const-class
                                                                     (car x))))
                                                         (equal?
                                                           x
                                                           `(not (,const-class
                                                                   ,(cadr srch))))
                                                         (and (equal?
                                                                (cadr x)
                                                                (cadr srch))
                                                              (equal-test?
                                                                x)
                                                              (not (equal?
                                                                     (caddr
                                                                       srch)
                                                                     (caddr
                                                                       x))))
                                                         (mem (cdr l)))))))
                                ((disjoint? srch) (let mem ((l l))
                                                    (if (null? l)
                                                        #f
                                                        (let ((x (car l)))
                                                          (or (and (equal?
                                                                     (cadr x)
                                                                     (cadr srch))
                                                                   (disjoint?
                                                                     x)
                                                                   (not (equal?
                                                                          (car x)
                                                                          (car srch))))
                                                              (mem (cdr l)))))))
                                ((eq? (car srch) 'list?) (let mem ((l l))
                                                           (if (null? l)
                                                               #f
                                                               (let ((x (car l)))
                                                                 (or (and (equal?
                                                                            (cadr x)
                                                                            (cadr srch))
                                                                          (disjoint?
                                                                            x)
                                                                          (not (memq (car x)
                                                                                     '(list?
                                                                                        pair?
                                                                                        null?))))
                                                                     (mem (cdr l)))))))
                                ((vec-structure? srch) (let mem ((l l))
                                                         (if (null? l)
                                                             #f
                                                             (let ((x (car l)))
                                                               (or (and (equal?
                                                                          (cadr x)
                                                                          (cadr srch))
                                                                        (or (disjoint?
                                                                              x)
                                                                            (vec-structure?
                                                                              x))
                                                                        (not (equal?
                                                                               (car x)
                                                                               'vector?))
                                                                        (not (equal?
                                                                               (car x)
                                                                               (car srch))))
                                                                   (equal?
                                                                     x
                                                                     `(not (vector?
                                                                             ,(cadr srch))))
                                                                   (mem (cdr l)))))))
                                (else #f)))))))
             (equal-test? (lambda (tst)
                            (and (eq? (car tst) 'equal?)
                                 (let ((p (caddr tst)))
                                   (cond
                                     ((string? p) 'string?)
                                     ((boolean? p) 'boolean?)
                                     ((char? p) 'char?)
                                     ((number? p) 'number?)
                                     ((and (pair? p)
                                           (pair? (cdr p))
                                           (null? (cddr p))
                                           (eq? 'quote (car p))
                                           (symbol? (cadr p))) 'symbol?)
                                     (else #f))))))
             (disjoint? (lambda (tst)
                          (memq (car tst) match:disjoint-predicates)))
             (vec-structure? (lambda (tst)
                               (memq (car tst) match:vector-structures)))
             (add-a (lambda (a)
                      (let ((new (and (pair? a) (assq (car a) c---rs))))
                        (if new (cons (cadr new) (cdr a)) `(car ,a)))))
             (add-d (lambda (a)
                      (let ((new (and (pair? a) (assq (car a) c---rs))))
                        (if new (cons (cddr new) (cdr a)) `(cdr ,a)))))
             (c---rs '((car caar . cdar)
                       (cdr cadr . cddr)
                       (caar caaar . cdaar)
                       (cadr caadr . cdadr)
                       (cdar cadar . cddar)
                       (cddr caddr . cdddr)
                       (caaar caaaar . cdaaar)
                       (caadr caaadr . cdaadr)
                       (cadar caadar . cdadar)
                       (caddr caaddr . cdaddr)
                       (cdaar cadaar . cddaar)
                       (cdadr cadadr . cddadr)
                       (cddar caddar . cdddar)
                       (cdddr cadddr . cddddr)))
             (setter (lambda (e p)
                       (let ((mk-setter (lambda (s)
                                          (symbol-append 'set- s '!))))
                         (cond
                           ((not (pair? e)) (match:syntax-err
                                              p
                                              "unnested set! pattern"))
                           ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
                                                         (lambda (y)
                                                           (vector-set!
                                                             x
                                                             ,(caddr e)
                                                             y))))
                           ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
                                                    (lambda (y)
                                                      (set-box! x y))))
                           ((eq? (car e) 'car) `(let ((x ,(cadr e)))
                                                  (lambda (y)
                                                    (set-car! x y))))
                           ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
                                                  (lambda (y)
                                                    (set-cdr! x y))))
                           ((let ((a (assq (car e) get-c---rs)))
                              (and a
                                   `(let ((x (,(cadr a) ,(cadr e))))
                                      (lambda (y)
                                        (,(mk-setter (cddr a)) x y))))))
                           (else `(let ((x ,(cadr e)))
                                    (lambda (y)
                                      (,(mk-setter (car e)) x y))))))))
             (getter (lambda (e p)
                       (cond
                         ((not (pair? e)) (match:syntax-err
                                            p
                                            "unnested get! pattern"))
                         ((eq? (car e) 'vector-ref) `(let ((x ,(cadr e)))
                                                       (lambda ()
                                                         (vector-ref
                                                           x
                                                           ,(caddr e)))))
                         ((eq? (car e) 'unbox) `(let ((x ,(cadr e)))
                                                  (lambda () (unbox x))))
                         ((eq? (car e) 'car) `(let ((x ,(cadr e)))
                                                (lambda () (car x))))
                         ((eq? (car e) 'cdr) `(let ((x ,(cadr e)))
                                                (lambda () (cdr x))))
                         ((let ((a (assq (car e) get-c---rs)))
                            (and a
                                 `(let ((x (,(cadr a) ,(cadr e))))
                                    (lambda () (,(cddr a) x))))))
                         (else `(let ((x ,(cadr e)))
                                  (lambda () (,(car e) x)))))))
             (get-c---rs '((caar car . car)
                           (cadr cdr . car)
                           (cdar car . cdr)
                           (cddr cdr . cdr)
                           (caaar caar . car)
                           (caadr cadr . car)
                           (cadar cdar . car)
                           (caddr cddr . car)
                           (cdaar caar . cdr)
                           (cdadr cadr . cdr)
                           (cddar cdar . cdr)
                           (cdddr cddr . cdr)
                           (caaaar caaar . car)
                           (caaadr caadr . car)
                           (caadar cadar . car)
                           (caaddr caddr . car)
                           (cadaar cdaar . car)
                           (cadadr cdadr . car)
                           (caddar cddar . car)
                           (cadddr cdddr . car)
                           (cdaaar caaar . cdr)
                           (cdaadr caadr . cdr)
                           (cdadar cadar . cdr)
                           (cdaddr caddr . cdr)
                           (cddaar cdaar . cdr)
                           (cddadr cdadr . cdr)
                           (cdddar cddar . cdr)
                           (cddddr cdddr . cdr)))
             (symbol-append (lambda l
                              (string->symbol
                                (apply
                                  string-append
                                  (map (lambda (x)
                                         (cond
                                           ((symbol? x) (symbol->string x))
                                           ((number? x) (number->string x))
                                           (else x)))
                                       l)))))
             (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l)))))
             (rdc (lambda (l)
                    (if (null? (cdr l)) '() (cons (car l) (rdc (cdr l)))))))
      (list genmatch genletrec gendefine pattern-var?))))
(defmacro
  match
  args
  (cond
    ((and (list? args)
          (<= 1 (length args))
          (match:andmap
            (lambda (y) (and (list? y) (<= 2 (length y))))
            (cdr args))) (let* ((exp (car args))
                                (clauses (cdr args))
                                (e (if (symbol? exp) exp (gensym))))
                           (if (symbol? exp)
                               ((car match:expanders)
                                e
                                clauses
                                `(match ,@args))
                               `(let ((,e ,exp))
                                  ,((car match:expanders)
                                    e
                                    clauses
                                    `(match ,@args))))))
    (else (match:syntax-err `(match ,@args) "syntax error in"))))
(defmacro
  match-lambda
  args
  (if (and (list? args)
           (match:andmap
             (lambda (g128)
               (if (and (pair? g128) (list? (cdr g128)))
                   (pair? (cdr g128))
                   #f))
             args))
      ((lambda ()
         (let ((e (gensym))) `(lambda (,e) (match ,e ,@args)))))
      ((lambda ()
         (match:syntax-err
           `(match-lambda ,@args)
           "syntax error in")))))
(defmacro
  match-lambda*
  args
  (if (and (list? args)
           (match:andmap
             (lambda (g136)
               (if (and (pair? g136) (list? (cdr g136)))
                   (pair? (cdr g136))
                   #f))
             args))
      ((lambda ()
         (let ((e (gensym))) `(lambda ,e (match ,e ,@args)))))
      ((lambda ()
         (match:syntax-err
           `(match-lambda* ,@args)
           "syntax error in")))))
(defmacro
  match-let
  args
  (let ((g160 (lambda (pat exp body)
                `(match ,exp (,pat ,@body))))
        (g156 (lambda (pat exp body)
                (let ((g (map (lambda (x) (gensym)) pat))
                      (vpattern (list->vector pat)))
                  `(let ,(map list g exp)
                     (match (vector ,@g) (,vpattern ,@body))))))
        (g148 (lambda ()
                (match:syntax-err `(match-let ,@args) "syntax error in")))
        (g147 (lambda (p1 e1 p2 e2 body)
                (let ((g1 (gensym)) (g2 (gensym)))
                  `(let ((,g1 ,e1) (,g2 ,e2))
                     (match (cons ,g1 ,g2) ((,p1 . ,p2) ,@body))))))
        (g138 (cadddr match:expanders)))
    (if (pair? args)
        (if (symbol? (car args))
            (if (and (pair? (cdr args)) (list? (cadr args)))
                (let g163 ((g164 (cadr args)) (g162 '()) (g161 '()))
                  (if (null? g164)
                      (if (and (list? (cddr args)) (pair? (cddr args)))
                          ((lambda (name pat exp body)
                             (if (match:andmap
                                   (cadddr match:expanders)
                                   pat)
                                 `(let ,@args)
                                 `(letrec ((,name (match-lambda*
                                                    (,pat ,@body))))
                                    (,name ,@exp))))
                           (car args)
                           (reverse g161)
                           (reverse g162)
                           (cddr args))
                          (g148))
                      (if (and (pair? (car g164))
                               (pair? (cdar g164))
                               (null? (cddar g164)))
                          (g163 (cdr g164)
                                (cons (cadar g164) g162)
                                (cons (caar g164) g161))
                          (g148))))
                (g148))
            (if (list? (car args))
                (if (match:andmap
                      (lambda (g169)
                        (if (and (pair? g169)
                                 (g138 (car g169))
                                 (pair? (cdr g169)))
                            (null? (cddr g169))
                            #f))
                      (car args))
                    (if (and (list? (cdr args)) (pair? (cdr args)))
                        ((lambda () `(let ,@args)))
                        (let g151 ((g152 (car args)) (g150 '()) (g149 '()))
                          (if (null? g152)
                              (g148)
                              (if (and (pair? (car g152))
                                       (pair? (cdar g152))
                                       (null? (cddar g152)))
                                  (g151 (cdr g152)
                                        (cons (cadar g152) g150)
                                        (cons (caar g152) g149))
                                  (g148)))))
                    (if (and (pair? (car args))
                             (pair? (caar args))
                             (pair? (cdaar args))
                             (null? (cddaar args)))
                        (if (null? (cdar args))
                            (if (and (list? (cdr args)) (pair? (cdr args)))
                                (g160 (caaar args)
                                      (cadaar args)
                                      (cdr args))
                                (let g151 ((g152 (car args))
                                           (g150 '())
                                           (g149 '()))
                                  (if (null? g152)
                                      (g148)
                                      (if (and (pair? (car g152))
                                               (pair? (cdar g152))
                                               (null? (cddar g152)))
                                          (g151 (cdr g152)
                                                (cons (cadar g152) g150)
                                                (cons (caar g152) g149))
                                          (g148)))))
                            (if (and (pair? (cdar args))
                                     (pair? (cadar args))
                                     (pair? (cdadar args))
                                     (null? (cdr (cdadar args)))
                                     (null? (cddar args)))
                                (if (and (list? (cdr args))
                                         (pair? (cdr args)))
                                    (g147 (caaar args)
                                          (cadaar args)
                                          (caadar args)
                                          (car (cdadar args))
                                          (cdr args))
                                    (let g151 ((g152 (car args))
                                               (g150 '())
                                               (g149 '()))
                                      (if (null? g152)
                                          (g148)
                                          (if (and (pair? (car g152))
                                                   (pair? (cdar g152))
                                                   (null? (cddar g152)))
                                              (g151 (cdr g152)
                                                    (cons (cadar g152)
                                                          g150)
                                                    (cons (caar g152)
                                                          g149))
                                              (g148)))))
                                (let g151 ((g152 (car args))
                                           (g150 '())
                                           (g149 '()))
                                  (if (null? g152)
                                      (if (and (list? (cdr args))
                                               (pair? (cdr args)))
                                          (g156 (reverse g149)
                                                (reverse g150)
                                                (cdr args))
                                          (g148))
                                      (if (and (pair? (car g152))
                                               (pair? (cdar g152))
                                               (null? (cddar g152)))
                                          (g151 (cdr g152)
                                                (cons (cadar g152) g150)
                                                (cons (caar g152) g149))
                                          (g148))))))
                        (let g151 ((g152 (car args)) (g150 '()) (g149 '()))
                          (if (null? g152)
                              (if (and (list? (cdr args))
                                       (pair? (cdr args)))
                                  (g156 (reverse g149)
                                        (reverse g150)
                                        (cdr args))
                                  (g148))
                              (if (and (pair? (car g152))
                                       (pair? (cdar g152))
                                       (null? (cddar g152)))
                                  (g151 (cdr g152)
                                        (cons (cadar g152) g150)
                                        (cons (caar g152) g149))
                                  (g148))))))
                (if (pair? (car args))
                    (if (and (pair? (caar args))
                             (pair? (cdaar args))
                             (null? (cddaar args)))
                        (if (null? (cdar args))
                            (if (and (list? (cdr args)) (pair? (cdr args)))
                                (g160 (caaar args)
                                      (cadaar args)
                                      (cdr args))
                                (let g151 ((g152 (car args))
                                           (g150 '())
                                           (g149 '()))
                                  (if (null? g152)
                                      (g148)
                                      (if (and (pair? (car g152))
                                               (pair? (cdar g152))
                                               (null? (cddar g152)))
                                          (g151 (cdr g152)
                                                (cons (cadar g152) g150)
                                                (cons (caar g152) g149))
                                          (g148)))))
                            (if (and (pair? (cdar args))
                                     (pair? (cadar args))
                                     (pair? (cdadar args))
                                     (null? (cdr (cdadar args)))
                                     (null? (cddar args)))
                                (if (and (list? (cdr args))
                                         (pair? (cdr args)))
                                    (g147 (caaar args)
                                          (cadaar args)
                                          (caadar args)
                                          (car (cdadar args))
                                          (cdr args))
                                    (let g151 ((g152 (car args))
                                               (g150 '())
                                               (g149 '()))
                                      (if (null? g152)
                                          (g148)
                                          (if (and (pair? (car g152))
                                                   (pair? (cdar g152))
                                                   (null? (cddar g152)))
                                              (g151 (cdr g152)
                                                    (cons (cadar g152)
                                                          g150)
                                                    (cons (caar g152)
                                                          g149))
                                              (g148)))))
                                (let g151 ((g152 (car args))
                                           (g150 '())
                                           (g149 '()))
                                  (if (null? g152)
                                      (if (and (list? (cdr args))
                                               (pair? (cdr args)))
                                          (g156 (reverse g149)
                                                (reverse g150)
                                                (cdr args))
                                          (g148))
                                      (if (and (pair? (car g152))
                                               (pair? (cdar g152))
                                               (null? (cddar g152)))
                                          (g151 (cdr g152)
                                                (cons (cadar g152) g150)
                                                (cons (caar g152) g149))
                                          (g148))))))
                        (let g151 ((g152 (car args)) (g150 '()) (g149 '()))
                          (if (null? g152)
                              (if (and (list? (cdr args))
                                       (pair? (cdr args)))
                                  (g156 (reverse g149)
                                        (reverse g150)
                                        (cdr args))
                                  (g148))
                              (if (and (pair? (car g152))
                                       (pair? (cdar g152))
                                       (null? (cddar g152)))
                                  (g151 (cdr g152)
                                        (cons (cadar g152) g150)
                                        (cons (caar g152) g149))
                                  (g148)))))
                    (g148))))
        (g148))))
(defmacro
  match-let*
  args
  (let ((g178 (lambda ()
                (match:syntax-err `(match-let* ,@args) "syntax error in"))))
    (if (pair? args)
        (if (null? (car args))
            (if (and (list? (cdr args)) (pair? (cdr args)))
                ((lambda (body) `(let* ,@args)) (cdr args))
                (g178))
            (if (and (pair? (car args))
                     (pair? (caar args))
                     (pair? (cdaar args))
                     (null? (cddaar args))
                     (list? (cdar args))
                     (list? (cdr args))
                     (pair? (cdr args)))
                ((lambda (pat exp rest body)
                   (if ((cadddr match:expanders) pat)
                       `(let ((,pat ,exp)) (match-let* ,rest ,@body))
                       `(match ,exp (,pat (match-let* ,rest ,@body)))))
                 (caaar args)
                 (cadaar args)
                 (cdar args)
                 (cdr args))
                (g178)))
        (g178))))
(defmacro
  match-letrec
  args
  (let ((g202 (cadddr match:expanders))
        (g201 (lambda (p1 e1 p2 e2 body)
                `(match-letrec (((,p1 . ,p2) (cons ,e1 ,e2))) ,@body)))
        (g197 (lambda ()
                (match:syntax-err
                  `(match-letrec ,@args)
                  "syntax error in")))
        (g196 (lambda (pat exp body)
                `(match-letrec
                   ((,(list->vector pat) (vector ,@exp)))
                   ,@body)))
        (g188 (lambda (pat exp body)
                ((cadr match:expanders)
                 pat
                 exp
                 body
                 `(match-letrec ((,pat ,exp)) ,@body)))))
    (if (pair? args)
        (if (list? (car args))
            (if (match:andmap
                  (lambda (g208)
                    (if (and (pair? g208)
                             (g202 (car g208))
                             (pair? (cdr g208)))
                        (null? (cddr g208))
                        #f))
                  (car args))
                (if (and (list? (cdr args)) (pair? (cdr args)))
                    ((lambda () `(letrec ,@args)))
                    (let g191 ((g192 (car args)) (g190 '()) (g189 '()))
                      (if (null? g192)
                          (g197)
                          (if (and (pair? (car g192))
                                   (pair? (cdar g192))
                                   (null? (cddar g192)))
                              (g191 (cdr g192)
                                    (cons (cadar g192) g190)
                                    (cons (caar g192) g189))
                              (g197)))))
                (if (and (pair? (car args))
                         (pair? (caar args))
                         (pair? (cdaar args))
                         (null? (cddaar args)))
                    (if (null? (cdar args))
                        (if (and (list? (cdr args)) (pair? (cdr args)))
                            (g188 (caaar args) (cadaar args) (cdr args))
                            (let g191 ((g192 (car args))
                                       (g190 '())
                                       (g189 '()))
                              (if (null? g192)
                                  (g197)
                                  (if (and (pair? (car g192))
                                           (pair? (cdar g192))
                                           (null? (cddar g192)))
                                      (g191 (cdr g192)
                                            (cons (cadar g192) g190)
                                            (cons (caar g192) g189))
                                      (g197)))))
                        (if (and (pair? (cdar args))
                                 (pair? (cadar args))
                                 (pair? (cdadar args))
                                 (null? (cdr (cdadar args)))
                                 (null? (cddar args)))
                            (if (and (list? (cdr args)) (pair? (cdr args)))
                                (g201 (caaar args)
                                      (cadaar args)
                                      (caadar args)
                                      (car (cdadar args))
                                      (cdr args))
                                (let g191 ((g192 (car args))
                                           (g190 '())
                                           (g189 '()))
                                  (if (null? g192)
                                      (g197)
                                      (if (and (pair? (car g192))
                                               (pair? (cdar g192))
                                               (null? (cddar g192)))
                                          (g191 (cdr g192)
                                                (cons (cadar g192) g190)
                                                (cons (caar g192) g189))
                                          (g197)))))
                            (let g191 ((g192 (car args))
                                       (g190 '())
                                       (g189 '()))
                              (if (null? g192)
                                  (if (and (list? (cdr args))
                                           (pair? (cdr args)))
                                      (g196 (reverse g189)
                                            (reverse g190)
                                            (cdr args))
                                      (g197))
                                  (if (and (pair? (car g192))
                                           (pair? (cdar g192))
                                           (null? (cddar g192)))
                                      (g191 (cdr g192)
                                            (cons (cadar g192) g190)
                                            (cons (caar g192) g189))
                                      (g197))))))
                    (let g191 ((g192 (car args)) (g190 '()) (g189 '()))
                      (if (null? g192)
                          (if (and (list? (cdr args)) (pair? (cdr args)))
                              (g196 (reverse g189)
                                    (reverse g190)
                                    (cdr args))
                              (g197))
                          (if (and (pair? (car g192))
                                   (pair? (cdar g192))
                                   (null? (cddar g192)))
                              (g191 (cdr g192)
                                    (cons (cadar g192) g190)
                                    (cons (caar g192) g189))
                              (g197))))))
            (if (pair? (car args))
                (if (and (pair? (caar args))
                         (pair? (cdaar args))
                         (null? (cddaar args)))
                    (if (null? (cdar args))
                        (if (and (list? (cdr args)) (pair? (cdr args)))
                            (g188 (caaar args) (cadaar args) (cdr args))
                            (let g191 ((g192 (car args))
                                       (g190 '())
                                       (g189 '()))
                              (if (null? g192)
                                  (g197)
                                  (if (and (pair? (car g192))
                                           (pair? (cdar g192))
                                           (null? (cddar g192)))
                                      (g191 (cdr g192)
                                            (cons (cadar g192) g190)
                                            (cons (caar g192) g189))
                                      (g197)))))
                        (if (and (pair? (cdar args))
                                 (pair? (cadar args))
                                 (pair? (cdadar args))
                                 (null? (cdr (cdadar args)))
                                 (null? (cddar args)))
                            (if (and (list? (cdr args)) (pair? (cdr args)))
                                (g201 (caaar args)
                                      (cadaar args)
                                      (caadar args)
                                      (car (cdadar args))
                                      (cdr args))
                                (let g191 ((g192 (car args))
                                           (g190 '())
                                           (g189 '()))
                                  (if (null? g192)
                                      (g197)
                                      (if (and (pair? (car g192))
                                               (pair? (cdar g192))
                                               (null? (cddar g192)))
                                          (g191 (cdr g192)
                                                (cons (cadar g192) g190)
                                                (cons (caar g192) g189))
                                          (g197)))))
                            (let g191 ((g192 (car args))
                                       (g190 '())
                                       (g189 '()))
                              (if (null? g192)
                                  (if (and (list? (cdr args))
                                           (pair? (cdr args)))
                                      (g196 (reverse g189)
                                            (reverse g190)
                                            (cdr args))
                                      (g197))
                                  (if (and (pair? (car g192))
                                           (pair? (cdar g192))
                                           (null? (cddar g192)))
                                      (g191 (cdr g192)
                                            (cons (cadar g192) g190)
                                            (cons (caar g192) g189))
                                      (g197))))))
                    (let g191 ((g192 (car args)) (g190 '()) (g189 '()))
                      (if (null? g192)
                          (if (and (list? (cdr args)) (pair? (cdr args)))
                              (g196 (reverse g189)
                                    (reverse g190)
                                    (cdr args))
                              (g197))
                          (if (and (pair? (car g192))
                                   (pair? (cdar g192))
                                   (null? (cddar g192)))
                              (g191 (cdr g192)
                                    (cons (cadar g192) g190)
                                    (cons (caar g192) g189))
                              (g197)))))
                (g197)))
        (g197))))
(defmacro
  match-define
  args
  (let ((g212 (cadddr match:expanders))
        (g211 (lambda ()
                (match:syntax-err
                  `(match-define ,@args)
                  "syntax error in"))))
    (if (pair? args)
        (if (g212 (car args))
            (if (and (pair? (cdr args)) (null? (cddr args)))
                ((lambda () `(begin (define ,@args))))
                (g211))
            (if (and (pair? (cdr args)) (null? (cddr args)))
                ((lambda (pat exp)
                   ((caddr match:expanders)
                    pat
                    exp
                    `(match-define ,@args)))
                 (car args)
                 (cadr args))
                (g211)))
        (g211))))
(define match:runtime-structures #f)
(define match:set-runtime-structures
  (lambda (v) (set! match:runtime-structures v)))
(defmacro
  defstruct
  args
  (let ((field? (lambda (x)
                  (if (symbol? x)
                      ((lambda () #t))
                      (if (and (pair? x)
                               (symbol? (car x))
                               (pair? (cdr x))
                               (symbol? (cadr x))
                               (null? (cddr x)))
                          ((lambda () #t))
                          ((lambda () #f))))))
        (selector-name (lambda (x)
                         (if (symbol? x)
                             ((lambda () x))
                             (if (and (pair? x)
                                      (symbol? (car x))
                                      (pair? (cdr x))
                                      (null? (cddr x)))
                                 ((lambda (s) s) (car x))
                                 (match:error x)))))
        (mutator-name (lambda (x)
                        (if (symbol? x)
                            ((lambda () #f))
                            (if (and (pair? x)
                                     (pair? (cdr x))
                                     (symbol? (cadr x))
                                     (null? (cddr x)))
                                ((lambda (s) s) (cadr x))
                                (match:error x)))))
        (filter-map-with-index (lambda (f l)
                                 (letrec ((mapi (lambda (l i)
                                                  (cond
                                                    ((null? l) '())
                                                    ((f (car l) i) =>
                                                     (lambda (x)
                                                       (cons x
                                                             (mapi (cdr l)
                                                                   (+ 1
                                                                      i)))))
                                                    (else (mapi (cdr l)
                                                                (+ 1 i)))))))
                                   (mapi l 1)))))
    (let ((g229 (lambda ()
                  (match:syntax-err `(defstruct ,@args) "syntax error in"))))
      (if (and (pair? args)
               (symbol? (car args))
               (pair? (cdr args))
               (symbol? (cadr args))
               (pair? (cddr args))
               (symbol? (caddr args))
               (list? (cdddr args)))
          (let g231 ((g232 (cdddr args)) (g230 '()))
            (if (null? g232)
                ((lambda (name constructor predicate fields)
                   (let* ((selectors (map selector-name fields))
                          (mutators (map mutator-name fields))
                          (tag (if match:runtime-structures
                                   (gensym)
                                   `',(match:make-structure-tag name))))
                     (cond
                       ((eq? match:structure-control 'disjoint) (if (eq? vector?
                                                                         #%vector?)
                                                                    (set! vector?
                                                                      (lambda (v)
                                                                        (and (#%vector?
                                                                               v)
                                                                             (or (zero?
                                                                                   (#%vector-length
                                                                                     v))
                                                                                 (not (#%symbol?
                                                                                        (#%vector-ref
                                                                                          v
                                                                                          0)))
                                                                                 (not (match:structure?
                                                                                        (#%vector-ref
                                                                                          v
                                                                                          0))))))))
                        (if (not (memq predicate
                                       match:disjoint-predicates))
                            (set! match:disjoint-predicates
                              (cons predicate match:disjoint-predicates))))
                       ((eq? match:structure-control 'vector) (if (not (memq predicate
                                                                             match:vector-structures))
                                                                  (set! match:vector-structures
                                                                    (cons predicate
                                                                          match:vector-structures))))
                       (else (match:syntax-err
                               '(vector disjoint)
                               "invalid value for match:structure-control, legal values are")))
                     `(begin ,@(if match:runtime-structures
                                   `((define ,tag
                                       (match:make-structure-tag ',name)))
                                   '())
                             (define ,constructor
                               (lambda ,selectors
                                 (#%vector ,tag ,@selectors)))
                             (define ,predicate
                               (lambda (obj)
                                 (and (#%vector? obj)
                                      (#%= (#%vector-length obj)
                                           ,(+ 1 (length selectors)))
                                      (#%eq? (#%vector-ref obj 0) ,tag))))
                             ,@(filter-map-with-index
                                 (lambda (n i)
                                   `(define ,n
                                      (lambda (obj)
                                        ,@(if (< (optimize-level) 1)
                                              `((unless (,predicate obj)
                                                  (#%error
                                                    ',n
                                                    "~s is not a ~s"
                                                    obj
                                                    ,tag)))
                                              '())
                                        (#%vector-ref obj ,i))))
                                 selectors)
                             ,@(filter-map-with-index
                                 (lambda (n i)
                                   (and n
                                        `(define ,n
                                           (lambda (obj newval)
                                             ,@(if (< (optimize-level) 1)
                                                   `((unless (,predicate
                                                               obj)
                                                       (#%error
                                                         ',n
                                                         "~s is not a ~s"
                                                         obj
                                                         ,tag)))
                                                   '())
                                             (#%vector-set!
                                               obj
                                               ,i
                                               newval)))))
                                 mutators))))
                 (car args)
                 (cadr args)
                 (caddr args)
                 (reverse g230))
                (if (field? (car g232))
                    (g231 (cdr g232) (cons (car g232) g230))
                    (g229))))
          (g229)))))
(defmacro
  define-structure
  args
  (let ((g244 (lambda ()
                (match:syntax-err
                  `(define-structure ,@args)
                  "syntax error in"))))
    (if (and (pair? args)
             (pair? (car args))
             (list? (cdar args)))
        (if (null? (cdr args))
            ((lambda (name id1) `(define-structure (,name ,@id1) ()))
             (caar args)
             (cdar args))
            (if (and (pair? (cdr args)) (list? (cadr args)))
                (let g241 ((g242 (cadr args)) (g240 '()) (g239 '()))
                  (if (null? g242)
                      (if (null? (cddr args))
                          ((lambda (name id1 id2 val)
                             (let ((mk-id (lambda (id)
                                            (if (and (pair? id)
                                                     (equal? (car id) '@)
                                                     (pair? (cdr id))
                                                     (symbol? (cadr id))
                                                     (null? (cddr id)))
                                                ((lambda (x) x) (cadr id))
                                                ((lambda () `(! ,id)))))))
                               `(define-const-structure
                                  (,name ,@(map mk-id id1))
                                  ,(map (lambda (id v) `(,(mk-id id) ,v))
                                        id2
                                        val))))
                           (caar args)
                           (cdar args)
                           (reverse g239)
                           (reverse g240))
                          (g244))
                      (if (and (pair? (car g242))
                               (pair? (cdar g242))
                               (null? (cddar g242)))
                          (g241 (cdr g242)
                                (cons (cadar g242) g240)
                                (cons (caar g242) g239))
                          (g244))))
                (g244)))
        (g244))))
(defmacro
  define-const-structure
  args
  (let ((field? (lambda (id)
                  (if (symbol? id)
                      ((lambda () #t))
                      (if (and (pair? id)
                               (equal? (car id) '!)
                               (pair? (cdr id))
                               (symbol? (cadr id))
                               (null? (cddr id)))
                          ((lambda () #t))
                          ((lambda () #f))))))
        (field-name (lambda (x) (if (symbol? x) x (cadr x))))
        (has-mutator? (lambda (x) (not (symbol? x))))
        (filter-map-with-index (lambda (f l)
                                 (letrec ((mapi (lambda (l i)
                                                  (cond
                                                    ((null? l) '())
                                                    ((f (car l) i) =>
                                                     (lambda (x)
                                                       (cons x
                                                             (mapi (cdr l)
                                                                   (+ 1
                                                                      i)))))
                                                    (else (mapi (cdr l)
                                                                (+ 1 i)))))))
                                   (mapi l 1))))
        (symbol-append (lambda l
                         (string->symbol
                           (apply
                             string-append
                             (map (lambda (x)
                                    (cond
                                      ((symbol? x) (symbol->string x))
                                      ((number? x) (number->string x))
                                      (else x)))
                                  l))))))
    (let ((g268 (lambda ()
                  (match:syntax-err
                    `(define-const-structure ,@args)
                    "syntax error in"))))
      (if (and (pair? args)
               (pair? (car args))
               (list? (cdar args)))
          (if (null? (cdr args))
              ((lambda (name id1)
                 `(define-const-structure (,name ,@id1) ()))
               (caar args)
               (cdar args))
              (if (symbol? (caar args))
                  (let g261 ((g262 (cdar args)) (g260 '()))
                    (if (null? g262)
                        (if (and (pair? (cdr args)) (list? (cadr args)))
                            (let g265 ((g266 (cadr args))
                                       (g264 '())
                                       (g263 '()))
                              (if (null? g266)
                                  (if (null? (cddr args))
                                      ((lambda (name id1 id2 val)
                                         (let* ((id1id2 (append id1 id2))
                                                (raw-constructor (symbol-append
                                                                   'make-raw-
                                                                   name))
                                                (constructor (symbol-append
                                                               'make-
                                                               name))
                                                (predicate (symbol-append
                                                             name
                                                             '?)))
                                           `(begin (defstruct
                                                     ,name
                                                     ,raw-constructor
                                                     ,predicate
                                                     ,@(filter-map-with-index
                                                         (lambda (arg i)
                                                           (if (has-mutator?
                                                                 arg)
                                                               `(,(symbol-append
                                                                    name
                                                                    '-
                                                                    i)
                                                                  ,(symbol-append
                                                                     'set-
                                                                     name
                                                                     '-
                                                                     i
                                                                     '!))
                                                               (symbol-append
                                                                 name
                                                                 '-
                                                                 i)))
                                                         id1id2))
                                                   ,(let* ((make-fresh (lambda (x)
                                                                         (if (eq? '_
                                                                                  x)
                                                                             (gensym)
                                                                             x)))
                                                           (names1 (map make-fresh
                                                                        (map field-name
                                                                             id1)))
                                                           (names2 (map make-fresh
                                                                        (map field-name
                                                                             id2))))
                                                      `(define ,constructor
                                                         (lambda ,names1
                                                           (let* ,(map list
                                                                       names2
                                                                       val)
                                                             (,raw-constructor
                                                               ,@names1
                                                               ,@names2)))))
                                                   ,@(filter-map-with-index
                                                       (lambda (field i)
                                                         (if (eq? (field-name
                                                                    field)
                                                                  '_)
                                                             #f
                                                             `(define ,(symbol-append
                                                                         name
                                                                         '-
                                                                         (field-name
                                                                           field))
                                                                ,(symbol-append
                                                                   name
                                                                   '-
                                                                   i))))
                                                       id1id2)
                                                   ,@(filter-map-with-index
                                                       (lambda (field i)
                                                         (if (or (eq? (field-name
                                                                        field)
                                                                      '_)
                                                                 (not (has-mutator?
                                                                        field)))
                                                             #f
                                                             `(define ,(symbol-append
                                                                         'set-
                                                                         name
                                                                         '-
                                                                         (field-name
                                                                           field)
                                                                         '!)
                                                                ,(symbol-append
                                                                   'set-
                                                                   name
                                                                   '-
                                                                   i
                                                                   '!))))
                                                       id1id2))))
                                       (caar args)
                                       (reverse g260)
                                       (reverse g263)
                                       (reverse g264))
                                      (g268))
                                  (if (and (pair? (car g266))
                                           (field? (caar g266))
                                           (pair? (cdar g266))
                                           (null? (cddar g266)))
                                      (g265 (cdr g266)
                                            (cons (cadar g266) g264)
                                            (cons (caar g266) g263))
                                      (g268))))
                            (g268))
                        (if (field? (car g262))
                            (g261 (cdr g262) (cons (car g262) g260))
                            (g268))))
                  (g268)))
          (g268)))))
