; Soft Scheme -- Copyright (C) 1993, 1994 Andrew K. Wright
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
;
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;
; Packaged as a single file for Larceny by Lars T Hansen.
; Modified 2000-02-15 by lth.
;
; Compilation notes.
; 
; The macro definitions for MATCH in this file depend on the presence of 
; certain helper functions in the compilation environment, eg. match:andmap.
; (That is not a problem when loading this file, but it is an issue when
; compiling it.)  The easiest way to provide the helper functions during
; compilation is to load match.sch into the compilation environment before
; compiling.
;
; Once compiled, this program is self-contained.

; The SoftScheme benchmark performs soft typing on a program and prints
; a diagnostic report.  All screen output is captured in an output
; string port, which is subsequently discarded.  (There is a moderate
; amount of output).  No file I/O occurs while the program is running.

(define (softscheme-benchmark)
  (let ((expr `(begin ,@(readfile "ss-input.scm")))
        (out  (open-output-string)))
    (run-benchmark "softscheme"
                   (lambda () 
                     (with-output-to-port out
                       (lambda ()
                         (soft-def expr #f)))))
    (newline)
    (display (string-length (get-output-string out)))
    (display " characters of output written.")
    (newline)))

;;; Define defmacro, macro?, and macroexpand-1.

(define *macros* '())

(define-syntax
  defmacro
  (transformer
    (lambda (exp rename compare)
      (define (arglist? x)
        (or (symbol? x)
            (null? x)
            (and (pair? x)
                 (symbol? (car x))
                 (arglist? (cdr x)))))
      (if (not (and (list? exp)
                    (>= (length exp) 4)
                    (symbol? (cadr exp))
                    (arglist? (caddr exp))))
        (error "Bad macro definition: " exp))
      (let ((name (cadr exp))
            (args (caddr exp))
            (body (cdddr exp)))
        `(begin
           (define-syntax
             ,name
             (transformer
              (lambda (_defmacro_exp
                       _defmacro_rename
                       _defmacro_compare)
                (apply (lambda ,args ,@body) (cdr _defmacro_exp)))))
           (set! *macros*
                 (cons (cons ',name
                             (lambda (_exp)
                               (apply (lambda ,args ,@body) (cdr _exp))))
                       *macros*))
           )))))

(define (macroexpand-1 exp)
  (cond ((pair? exp)
         (let ((probe (assq (car exp) *macros*)))
           (if probe ((cdr probe) exp) exp)))
        (else exp)))

(define (macro? keyword)
  (and (symbol? keyword) (assq keyword *macros*)))

;;; Other compatibility hacks

(define slib:error error)

(define force-output flush-output-port)

(define format
  (let ((format format))
    (lambda (port . rest)
      (if (not port)
        (let ((s (open-output-string)))
          (apply format s rest)
          (get-output-string s))
        (apply format port rest)))))

(define gentemp
  (let ((gensym gensym)) (lambda () (gensym "G"))))

(define getenv
  (let ((getenv getenv))
    (lambda (x)
      (or (getenv x)
          (if (string=? x "HOME")
            "Ertevann:Desktop folder:"
            #f)))))

;;; The rest of the file should be more or less portable.

(define match-file #f)
(define installation-directory #f)
(define customization-file #f)
(define fastlibrary-file #f)
(define st:version
  "Larceny Version 0.18, April 21, 1995")
(define match:version
  "Version 1.18, July 17, 1995")
(define match:error
  (lambda (val . args)
    (for-each pretty-print args)
    (slib:error "no matching clause for " val)))
(define match:andmap
  (lambda (f l)
    (if (null? l)
      (and)
      (and (f (car l)) (match:andmap f (cdr l))))))
(define match:syntax-err
  (lambda (obj msg) (slib:error msg obj)))
(define match:disjoint-structure-tags '())
(define match:make-structure-tag
  (lambda (name)
    (if (or (eq? match:structure-control 'disjoint)
            match:runtime-structures)
      (let ((tag (gentemp)))
        (set! match:disjoint-structure-tags
          (cons tag match:disjoint-structure-tags))
        tag)
      (string->symbol
        (string-append "<" (symbol->string name) ">")))))
(define match:structure?
  (lambda (tag)
    (memq tag match:disjoint-structure-tags)))
(define match:structure-control 'vector)
(define match:set-structure-control
  (lambda (v) (set! match:structure-control v)))
(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?)))
(define match:vector-structures '())
(define match:expanders
  (letrec ((genmatch
             (lambda (x clauses match-expr)
               (let* ((length>= (gentemp))
                      (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 (gentemp))
                                           (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 (gentemp))
                                            #f)))
                                  clauses))
                      (code (gen x
                                 '()
                                 plist
                                 (cdr eb-errf)
                                 length>=
                                 (gentemp))))
                 (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>= (gentemp))
                      (eb-errf (error-maker match-expr))
                      (x (bound (validate-pattern pat)))
                      (p (car x))
                      (bv (cadr x))
                      (bindings (caddr x))
                      (code (gentemp))
                      (plist (list (list p code bv #f #f)))
                      (x (gentemp))
                      (m (gen x
                              '()
                              plist
                              (cdr eb-errf)
                              length>=
                              (gentemp)))
                      (gs (map (lambda (_) (gentemp)) 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>= (gentemp))
                      (eb-errf (error-maker match-expr))
                      (x (bound (validate-pattern pat)))
                      (p (car x))
                      (bv (cadr x))
                      (bindings (caddr x))
                      (code (gentemp))
                      (plist (list (list p code bv #f #f)))
                      (x (gentemp))
                      (m (gen x
                              '()
                              plist
                              (cdr eb-errf)
                              length>=
                              (gentemp)))
                      (gs (map (lambda (_) (gentemp)) 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 (gentemp)) (arg (gentemp)))
                        (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 ((g88 (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))
                                          (g88 (car p) (cdr p)))
                                        (if (equal? (car p) 'quote)
                                          (if (and (pair? (cdr p))
                                                   (null? (cddr p)))
                                            ((lambda (p) p) p)
                                            (g88 (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))
                                              (g88 (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))
                                                (g88 (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))
                                                  (g88 (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))
                                                    (g88 (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))
                                                      (g88 (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))
                                                        (g88 (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)
                                                          (g88 (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)
                                                            (g88 (car p)
                                                                 (cdr p)))
                                                          (if (equal?
                                                                (car p)
                                                                'unquote)
                                                            (g88 (car p)
                                                                 (cdr p))
                                                            (if (equal?
                                                                  (car p)
                                                                  'unquote-splicing)
                                                              (g88 (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))
                                                                (g88 (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)
                                        ((lambda ()
                                           (match:syntax-err
                                             pattern
                                             "syntax error in pattern")))))))))))
                        (quasi (lambda (p)
                                 (let ((g109 (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))
                                             (g109 (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))
                                               (g109 (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)
                                           ((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 (gentemp)))
                                                      (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 (gentemp)))
                                                      (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
                                                             ,(gentemp)
                                                             ,(gentemp)
                                                             ,(map (lambda (_)
                                                                     (gentemp))
                                                                   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))))
                                            (else (k p a)))))
                             (boundv
                               (lambda (plist a k)
                                 (let ((g115 (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)
                                         (g115)
                                         ((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)
                                       (g115)
                                       (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)))))))))))
                              (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 (gentemp))))
           (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 (g126)
               (if (and (pair? g126) (list? (cdr g126)))
                 (pair? (cdr g126))
                 #f))
             args))
    ((lambda ()
       (let ((e (gentemp)))
         `(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 (g134)
               (if (and (pair? g134) (list? (cdr g134)))
                 (pair? (cdr g134))
                 #f))
             args))
    ((lambda ()
       (let ((e (gentemp)))
         `(lambda ,e (match ,e ,@args)))))
    ((lambda ()
       (match:syntax-err
         `(match-lambda* ,@args)
         "syntax error in")))))
(defmacro
  match-let
  args
  (let ((g158 (lambda (pat exp body)
                `(match ,exp (,pat ,@body))))
        (g154 (lambda (pat exp body)
                (let ((g (map (lambda (x) (gentemp)) pat))
                      (vpattern (list->vector pat)))
                  `(let ,(map list g exp)
                     (match (vector ,@g) (,vpattern ,@body))))))
        (g146 (lambda ()
                (match:syntax-err
                  `(match-let ,@args)
                  "syntax error in")))
        (g145 (lambda (p1 e1 p2 e2 body)
                (let ((g1 (gentemp)) (g2 (gentemp)))
                  `(let ((,g1 ,e1) (,g2 ,e2))
                     (match (cons ,g1 ,g2) ((,p1 unquote p2) ,@body))))))
        (g136 (cadddr match:expanders)))
    (if (pair? args)
      (if (symbol? (car args))
        (if (and (pair? (cdr args)) (list? (cadr args)))
          (let g161 ((g162 (cadr args)) (g160 '()) (g159 '()))
            (if (null? g162)
              (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 g159)
                 (reverse g160)
                 (cddr args))
                (g146))
              (if (and (pair? (car g162))
                       (pair? (cdar g162))
                       (null? (cddar g162)))
                (g161 (cdr g162)
                      (cons (cadar g162) g160)
                      (cons (caar g162) g159))
                (g146))))
          (g146))
        (if (list? (car args))
          (if (match:andmap
                (lambda (g167)
                  (if (and (pair? g167)
                           (g136 (car g167))
                           (pair? (cdr g167)))
                    (null? (cddr g167))
                    #f))
                (car args))
            (if (and (list? (cdr args)) (pair? (cdr args)))
              ((lambda () `(let ,@args)))
              (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                (if (null? g150)
                  (g146)
                  (if (and (pair? (car g150))
                           (pair? (cdar g150))
                           (null? (cddar g150)))
                    (g149 (cdr g150)
                          (cons (cadar g150) g148)
                          (cons (caar g150) g147))
                    (g146)))))
            (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)))
                  (g158 (caaar args) (cadaar args) (cdr args))
                  (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                    (if (null? g150)
                      (g146)
                      (if (and (pair? (car g150))
                               (pair? (cdar g150))
                               (null? (cddar g150)))
                        (g149 (cdr g150)
                              (cons (cadar g150) g148)
                              (cons (caar g150) g147))
                        (g146)))))
                (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)))
                    (g145 (caaar args)
                          (cadaar args)
                          (caadar args)
                          (car (cdadar args))
                          (cdr args))
                    (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                      (if (null? g150)
                        (g146)
                        (if (and (pair? (car g150))
                                 (pair? (cdar g150))
                                 (null? (cddar g150)))
                          (g149 (cdr g150)
                                (cons (cadar g150) g148)
                                (cons (caar g150) g147))
                          (g146)))))
                  (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                    (if (null? g150)
                      (if (and (list? (cdr args)) (pair? (cdr args)))
                        (g154 (reverse g147) (reverse g148) (cdr args))
                        (g146))
                      (if (and (pair? (car g150))
                               (pair? (cdar g150))
                               (null? (cddar g150)))
                        (g149 (cdr g150)
                              (cons (cadar g150) g148)
                              (cons (caar g150) g147))
                        (g146))))))
              (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                (if (null? g150)
                  (if (and (list? (cdr args)) (pair? (cdr args)))
                    (g154 (reverse g147) (reverse g148) (cdr args))
                    (g146))
                  (if (and (pair? (car g150))
                           (pair? (cdar g150))
                           (null? (cddar g150)))
                    (g149 (cdr g150)
                          (cons (cadar g150) g148)
                          (cons (caar g150) g147))
                    (g146))))))
          (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)))
                  (g158 (caaar args) (cadaar args) (cdr args))
                  (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                    (if (null? g150)
                      (g146)
                      (if (and (pair? (car g150))
                               (pair? (cdar g150))
                               (null? (cddar g150)))
                        (g149 (cdr g150)
                              (cons (cadar g150) g148)
                              (cons (caar g150) g147))
                        (g146)))))
                (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)))
                    (g145 (caaar args)
                          (cadaar args)
                          (caadar args)
                          (car (cdadar args))
                          (cdr args))
                    (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                      (if (null? g150)
                        (g146)
                        (if (and (pair? (car g150))
                                 (pair? (cdar g150))
                                 (null? (cddar g150)))
                          (g149 (cdr g150)
                                (cons (cadar g150) g148)
                                (cons (caar g150) g147))
                          (g146)))))
                  (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                    (if (null? g150)
                      (if (and (list? (cdr args)) (pair? (cdr args)))
                        (g154 (reverse g147) (reverse g148) (cdr args))
                        (g146))
                      (if (and (pair? (car g150))
                               (pair? (cdar g150))
                               (null? (cddar g150)))
                        (g149 (cdr g150)
                              (cons (cadar g150) g148)
                              (cons (caar g150) g147))
                        (g146))))))
              (let g149 ((g150 (car args)) (g148 '()) (g147 '()))
                (if (null? g150)
                  (if (and (list? (cdr args)) (pair? (cdr args)))
                    (g154 (reverse g147) (reverse g148) (cdr args))
                    (g146))
                  (if (and (pair? (car g150))
                           (pair? (cdar g150))
                           (null? (cddar g150)))
                    (g149 (cdr g150)
                          (cons (cadar g150) g148)
                          (cons (caar g150) g147))
                    (g146)))))
            (g146))))
      (g146))))
(defmacro
  match-let*
  args
  (let ((g176 (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))
          (g176))
        (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))
          (g176)))
      (g176))))
(defmacro
  match-letrec
  args
  (let ((g200 (cadddr match:expanders))
        (g199 (lambda (p1 e1 p2 e2 body)
                `(match-letrec
                   (((,p1 unquote p2) (cons ,e1 ,e2)))
                   ,@body)))
        (g195 (lambda ()
                (match:syntax-err
                  `(match-letrec ,@args)
                  "syntax error in")))
        (g194 (lambda (pat exp body)
                `(match-letrec
                   ((,(list->vector pat) (vector ,@exp)))
                   ,@body)))
        (g186 (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 (g206)
                (if (and (pair? g206)
                         (g200 (car g206))
                         (pair? (cdr g206)))
                  (null? (cddr g206))
                  #f))
              (car args))
          (if (and (list? (cdr args)) (pair? (cdr args)))
            ((lambda () `(letrec ,@args)))
            (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
              (if (null? g190)
                (g195)
                (if (and (pair? (car g190))
                         (pair? (cdar g190))
                         (null? (cddar g190)))
                  (g189 (cdr g190)
                        (cons (cadar g190) g188)
                        (cons (caar g190) g187))
                  (g195)))))
          (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)))
                (g186 (caaar args) (cadaar args) (cdr args))
                (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                  (if (null? g190)
                    (g195)
                    (if (and (pair? (car g190))
                             (pair? (cdar g190))
                             (null? (cddar g190)))
                      (g189 (cdr g190)
                            (cons (cadar g190) g188)
                            (cons (caar g190) g187))
                      (g195)))))
              (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)))
                  (g199 (caaar args)
                        (cadaar args)
                        (caadar args)
                        (car (cdadar args))
                        (cdr args))
                  (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                    (if (null? g190)
                      (g195)
                      (if (and (pair? (car g190))
                               (pair? (cdar g190))
                               (null? (cddar g190)))
                        (g189 (cdr g190)
                              (cons (cadar g190) g188)
                              (cons (caar g190) g187))
                        (g195)))))
                (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                  (if (null? g190)
                    (if (and (list? (cdr args)) (pair? (cdr args)))
                      (g194 (reverse g187) (reverse g188) (cdr args))
                      (g195))
                    (if (and (pair? (car g190))
                             (pair? (cdar g190))
                             (null? (cddar g190)))
                      (g189 (cdr g190)
                            (cons (cadar g190) g188)
                            (cons (caar g190) g187))
                      (g195))))))
            (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
              (if (null? g190)
                (if (and (list? (cdr args)) (pair? (cdr args)))
                  (g194 (reverse g187) (reverse g188) (cdr args))
                  (g195))
                (if (and (pair? (car g190))
                         (pair? (cdar g190))
                         (null? (cddar g190)))
                  (g189 (cdr g190)
                        (cons (cadar g190) g188)
                        (cons (caar g190) g187))
                  (g195))))))
        (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)))
                (g186 (caaar args) (cadaar args) (cdr args))
                (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                  (if (null? g190)
                    (g195)
                    (if (and (pair? (car g190))
                             (pair? (cdar g190))
                             (null? (cddar g190)))
                      (g189 (cdr g190)
                            (cons (cadar g190) g188)
                            (cons (caar g190) g187))
                      (g195)))))
              (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)))
                  (g199 (caaar args)
                        (cadaar args)
                        (caadar args)
                        (car (cdadar args))
                        (cdr args))
                  (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                    (if (null? g190)
                      (g195)
                      (if (and (pair? (car g190))
                               (pair? (cdar g190))
                               (null? (cddar g190)))
                        (g189 (cdr g190)
                              (cons (cadar g190) g188)
                              (cons (caar g190) g187))
                        (g195)))))
                (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
                  (if (null? g190)
                    (if (and (list? (cdr args)) (pair? (cdr args)))
                      (g194 (reverse g187) (reverse g188) (cdr args))
                      (g195))
                    (if (and (pair? (car g190))
                             (pair? (cdar g190))
                             (null? (cddar g190)))
                      (g189 (cdr g190)
                            (cons (cadar g190) g188)
                            (cons (caar g190) g187))
                      (g195))))))
            (let g189 ((g190 (car args)) (g188 '()) (g187 '()))
              (if (null? g190)
                (if (and (list? (cdr args)) (pair? (cdr args)))
                  (g194 (reverse g187) (reverse g188) (cdr args))
                  (g195))
                (if (and (pair? (car g190))
                         (pair? (cdar g190))
                         (null? (cddar g190)))
                  (g189 (cdr g190)
                        (cons (cadar g190) g188)
                        (cons (caar g190) g187))
                  (g195)))))
          (g195)))
      (g195))))
(defmacro
  match-define
  args
  (let ((g210 (cadddr match:expanders))
        (g209 (lambda ()
                (match:syntax-err
                  `(match-define ,@args)
                  "syntax error in"))))
    (if (pair? args)
      (if (g210 (car args))
        (if (and (pair? (cdr args)) (null? (cddr args)))
          ((lambda () `(begin (define ,@args))))
          (g209))
        (if (and (pair? (cdr args)) (null? (cddr args)))
          ((lambda (pat exp)
             ((caddr match:expanders)
              pat
              exp
              `(match-define ,@args)))
           (car args)
           (cadr args))
          (g209)))
      (g209))))
(define match:runtime-structures #f)
(define match:set-runtime-structures
  (lambda (v) (set! match:runtime-structures v)))
(define match:primitive-vector? vector?)
(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 ((g227 (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 g229 ((g230 (cdddr args)) (g228 '()))
          (if (null? g230)
            ((lambda (name constructor predicate fields)
               (let* ((selectors (map selector-name fields))
                      (mutators (map mutator-name fields))
                      (tag (if match:runtime-structures
                             (gentemp)
                             `',(match:make-structure-tag name)))
                      (vectorp
                        (cond ((eq? match:structure-control 'disjoint)
                               'match:primitive-vector?)
                              ((eq? match:structure-control 'vector)
                               'vector?))))
                 (cond ((eq? match:structure-control 'disjoint)
                        (if (eq? vector? match:primitive-vector?)
                          (set! vector?
                            (lambda (v)
                              (and (match:primitive-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 (,vectorp obj)
                             (= (vector-length obj) ,(+ 1 (length selectors)))
                             (eq? (vector-ref obj 0) ,tag))))
                    ,@(filter-map-with-index
                        (lambda (n i)
                          `(define ,n (lambda (obj) (vector-ref obj ,i))))
                        selectors)
                    ,@(filter-map-with-index
                        (lambda (n i)
                          (and n
                               `(define ,n
                                  (lambda (obj newval)
                                    (vector-set! obj ,i newval)))))
                        mutators))))
             (car args)
             (cadr args)
             (caddr args)
             (reverse g228))
            (if (field? (car g230))
              (g229 (cdr g230) (cons (car g230) g228))
              (g227))))
        (g227)))))
(defmacro
  define-structure
  args
  (let ((g242 (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 g239 ((g240 (cadr args)) (g238 '()) (g237 '()))
            (if (null? g240)
              (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 g237)
                 (reverse g238))
                (g242))
              (if (and (pair? (car g240))
                       (pair? (cdar g240))
                       (null? (cddar g240)))
                (g239 (cdr g240)
                      (cons (cadar g240) g238)
                      (cons (caar g240) g237))
                (g242))))
          (g242)))
      (g242))))
(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 ((g266 (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 g259 ((g260 (cdar args)) (g258 '()))
              (if (null? g260)
                (if (and (pair? (cdr args)) (list? (cadr args)))
                  (let g263 ((g264 (cadr args)) (g262 '()) (g261 '()))
                    (if (null? g264)
                      (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) (gentemp) 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 (unquote
                                                  (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 (unquote
                                                  (symbol-append
                                                    'set-
                                                    name
                                                    '-
                                                    (field-name field)
                                                    '!))
                                           ,(symbol-append
                                              'set-
                                              name
                                              '-
                                              i
                                              '!))))
                                    id1id2))))
                         (caar args)
                         (reverse g258)
                         (reverse g261)
                         (reverse g262))
                        (g266))
                      (if (and (pair? (car g264))
                               (field? (caar g264))
                               (pair? (cdar g264))
                               (null? (cddar g264)))
                        (g263 (cdr g264)
                              (cons (cadar g264) g262)
                              (cons (caar g264) g261))
                        (g266))))
                  (g266))
                (if (field? (car g260))
                  (g259 (cdr g260) (cons (car g260) g258))
                  (g266))))
            (g266)))
        (g266)))))
(define home-directory
  (or (getenv "HOME")
      (error "environment variable HOME is not defined")))
(defmacro recur args `(let ,@args))
(defmacro
  rec
  args
  (match args
         (((? symbol? x) v) `(letrec ((,x ,v)) ,x))))
(defmacro
  parameterize
  args
  (match args ((bindings exp ...) `(begin ,@exp))))
(define gensym gentemp)
(define expand-once macroexpand-1)
(defmacro check-increment-counter args #f)
(define symbol-append
  (lambda l
    (string->symbol
      (apply string-append
             (map (lambda (x) (format #f "~a" x)) l)))))
(define gensym gentemp)
(define andmap
  (lambda (f . lists)
    (cond ((null? (car lists)) (and))
          ((null? (cdr (car lists)))
           (apply f (map car lists)))
          (else
           (and (apply f (map car lists))
                (apply andmap f (map cdr lists)))))))
(define true-object? (lambda (x) (eq? #t x)))
(define false-object? (lambda (x) (eq? #f x)))
(define void (lambda () (cond (#f #f))))
(defmacro
  when
  args
  (match args
         ((tst body __1)
          `(if ,tst (begin ,@body (void)) (void)))))
(defmacro
  unless
  args
  (match args
         ((tst body __1)
          `(if ,tst (void) (begin ,@body (void))))))
(define should-never-reach
  (lambda (form)
    (slib:error "fell off end of " form)))
(define make-cvector make-vector)
(define cvector vector)
(define cvector-length vector-length)
(define cvector-ref vector-ref)
(define cvector->list vector->list)
(define list->cvector list->vector)
(define-const-structure (record _))
(defmacro
  record
  args
  (match args
         ((((? symbol? id) exp) ...)
          `(make-record
             (list ,@(map (lambda (i x) `(cons ',i ,x)) id exp))))
         (_ (slib:error "syntax error at " `(record ,@args)))))
(defmacro
  field
  args
  (match args
         (((? symbol? id) exp)
          `(match ,exp
                  (($ record x)
                   (match (assq ',id x)
                          (#f
                           (slib:error
                             "no field "
                             ,id
                             'in
                             (cons 'record (map car x))))
                          ((_ . x) x)))
                  (_ (slib:error "not a record: " '(field ,id _)))))
         (_ (slib:error "syntax error at " `(field ,@args)))))
(define-const-structure (module _))
(defmacro
  module
  args
  (match args
         (((i ...) defs ...)
          `(let ()
             ,@defs
             (make-module
               (record ,@(map (lambda (x) (list x x)) i)))))
         (_ (slib:error "syntax error at " `(module ,@args)))))
(defmacro
  import
  args
  (match args
         ((((mod defs ...) ...) body __1)
          (let* ((m (map (lambda (_) (gentemp)) mod))
                 (newdefs
                   (let loop ((mod-names m) (l-defs defs))
                     (if (null? mod-names)
                       '()
                       (append
                         (let ((m (car mod-names)))
                           (map (match-lambda
                                  ((? symbol? x) `(,x (field ,x ,m)))
                                  (((? symbol? i) (? symbol? e))
                                   `(,i (field ,e ,m)))
                                  (x (slib:error "ill-formed definition: " x)))
                                (car l-defs)))
                         (loop (cdr mod-names) (cdr l-defs)))))))
            `(let (unquote
                   (map (lambda (m mod)
                          `(,m (match ,mod (($ module x) x))))
                        m
                        mod))
               (let ,newdefs body ...))))))
(define raise
  (lambda vals
    (slib:error "Unhandled exception " vals)))
(defmacro
  fluid-let
  args
  (match args
         ((((x val) ...) body __1)
          (let ((old-x (map (lambda (_) (gentemp)) x))
                (swap-x (map (lambda (_) (gentemp)) x))
                (swap (gentemp)))
            `(let ,(map list old-x val)
               (let ((,swap
                      (lambda ()
                        (let ,(map list swap-x old-x)
                          ,@(map (lambda (old x) `(set! ,old ,x)) old-x x)
                          ,@(map (lambda (x swap) `(set! ,x ,swap))
                                 x
                                 swap-x)))))
                 (dynamic-wind ,swap (lambda () ,@body) ,swap)))))
         (_ (slib:error
              "syntax error at "
              `(fluid-let ,@args)))))
(defmacro
  handle
  args
  (match args
         ((e h)
          (let ((k (gentemp)) (exn (gentemp)))
            `((call-with-current-continuation
                (lambda (k)
                  (fluid-let
                    ((raise (lambda ,exn (k (lambda () (apply ,h ,exn))))))
                    (let ((v ,e)) (lambda () v))))))))
         (_ (slib:error "syntax error in " `(handle ,@args)))))
(defmacro
  :
  args
  (match args ((typeexp exp) exp)))
(defmacro
  module:
  args
  (match args
         ((((i type) ...) defs ...)
          `(let ()
             ,@defs
             (make-module
               (record
                 ,@(map (lambda (i type) `(,i (: ,type ,i))) i type)))))))
(defmacro
  define:
  args
  (match args
         ((name type exp) `(define ,name (: ,type ,exp)))))
(define st:failure
  (lambda (chk fmt . args)
    (slib:error
      (apply format
             #f
             (string-append "~a : " fmt)
             chk
             args))))
(defmacro
  check-bound
  args
  (match args
         ((var) var)
         (x (st:failure `(check-bound ,@x) "syntax-error"))))
(defmacro
  clash
  args
  (match args
         ((name info ...) name)
         (x (st:failure `(clash ,@x) "syntax error"))))
(defmacro
  check-lambda
  args
  (match args
         (((id info ...) (? symbol? args) body __1)
          `(lambda ,args
             (check-increment-counter ,id)
             ,@body))
         (((id info ...) args body __1)
          (let* ((n 0)
                 (chk (let loop ((a args) (nargs 0))
                        (cond ((pair? a) (loop (cdr a) (+ 1 nargs)))
                              ((null? a)
                               (set! n nargs)
                               `(= ,nargs (length args)))
                              (else
                               (set! n nargs)
                               `(<= ,nargs (length args))))))
                 (incr (if (number? id)
                         `(check-increment-counter ,id)
                         #f)))
            `(let ((lam (lambda ,args ,@body)))
               (lambda args
                 ,incr
                 (if ,chk
                   (apply lam args)
                   ,(if (eq? '= (car chk))
                      `(st:failure
                         '(check-lambda ,id ,@info)
                         "requires ~a arguments, passed: ~a"
                         ,n
                         args)
                      `(st:failure
                         '(check-lambda ,id ,@info)
                         "requires >= ~a arguments, passed: ~a"
                         ,n
                         args)))))))
         (x (st:failure `(check-lambda ,@x) "syntax error"))))
(defmacro
  check-ap
  args
  (match args
         (((id info ...) (? symbol? f) args ...)
          `(begin
             (check-increment-counter ,id)
             (if (procedure? ,f)
               (,f ,@args)
               (st:failure
                 '(check-ap ,id ,@info)
                 "not a procedure: ~a"
                 ,f))))
         (((id info ...) f args ...)
          `((lambda (proc . args)
              (check-increment-counter ,id)
              (if (procedure? proc)
                (apply proc args)
                (st:failure
                  '(check-ap ,id ,@info)
                  "not a procedure: ~a"
                  proc)))
            ,f
            ,@args))
         (x (st:failure `(check-ap ,@x) "syntax error"))))
(defmacro
  check-field
  args
  (match args
         (((id info ...) (? symbol? f) exp)
          `(match ,exp
                  (($ record x)
                   (match (assq ',f x)
                          (#f
                           (st:failure
                             '(check-field ,id ,@info)
                             "no ~a field in (record ~a)"
                             ',f
                             (map car x)))
                          ((_ . x) x)))
                  (v (st:failure
                       '(check-field ,id ,@info)
                       "not a record: ~a"
                       v))))
         (x (st:failure `(check-field ,@x) "syntax error"))))
(defmacro
  check-match
  args
  (match args
         (((id info ...) exp (and clause (pat _ __1)) ...)
          (letrec ((last (lambda (pl)
                           (if (null? (cdr pl)) (car pl) (last (cdr pl))))))
            (if (match (last pat)
                       ((? symbol?) #t)
                       (('and subp ...) (andmap symbol? subp))
                       (_ #f))
              `(begin
                 (check-increment-counter ,id)
                 (match ,exp ,@clause))
              `(begin
                 (check-increment-counter ,id)
                 (match ,exp
                        ,@clause
                        (x (st:failure
                             '(check-match ,id ,@info)
                             "no matching clause for ~a"
                             x)))))))
         (x (st:failure `(check-match ,@x) "syntax error"))))
(defmacro
  check-:
  args
  (match args
         (((id info ...) typeexp exp)
          `(st:failure
             '(check-: ,id ,@info)
             "static type annotation reached"))
         (x (st:failure `(check-: ,@x) "syntax error"))))
(defmacro
  make-check-typed
  args
  (match args
         ((prim)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (null? a)
                             (,prim)
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim '_)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (= 1 (length a))
                             (,prim (car a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim type1)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (and (= 1 (length a)) (,type1 (car a)))
                             (,prim (car a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim '_ '_)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (= 2 (length a))
                             (,prim (car a) (cadr a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim '_ type2)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (and (= 2 (length a)) (,type2 (cadr a)))
                             (,prim (car a) (cadr a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim type1 '_)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (and (= 2 (length a)) (,type1 (car a)))
                             (,prim (car a) (cadr a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim type1 type2)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (and (= 2 (length a))
                                    (,type1 (car a))
                                    (,type2 (cadr a)))
                             (,prim (car a) (cadr a))
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))
         ((prim types ...)
          (let ((nargs (length types))
                (chkprim (symbol-append 'check- prim))
                (types (map (match-lambda ('_ '(lambda (_) #t)) (x x))
                            types)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (if (and (= ,nargs (length a))
                                    (andmap
                                      (lambda (f a) (f a))
                                      (list ,@types)
                                      a))
                             (apply ,prim a)
                             (st:failure
                               (cons ',chkprim '(,'unquote id))
                               "invalid arguments: ~a"
                               a)))))))))
(defmacro
  make-check-selector
  args
  (match args
         ((prim pat)
          (let ((chkprim (symbol-append 'check- prim)))
            (list 'defmacro
                  chkprim
                  'id
                  (list 'quasiquote
                        `(lambda a
                           (check-increment-counter (,'unquote (car id)))
                           (match a
                                  ((,pat) x)
                                  (_ (st:failure
                                       (cons ',chkprim '(,'unquote id))
                                       "invalid arguments: ~a"
                                       a))))))))))
(make-check-typed number? _)
(make-check-typed null? _)
(make-check-typed char? _)
(make-check-typed symbol? _)
(make-check-typed string? _)
(make-check-typed vector? _)
(make-check-typed box? _)
(make-check-typed pair? _)
(make-check-typed procedure? _)
(make-check-typed eof-object? _)
(make-check-typed input-port? _)
(make-check-typed output-port? _)
(make-check-typed true-object? _)
(make-check-typed false-object? _)
(make-check-typed boolean? _)
(make-check-typed list? _)
(make-check-typed not _)
(make-check-typed eqv? _ _)
(make-check-typed eq? _ _)
(make-check-typed equal? _ _)
(make-check-typed cons _ _)
(make-check-selector car (x . _))
(make-check-selector cdr (_ . x))
(make