defsubst

[bpt/guile.git] / gc-benchmarks / larceny / softscheme.sch

; 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-check-selector caar ((x . _) . _))
(make-check-selector cadr (_ x . _))
(make-check-selector cdar ((_ . x) . _))
(make-check-selector cddr (_ _ . x))
(make-check-selector caaar (((x . _) . _) . _))
(make-check-selector caadr (_ (x . _) . _))
(make-check-selector cadar ((_ x . _) . _))
(make-check-selector caddr (_ _ x . _))
(make-check-selector cdaar (((_ . x) . _) . _))
(make-check-selector cdadr (_ (_ . x) . _))
(make-check-selector cddar ((_ _ . x) . _))
(make-check-selector cdddr (_ _ _ . x))
(make-check-selector
  caaaar
  ((((x . _) . _) . _) . _))
(make-check-selector
  caaadr
  (_ ((x . _) . _) . _))
(make-check-selector
  caadar
  ((_ (x . _) . _) . _))
(make-check-selector caaddr (_ _ (x . _) . _))
(make-check-selector
  cadaar
  (((_ x . _) . _) . _))
(make-check-selector cadadr (_ (_ x . _) . _))
(make-check-selector caddar ((_ _ x . _) . _))
(make-check-selector cadddr (_ _ _ x . _))
(make-check-selector
  cdaaar
  ((((_ . x) . _) . _) . _))
(make-check-selector
  cdaadr
  (_ ((_ . x) . _) . _))
(make-check-selector
  cdadar
  ((_ (_ . x) . _) . _))
(make-check-selector cdaddr (_ _ (_ . x) . _))
(make-check-selector
  cddaar
  (((_ _ . x) . _) . _))
(make-check-selector cddadr (_ (_ _ . x) . _))
(make-check-selector cdddar ((_ _ _ . x) . _))
(make-check-selector cddddr (_ _ _ _ . x))
(make-check-typed set-car! pair? _)
(make-check-typed set-cdr! pair? _)
(defmacro
  check-list
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (apply list a)))
(make-check-typed length list?)
(defmacro
  check-append
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (let loop ((b a))
       (match b
              (() #t)
              ((l) #t)
              (((? list?) . y) (loop y))
              (_ (st:failure
                   (cons 'check-append ',id)
                   "invalid arguments: ~a"
                   a))))
     (apply append a)))
(make-check-typed reverse list?)
(make-check-typed list-tail list? number?)
(make-check-typed list-ref list? number?)
(make-check-typed memq _ list?)
(make-check-typed memv _ list?)
(make-check-typed member _ list?)
(defmacro
  check-assq
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (= 2 (length a))
              (list? (cadr a))
              (andmap pair? (cadr a)))
       (assq (car a) (cadr a))
       (st:failure
         (cons 'check-assq ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-assv
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (= 2 (length a))
              (list? (cadr a))
              (andmap pair? (cadr a)))
       (assv (car a) (cadr a))
       (st:failure
         (cons 'check-assv ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-assoc
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (= 2 (length a))
              (list? (cadr a))
              (andmap pair? (cadr a)))
       (assoc (car a) (cadr a))
       (st:failure
         (cons 'check-assoc ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed symbol->string symbol?)
(make-check-typed string->symbol string?)
(make-check-typed complex? _)
(make-check-typed real? _)
(make-check-typed rational? _)
(make-check-typed integer? _)
(make-check-typed exact? number?)
(make-check-typed inexact? number?)
(defmacro
  check-=
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a)) (andmap number? a))
       (apply = a)
       (st:failure
         (cons 'check-= ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-<
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a)) (andmap number? a))
       (apply < a)
       (st:failure
         (cons 'check-< ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check->
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a)) (andmap number? a))
       (apply > a)
       (st:failure
         (cons 'check-> ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-<=
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a)) (andmap number? a))
       (apply <= a)
       (st:failure
         (cons 'check-<= ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check->=
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a)) (andmap number? a))
       (apply >= a)
       (st:failure
         (cons 'check->= ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed zero? number?)
(make-check-typed positive? number?)
(make-check-typed negative? number?)
(make-check-typed odd? number?)
(make-check-typed even? number?)
(defmacro
  check-max
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 1 (length a)) (andmap number? a))
       (apply max a)
       (st:failure
         (cons 'check-max ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-min
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 1 (length a)) (andmap number? a))
       (apply min a)
       (st:failure
         (cons 'check-min ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-+
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap number? a)
       (apply + a)
       (st:failure
         (cons 'check-+ ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-*
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap number? a)
       (apply * a)
       (st:failure
         (cons 'check-* ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check--
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 1 (length a)) (andmap number? a))
       (apply - a)
       (st:failure
         (cons 'check-- ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-/
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 1 (length a)) (andmap number? a))
       (apply / a)
       (st:failure
         (cons 'check-/ ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed abs number?)
(make-check-typed quotient number? number?)
(make-check-typed remainder number? number?)
(make-check-typed modulo number? number?)
(defmacro
  check-gcd
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap number? a)
       (apply gcd a)
       (st:failure
         (cons 'check-gcd ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-lcm
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap number? a)
       (apply lcm a)
       (st:failure
         (cons 'check-lcm ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed numerator number?)
(make-check-typed denominator number?)
(make-check-typed floor number?)
(make-check-typed ceiling number?)
(make-check-typed truncate number?)
(make-check-typed round number?)
(make-check-typed rationalize number? number?)
(make-check-typed exp number?)
(make-check-typed log number?)
(make-check-typed sin number?)
(make-check-typed cos number?)
(make-check-typed tan number?)
(make-check-typed asin number?)
(make-check-typed acos number?)
(defmacro
  check-atan
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (andmap number? a)
              (pair? a)
              (>= 2 (length a)))
       (apply atan a)
       (st:failure
         (cons 'check-atan ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed sqrt number?)
(make-check-typed expt number? number?)
(make-check-typed
  make-rectangular
  number?
  number?)
(make-check-typed make-polar number? number?)
(make-check-typed real-part number?)
(make-check-typed imag-part number?)
(make-check-typed magnitude number?)
(make-check-typed angle number?)
(make-check-typed exact->inexact number?)
(make-check-typed inexact->exact number?)
(defmacro
  check-number->string
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (andmap number? a)
              (pair? a)
              (>= 2 (length a)))
       (apply number->string a)
       (st:failure
         (cons 'check-number->string ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-string->number
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (string? (car a))
              (>= 2 (length a))
              (or (null? (cdr a)) (number? (cadr a))))
       (apply string->number a)
       (st:failure
         (cons 'check-string->number ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed char=? char? char?)
(make-check-typed char<? char? char?)
(make-check-typed char>? char? char?)
(make-check-typed char<=? char? char?)
(make-check-typed char>=? char? char?)
(make-check-typed char-ci=? char? char?)
(make-check-typed char-ci<? char? char?)
(make-check-typed char-ci>? char? char?)
(make-check-typed char-ci<=? char? char?)
(make-check-typed char-ci>=? char? char?)
(make-check-typed char-alphabetic? char?)
(make-check-typed char-numeric? char?)
(make-check-typed char-whitespace? char?)
(make-check-typed char-upper-case? char?)
(make-check-typed char-lower-case? char?)
(make-check-typed char->integer char?)
(make-check-typed integer->char number?)
(make-check-typed char-upcase char?)
(make-check-typed char-downcase char?)
(defmacro
  check-make-string
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (number? (car a))
              (>= 2 (length a))
              (or (null? (cdr a)) (char? (cadr a))))
       (apply make-string a)
       (st:failure
         (cons 'check-make-string ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-string
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap char? a)
       (apply string a)
       (st:failure
         (cons 'check-string ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed string-length string?)
(make-check-typed string-ref string? number?)
(make-check-typed
  string-set!
  string?
  number?
  char?)
(make-check-typed string=? string? string?)
(make-check-typed string<? string? string?)
(make-check-typed string>? string? string?)
(make-check-typed string<=? string? string?)
(make-check-typed string>=? string? string?)
(make-check-typed string-ci=? string? string?)
(make-check-typed string-ci<? string? string?)
(make-check-typed string-ci>? string? string?)
(make-check-typed string-ci<=? string? string?)
(make-check-typed string-ci>=? string? string?)
(make-check-typed
  substring
  string?
  number?
  number?)
(defmacro
  check-string-append
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (andmap string? a)
       (apply string-append a)
       (st:failure
         (cons 'check-string-append ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed string->list string?)
(defmacro
  check-list->string
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (= 1 (length a))
              (list? (car a))
              (andmap char? (car a)))
       (list->string (car a))
       (st:failure
         (cons 'check-list->string ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed string-copy string?)
(make-check-typed string-fill! string? char?)
(make-check-typed make-vector number? _)
(defmacro
  check-vector
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (apply vector a)))
(make-check-typed vector-length vector?)
(make-check-typed vector-ref vector? number?)
(make-check-typed vector-set! vector? number? _)
(make-check-typed vector->list vector?)
(make-check-typed list->vector list?)
(make-check-typed vector-fill! vector? _)
(defmacro
  check-apply
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (pair? a)
       (let loop ((arg (cdr a)))
         (match arg
                (((? list?)) (apply apply a))
                ((_ . y) (loop y))
                (_ (st:failure
                     (cons 'check-apply ',id)
                     "invalid arguments: ~a"
                     a))))
       (st:failure
         `(check-apply ,@id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-map
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a))
              (procedure? (car a))
              (andmap list? (cdr a)))
       (apply map a)
       (st:failure
         (cons 'check-map ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-for-each
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (<= 2 (length a))
              (procedure? (car a))
              (andmap list? (cdr a)))
       (apply for-each a)
       (st:failure
         (cons 'check-for-each ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed force procedure?)
(defmacro
  check-call-with-current-continuation
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (= 1 (length a)) (procedure? (car a)))
       (call-with-current-continuation
         (lambda (k)
           ((car a) (check-lambda (continuation) (x) (k x)))))
       (st:failure
         (cons 'check-call-with-current-continuation ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed
  call-with-input-file
  string?
  procedure?)
(make-check-typed
  call-with-output-file
  string?
  procedure?)
(make-check-typed input-port? _)
(make-check-typed output-port? _)
(make-check-typed current-input-port)
(make-check-typed current-output-port)
(make-check-typed
  with-input-from-file
  string?
  procedure?)
(make-check-typed
  with-output-to-file
  string?
  procedure?)
(make-check-typed open-input-file string?)
(make-check-typed open-output-file string?)
(make-check-typed close-input-port input-port?)
(make-check-typed close-output-port output-port?)
(defmacro
  check-read
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (or (null? a)
             (and (= 1 (length a)) (input-port? (car a))))
       (apply read a)
       (st:failure
         (cons 'check-read ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-read-char
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (or (null? a)
             (and (= 1 (length a)) (input-port? (car a))))
       (apply read-char a)
       (st:failure
         (cons 'check-read-char ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-peek-char
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (or (null? a)
             (and (= 1 (length a)) (input-port? (car a))))
       (apply peek-char a)
       (st:failure
         (cons 'check-peek-char ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-char-ready?
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (or (null? a)
             (and (= 1 (length a)) (input-port? (car a))))
       (apply char-ready? a)
       (st:failure
         (cons 'check-char-ready? ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-write
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (or (null? (cdr a)) (output-port? (cadr a))))
       (apply write a)
       (st:failure
         (cons 'check-write ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-display
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (or (null? (cdr a)) (output-port? (cadr a))))
       (apply display a)
       (st:failure
         (cons 'check-display ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-newline
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (or (null? a) (output-port? (car a)))
       (apply newline a)
       (st:failure
         (cons 'check-newline ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-write-char
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (char? (car a))
              (or (null? (cdr a)) (output-port? (cadr a))))
       (apply write-char a)
       (st:failure
         (cons 'check-write-char ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed load string?)
(make-check-typed transcript-on string?)
(make-check-typed transcript-off)
(defmacro
  check-symbol-append
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (apply symbol-append a)))
(make-check-typed box _)
(make-check-typed unbox box?)
(make-check-typed set-box! box? _)
(make-check-typed void)
(make-check-typed make-module _)
(defmacro
  check-match:error
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (pair? a)
       (apply match:error a)
       (st:failure
         (cons 'check-match:error ',id)
         "invalid arguments: ~a"
         a))))
(make-check-typed should-never-reach symbol?)
(defmacro
  check-make-cvector
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (if (and (pair? a)
              (number? (car a))
              (= 2 (length a)))
       (apply make-cvector a)
       (st:failure
         (cons 'check-make-cvector ',id)
         "invalid arguments: ~a"
         a))))
(defmacro
  check-cvector
  id
  `(lambda a
     (check-increment-counter ,(car id))
     (apply cvector a)))
(make-check-typed cvector-length cvector?)
(make-check-typed cvector-ref cvector? number?)
(make-check-typed cvector->list cvector?)
(make-check-typed list->cvector list?)
(defmacro
  check-define-const-structure
  args
  (let ((field?
          (lambda (x)
            (or (symbol? x)
                (and (pair? x)
                     (equal? (car x) '!)
                     (pair? (cdr x))
                     (symbol? (cadr x))
                     (null? (cddr x))))))
        (arg-name
          (lambda (x) (if (symbol? x) x (cadr x))))
        (with-mutator? (lambda (x) (not (symbol? x)))))
    (match args
           ((((? symbol? name) (? field? id1) ...))
            (let ((constructor (symbol-append 'make- name))
                  (check-constructor
                    (symbol-append 'check-make- name))
                  (predicate (symbol-append name '?))
                  (access
                    (let loop ((l id1))
                      (cond ((null? l) '())
                            ((eq? '_ (arg-name (car l))) (loop (cdr l)))
                            (else
                             (cons (symbol-append name '- (arg-name (car l)))
                                   (loop (cdr l)))))))
                  (assign
                    (let loop ((l id1))
                      (cond ((null? l) '())
                            ((eq? '_ (arg-name (car l))) (loop (cdr l)))
                            ((not (with-mutator? (car l))) (loop (cdr l)))
                            (else
                             (cons (symbol-append
                                     'set-
                                     name
                                     '-
                                     (arg-name (car l))
                                     '!)
                                   (loop (cdr l)))))))
                  (nargs (length id1)))
              `(begin
                 (define-const-structure (,name ,@id1) ())
                 (defmacro
                   ,check-constructor
                   id
                   (lambda a
                     (check-increment-counter (,'unquote (car id)))
                     (if (= ,nargs (length a))
                       (apply ,constructor a)
                       (st:failure
                         (cons ',check-constructor '(,'unquote id))
                         "invalid arguments: ~a"
                         a))))
                 (make-check-typed ,predicate _)
                 ,@(map (lambda (a) `(make-check-typed ,a ,predicate))
                        access)
                 ,@(map (lambda (a) `(make-check-typed ,a ,predicate _))
                        assign))))
           (x (st:failure
                `(check-define-const-structure ,@x)
                "syntax error")))))
(if (equal? '(match 1) (macroexpand-1 '(match 1)))
  (load "/home/wright/scheme/match/match-slib.scm"))
(define sprintf
  (lambda args (apply format #f args)))
(define printf
  (lambda args (apply format #t args)))
(define disaster
  (lambda (context fmt . args)
    (slib:error
      (apply sprintf
             (string-append "in ~a: " fmt)
             context
             args))))
(define use-error
  (lambda (fmt . args)
    (slib:error (apply sprintf fmt args))))
(define syntax-err
  (lambda (context fmt . args)
    (newline)
    (if context (pretty-print context))
    (slib:error
      (apply sprintf
             (string-append "in syntax: " fmt)
             args))))
(define flush-output force-output)
(define print-context
  (lambda (obj depth)
    (pretty-print
      (recur loop
             ((obj obj) (n 0))
             (if (pair? obj)
               (if (< n depth)
                 (cons (loop (car obj) (+ 1 n))
                       (loop (cdr obj) n))
                 '(...))
               obj)))))
(define *box-tag* (gensym))
(define box (lambda (a) (cons *box-tag* a)))
(define box?
  (lambda (b)
    (and (pair? b) (eq? (car b) *box-tag*))))
(define unbox cdr)
(define box-1 cdr)
(define set-box! set-cdr!)
(define sort-list sort)
(define expand-once-if-macro
  (lambda (e)
    (and (macro? (car e)) (macroexpand-1 e))))
(define ormap
  (lambda (f . lists)
    (if (null? (car lists))
      (or)
      (or (apply f (map car lists))
          (apply ormap f (map cdr lists))))))
(define call/cc call-with-current-continuation)
(define (cpu-time) 0)
(define (pretty-print x) (display x) (newline))
(define clock-granularity 1.0e-3)
(define set-vector! vector-set!)
(define set-string! string-set!)
(define maplr
  (lambda (f l)
    (match l
           (() '())
           ((x . y) (let ((v (f x))) (cons v (maplr f y)))))))
(define maprl
  (lambda (f l)
    (match l
           (() '())
           ((x . y) (let ((v (maprl f y))) (cons (f x) v))))))
(define foldl
  (lambda (f i l)
    (recur loop
           ((l l) (acc i))
           (match l (() acc) ((x . y) (loop y (f x acc)))))))
(define foldr
  (lambda (f i l)
    (recur loop
           ((l l))
           (match l (() i) ((x . y) (f x (loop y)))))))
(define filter
  (lambda (p l)
    (match l
           (() '())
           ((x . y)
            (if (p x) (cons x (filter p y)) (filter p y))))))
(define filter-map
  (lambda (p l)
    (match l
           (() '())
           ((x . y)
            (match (p x)
                   (#f (filter-map p y))
                   (x (cons x (filter-map p y))))))))
(define rac
  (lambda (l)
    (match l ((last) last) ((_ . rest) (rac rest)))))
(define rdc
  (lambda (l)
    (match l
           ((_) '())
           ((x . rest) (cons x (rdc rest))))))
(define map-with-n
  (lambda (f l)
    (recur loop
           ((l l) (n 0))
           (match l
                  (() '())
                  ((x . y)
                   (let ((v (f x n))) (cons v (loop y (+ 1 n)))))))))
(define readfile
  (lambda (f)
    (with-input-from-file
      f
      (letrec ((rf (lambda ()
                     (match (read)
                            ((? eof-object?) '())
                            (sexp (cons sexp (rf)))))))
        rf))))
(define map2
  (lambda (f a b)
    (match (cons a b)
           ((()) '())
           (((ax . ay) bx . by)
            (let ((v (f ax bx))) (cons v (map2 f ay by))))
           (else (error 'map2 "lists differ in length")))))
(define for-each2
  (lambda (f a b)
    (match (cons a b)
           ((()) (void))
           (((ax . ay) bx . by)
            (f ax bx)
            (for-each2 f ay by))
           (else (error 'for-each2 "lists differ in length")))))
(define andmap2
  (lambda (f a b)
    (match (cons a b)
           ((()) (and))
           (((ax) bx) (f ax bx))
           (((ax . ay) bx . by)
            (and (f ax bx) (andmap2 f ay by)))
           (else (error 'andmap2 "lists differ in length")))))
(define ormap2
  (lambda (f a b)
    (match (cons a b)
           ((()) (or))
           (((ax) bx) (f ax bx))
           (((ax . ay) bx . by)
            (or (f ax bx) (ormap2 f ay by)))
           (else (error 'ormap2 "lists differ in length")))))
(define empty-set '())
(define empty-set? null?)
(define set (lambda l (list->set l)))
(define list->set
  (match-lambda
    (() '())
    ((x . y)
     (if (memq x y)
       (list->set y)
       (cons x (list->set y))))))
(define element-of?
  (lambda (x set) (and (memq x set) #t)))
(define cardinality length)
(define set<=
  (lambda (a b)
    (foldr (lambda (a-elt acc) (and acc (memq a-elt b) #t))
           (and)
           a)))
(define set-eq?
  (lambda (a b)
    (and (= (cardinality a) (cardinality b))
         (set<= a b))))
(define union2
  (lambda (a b)
    (if (null? b)
      a
      (foldr (lambda (x b) (if (memq x b) b (cons x b)))
             b
             a))))
(define union (lambda l (foldr union2 '() l)))
(define setdiff2
  (lambda (a b)
    (if (null? b)
      a
      (foldr (lambda (x c) (if (memq x b) c (cons x c)))
             '()
             a))))
(define setdiff
  (lambda l
    (if (null? l)
      '()
      (setdiff2 (car l) (foldr union2 '() (cdr l))))))
(define intersect2
  (lambda (a b)
    (if (null? b)
      a
      (foldr (lambda (x c) (if (memq x b) (cons x c) c))
             '()
             a))))
(define intersect
  (lambda l
    (if (null? l) '() (foldl intersect2 (car l) l))))
(define-const-structure (some _))
(define-const-structure (none))
(define none (make-none))
(define some make-some)
(define-const-structure (and exps))
(define-const-structure (app exp exps))
(define-const-structure (begin exps))
(define-const-structure (const val pred))
(define-const-structure (if exp1 exp2 exp3))
(define-const-structure (lam names body))
(define-const-structure (let binds body))
(define-const-structure (let* binds body))
(define-const-structure (letr binds body))
(define-const-structure (or exps))
(define-const-structure (prim name))
(define-const-structure (delay exp))
(define-const-structure (set! (! name) exp))
(define-const-structure (var (! name)))
(define-const-structure (vlam names name body))
(define-const-structure (match exp mclauses))
(define-const-structure (record binds))
(define-const-structure (field name exp))
(define-const-structure (cast type exp))
(define-const-structure (body defs exps))
(define-const-structure (bind name exp))
(define-const-structure (mclause pat body fail))
(define-const-structure (pvar name))
(define-const-structure (pany))
(define-const-structure (pelse))
(define-const-structure (pconst name pred))
(define-const-structure (pobj name pats))
(define-const-structure (ppred name))
(define-const-structure (pand pats))
(define-const-structure (pnot pat))
(define-const-structure (define name (! exp)))
(define-const-structure
  (defstruct
    tag
    args
    make
    pred
    get
    set
    getn
    setn
    mutable))
(define-const-structure (datatype _))
(define-const-structure
  (variant con pred arg-types))
(define-structure
  (name name
        ty
        timestamp
        occ
        mutated
        gdef
        primitive
        struct
        pure
        predicate
        variant
        selector))
(define-structure (type ty exp))
(define-const-structure (shape _ _))
(define-const-structure (check _ _))
(define parse-def
  (lambda (def)
    (let ((parse-name
            (match-lambda
              ((? symbol? s)
               (if (keyword? s)
                 (syntax-err def "invalid use of keyword ~a" s)
                 s))
              (n (syntax-err def "invalid variable at ~a" n)))))
      (match def
             (('extend-syntax ((? symbol? name) . _) . _)
              (printf
                "Note: installing but _not_ checking (extend-syntax (~a) ...)~%"
                name)
              (eval def)
              '())
             (('extend-syntax . _)
              (syntax-err def "invalid syntax"))
             (('defmacro (? symbol? name) . _)
              (printf
                "Note: installing but _not_ checking (defmacro ~a ...)~%"
                name)
              (eval def)
              '())
             (('defmacro . _)
              (syntax-err def "invalid syntax"))
             (('define (? symbol? n) e)
              (list (make-define (parse-name n) (parse-exp e))))
             (('define (n . args) . body)
              (list (make-define
                      (parse-name n)
                      (parse-exp `(lambda ,args ,@body)))))
             (('define . _) (syntax-err def "at define"))
             (('begin . defs)
              (foldr append '() (smap parse-def defs)))
             (('define-structure (n . args))
              (parse-def `(define-structure (,n ,@args) ())))
             (('define-structure (n . args) inits)
              (let ((m-args (smap (lambda (x) `(! ,x)) args))
                    (m-inits
                      (smap (match-lambda
                              ((x e) `((! ,x) ,e))
                              (_ (syntax-err
                                   def
                                   "invalid structure initializer")))
                            inits)))
                (parse-def
                  `(define-const-structure (,n ,@m-args) ,m-inits))))
             (('define-const-structure ((? symbol? n) . args))
              (parse-def
                `(define-const-structure (,n ,@args) ())))
             (('define-const-structure
               ((? symbol? n) . args)
               ())
              (letrec ((smap-with-n
                         (lambda (f l)
                           (recur loop
                                  ((l l) (n 0))
                                  (match l
                                         (() '())
                                         ((x . y)
                                          (let ((v (f x n)))
                                            (cons v (loop y (+ 1 n)))))
                                         (_ (syntax-err l "invalid list"))))))
                       (parse-arg
                         (lambda (a index)
                           (match a
                                  (('! '_)
                                   (list none
                                         none
                                         (some (symbol-append
                                                 n
                                                 '-
                                                 (+ index 1)))
                                         (some (symbol-append
                                                 'set-
                                                 n
                                                 '-
                                                 (+ index 1)
                                                 '!))
                                         #t))
                                  (('! a)
                                   (let ((a (parse-name a)))
                                     (list (some (symbol-append n '- a))
                                           (some (symbol-append
                                                   'set-
                                                   n
                                                   '-
                                                   a
                                                   '!))
                                           (some (symbol-append
                                                   n
                                                   '-
                                                   (+ index 1)))
                                           (some (symbol-append
                                                   'set-
                                                   n
                                                   '-
                                                   (+ index 1)
                                                   '!))
                                           #t)))
                                  ('_
                                   (list none
                                         none
                                         (some (symbol-append
                                                 n
                                                 '-
                                                 (+ index 1)))
                                         none
                                         #f))
                                  (a (let ((a (parse-name a)))
                                       (list (some (symbol-append n '- a))
                                             none
                                             (some (symbol-append
                                                     n
                                                     '-
                                                     (+ index 1)))
                                             none
                                             #f)))))))
                (let* ((arg-info (smap-with-n parse-arg args))
                       (get (map car arg-info))
                       (set (map cadr arg-info))
                       (getn (map caddr arg-info))
                       (setn (map cadddr arg-info))
                       (mutable
                         (map (lambda (x) (car (cddddr x))) arg-info)))
                  (list (make-defstruct
                          n
                          (cons n args)
                          (symbol-append 'make- n)
                          (symbol-append n '?)
                          get
                          set
                          getn
                          setn
                          mutable)))))
             (('define-const-structure
               ((? symbol? n) . args)
               inits)
              (syntax-err
                def
                "sorry, structure initializers are not supported"))
             (('datatype . d)
              (let* ((parse-variant
                       (match-lambda
                         (((? symbol? con) ? list? args)
                          (let ((n (parse-name con)))
                            (make-variant
                              (symbol-append 'make- n)
                              (symbol-append n '?)
                              (cons con args))))
                         (_ (syntax-err def "invalid datatype syntax"))))
                     (parse-dt
                       (match-lambda
                         (((? symbol? type) . variants)
                          (cons (list (parse-name type))
                                (smap parse-variant variants)))
                         ((((? symbol? type) ? list? targs) . variants)
                          (cons (cons (parse-name type)
                                      (smap parse-name targs))
                                (smap parse-variant variants)))
                         (_ (syntax-err def "invalid datatype syntax")))))
                (list (make-datatype (smap parse-dt d)))))
             (((? symbol? k) . _)
              (cond ((and (not (keyword? k))
                          (expand-once-if-macro def))
                     =>
                     parse-def)
                    (else (list (make-define #f (parse-exp def))))))
             (_ (list (make-define #f (parse-exp def))))))))
(define keep-match #t)
(define parse-exp
  (lambda (expression)
    (letrec ((n-primitive (string->symbol "#primitive"))
             (parse-exp
               (match-lambda
                 (('quote (? symbol? s)) (make-const s 'symbol?))
                 ((and m ('quote _)) (parse-exp (quote-tf m)))
                 ((and m ('quasiquote _))
                  (parse-exp (quasiquote-tf m)))
                 ((and m (? box?)) (parse-exp (quote-tf m)))
                 ((and m (? vector?)) (parse-exp (quote-tf m)))
                 ((and m ('cond . _)) (parse-exp (cond-tf m)))
                 ((and m ('case . _)) (parse-exp (case-tf m)))
                 ((and m ('do . _)) (parse-exp (do-tf m)))
                 ((? symbol? s) (make-var (parse-name s)))
                 (#t (make-const #t 'true-object?))
                 (#f (make-const #f 'false-object?))
                 ((? null? c) (make-const c 'null?))
                 ((? number? c) (make-const c 'number?))
                 ((? char? c) (make-const c 'char?))
                 ((? string? c) (make-const c 'string?))
                 ((': ty e1) (make-cast ty (parse-exp e1)))
                 ((and exp ('record . bind))
                  (let ((bindings (smap parse-bind bind)))
                    (no-repeats (map bind-name bindings) exp)
                    (make-record bindings)))
                 ((and exp ('field name e1))
                  (make-field (parse-name name) (parse-exp e1)))
                 ((and exp ('match e clause0 . clauses))
                  (=> fail)
                  (if keep-match
                    (let* ((e2 (parse-exp e))
                           (parse-clause
                             (match-lambda
                               ((p ('=> (? symbol? failsym)) . body)
                                (make-mclause
                                  (parse-pat p expression)
                                  (parse-body
                                    `((let ((,failsym (lambda () (,failsym))))
                                        ,@body)))
                                  failsym))
                               ((p . body)
                                (make-mclause
                                  (parse-pat p expression)
                                  (parse-body body)
                                  #f))
                               (_ (syntax-err exp "invalid match clause")))))
                      (make-match
                        e2
                        (smap parse-clause (cons clause0 clauses))))
                    (fail)))
                 ((and exp ('lambda bind . body))
                  (recur loop
                         ((b bind) (names '()))
                         (match b
                                ((? symbol? n)
                                 (let ((rest (parse-name n)))
                                   (no-repeats (cons rest names) exp)
                                   (make-vlam
                                     (reverse names)
                                     rest
                                     (parse-body body))))
                                (()
                                 (no-repeats names exp)
                                 (make-lam (reverse names) (parse-body body)))
                                ((n . x) (loop x (cons (parse-name n) names)))
                                (_ (syntax-err
                                     exp
                                     "invalid lambda expression")))))
                 (('if e1 e2 e3)
                  (make-if
                    (parse-exp e1)
                    (parse-exp e2)
                    (parse-exp e3)))
                 ((and if-expr ('if e1 e2))
                  (printf "Note: one-armed if: ")
                  (print-context if-expr 2)
                  (make-if
                    (parse-exp e1)
                    (parse-exp e2)
                    (parse-exp '(void))))
                 (('delay e) (make-delay (parse-exp e)))
                 (('set! n e)
                  (make-set! (parse-name n) (parse-exp e)))
                 (('and . args) (make-and (smap parse-exp args)))
                 (('or . args) (make-or (smap parse-exp args)))
                 ((and exp ('let (? symbol? n) bind . body))
                  (let* ((nb (parse-name n))
                         (bindings (smap parse-bind bind)))
                    (no-repeats (map bind-name bindings) exp)
                    (make-app
                      (make-letr
                        (list (make-bind
                                nb
                                (make-lam
                                  (map bind-name bindings)
                                  (parse-body body))))
                        (make-body '() (list (make-var nb))))
                      (map bind-exp bindings))))
                 ((and exp ('let bind . body))
                  (let ((bindings (smap parse-bind bind)))
                    (no-repeats (map bind-name bindings) exp)
                    (make-let bindings (parse-body body))))
                 (('let* bind . body)
                  (make-let*
                    (smap parse-bind bind)
                    (parse-body body)))
                 ((and exp ('letrec bind . body))
                  (let ((bindings (smap parse-bind bind)))
                    (no-repeats (map bind-name bindings) exp)
                    (make-letr bindings (parse-body body))))
                 (('begin e1 . rest)
                  (make-begin (smap parse-exp (cons e1 rest))))
                 (('define . _)
                  (syntax-err
                    expression
                    "invalid context for internal define"))
                 (('define-structure . _)
                  (syntax-err
                    expression
                    "invalid context for internal define-structure"))
                 (('define-const-structure . _)
                  (syntax-err
                    expression
                    "invalid context for internal define-const-structure"))
                 ((and m (f . args))
                  (cond ((and (eq? f n-primitive)
                              (match args
                                     (((? symbol? p)) (make-prim p))
                                     (_ #f))))
                        ((and (symbol? f)
                              (not (keyword? f))
                              (expand-once-if-macro m))
                         =>
                         parse-exp)
                        (else
                         (make-app (parse-exp f) (smap parse-exp args)))))
                 (x (syntax-err
                      expression
                      "invalid expression at ~a"
                      x))))
             (parse-name
               (match-lambda
                 ((? symbol? s)
                  (when (keyword? s)
                        (syntax-err
                          expression
                          "invalid use of keyword ~a"
                          s))
                  s)
                 (n (syntax-err
                      expression
                      "invalid variable at ~a"
                      n))))
             (parse-bind
               (match-lambda
                 ((x e) (make-bind (parse-name x) (parse-exp e)))
                 (b (syntax-err expression "invalid binding at ~a" b))))
             (parse-body
               (lambda (body)
                 (recur loop
                        ((b body) (defs '()))
                        (match b
                               (((and d ('define . _)) . rest)
                                (loop rest (append defs (parse-def d))))
                               (((and d ('define-structure . _)) . rest)
                                (loop rest (append defs (parse-def d))))
                               (((and d ('define-const-structure . _)) . rest)
                                (loop rest (append defs (parse-def d))))
                               ((('begin) . rest) (loop rest defs))
                               (((and beg ('begin ('define . _) . _)) . rest)
                                (loop rest (append defs (parse-def beg))))
                               (((and beg ('begin ('define-structure . _) . _))
                                 .
                                 rest)
                                (loop rest (append defs (parse-def beg))))
                               (((and beg
                                      ('begin
                                       ('define-const-structure . _)
                                       .
                                       _))
                                 .
                                 rest)
                                (loop rest (append defs (parse-def beg))))
                               ((_ . _) (make-body defs (smap parse-exp b)))
                               (_ (syntax-err
                                    expression
                                    "invalid body at ~a"
                                    b))))))
             (no-repeats
               (lambda (l exp)
                 (match l
                        (() #f)
                        ((_) #f)
                        ((x . l)
                         (if (memq x l)
                           (syntax-err exp "name ~a repeated" x)
                           (no-repeats l exp)))))))
      (parse-exp expression))))
(define parse-pat
  (lambda (pat expression)
    (letrec ((parse-pat
               (match-lambda
                 (#f (make-ppred 'false-object?))
                 (#t (make-ppred 'true-object?))
                 (() (make-ppred 'null?))
                 ((? number? c) (make-pconst c 'number?))
                 ((? char? c) (make-pconst c 'char?))
                 ((? string? c) (make-pconst c 'string?))
                 (('quote x) (parse-quote x))
                 ('_ (make-pany))
                 ('else (make-pelse))
                 ((? symbol? n) (make-pvar (parse-pname n)))
                 (('not . pats)
                  (syntax-err
                    expression
                    "not patterns are not supported"))
                 (('or . pats)
                  (syntax-err
                    expression
                    "or patterns are not supported"))
                 (('get! . pats)
                  (syntax-err
                    expression
                    "get! patterns are not supported"))
                 (('set! . pats)
                  (syntax-err
                    expression
                    "set! patterns are not supported"))
                 (('and . pats)
                  (let* ((pats (smap parse-pat pats))
                         (p (make-flat-pand pats))
                         (non-var?
                           (match-lambda
                             ((? pvar?) #f)
                             ((? pany?) #f)
                             (_ #t))))
                    (match p
                           (($ pand pats)
                            (when (< 1 (length (filter non-var? pats)))
                                  (syntax-err
                                    expression
                                    "~a has conflicting subpatterns"
                                    (ppat p))))
                           (_ #f))
                    p))
                 (('? (? symbol? pred) p)
                  (parse-pat `(and (? ,pred) ,p)))
                 (('? (? symbol? pred))
                  (if (keyword? pred)
                    (syntax-err
                      expression
                      "invalid use of keyword ~a"
                      pred)
                    (make-ppred pred)))
                 (('$ (? symbol? c) . args)
                  (if (memq c '(? _ $))
                    (syntax-err
                      expression
                      "invalid use of pattern keyword ~a"
                      c)
                    (make-pobj
                      (symbol-append c '?)
                      (smap parse-pat args))))
                 ((? box? cb)
                  (make-pobj 'box? (list (parse-pat (unbox cb)))))
                 ((x . y)
                  (make-pobj
                    'pair?
                    (list (parse-pat x) (parse-pat y))))
                 ((? vector? v)
                  (make-pobj
                    'vector?
                    (map parse-pat (vector->list v))))
                 (m (syntax-err expression "invalid pattern at ~a" m))))
             (parse-quote
               (match-lambda
                 (#f (make-pobj 'false-object? '()))
                 (#t (make-pobj 'true-object? '()))
                 (() (make-pobj 'null? '()))
                 ((? number? c) (make-pconst c 'number?))
                 ((? char? c) (make-pconst c 'char?))
                 ((? string? c) (make-pconst c 'string?))
                 ((? symbol? s) (make-pconst s 'symbol?))
                 ((? box? cb)
                  (make-pobj 'box? (list (parse-quote (unbox cb)))))
                 ((x . y)
                  (make-pobj
                    'pair?
                    (list (parse-quote x) (parse-quote y))))
                 ((? vector? v)
                  (make-pobj
                    'vector?
                    (map parse-quote (vector->list v))))
                 (m (syntax-err expression "invalid pattern at ~a" m))))
             (parse-pname
               (match-lambda
                 ((? symbol? s)
                  (cond ((keyword? s)
                         (syntax-err
                           expression
                           "invalid use of keyword ~a"
                           s))
                        ((memq s '(? _ else $ and or not set! get! ...))
                         (syntax-err
                           expression
                           "invalid use of pattern keyword ~a"
                           s))
                        (else s)))
                 (n (syntax-err
                      expression
                      "invalid pattern variable at ~a"
                      n)))))
      (parse-pat pat))))
(define smap
  (lambda (f l)
    (match l
           (() '())
           ((x . r) (let ((v (f x))) (cons v (smap f r))))
           (_ (syntax-err l "invalid list")))))
(define primitive
  (lambda (p)
    (list (string->symbol "#primitive") p)))
(define keyword?
  (lambda (s)
    (or (memq s
              '(=> and
                   begin
                   case
                   cond
                   do
                   define
                   delay
                   if
                   lambda
                   let
                   let*
                   letrec
                   or
                   quasiquote
                   quote
                   set!
                   unquote
                   unquote-splicing
                   define-structure
                   define-const-structure
                   record
                   field
                   :
                   datatype))
        (and keep-match (eq? s 'match)))))
(define make-flat-pand
  (lambda (pats)
    (let* ((l (foldr (lambda (p plist)
                       (match p
                              (($ pand pats) (append pats plist))
                              (_ (cons p plist))))
                     '()
                     pats))
           (concrete?
             (match-lambda
               ((? pconst?) #t)
               ((? pobj?) #t)
               ((? ppred?) #t)
               (_ #f)))
           (sorted
             (append
               (filter concrete? l)
               (filter (lambda (x) (not (concrete? x))) l))))
      (match sorted ((p) p) (_ (make-pand sorted))))))
(define never-counter 0)
(define reinit-macros!
  (lambda () (set! never-counter 0)))
(define cond-tf
  (lambda (cond-expr)
    (recur loop
           ((e (cdr cond-expr)))
           (match e
                  (()
                   (begin
                     (set! never-counter (+ 1 never-counter))
                     `(,(primitive 'should-never-reach)
                       '(cond ,never-counter))))
                  ((('else b1 . body)) `(begin ,b1 ,@body))
                  ((('else . _) . _)
                   (syntax-err cond-expr "invalid cond expression"))
                  (((test '=> proc) . rest)
                   (let ((g (gensym)))
                     `(let ((,g ,test))
                        (if ,g (,proc ,g) ,(loop rest)))))
                  (((#t b1 . body)) `(begin ,b1 ,@body))
                  (((test) . rest) `(or ,test ,(loop rest)))
                  (((test . body) . rest)
                   `(if ,test (begin ,@body) ,(loop rest)))
                  (_ (syntax-err cond-expr "invalid cond expression"))))))
(define scheme-cond-tf
  (lambda (cond-expr)
    (recur loop
           ((e (cdr cond-expr)))
           (match e
                  (() `(,(primitive 'void)))
                  ((('else b1 . body)) `(begin ,b1 ,@body))
                  ((('else . _) . _)
                   (syntax-err cond-expr "invalid cond expression"))
                  (((test '=> proc) . rest)
                   (let ((g (gensym)))
                     `(let ((,g ,test))
                        (if ,g (,proc ,g) ,(loop rest)))))
                  (((#t b1 . body)) `(begin ,b1 ,@body))
                  (((test) . rest) `(or ,test ,(loop rest)))
                  (((test . body) . rest)
                   `(if ,test (begin ,@body) ,(loop rest)))
                  (_ (syntax-err cond-expr "invalid cond expression"))))))
(define case-tf
  (lambda (case-expr)
    (recur loop
           ((e (cdr case-expr)))
           (match e
                  ((exp) `(begin ,exp (,(primitive 'void))))
                  ((exp ('else b1 . body)) `(begin ,b1 ,@body))
                  ((exp ('else . _) . _)
                   (syntax-err case-expr "invalid case expression"))
                  (((? symbol? exp)
                    ((? list? test) b1 . body)
                    .
                    rest)
                   `(if (,(primitive 'memv) ,exp ',test)
                      (begin ,b1 ,@body)
                      ,(loop (cons exp rest))))
                  (((? symbol? exp) (test b1 . body) . rest)
                   `(if (,(primitive 'memv) ,exp '(,test))
                      (begin ,b1 ,@body)
                      ,(loop (cons exp rest))))
                  ((exp . rest)
                   (if (not (symbol? exp))
                     (let ((g (gensym)))
                       `(let ((,g ,exp)) ,(loop (cons g rest))))
                     (syntax-err case-expr "invalid case expression")))
                  (_ (syntax-err case-expr "invalid case expression"))))))
(define conslimit 8)
(define quote-tf
  (lambda (exp)
    (letrec ((qloop (match-lambda
                      ((? box? q)
                       `(,(primitive qbox) ,(qloop (unbox q))))
                      ((? symbol? q) `',q)
                      ((? null? q) q)
                      ((? list? q)
                       (if (< (length q) conslimit)
                         `(,(primitive qcons)
                           ,(qloop (car q))
                           ,(qloop (cdr q)))
                         `(,(primitive qlist) ,@(map qloop q))))
                      ((x . y)
                       `(,(primitive qcons) ,(qloop x) ,(qloop y)))
                      ((? vector? q)
                       `(,(primitive qvector)
                         ,@(map qloop (vector->list q))))
                      ((? boolean? q) q)
                      ((? number? q) q)
                      ((? char? q) q)
                      ((? string? q) q)
                      (q (syntax-err
                           exp
                           "invalid quote expression at ~a"
                           q)))))
      (match exp
             (('quote q) (qloop q))
             ((? vector? q) (qloop q))
             ((? box? q) (qloop q))))))
(define quasiquote-tf
  (lambda (exp)
    (letrec ((make-cons
               (lambda (x y)
                 (cond ((null? y) `(,(primitive 'list) ,x))
                       ((and (pair? y)
                             (equal? (car y) (primitive 'list)))
                        (cons (car y) (cons x (cdr y))))
                       (else `(,(primitive 'cons) ,x ,y)))))
             (qloop (lambda (e n)
                      (match e
                             (('quasiquote e)
                              (make-cons 'quasiquote (qloop `(,e) (+ 1 n))))
                             (('unquote e)
                              (if (zero? n)
                                e
                                (make-cons 'unquote (qloop `(,e) (- n 1)))))
                             (('unquote-splicing e)
                              (if (zero? n)
                                e
                                (make-cons
                                  'unquote-splicing
                                  (qloop `(,e) (- n 1)))))
                             ((('unquote-splicing e) . y)
                              (=> fail)
                              (if (zero? n)
                                (if (null? y)
                                  e
                                  `(,(primitive 'append) ,e ,(qloop y n)))
                                (fail)))
                             ((? box? q)
                              `(,(primitive 'box) ,(qloop (unbox q) n)))
                             ((? symbol? q)
                              (if (memq q
                                        '(quasiquote unquote unquote-splicing))
                                (syntax-err
                                  exp
                                  "invalid use of ~a inside quasiquote"
                                  q)
                                `',q))
                             ((? null? q) q)
                             ((x . y) (make-cons (qloop x n) (qloop y n)))
                             ((? vector? q)
                              `(,(primitive 'vector)
                                ,@(map (lambda (z) (qloop z n))
                                       (vector->list q))))
                             ((? boolean? q) q)
                             ((? number? q) q)
                             ((? char? q) q)
                             ((? string? q) q)
                             (q (syntax-err
                                  exp
                                  "invalid quasiquote expression at ~a"
                                  q))))))
      (match exp (('quasiquote q) (qloop q 0))))))
(define do-tf
  (lambda (do-expr)
    (recur loop
           ((e (cdr do-expr)))
           (match e
                  (((? list? vis) (e0 ? list? e1) ? list? c)
                   (if (andmap (match-lambda ((_ _ . _) #t) (_ #f)) vis)
                     (let* ((var (map car vis))
                            (init (map cadr vis))
                            (step (map cddr vis))
                            (step (map (lambda (v s)
                                         (match s
                                                (() v)
                                                ((e) e)
                                                (_ (syntax-err
                                                     do-expr
                                                     "invalid do expression"))))
                                       var
                                       step)))
                       (let ((doloop (gensym)))
                         (match e1
                                (()
                                 `(let ,doloop
                                    ,(map list var init)
                                    (if (not ,e0)
                                      (begin ,@c (,doloop ,@step) (void))
                                      (void))))
                                ((body0 ? list? body)
                                 `(let ,doloop
                                    ,(map list var init)
                                    (if ,e0
                                      (begin ,body0 ,@body)
                                      (begin ,@c (,doloop ,@step)))))
                                (_ (syntax-err
                                     do-expr
                                     "invalid do expression")))))
                     (syntax-err do-expr "invalid do expression")))
                  (_ (syntax-err do-expr "invalid do expression"))))))
(define empty-env '())
(define lookup
  (lambda (env x)
    (match (assq x env)
           (#f (disaster 'lookup "no binding for ~a" x))
           ((_ . b) b))))
(define lookup?
  (lambda (env x)
    (match (assq x env) (#f #f) ((_ . b) b))))
(define bound?
  (lambda (env x)
    (match (assq x env) (#f #f) (_ #t))))
(define extend-env
  (lambda (env x v) (cons (cons x v) env)))
(define extend-env*
  (lambda (env xs vs)
    (append (map2 cons xs vs) env)))
(define join-env
  (lambda (env newenv) (append newenv env)))
(define populated #t)
(define pseudo #f)
(define global-error #f)
(define share #f)
(define matchst #f)
(define fullsharing #t)
(define dump-depths #f)
(define flags #t)
(define-structure
  (c depth kind fsym pres args next))
(define-structure
  (v depth kind name vis split inst))
(define-structure (ts type n-gen))
(define-structure (k name order args))
(define top (box 'top))
(define bot (box 'bot))
(define generic? (lambda (d) (< d 0)))
(define new-type
  (lambda (s d)
    (let ((t (box s)))
      (vector-set!
        types
        d
        (cons t (vector-ref types d)))
      t)))
(define generate-counter
  (lambda ()
    (let ((n 0)) (lambda () (set! n (+ 1 n)) n))))
(define var-counter (generate-counter))
(define make-raw-tvar
  (lambda (d k) (make-v d k var-counter #t #f #f)))
(define make-tvar
  (lambda (d k) (new-type (make-raw-tvar d k) d)))
(define ord? (lambda (k) (eq? 'ord k)))
(define abs? (lambda (k) (eq? 'abs k)))
(define pre? (lambda (k) (eq? 'pre k)))
(define ord-depth 2)
(define depth ord-depth)
(define types (make-vector 16 '()))
(define reset-types!
  (lambda ()
    (set! depth ord-depth)
    (set! types (make-vector 16 '()))))
(define push-level
  (lambda ()
    (set! depth (+ depth 1))
    (when (< (vector-length types) (+ 1 depth))
          (set! types
            (let ((l (vector->list types)))
              (list->vector
                (append l (map (lambda (_) '()) l))))))))
(define pop-level
  (lambda ()
    (vector-set! types depth '())
    (set! depth (- depth 1))))
(define v-ord (lambda () (make-tvar depth 'ord)))
(define v-abs (lambda () (make-tvar depth 'abs)))
(define v-pre (lambda () (make-tvar depth 'pre)))
(define tvar v-ord)
(define out1tvar
  (lambda () (make-tvar (- depth 1) 'ord)))
(define monotvar
  (lambda () (make-tvar ord-depth 'ord)))
(define pvar
  (match-lambda
    (($ box (and x ($ v d k _ vis _ _)))
     (unless
       (number? (v-name x))
       (set-v-name! x ((v-name x))))
     (string->symbol
       (sprintf
         "~a~a~a"
         (match k
                ('ord
                 (if (generic? d)
                   (if vis "X" "x")
                   (if vis "Z" "z")))
                ('abs (if vis "A" "a"))
                ('pre (if vis "P" "p")))
         (v-name x)
         (if dump-depths (sprintf ".~a" d) ""))))))
(define make-tvar-like
  (match-lambda
    (($ box ($ v d k _ _ _ _)) (make-tvar d k))))
(define ind*
  (lambda (t)
    (match (unbox t)
           ((? box? u)
            (let ((v (ind* u))) (set-box! t v) v))
           (_ t))))
(define type-check?
  (match-lambda
    ((abs def inexhaust once _)
     (cond (((if once check-abs1? check-abs?) abs)
            (if (and def (definite? def)) 'def #t))
           (inexhaust 'inexhaust)
           (else #f)))))
(define type-check1?
  (match-lambda
    ((abs def inexhaust _ _)
     (cond ((check-abs1? abs)
            (if (and def (definite? def)) 'def #t))
           (inexhaust 'inexhaust)
           (else #f)))))
(define check-abs?
  (lambda (vlist)
    (letrec ((seen '())
             (labs? (lambda (t)
                      (match t
                             (($ box ($ v _ _ _ _ _ inst))
                              (and inst
                                   (not (memq t seen))
                                   (begin
                                     (set! seen (cons t seen))
                                     (ormap (match-lambda ((t . _) (labs? t)))
                                            inst))))
                             (($ box ($ c _ _ _ p _ n))
                              (or (labs? p) (labs? n)))
                             (($ box (? symbol?)) #t)
                             (($ box i) (labs? i))))))
      (ormap labs? vlist))))
(define check-abs1?
  (lambda (vlist)
    (letrec ((labs1?
               (lambda (t)
                 (match t
                        (($ box (? v?)) #f)
                        (($ box ($ c _ _ _ p _ n))
                         (or (labs1? p) (labs1? n)))
                        (($ box (? symbol?)) #t)
                        (($ box i) (labs1? i))))))
      (ormap labs1? vlist))))
(define check-sources
  (lambda (info)
    (letrec ((seen '())
             (lsrcs (lambda (t source)
                      (match t
                             (($ box ($ v _ k _ _ _ inst))
                              (union (if (and inst (not (memq t seen)))
                                       (begin
                                         (set! seen (cons t seen))
                                         (foldr union
                                                empty-set
                                                (map (match-lambda
                                                       ((t . s) (lsrcs t s)))
                                                     inst)))
                                       empty-set)))
                             (($ box ($ c _ _ _ p _ n))
                              (union (lsrcs p source) (lsrcs n source)))
                             (($ box (? symbol?))
                              (if source (set source) empty-set))
                             (($ box i) (lsrcs i source))))))
      (match-let
        (((abs _ _ _ _) info))
        (if (eq? #t abs)
          empty-set
          (foldr union
                 empty-set
                 (map (lambda (t) (lsrcs t #f)) abs)))))))
(define check-local-sources
  (match-lambda ((_ _ _ _ component) component)))
(define mk-definite-prim
  (match-lambda
    (($ box ($ c _ _ x p a n))
     (if (eq? (k-name x) '?->)
       (let ((seen '()))
         (recur lprim
                ((t (car a)))
                (match t
                       (($ box ($ c _ _ x p a n))
                        (if (memq t seen)
                          '()
                          (begin
                            (set! seen (cons t seen))
                            (match (k-name x)
                                   ('noarg (cons p (lprim n)))
                                   ('arg
                                    (let ((args (recur argloop
                                                       ((a (car a)))
                                                       (match a
                                                              (($ box
                                                                  ($ c
                                                                     _
                                                                     _
                                                                     _
                                                                     p
                                                                     _
                                                                     n))
                                                               (cons p
                                                                     (argloop
                                                                       n)))
                                                              (($ box
                                                                  ($ v
                                                                     _
                                                                     k
                                                                     _
                                                                     _
                                                                     _
                                                                     _))
                                                               (if (ord? k)
                                                                 (list a)
                                                                 '()))
                                                              (($ box
                                                                  (? symbol?))
                                                               '())
                                                              (($ box i)
                                                               (argloop i))))))
                                      (cons (list p args (lprim (cadr a)))
                                            (lprim n))))))))
                       (($ box ($ v _ k _ _ _ _))
                        (if (ord? k) (list t) '()))
                       (($ box (? symbol?)) '())
                       (($ box i) (lprim i)))))
       (mk-definite-prim n)))
    (($ box (? v?)) '())
    (($ box (? symbol?)) '())
    (($ box i) (mk-definite-prim i))))
(define mk-definite-app
  (match-lambda
    (($ box ($ c _ _ _ p _ _)) (list p))))
(define mk-definite-lam
  (match-lambda
    (($ box ($ c _ _ x p a n))
     (if (eq? (k-name x) '?->)
       (let ((seen '()))
         (recur llam
                ((t (car a)))
                (match t
                       (($ box ($ c _ _ x p a n))
                        (if (memq t seen)
                          '()
                          (begin
                            (set! seen (cons t seen))
                            (match (k-name x)
                                   ('noarg (cons p (llam n)))
                                   ('arg
                                    (let ((args (list top)))
                                      (cons (list p args (llam (cadr a)))
                                            (llam n))))))))
                       (($ box ($ v _ k _ _ _ _))
                        (if (ord? k) (list t) '()))
                       (($ box (? symbol?)) '())
                       (($ box i) (llam i)))))
       (mk-definite-lam n)))
    (($ box (? v?)) '())
    (($ box (? symbol?)) '())
    (($ box i) (mk-definite-lam i))))
(define definite?
  (lambda (def-info)
    (letrec ((non-empty?
               (lambda (t)
                 (let ((seen '()))
                   (recur ldef
                          ((t t))
                          (match t
                                 (($ box ($ c _ _ _ p _ n))
                                  (or (ldef p) (ldef n)))
                                 (($ box ($ v d k _ _ _ inst))
                                  (if (or global-error (abs? k))
                                    (and inst
                                         (generic? d)
                                         (not (memq t seen))
                                         (begin
                                           (set! seen (cons t seen))
                                           (ormap (match-lambda
                                                    ((t . _) (ldef t)))
                                                  inst)))
                                    (generic? d)))
                                 (($ box 'top) #t)
                                 (($ box 'bot) #f)
                                 (($ box i) (ldef i)))))))
             (ok (lambda (l)
                   (ormap (match-lambda
                            ((? box? t) (non-empty? t))
                            ((p arg rest)
                             (and (non-empty? p)
                                  (ormap non-empty? arg)
                                  (ok rest))))
                          l))))
      (not (ok def-info)))))
(define close
  (lambda (t-list) (close-type t-list #f)))
(define closeall
  (lambda (t) (car (close-type (list t) #t))))
(define for
  (lambda (from to f)
    (cond ((= from to) (f from))
          ((< from to)
           (begin (f from) (for (+ from 1) to f)))
          (else #f))))
(define close-type
  (lambda (t-list all?)
    (let* ((sorted (make-vector (+ depth 1) '()))
           (sort (lambda (t)
                   (match t
                          (($ box ($ c d _ _ _ _ _))
                           (vector-set!
                             sorted
                             d
                             (cons t (vector-ref sorted d))))
                          (($ box ($ v d _ _ _ _ _))
                           (vector-set!
                             sorted
                             d
                             (cons t (vector-ref sorted d))))
                          (_ #f))))
           (prop-d
             (lambda (down)
               (letrec ((pr (match-lambda
                              (($ box (and x ($ v d _ _ _ _ _)))
                               (when (< down d) (set-v-depth! x down)))
                              (($ box (and x ($ c d _ _ p a n)))
                               (when (< down d)
                                     (set-c-depth! x down)
                                     (pr p)
                                     (for-each pr a)
                                     (pr n)))
                              (($ box (? symbol?)) #f)
                              (z (pr (ind* z))))))
                 (match-lambda
                   (($ box (and x ($ c d _ _ p a n)))
                    (when (<= down d) (pr p) (for-each pr a) (pr n)))
                   (_ #f)))))
           (prop-k
             (lambda (t)
               (let ((pk (lambda (kind)
                           (rec pr
                                (match-lambda
                                  (($ box (and x ($ v _ k _ _ _ _)))
                                   (when (kind< kind k) (set-v-kind! x kind)))
                                  (($ box (and x ($ c _ k _ p a n)))
                                   (when (kind< kind k)
                                         (set-c-kind! x kind)
                                         (pr p)
                                         (unless populated (for-each pr a))
                                         (pr n)))
                                  (($ box (? symbol?)) #f)
                                  (z (pr (ind* z))))))))
                 (match t
                        (($ box (and x ($ c _ k _ p a n)))
                         (when (not (ord? k))
                               (let ((prop (pk k)))
                                 (prop p)
                                 (unless populated (for-each prop a))
                                 (prop n))))
                        (_ #f)))))
           (might-be-generalized?
             (match-lambda
               (($ box ($ v d k _ _ _ _))
                (and (<= depth d) (or populated (ord? k) all?)))
               (($ box ($ c d k _ _ _ _))
                (and (<= depth d) (or populated (ord? k) all?)))
               (($ box (? symbol?)) #f)))
           (leaves '())
           (depth-of
             (match-lambda
               (($ box ($ v d _ _ _ _ _)) d)
               (($ box ($ c d _ _ _ _ _)) d)))
           (vector-grow
             (lambda (v)
               (let* ((n (vector-length v))
                      (v2 (make-vector (* n 2) '())))
                 (recur loop
                        ((i 0))
                        (when (< i n)
                              (vector-set! v2 i (vector-ref v i))
                              (loop (+ 1 i))))
                 v2)))
           (parents (make-vector 64 '()))
           (parent-index 0)
           (parents-of
             (lambda (t)
               (let ((d (depth-of t)))
                 (if (< depth d)
                   (vector-ref parents (- (- d depth) 1))
                   '()))))
           (xtnd-parents!
             (lambda (t parent)
               (match t
                      (($ box (and x ($ v d _ _ _ _ _)))
                       (when (= d depth)
                             (set! parent-index (+ 1 parent-index))
                             (set-v-depth! x (+ depth parent-index))
                             (when (< (vector-length parents) parent-index)
                                   (set! parents (vector-grow parents)))
                             (set! d (+ depth parent-index)))
                       (vector-set!
                         parents
                         (- (- d depth) 1)
                         (cons parent
                               (vector-ref parents (- (- d depth) 1)))))
                      (($ box (and x ($ c d _ _ _ _ _)))
                       (when (= d depth)
                             (set! parent-index (+ 1 parent-index))
                             (set-c-depth! x (+ depth parent-index))
                             (when (< (vector-length parents) parent-index)
                                   (set! parents (vector-grow parents)))
                             (set! d (+ depth parent-index)))
                       (vector-set!
                         parents
                         (- (- d depth) 1)
                         (cons parent
                               (vector-ref parents (- (- d depth) 1))))))))
           (needs-cleanup '())
           (revtype
             (rec revtype
                  (lambda (parent t)
                    (let ((t (ind* t)))
                      (cond ((not (might-be-generalized? t)) #f)
                            ((null? (parents-of t))
                             (xtnd-parents! t parent)
                             (set! needs-cleanup (cons t needs-cleanup))
                             (match t
                                    (($ box (? v?))
                                     (set! leaves (cons t leaves)))
                                    (($ box ($ c _ _ _ p a n))
                                     (let ((rev (lambda (q) (revtype t q))))
                                       (rev p)
                                       (for-each rev a)
                                       (rev n)))))
                            ((not (memq parent (parents-of t)))
                             (xtnd-parents! t parent))
                            (else #f))))))
           (generic-index 0)
           (gen (rec gen
                     (lambda (t)
                       (let ((t (ind* t)))
                         (when (might-be-generalized? t)
                               (set! generic-index (- generic-index 1))
                               (let ((parents (parents-of t)))
                                 (match t
                                        (($ box (and x ($ v _ k _ _ _ _)))
                                         (set-v-depth! x generic-index)
                                         (when (and populated
                                                    (or global-error
                                                        (abs? k)
                                                        (pre? k))
                                                    (not all?))
                                               (set-v-inst! x '())))
                                        (($ box (? c? x))
                                         (set-c-depth! x generic-index)))
                                 (for-each gen parents)))))))
           (cleanup
             (match-lambda
               (($ box (and x ($ v d _ _ _ _ _)))
                (unless (< d 0) (set-v-depth! x (- depth 1))))
               (($ box (and x ($ c d _ _ _ _ _)))
                (unless (< d 0) (set-c-depth! x (- depth 1))))))
           (gen2 (rec gen
                      (lambda (t)
                        (let ((t (ind* t)))
                          (when (might-be-generalized? t)
                                (set! generic-index (- generic-index 1))
                                (match t
                                       (($ box (and x ($ v _ k _ _ _ _)))
                                        (set-v-depth! x generic-index)
                                        (when (and populated
                                                   (or global-error
                                                       (abs? k)
                                                       (pre? k))
                                                   (not all?))
                                              (set-v-inst! x '())))
                                       (($ box (and x ($ c _ _ _ p a n)))
                                        (set-c-depth! x generic-index)
                                        (gen p)
                                        (for-each gen a)
                                        (gen n))))))))
           (upd (lambda (t)
                  (let ((d (depth-of t)))
                    (when (< 0 d)
                          (vector-set!
                            types
                            d
                            (cons t (vector-ref types d))))))))
      (for-each sort (vector-ref types depth))
      (for 0
           (- depth 1)
           (lambda (i)
             (for-each (prop-d i) (vector-ref sorted i))))
      (for-each prop-k (vector-ref types depth))
      (vector-set! types depth '())
      (if fullsharing
        (begin
          (for-each (lambda (t) (revtype t t)) t-list)
          (for-each gen leaves)
          (for-each cleanup needs-cleanup))
        (for-each gen2 t-list))
      (for 0
           depth
           (lambda (i) (for-each upd (vector-ref sorted i))))
      (if (null? t-list)
        '()
        (match-let*
          ((n-gen (- generic-index))
           ((t-list n-gen)
            (if (and pseudo flags (not all?))
              (pseudo t-list n-gen)
              (list t-list n-gen))))
          (visible t-list n-gen)
          (map (lambda (t) (make-ts t n-gen)) t-list))))))
(define visible-time 0)
(define visible
  (lambda (t-list n-gen)
    (let* ((before (cpu-time))
           (valences (make-vector n-gen '()))
           (namer (generate-counter))
           (lvis (rec lvis
                      (lambda (t pos rcd)
                        (match t
                               (($ box ($ c d _ x p a n))
                                (when (and (generic? d)
                                           (not (element-of?
                                                  pos
                                                  (vector-ref
                                                    valences
                                                    (- (- d) 1)))))
                                      (let ((u (union (vector-ref
                                                        valences
                                                        (- (- d) 1))
                                                      (set pos))))
                                        (vector-set! valences (- (- d) 1) u))
                                      (lvis p pos rcd)
                                      (match (k-name x)
                                             ('?->
                                              (lvis (car a) (not pos) #f)
                                              (lvis (cadr a) pos #f))
                                             ('record (lvis (car a) pos #t))
                                             (_ (for-each
                                                  (lambda (x) (lvis x pos #f))
                                                  a)))
                                      (lvis n pos rcd)))
                               (($ box (and x ($ v d k _ _ _ _)))
                                (when (and (generic? d)
                                           (not (element-of?
                                                  pos
                                                  (vector-ref
                                                    valences
                                                    (- (- d) 1)))))
                                      (let ((u (union (vector-ref
                                                        valences
                                                        (- (- d) 1))
                                                      (set pos))))
                                        (vector-set! valences (- (- d) 1) u)
                                        (set-v-name! x namer)
                                        (cond ((abs? k) #f)
                                              ((= 2 (cardinality u))
                                               (set-v-split! x #t)
                                               (set-v-vis! x #t))
                                              ((eq? pos rcd) (set-v-vis! x #t))
                                              (else (set-v-vis! x #f))))))
                               (($ box (? symbol?)) #f)
                               (($ box i) (lvis i pos rcd)))))))
      (for-each (lambda (t) (lvis t #t #f)) t-list)
      (set! visible-time
        (+ visible-time (- (cpu-time) before))))))
(define visible?
  (match-lambda
    (($ box ($ v _ k _ vis _ _))
     (or (pre? k) (and vis (not (abs? k)))))
    (($ box 'top) #t)
    (($ box 'bot) #f)
    (($ box i) (visible? i))))
(define instantiate
  (lambda (ts syntax)
    (match ts
           (($ ts t n-gen)
            (let* ((absv '())
                   (seen (make-vector n-gen #f))
                   (t2 (recur linst
                              ((t t))
                              (match t
                                     (($ box (and y ($ v d k _ _ _ inst)))
                                      (cond ((not (generic? d)) t)
                                            ((vector-ref seen (- (- d) 1)))
                                            (else
                                             (let ((u (make-tvar depth k)))
                                               (vector-set! seen (- (- d) 1) u)
                                               (when inst
                                                     (set-v-inst!
                                                       y
                                                       (cons (cons u syntax)
                                                             inst)))
                                               (when (or (abs? k) (pre? k))
                                                     (set! absv (cons u absv)))
                                               u))))
                                     (($ box ($ c d _ x p a n))
                                      (cond ((not (generic? d)) t)
                                            ((vector-ref seen (- (- d) 1)))
                                            (else
                                             (let ((u (new-type
                                                        '**fix**
                                                        depth)))
                                               (vector-set! seen (- (- d) 1) u)
                                               (set-box!
                                                 u
                                                 (make-c
                                                   depth
                                                   'ord
                                                   x
                                                   (if flags (linst p) top)
                                                   (map linst a)
                                                   (linst n)))
                                               u))))
                                     (($ box (? symbol?)) t)
                                     (($ box i) (linst i))))))
              (list t2 absv))))))
(define pseudo-subtype
  (lambda (t-list n-gen)
    (let* ((valences (make-vector n-gen '()))
           (valence-of
             (lambda (d) (vector-ref valences (- (- d) 1))))
           (set-valence
             (lambda (d v)
               (vector-set! valences (- (- d) 1) v)))
           (find (rec find
                      (lambda (t pos mutable)
                        (match t
                               (($ box ($ v d _ _ _ _ _))
                                (when (generic? d)
                                      (cond (mutable
                                             (set-valence d (set #t #f)))
                                            ((not (element-of?
                                                    pos
                                                    (valence-of d)))
                                             (set-valence
                                               d
                                               (union (valence-of d)
                                                      (set pos))))
                                            (else #f))))
                               (($ box ($ c d _ x p a n))
                                (when (generic? d)
                                      (cond ((= 2 (cardinality (valence-of d)))
                                             #f)
                                            (mutable
                                             (set-valence d (set #t #f))
                                             (for-each2
                                               (lambda (t m)
                                                 (find t pos mutable))
                                               a
                                               (k-args x))
                                             (find n pos mutable))
                                            ((not (element-of?
                                                    pos
                                                    (valence-of d)))
                                             (set-valence
                                               d
                                               (union (valence-of d)
                                                      (set pos)))
                                             (if (eq? '?-> (k-name x))
                                               (begin
                                                 (find (car a)
                                                       (not pos)
                                                       mutable)
                                                 (find (cadr a) pos mutable))
                                               (for-each2
                                                 (lambda (t m)
                                                   (find t pos (or m mutable)))
                                                 a
                                                 (k-args x)))
                                             (find n pos mutable))
                                            (else #f))))
                               (($ box (? symbol?)) #f)
                               (($ box i) (find i pos mutable))))))
           (seen (make-vector n-gen #f))
           (new-generic-var
             (lambda ()
               (set! n-gen (+ 1 n-gen))
               (box (make-raw-tvar (- n-gen) 'ord))))
           (copy (rec copy
                      (lambda (t)
                        (match t
                               (($ box ($ v d k _ _ _ _))
                                (if (generic? d)
                                  (or (vector-ref seen (- (- d) 1))
                                      (let ((u (if (and (abs? k)
                                                        (equal?
                                                          (valence-of d)
                                                          '(#t)))
                                                 (new-generic-var)
                                                 t)))
                                        (vector-set! seen (- (- d) 1) u)
                                        u))
                                  t))
                               (($ box ($ c d k x p a n))
                                (if (generic? d)
                                  (or (vector-ref seen (- (- d) 1))
                                      (let* ((u (box '**fix**))
                                             (_ (vector-set!
                                                  seen
                                                  (- (- d) 1)
                                                  u))
                                             (new-p (if (and (eq? (ind* p) top)
                                                             (equal?
                                                               (valence-of d)
                                                               '(#f)))
                                                      (new-generic-var)
                                                      (copy p)))
                                             (new-a (map copy a))
                                             (new-n (copy n)))
                                        (set-box!
                                          u
                                          (make-c d 'ord x new-p new-a new-n))
                                        u))
                                  t))
                               (($ box (? symbol?)) t)
                               (($ box i) (copy i))))))
           (t-list
             (map (lambda (t) (find t #t #f) (copy t)) t-list)))
      (list t-list n-gen))))
(set! pseudo pseudo-subtype)
(define unify
  (letrec ((uni (lambda (u v)
                  (unless
                    (eq? u v)
                    (match (cons u v)
                           ((($ box (and us ($ c ud uk ux up ua un)))
                             $
                             box
                             (and vs ($ c vd vk vx vp va vn)))
                            (if (eq? ux vx)
                              (begin
                                (if (< ud vd)
                                  (begin
                                    (set-box! v u)
                                    (when (kind< vk uk) (set-c-kind! us vk)))
                                  (begin
                                    (set-box! u v)
                                    (when (kind< uk vk) (set-c-kind! vs uk))))
                                (uni un vn)
                                (for-each2 uni ua va)
                                (uni up vp))
                              (let* ((next (tvar))
                                     (k (if (kind< uk vk) uk vk)))
                                (if (< ud vd)
                                  (begin
                                    (when (< vd ud) (set-c-depth! us vd))
                                    (when (kind< vk uk) (set-c-kind! us vk))
                                    (set-box! v u))
                                  (begin
                                    (when (< ud vd) (set-c-depth! vs ud))
                                    (when (kind< uk vk) (set-c-kind! vs uk))
                                    (set-box! u v)))
                                (uni (new-type
                                       (make-c depth k ux up ua next)
                                       depth)
                                     vn)
                                (uni un
                                     (new-type
                                       (make-c depth k vx vp va next)
                                       depth)))))
                           ((($ box (and x ($ v ud uk _ _ _ _)))
                             $
                             box
                             ($ v vd vk _ _ _ _))
                            (set-v-depth! x (min ud vd))
                            (set-v-kind! x (if (kind< uk vk) uk vk))
                            (set-box! v u))
                           ((($ box ($ v ud uk _ _ _ _))
                             $
                             box
                             (and x ($ c vd vk _ _ _ _)))
                            (when (< ud vd) (set-c-depth! x ud))
                            (when (kind< uk vk) (set-c-kind! x uk))
                            (set-box! u v))
                           ((($ box (and x ($ c ud uk _ _ _ _)))
                             $
                             box
                             ($ v vd vk _ _ _ _))
                            (when (< vd ud) (set-c-depth! x vd))
                            (when (kind< vk uk) (set-c-kind! x vk))
                            (set-box! v u))
                           ((($ box ($ v _ _ _ _ _ _)) $ box (? symbol?))
                            (set-box! u v))
                           ((($ box (? symbol?)) $ box ($ v _ _ _ _ _ _))
                            (set-box! v u))
                           ((($ box 'bot) $ box ($ c _ _ _ p _ n))
                            (set-box! v u)
                            (uni u p)
                            (uni u n))
                           ((($ box ($ c _ _ _ p _ n)) $ box 'bot)
                            (set-box! u v)
                            (uni v p)
                            (uni v n))
                           (_ (uni (ind* u) (ind* v))))))))
    uni))
(define kind<
  (lambda (k1 k2) (and (ord? k2) (not (ord? k1)))))
(define r+-
  (lambda (flag+ flag- tail+- absent- pos env type)
    (letrec ((absent+ v-ord)
             (tvars '())
             (fvars '())
             (absv '())
             (make-flag
               (lambda (pos)
                 (cond ((not flags) top)
                       (pos (flag+))
                       (else (flag-)))))
             (typevar?
               (lambda (v)
                 (and (symbol? v)
                      (not (bound? env v))
                      (not (memq v
                                 '(_ bool
                                     mu
                                     list
                                     &list
                                     &optional
                                     &rest
                                     arglist
                                     +
                                     not
                                     rec
                                     *tidy))))))
             (parse-type
               (lambda (t pos)
                 (match t
                        (('mu a t)
                         (unless
                           (typevar? a)
                           (raise 'type "invalid type syntax at ~a" t))
                         (when (assq a tvars)
                               (raise 'type "~a is defined more than once" a))
                         (let* ((fix (new-type '**fix** depth))
                                (_ (set! tvars (cons (list a fix '()) tvars)))
                                (t (parse-type t pos)))
                           (when (eq? t fix)
                                 (raise 'type
                                        "recursive type is not contractive"))
                           (set-box! fix t)
                           (ind* t)))
                        (('rec (? list? bind) t2)
                         (for-each
                           (match-lambda
                             ((a _)
                              (unless
                                (typevar? a)
                                (raise 'type "invalid type syntax at ~a" t))
                              (when (assq a tvars)
                                    (raise 'type
                                           "~a is defined more than once"
                                           a))
                              (set! tvars
                                (cons (list a (new-type '**fix** depth) '())
                                      tvars)))
                             (_ (raise 'type "invalid type syntax at ~a" t)))
                           bind)
                         (for-each
                           (match-lambda
                             ((a t)
                              (match (assq a tvars)
                                     ((_ fix _)
                                      (let ((t (parse-type t '?)))
                                        (when (eq? t fix)
                                              (raise 'type
                                                     "type is not contractive"))
                                        (set-box! fix t))))))
                           bind)
                         (parse-type t2 pos))
                        ('bool (parse-type '(+ false true) pos))
                        ('s-exp
                         (let ((v (gensym)))
                           (parse-type
                             `(mu ,v
                                  (+ num
                                     nil
                                     false
                                     true
                                     char
                                     sym
                                     str
                                     (vec ,v)
                                     (box ,v)
                                     (cons ,v ,v)))
                             pos)))
                        (('list t)
                         (let ((u (gensym)))
                           (parse-type `(mu ,u (+ nil (cons ,t ,u))) pos)))
                        (('arglist t)
                         (let ((u (gensym)))
                           (parse-type `(mu ,u (+ noarg (arg ,t ,u))) pos)))
                        (('+ ? list? union) (parse-union union pos))
                        (t (parse-union (list t) pos)))))
             (parse-union
               (lambda (t pos)
                 (letrec ((sort-cs
                            (lambda (cs)
                              (sort-list
                                cs
                                (lambda (x y) (k< (c-fsym x) (c-fsym y))))))
                          (link (lambda (c t)
                                  (set-c-next! c t)
                                  (new-type c depth))))
                   (recur loop
                          ((t t) (cs '()))
                          (match t
                                 (()
                                  (foldr link
                                         (if pos
                                           (absent+)
                                           (let ((v (absent-)))
                                             (set! absv (cons v absv))
                                             v))
                                         (sort-cs cs)))
                                 (((? box? t)) (foldr link t (sort-cs cs)))
                                 (('_) (foldr link (tail+-) (sort-cs cs)))
                                 (((? symbol? a))
                                  (=> fail)
                                  (unless (typevar? a) (fail))
                                  (let* ((cs (sort-cs cs))
                                         (ks (map c-fsym cs)))
                                    (foldr link
                                           (match (assq a tvars)
                                                  ((_ f aks)
                                                   (unless
                                                     (equal? ks aks)
                                                     (raise 'type
                                                            "variable ~a is not tidy"
                                                            a))
                                                   f)
                                                  (#f
                                                   (let ((v (tail+-)))
                                                     (set! tvars
                                                       (cons (list a v ks)
                                                             tvars))
                                                     v)))
                                           cs)))
                                 ((k . rest)
                                  (loop rest (cons (parse-k k pos) cs))))))))
             (parse-k
               (lambda (k pos)
                 (cond ((and (list? k)
                             (let ((n (length k)))
                               (and (<= 2 n) (eq? '-> (list-ref k (- n 2))))))
                        (let* ((rk (reverse k))
                               (arg (reverse (cddr rk)))
                               (res (car rk)))
                          (letrec ((mkargs
                                     (match-lambda
                                       (() 'noarg)
                                       ((('&rest x)) x)
                                       ((('&list x))
                                        (let ((u (gensym)))
                                          `(mu ,u (+ noarg (arg ,x ,u)))))
                                       ((('&optional x))
                                        `(+ noarg (arg ,x noarg)))
                                       ((x . y) `(arg ,x ,(mkargs y)))
                                       (_ (raise 'type
                                                 "invalid type syntax")))))
                            (make-c
                              depth
                              'ord
                              (lookup env '?->)
                              (make-flag pos)
                              (let ((a (parse-type (mkargs arg) (flip pos)))
                                    (r (parse-type res pos)))
                                (list a r))
                              '**fix**))))
                       (else
                        (match k
                               ((arg '?-> res)
                                (make-c
                                  depth
                                  'ord
                                  (lookup env '?->)
                                  (make-flag pos)
                                  (let ((a (parse-type arg (flip pos)))
                                        (r (parse-type res pos)))
                                    (list a r))
                                  '**fix**))
                               (('record ? list? fields)
                                (make-c
                                  depth
                                  'ord
                                  (lookup env 'record)
                                  (make-flag pos)
                                  (list (recur loop
                                               ((fields fields))
                                               (match fields
                                                      (() (if pos bot (v-ord)))
                                                      ((((? symbol? f) ftype)
                                                        .
                                                        rest)
                                                       (new-type
                                                         (make-c
                                                           depth
                                                           'ord
                                                           (new-field! f)
                                                           (if pos
                                                             (v-ord)
                                                             (let ((v (v-pre)))
                                                               (set! absv
                                                                 (cons v absv))
                                                               v))
                                                           (list (parse-type
                                                                   ftype
                                                                   pos))
                                                           (loop rest))
                                                         depth)))))
                                  '**fix**))
                               (('not (? k? k))
                                (make-c
                                  depth
                                  'ord
                                  k
                                  (if pos
                                    (absent+)
                                    (let ((v (absent-)))
                                      (set! absv (cons v absv))
                                      v))
                                  (map (lambda (x) (tail+-)) (k-args k))
                                  '**fix**))
                               (('not c)
                                (unless
                                  (bound? env c)
                                  (raise 'type "invalid type syntax at ~a" k))
                                (let ((k (lookup env c)))
                                  (make-c
                                    depth
                                    'ord
                                    k
                                    (if pos
                                      (absent+)
                                      (let ((v (absent-)))
                                        (set! absv (cons v absv))
                                        v))
                                    (map (lambda (x) (tail+-)) (k-args k))
                                    '**fix**)))
                               (('*tidy c (? symbol? f))
                                (unless
                                  (bound? env c)
                                  (raise 'type "invalid type syntax at ~a" k))
                                (let ((k (lookup env c)))
                                  (make-c
                                    depth
                                    'ord
                                    k
                                    (match (assq f fvars)
                                           ((_ . f) f)
                                           (#f
                                            (let ((v (tail+-)))
                                              (set! fvars
                                                (cons (cons f v) fvars))
                                              v)))
                                    (map (lambda (x) (parse-type '(+) pos))
                                         (k-args k))
                                    '**fix**)))
                               (((? k? k) ? list? arg)
                                (unless
                                  (= (length arg) (length (k-args k)))
                                  (raise 'type
                                         "~a requires ~a arguments"
                                         (k-name k)
                                         (length (k-args k))))
                                (make-c
                                  depth
                                  'ord
                                  k
                                  (make-flag pos)
                                  (smap (lambda (x) (parse-type x pos)) arg)
                                  '**fix**))
                               ((c ? list? arg)
                                (unless
                                  (bound? env c)
                                  (raise 'type "invalid type syntax at ~a" k))
                                (let ((k (lookup env c)))
                                  (unless
                                    (= (length arg) (length (k-args k)))
                                    (raise 'type
                                           "~a requires ~a arguments"
                                           c
                                           (length (k-args k))))
                                  (make-c
                                    depth
                                    'ord
                                    k
                                    (make-flag pos)
                                    (smap (lambda (x) (parse-type x pos)) arg)
                                    '**fix**)))
                               (c (unless
                                    (bound? env c)
                                    (raise 'type
                                           "invalid type syntax at ~a"
                                           k))
                                  (let ((k (lookup env c)))
                                    (unless
                                      (= 0 (length (k-args k)))
                                      (raise 'type
                                             "~a requires ~a arguments"
                                             c
                                             (length (k-args k))))
                                    (make-c
                                      depth
                                      'ord
                                      k
                                      (make-flag pos)
                                      '()
                                      '**fix**))))))))
             (flip (match-lambda ('? '?) (#t #f) (#f #t))))
      (let ((t (parse-type type pos))) (list t absv)))))
(define v-top (lambda () top))
(define r+
  (lambda (env t)
    (car (r+- v-top v-ord v-ord v-abs #t env t))))
(define r-
  (lambda (env t)
    (car (r+- v-top v-ord v-ord v-abs #f env t))))
(define r++
  (lambda (env t)
    (car (r+- v-top v-ord v-ord v-ord #t env t))))
(define r+collect
  (lambda (env t)
    (r+- v-top v-ord v-ord v-abs #t env t)))
(define r-collect
  (lambda (env t)
    (r+- v-top v-ord v-ord v-abs #f env t)))
(define r (lambda (t) (r+ initial-type-env t)))
(define r-match
  (lambda (t)
    (close '())
    '(pretty-print `(fixing ,(ptype t)))
    (fix-pat-abs! t)
    (list t (collect-abs t))))
(define collect-abs
  (lambda (t)
    (let ((seen '()))
      (recur loop
             ((t t))
             (match t
                    (($ box ($ v _ k _ _ _ _))
                     (if (abs? k) (set t) empty-set))
                    (($ box ($ c _ _ _ p a n))
                     (if (memq t seen)
                       empty-set
                       (begin
                         (set! seen (cons t seen))
                         (foldr union
                                (union (loop p) (loop n))
                                (map loop a)))))
                    (($ box (? symbol?)) empty-set)
                    (($ box i) (loop i)))))))
(define fix-pat-abs!
  (lambda (t)
    (let ((seen '()))
      (recur loop
             ((t t))
             (match t
                    (($ box (and x ($ v d _ _ _ _ _)))
                     (when (= d depth) (set-v-kind! x 'abs)))
                    (($ box (and c ($ c _ _ _ p a n)))
                     (unless
                       (memq t seen)
                       (set! seen (cons t seen))
                       (loop p)
                       (when (and matchst flags (eq? (ind* p) top))
                             (set-c-pres! c (v-ord)))
                       (for-each loop a)
                       (loop n)))
                    (($ box (? symbol?)) t)
                    (($ box i) (loop i)))))))
(define pat-var-bind
  (lambda (t)
    (let ((seen '()))
      (recur loop
             ((t t))
             (match t
                    (($ box ($ v d _ _ _ _ _))
                     (if (< d depth)
                       t
                       (match (assq t seen)
                              ((_ . new) new)
                              (#f
                               (let* ((new (v-ord)))
                                 (set! seen (cons (cons t new) seen))
                                 new)))))
                    (($ box ($ c d k x p a n))
                     (match (assq t seen)
                            ((_ . new) new)
                            (#f
                             (let* ((fix (new-type '**fix** depth))
                                    (fixbox (box fix))
                                    (_ (set! seen (cons (cons t fixbox) seen)))
                                    (new-p (if flags (loop p) top))
                                    (new-a (map2 (lambda (mutable a)
                                                   (if mutable a (loop a)))
                                                 (k-args x)
                                                 a))
                                    (new-n (loop n)))
                               (if (and (eq? new-p p)
                                        (eq? new-n n)
                                        (andmap eq? new-a a))
                                 (begin (set-box! fixbox t) t)
                                 (begin
                                   (set-box!
                                     fix
                                     (make-c d k x new-p new-a new-n))
                                   fix))))))
                    (($ box (? symbol?)) t)
                    (($ box i) (loop i)))))))
(define fields '())
(define new-field!
  (lambda (x)
    (match (assq x fields)
           (#f
            (let ((k (make-k x (+ 1 (length fields)) '(#f))))
              (set! fields (cons (cons x k) fields))
              k))
           ((_ . k) k))))
(define k<
  (lambda (x y) (< (k-order x) (k-order y))))
(define k-counter 0)
(define bind-tycon
  (lambda (x args covers fail-thunk)
    (when (memq x
                '(_ bool
                    mu
                    list
                    &list
                    &optional
                    &rest
                    arglist
                    +
                    not
                    rec
                    *tidy))
          (fail-thunk "invalid type constructor ~a" x))
    (set! k-counter (+ 1 k-counter))
    (make-k
      (if covers
        (symbol-append x "." (- k-counter 100))
        x)
      k-counter
      args)))
(define initial-type-env '())
(define init-types!
  (lambda ()
    (set! k-counter 0)
    (set! var-counter (generate-counter))
    (set! initial-type-env
      (foldl (lambda (l env)
               (extend-env
                 env
                 (car l)
                 (bind-tycon
                   (car l)
                   (cdr l)
                   #f
                   (lambda x (apply disaster 'init x)))))
             empty-env
             initial-type-info))
    (set! k-counter 100)
    (reset-types!)))
(define reinit-types!
  (lambda ()
    (set! var-counter (generate-counter))
    (set! k-counter 100)
    (set! fields '())
    (set-cons-mutability! #t)
    (reset-types!)))
(define deftype
  (lambda (tag mutability)
    (set! initial-type-env
      (extend-env
        initial-type-env
        tag
        (make-k
          tag
          (+ 1 (length initial-type-env))
          mutability)))))
(define initial-type-info
  '((?-> #f #f)
    (arg #f #f)
    (noarg)
    (num)
    (nil)
    (false)
    (true)
    (char)
    (sym)
    (str)
    (void)
    (iport)
    (oport)
    (eof)
    (vec #t)
    (box #t)
    (cons #t #t)
    (cvec #f)
    (promise #t)
    (record #f)
    (module #f)))
(define cons-is-mutable #f)
(define set-cons-mutability!
  (lambda (m)
    (set! cons-is-mutable m)
    (set-k-args!
      (lookup initial-type-env 'cons)
      (list m m))))
(define tidy?
  (lambda (t)
    (let ((seen '()))
      (recur loop
             ((t t) (label '()))
             (match t
                    (($ box (? v?))
                     (match (assq t seen)
                            (#f (set! seen (cons (cons t label) seen)) #t)
                            ((_ . l2) (equal? label l2))))
                    (($ box ($ c _ _ x _ a n))
                     (match (assq t seen)
                            ((_ . l2) (equal? label l2))
                            (#f
                             (set! seen (cons (cons t label) seen))
                             (and (loop n (sort-list (cons x label) k<))
                                  (andmap (lambda (t) (loop t '())) a)))))
                    (($ box (? symbol?)) #t)
                    (($ box i) (loop i label)))))))
(define tidy
  (match-lambda
    (($ ts t _)
     (tidy-print t print-union assemble-union #f))
    (t (tidy-print t print-union assemble-union #f))))
(define ptype
  (match-lambda
    (($ ts t _)
     (tidy-print
       t
       print-raw-union
       assemble-raw-union
       #t))
    (t (tidy-print
         t
         print-raw-union
         assemble-raw-union
         #t))))
(define tidy-print
  (lambda (t print assemble top)
    (let* ((share (shared-unions t top))
           (bindings
             (map-with-n
               (lambda (t n)
                 (list t
                       (box #f)
                       (box #f)
                       (symbol-append "Y" (+ 1 n))))
               share))
           (body (print t (print-binding bindings)))
           (let-bindings
             (filter-map
               (match-lambda
                 ((_ _ ($ box #f) _) #f)
                 ((_ ($ box t) ($ box x) _) (list x t)))
               bindings)))
      (assemble let-bindings body))))
(define print-binding
  (lambda (bindings)
    (lambda (ty share-wrapper var-wrapper render)
      (match (assq ty bindings)
             (#f (render))
             ((_ box-tprint box-name nprint)
              (var-wrapper
                (or (unbox box-name)
                    (begin
                      (set-box! box-name nprint)
                      (set-box! box-tprint (share-wrapper (render)))
                      nprint))))))))
(define shared-unions
  (lambda (t all)
    (let ((seen '()))
      (recur loop
             ((t t) (top #t))
             (match t
                    (($ box (? v?)) #f)
                    (($ box ($ c _ _ _ _ a n))
                     (match (and top (assq t seen))
                            (#f
                             (set! seen (cons (cons t (box 1)) seen))
                             (for-each (lambda (x) (loop x #t)) a)
                             (loop n all))
                            ((_ . b) (set-box! b (+ 1 (unbox b))))))
                    (($ box (? symbol?)) #f)
                    (($ box i) (loop i top))))
      (reverse
        (filter-map
          (match-lambda ((_ $ box 1) #f) ((t . _) t))
          seen)))))
(define print-raw-union
  (lambda (t print-share)
    (recur loop
           ((t t))
           (match t
                  (($ box ($ v _ _ _ _ split _))
                   (if (and share split)
                     (string->symbol (sprintf "~a#" (pvar t)))
                     (pvar t)))
                  (($ box ($ c d k x p a n))
                   (print-share
                     t
                     (lambda (x) x)
                     (lambda (x) x)
                     (lambda ()
                       (let* ((name (if (abs? k)
                                      (symbol-append '~ (k-name x))
                                      (k-name x)))
                              (name (if dump-depths
                                      (symbol-append d '! name)
                                      name))
                              (pr-x `(,name ,@(maplr loop (cons p a)))))
                         (cons pr-x (loop n))))))
                  (($ box 'top) '+)
                  (($ box 'bot) '-)
                  (($ box i) (loop i))))))
(define assemble-raw-union
  (lambda (bindings body)
    (if (null? bindings) body `(rec ,bindings ,body))))
(define print-union
  (lambda (t print-share)
    (add-+ (recur loop
                  ((t t) (tailvis (visible? (tailvar t))))
                  (match t
                         (($ box (? v?))
                          (if (visible? t) (list (pvar t)) '()))
                         (($ box ($ c _ _ x p a n))
                          (print-share
                            t
                            add-+
                            list
                            (lambda ()
                              (cond ((visible? p)
                                     (let* ((split-flag
                                              (and share
                                                   (match (ind* p)
                                                          (($ box
                                                              ($ v
                                                                 _
                                                                 _
                                                                 _
                                                                 _
                                                                 split
                                                                 _))
                                                           split)
                                                          (_ #f))))
                                            (kname (if split-flag
                                                     (string->symbol
                                                       (sprintf
                                                         "~a#~a"
                                                         (k-name x)
                                                         (pvar p)))
                                                     (k-name x))))
                                       (cons (cond ((null? a) kname)
                                                   ((eq? '?-> (k-name x))
                                                    (let ((arg (add-+ (loop (car a)
                                                                            (visible?
                                                                              (tailvar
                                                                                (car a))))))
                                                          (res (add-+ (loop (cadr a)
                                                                            (visible?
                                                                              (tailvar
                                                                                (cadr a)))))))
                                                      (decode-arrow
                                                        kname
                                                        (lambda ()
                                                          (if split-flag
                                                            (string->symbol
                                                              (sprintf
                                                                "->#~a"
                                                                (pvar p)))
                                                            '->))
                                                        arg
                                                        res)))
                                                   ((eq? 'record (k-name x))
                                                    `(,kname
                                                      ,@(loop (car a) #f)))
                                                   (else
                                                    `(,kname
                                                      ,@(maplr (lambda (x)
                                                                 (add-+ (loop x
                                                                              (visible?
                                                                                (tailvar
                                                                                  x)))))
                                                               a))))
                                             (loop n tailvis))))
                                    ((not tailvis) (loop n tailvis))
                                    (else
                                     (cons `(not ,(k-name x))
                                           (loop n tailvis)))))))
                         (($ box 'bot) '())
                         (($ box i) (loop i tailvis)))))))
(define assemble-union
  (lambda (bindings body)
    (subst-small-type
      (map clean-binding bindings)
      body)))
(define add-+
  (match-lambda
    (() 'empty)
    ((t) t)
    (x (cons '+ x))))
(define tailvar
  (lambda (t)
    (match t
           (($ box (? v?)) t)
           (($ box ($ c _ _ _ _ _ n)) (tailvar n))
           (($ box 'bot) t)
           (($ box i) (tailvar i)))))
(define decode-arrow
  (lambda (kname thunk-> arg res)
    (let ((args (recur loop
                       ((l arg))
                       (match l
                              ('noarg '())
                              (('arg a b) `(,a ,@(loop b)))
                              (('+ ('arg a b) 'noarg . _)
                               `((&optional ,a) ,@(loop b)))
                              (('+ 'noarg ('arg a b) . _)
                               `((&optional ,a) ,@(loop b)))
                              ((? symbol? z)
                               (if (rectypevar? z) `(,z) `((&rest ,z))))
                              (('+ 'noarg z) (loop z))
                              (('+ ('arg a b) z)
                               (loop `(+ (arg ,a ,b) noarg ,z)))))))
      `(,@args ,(thunk->) ,res))))
(define rectypevar?
  (lambda (s)
    (memq (string-ref (symbol->string s) 0) '(#\Y))))
(define typevar?
  (lambda (s)
    (memq (string-ref (symbol->string s) 0)
          '(#\X #\Z))))
(define clean-binding
  (lambda (binding)
    (match binding
           ((u ('+ 'nil ('cons a v)))
            (if (and (equal? u v) (not (memq* u a)))
              (list u `(list ,a))
              binding))
           ((u ('+ ('cons a v) 'nil))
            (if (and (equal? u v) (not (memq* u a)))
              (list u `(list ,a))
              binding))
           ((u ('+ 'nil ('cons a v) (? symbol? z)))
            (if (and (equal? u v) (not (memq* u a)) (typevar? z))
              (list u `(list* ,a ,z))
              binding))
           ((u ('+ ('cons a v) 'nil (? symbol? z)))
            (if (and (equal? u v) (not (memq* u a)) (typevar? z))
              (list u `(list* ,a ,z))
              binding))
           ((u ('+ 'noarg ('arg a v)))
            (if (and (equal? u v) (not (memq* u a)))
              (list u `(&list ,a))
              binding))
           ((u ('+ ('arg a v) 'noarg))
            (if (and (equal? u v) (not (memq* u a)))
              (list u `(&list ,a))
              binding))
           (x x))))
(define memq*
  (lambda (v t)
    (recur loop
           ((t t))
           (match t
                  ((x . y) (or (loop x) (loop y)))
                  (_ (eq? v t))))))
(define subst-type
  (lambda (new old t)
    (match new
           (('list elem) (subst-list elem old t))
           (_ (subst* new old t)))))
(define subst-list
  (lambda (elem old t)
    (match t
           ((? symbol?) (if (eq? old t) `(list ,elem) t))
           (('+ 'nil ('cons a (? symbol? b)))
            (if (and (eq? b old) (equal? elem a))
              `(list ,elem)
              `(+ nil (cons ,(subst-list elem old a) ,b))))
           (('+ ('cons a (? symbol? b)) 'nil)
            (if (and (eq? b old) (equal? elem a))
              `(list ,elem)
              `(+ nil (cons ,(subst-list elem old a) ,b))))
           ((a . b)
            (cons (subst-list elem old a)
                  (subst-list elem old b)))
           (z z))))
(define subst*
  (lambda (new old t)
    (cond ((eq? old t) new)
          ((pair? t)
           (cons (subst* new old (car t))
                 (subst* new old (cdr t))))
          (else t))))
(define subst-small-type
  (lambda (bindings body)
    (recur loop
           ((bindings bindings) (newb '()) (body body))
           (match bindings
                  (()
                   (let ((newb (filter
                                 (match-lambda
                                   ((name type) (not (equal? name type))))
                                 newb)))
                     (if (null? newb)
                       body
                       `(rec ,(reverse newb) ,body))))
                  (((and b (name type)) . rest)
                   (if (and (not (memq* name type)) (small-type? type))
                     (loop (subst-type type name rest)
                           (subst-type type name newb)
                           (subst-type type name body))
                     (loop rest (cons b newb) body)))))))
(define small-type?
  (lambda (t)
    (>= 8
        (recur loop
               ((t t))
               (match t
                      ('+ 0)
                      ((? symbol? s) 1)
                      ((? number? n) 0)
                      ((x . y) (+ (loop x) (loop y)))
                      (() 0))))))
(define qop
  (lambda (s)
    (string->symbol (string-append "# " s))))
(define qcons (qop "cons"))
(define qbox (qop "box"))
(define qlist (qop "list"))
(define qvector (qop "vector"))
(define initial-info
  `((not (a -> bool))
    (eqv? (a a -> bool))
    (eq? (a a -> bool))
    (equal? (a a -> bool))
    (cons (a b -> (cons a b)) (ic))
    (car ((cons a b) -> a) (s (x . _)))
    (cdr ((cons b a) -> a) (s (_ . x)))
    (caar ((cons (cons a b) c) -> a)
          (s ((x . _) . _)))
    (cadr ((cons c (cons a b)) -> a) (s (_ x . _)))
    (cdar ((cons (cons b a) c) -> a)
          (s ((_ . x) . _)))
    (cddr ((cons c (cons b a)) -> a) (s (_ _ . x)))
    (caaar ((cons (cons (cons a b) c) d) -> a)
           (s (((x . _) . _) . _)))
    (caadr ((cons d (cons (cons a b) c)) -> a)
           (s (_ (x . _) . _)))
    (cadar ((cons (cons c (cons a b)) d) -> a)
           (s ((_ x . _) . _)))
    (caddr ((cons d (cons c (cons a b))) -> a)
           (s (_ _ x . _)))
    (cdaar ((cons (cons (cons b a) c) d) -> a)
           (s (((_ . x) . _) . _)))
    (cdadr ((cons d (cons (cons b a) c)) -> a)
           (s (_ (_ . x) . _)))
    (cddar ((cons (cons c (cons b a)) d) -> a)
           (s ((_ _ . x) . _)))
    (cdddr ((cons d (cons c (cons b a))) -> a)
           (s (_ _ _ . x)))
    (caaaar
      ((cons (cons (cons (cons a b) c) d) e) -> a)
      (s ((((x . _) . _) . _) . _)))
    (caaadr
      ((cons e (cons (cons (cons a b) c) d)) -> a)
      (s (_ ((x . _) . _) . _)))
    (caadar
      ((cons (cons d (cons (cons a b) c)) e) -> a)
      (s ((_ (x . _) . _) . _)))
    (caaddr
      ((cons e (cons d (cons (cons a b) c))) -> a)
      (s (_ _ (x . _) . _)))
    (cadaar
      ((cons (cons (cons c (cons a b)) d) e) -> a)
      (s (((_ x . _) . _) . _)))
    (cadadr
      ((cons e (cons (cons c (cons a b)) d)) -> a)
      (s (_ (_ x . _) . _)))
    (caddar
      ((cons (cons d (cons c (cons a b))) e) -> a)
      (s ((_ _ x . _) . _)))
    (cadddr
      ((cons e (cons d (cons c (cons a b)))) -> a)
      (s (_ _ _ x . _)))
    (cdaaar
      ((cons (cons (cons (cons b a) c) d) e) -> a)
      (s ((((_ . x) . _) . _) . _)))
    (cdaadr
      ((cons e (cons (cons (cons b a) c) d)) -> a)
      (s (_ ((_ . x) . _) . _)))
    (cdadar
      ((cons (cons d (cons (cons b a) c)) e) -> a)
      (s ((_ (_ . x) . _) . _)))
    (cdaddr
      ((cons e (cons d (cons (cons b a) c))) -> a)
      (s (_ _ (_ . x) . _)))
    (cddaar
      ((cons (cons (cons c (cons b a)) d) e) -> a)
      (s (((_ _ . x) . _) . _)))
    (cddadr
      ((cons e (cons (cons c (cons b a)) d)) -> a)
      (s (_ (_ _ . x) . _)))
    (cdddar
      ((cons (cons d (cons c (cons b a))) e) -> a)
      (s ((_ _ _ . x) . _)))
    (cddddr
      ((cons e (cons d (cons c (cons b a)))) -> a)
      (s (_ _ _ _ . x)))
    (set-car! ((cons a b) a -> void))
    (set-cdr! ((cons a b) b -> void))
    (list ((&list a) -> (list a)) (ic))
    (length ((list a) -> num))
    (append ((&list (list a)) -> (list a)) (ic) (d))
    (reverse ((list a) -> (list a)) (ic))
    (list-tail ((list a) num -> (list a)) (c))
    (list-ref ((list a) num -> a) (c))
    (memq (a (list a) -> (+ false (cons a (list a)))))
    (memv (a (list a) -> (+ false (cons a (list a)))))
    (member
      (a (list a) -> (+ false (cons a (list a)))))
    (assq (a (list (cons a c)) -> (+ false (cons a c))))
    (assv (a (list (cons a c)) -> (+ false (cons a c))))
    (assoc (a (list (cons a c)) -> (+ false (cons a c))))
    (symbol->string (sym -> str))
    (string->symbol (str -> sym))
    (complex? (a -> bool))
    (real? (a -> bool))
    (rational? (a -> bool))
    (integer? (a -> bool))
    (exact? (num -> bool))
    (inexact? (num -> bool))
    (= (num num (&list num) -> bool))
    (< (num num (&list num) -> bool))
    (> (num num (&list num) -> bool))
    (<= (num num (&list num) -> bool))
    (>= (num num (&list num) -> bool))
    (zero? (num -> bool))
    (positive? (num -> bool))
    (negative? (num -> bool))
    (odd? (num -> bool))
    (even? (num -> bool))
    (max (num (&list num) -> num))
    (min (num (&list num) -> num))
    (+ ((&list num) -> num))
    (* ((&list num) -> num))
    (- (num (&list num) -> num))
    (/ (num (&list num) -> num))
    (abs (num -> num))
    (quotient (num num -> num))
    (remainder (num num -> num))
    (modulo (num num -> num))
    (gcd ((&list num) -> num))
    (lcm ((&list num) -> num))
    (numerator (num -> num))
    (denominator (num -> num))
    (floor (num -> num))
    (ceiling (num -> num))
    (truncate (num -> num))
    (round (num -> num))
    (rationalize (num num -> num))
    (exp (num -> num))
    (log (num -> num))
    (sin (num -> num))
    (cos (num -> num))
    (tan (num -> num))
    (asin (num -> num))
    (acos (num -> num))
    (atan (num (&optional num) -> num))
    (sqrt (num -> num))
    (expt (num num -> num))
    (make-rectangular (num num -> num))
    (make-polar (num num -> num))
    (real-part (num -> num))
    (imag-part (num -> num))
    (magnitude (num -> num))
    (angle (num -> num))
    (exact->inexact (num -> num))
    (inexact->exact (num -> num))
    (number->string (num (&optional num) -> str))
    (string->number (str (&optional num) -> num))
    (char=? (char char -> bool))
    (char<? (char char -> bool))
    (char>? (char char -> bool))
    (char<=? (char char -> bool))
    (char>=? (char char -> bool))
    (char-ci=? (char char -> bool))
    (char-ci<? (char char -> bool))
    (char-ci>? (char char -> bool))
    (char-ci<=? (char char -> bool))
    (char-ci>=? (char char -> bool))
    (char-alphabetic? (char -> bool))
    (char-numeric? (char -> bool))
    (char-whitespace? (char -> bool))
    (char-upper-case? (char -> bool))
    (char-lower-case? (char -> bool))
    (char->integer (char -> num))
    (integer->char (num -> char))
    (char-upcase (char -> char))
    (char-downcase (char -> char))
    (make-string (num (&optional char) -> str))
    (string ((&list char) -> str))
    (string-length (str -> num))
    (string-ref (str num -> char))
    (string-set! (str num char -> void))
    (string=? (str str -> bool))
    (string<? (str str -> bool))
    (string>? (str str -> bool))
    (string<=? (str str -> bool))
    (string>=? (str str -> bool))
    (string-ci=? (str str -> bool))
    (string-ci<? (str str -> bool))
    (string-ci>? (str str -> bool))
    (string-ci<=? (str str -> bool))
    (string-ci>=? (str str -> bool))
    (substring (str num num -> str))
    (string-append ((&list str) -> str))
    (string->list (str -> (list char)) (ic))
    (list->string ((list char) -> str))
    (string-copy (str -> str))
    (string-fill! (str char -> void))
    (make-vector (num a -> (vec a)) (i))
    (vector ((&list a) -> (vec a)) (i))
    (vector-length ((vec a) -> num))
    (vector-ref ((vec a) num -> a))
    (vector-set! ((vec a) num a -> void))
    (vector->list ((vec a) -> (list a)) (ic))
    (list->vector ((list a) -> (vec a)) (i))
    (vector-fill! ((vec a) a -> void))
    (apply (((&list a) -> b) (list a) -> b) (i) (d))
    (map ((a -> b) (list a) -> (list b)) (i) (d))
    (for-each ((a -> b) (list a) -> void) (i) (d))
    (force ((promise a) -> a) (i))
    (call-with-current-continuation
      (((a -> b) -> a) -> a)
      (i))
    (call-with-input-file
      (str (iport -> a) -> a)
      (i))
    (call-with-output-file
      (str (oport -> a) -> a)
      (i))
    (input-port? (a -> bool))
    (output-port? (a -> bool))
    (current-input-port (-> iport))
    (current-output-port (-> oport))
    (with-input-from-file (str (-> a) -> a) (i))
    (with-output-to-file (str (-> a) -> a) (i))
    (open-input-file (str -> iport))
    (open-output-file (str -> oport))
    (close-input-port (iport -> void))
    (close-output-port (oport -> void))
    (read ((&optional iport)
           ->
           (+ eof
              num
              nil
              false
              true
              char
              sym
              str
              (box (mu sexp
                       (+ num
                          nil
                          false
                          true
                          char
                          sym
                          str
                          (vec sexp)
                          (cons sexp sexp)
                          (box sexp))))
              (cons sexp sexp)
              (vec sexp)))
          (i))
    (read-char
      ((&optional iport) -> (+ char eof))
      (i))
    (peek-char
      ((&optional iport) -> (+ char eof))
      (i))
    (char-ready? ((&optional iport) -> bool) (i))
    (write (a (&optional oport) -> void) (i))
    (display (a (&optional oport) -> void) (i))
    (newline ((&optional oport) -> void) (i))
    (write-char (char (&optional oport) -> void) (i))
    (load (str -> void))
    (transcript-on (str -> void))
    (transcript-off (-> void))
    (symbol-append ((&rest a) -> sym))
    (box (a -> (box a)) (i))
    (unbox ((box a) -> a) (s boxx))
    (set-box! ((box a) a -> void))
    (void (-> void))
    (make-module (a -> (module a)))
    (raise ((&rest a) -> b))
    (match:error (a (&rest b) -> c))
    (should-never-reach (a -> b))
    (make-cvector (num a -> (cvec a)))
    (cvector ((&list a) -> (cvec a)))
    (cvector-length ((cvec a) -> num))
    (cvector-ref ((cvec a) num -> a))
    (cvector->list ((cvec a) -> (list a)) (ic))
    (list->cvector ((list a) -> (cvec a)))
    (,qcons (a b -> (cons a b)) (ic) (n))
    (,qvector ((&list a) -> (vec a)) (i) (n))
    (,qbox (a -> (box a)) (i) (n))
    (,qlist ((&list a) -> (list a)) (ic) (n))
    (number? ((+ num x) -> bool) (p (num)))
    (null? ((+ nil x) -> bool) (p (nil)))
    (char? ((+ char x) -> bool) (p (char)))
    (symbol? ((+ sym x) -> bool) (p (sym)))
    (string? ((+ str x) -> bool) (p (str)))
    (vector? ((+ (vec a) x) -> bool) (p (vec a)))
    (cvector? ((+ (cvec a) x) -> bool) (p (cvec a)))
    (box? ((+ (box a) x) -> bool) (p (box a)))
    (pair? ((+ (cons a b) x) -> bool) (p (cons a b)))
    (procedure?
      ((+ ((&rest a) -> b) x) -> bool)
      (p (?-> a b)))
    (eof-object? ((+ eof x) -> bool) (p (eof)))
    (input-port? ((+ iport x) -> bool) (p (iport)))
    (output-port? ((+ oport x) -> bool) (p (oport)))
    (true-object? ((+ true x) -> bool) (p (true)))
    (false-object? ((+ false x) -> bool) (p (false)))
    (module?
      ((+ (module a) x) -> bool)
      (p (module a)))
    (boolean? ((+ true false x) -> bool) (p #t))
    (list? ((mu u (+ nil (cons y u) x)) -> bool)
           (p #t))))
(define initial-env '())
(define init-env!
  (lambda ()
    (set! initial-env
      (foldr init-prim empty-env initial-info))))
(define init-prim
  (lambda (l env)
    (letrec ((build-selector
               (match-lambda
                 ('x (lambda (x) x))
                 ('_ (lambda (x) (make-pany)))
                 ('boxx
                  (let ((c (lookup env 'box?)))
                    (lambda (x) (make-pobj c (list x)))))
                 ((x . y)
                  (let ((c (lookup env 'pair?))
                        (lx (build-selector x))
                        (ly (build-selector y)))
                    (lambda (x) (make-pobj c (list (lx x) (ly x)))))))))
      (match l
             ((name type . attr)
              (let* ((pure (cond ((assq 'i attr) #f)
                                 ((assq 'ic attr) 'cons)
                                 (else #t)))
                     (def (assq 'd attr))
                     (check (assq 'c attr))
                     (nocheck (assq 'n attr))
                     (pred (match (assq 'p attr)
                                  (#f #f)
                                  ((_ #t) #t)
                                  ((_ (tag . args))
                                   (cons (lookup initial-type-env tag) args))))
                     (sel (match (assq 's attr)
                                 (#f #f)
                                 ((_ s) (build-selector s))))
                     (env1 (extend-env
                             env
                             name
                             (make-name
                               name
                               (closeall (r+ initial-type-env type))
                               #f
                               0
                               #f
                               #f
                               (cond (nocheck 'nocheck)
                                     (check 'check)
                                     (def 'imprecise)
                                     (else #t))
                               #f
                               pure
                               pred
                               #f
                               sel)))
                     (env2 (extend-env
                             env1
                             (symbol-append 'check- name)
                             (make-name
                               (symbol-append 'check- name)
                               (closeall (r++ initial-type-env type))
                               #f
                               0
                               #f
                               #f
                               #t
                               #f
                               pure
                               pred
                               #f
                               sel))))
                env2))))))
(define defprim
  (lambda (name type mode)
    (handle
      (r+ initial-type-env type)
      (match-lambda*
        (('type . args) (apply syntax-err type args))
        (x (apply raise x))))
    (let* ((attr (match mode
                        ('impure '((i)))
                        ('pure '())
                        ('pure-if-cons-is '((ic)))
                        ('mutates-cons
                         (set! cons-mutators (cons name cons-mutators))
                         '())
                        (x (use-error
                             "invalid attribute ~a for st:defprim"
                             x))))
           (info `(,name ,type ,@attr)))
      (unless
        (equal? info (assq name initial-info))
        (set! initial-info (cons info initial-info))
        (set! initial-env (init-prim info initial-env))))))
(init-types!)
(init-env!)
(define %not (lookup initial-env 'not))
(define %list (lookup initial-env 'list))
(define %cons (lookup initial-env 'cons))
(define %should-never-reach
  (lookup initial-env 'should-never-reach))
(define %false-object?
  (lookup initial-env 'false-object?))
(define %eq? (lookup initial-env 'eq?))
(define %eqv? (lookup initial-env 'eqv?))
(define %equal? (lookup initial-env 'equal?))
(define %null? (lookup initial-env 'null?))
(define %vector? (lookup initial-env 'vector?))
(define %cvector? (lookup initial-env 'cvector?))
(define %list? (lookup initial-env 'list?))
(define %boolean? (lookup initial-env 'boolean?))
(define %procedure?
  (lookup initial-env 'procedure?))
(define n-unbound 0)
(define bind-defs
  (lambda (defs env0 tenv0 old-unbound timestamp)
    (letrec ((cons-mutable #f)
             (unbound '())
             (use-var
               (lambda (x env context mk-node)
                 (match (lookup? env x)
                        (#f
                         (let* ((b (bind-var x)) (n (mk-node b)))
                           (set-name-timestamp! b context)
                           (set! unbound (cons n unbound))
                           n))
                        (b (when (and (name-primitive b)
                                      (memq x cons-mutators))
                                 (set! cons-mutable #t))
                           (set-name-occ! b (+ 1 (name-occ b)))
                           (mk-node b)))))
             (bind-var
               (lambda (x)
                 (make-name
                   x
                   #f
                   timestamp
                   0
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f
                   #f)))
             (bind (lambda (e env tenv context)
                     (let ((bind-cur (lambda (x) (bind x env tenv context))))
                       (match e
                              (($ var x) (use-var x env context make-var))
                              (($ prim x)
                               (use-var x initial-env context make-var))
                              (($ const c pred)
                               (use-var
                                 pred
                                 initial-env
                                 context
                                 (lambda (p) (make-const c p))))
                              (($ lam args e2)
                               (let* ((b-args (map bind-var args))
                                      (newenv (extend-env* env args b-args)))
                                 (make-lam
                                   b-args
                                   (bind e2 newenv tenv context))))
                              (($ vlam args rest e2)
                               (let* ((b-args (map bind-var args))
                                      (b-rest (bind-var rest))
                                      (newenv
                                        (extend-env*
                                          env
                                          (cons rest args)
                                          (cons b-rest b-args))))
                                 (make-vlam
                                   b-args
                                   b-rest
                                   (bind e2 newenv tenv context))))
                              (($ match e1 clauses)
                               (make-match
                                 (bind-cur e1)
                                 (map (lambda (x)
                                        (bind-mclause x env tenv context))
                                      clauses)))
                              (($ app e1 args)
                               (make-app (bind-cur e1) (map bind-cur args)))
                              (($ begin exps) (make-begin (map bind-cur exps)))
                              (($ and exps) (make-and (map bind-cur exps)))
                              (($ or exps) (make-or (map bind-cur exps)))
                              (($ if test then els)
                               (make-if
                                 (bind-cur test)
                                 (bind-cur then)
                                 (bind-cur els)))
                              (($ delay e2) (make-delay (bind-cur e2)))
                              (($ set! x e2)
                               (use-var
                                 x
                                 env
                                 context
                                 (lambda (b)
                                   (when (name-struct b)
                                         (syntax-err
                                           (pexpr e)
                                           "define-structure identifier ~a may not be assigned"
                                           x))
                                   (when (name-primitive b)
                                         (syntax-err
                                           (pexpr e)
                                           "(set! ~a ...) requires (define ~a ...)"
                                           x
                                           x))
                                   (when (and (not (name-mutated b))
                                              (not (= (name-timestamp b)
                                                      timestamp)))
                                         (syntax-err
                                           (pexpr e)
                                           "(set! ~a ...) missing from compilation unit defining ~a"
                                           x
                                           x))
                                   (set-name-mutated! b #t)
                                   (make-set! b (bind-cur e2)))))
                              (($ let args e2)
                               (let* ((b-args
                                        (map (match-lambda
                                               (($ bind x e)
                                                (make-bind
                                                  (bind-var x)
                                                  (bind-cur e))))
                                             args))
                                      (newenv
                                        (extend-env*
                                          env
                                          (map bind-name args)
                                          (map bind-name b-args))))
                                 (make-let
                                   b-args
                                   (bind e2 newenv tenv context))))
                              (($ let* args e2)
                               (recur loop
                                      ((args args) (b-args '()) (env env))
                                      (match args
                                             ((($ bind x e) . rest)
                                              (let ((b (bind-var x)))
                                                (loop rest
                                                      (cons (make-bind
                                                              b
                                                              (bind e
                                                                    env
                                                                    tenv
                                                                    context))
                                                            b-args)
                                                      (extend-env env x b))))
                                             (()
                                              (make-let*
                                                (reverse b-args)
                                                (bind e2 env tenv context))))))
                              (($ letr args e2)
                               (let* ((b-args
                                        (map (match-lambda
                                               (($ bind x e)
                                                (make-bind (bind-var x) e)))
                                             args))
                                      (newenv
                                        (extend-env*
                                          env
                                          (map bind-name args)
                                          (map bind-name b-args)))
                                      (b-args
                                        (map (match-lambda
                                               (($ bind b e)
                                                (let* ((n (name-occ b))
                                                       (e2 (bind e
                                                                 newenv
                                                                 tenv
                                                                 context)))
                                                  (set-name-occ! b n)
                                                  (make-bind b e2))))
                                             b-args)))
                                 (make-letr
                                   b-args
                                   (bind e2 newenv tenv context))))
                              (($ body defs exps)
                               (match-let*
                                 (((defs newenv newtenv)
                                   (bind-defn defs env tenv #f)))
                                 (make-body
                                   defs
                                   (map (lambda (x)
                                          (bind x newenv newtenv context))
                                        exps))))
                              (($ record args)
                               (make-record
                                 (map (match-lambda
                                        (($ bind x e)
                                         (new-field! x)
                                         (make-bind x (bind-cur e))))
                                      args)))
                              (($ field x e2)
                               (new-field! x)
                               (make-field x (bind-cur e2)))
                              (($ cast ty e2)
                               (match-let
                                 (((t absv)
                                   (handle
                                     (r+collect
                                       tenv
                                       (match ty
                                              (('rec bind ty2)
                                               `(rec ,bind (,ty2 -> ,ty2)))
                                              (_ `(,ty -> ,ty))))
                                     (match-lambda*
                                       (('type . args)
                                        (apply syntax-err ty args))
                                       (x (apply raise x))))))
                                 (make-cast
                                   (list ty t absv)
                                   (bind-cur e2))))))))
             (bind-mclause
               (lambda (clause env tenv context)
                 (match-let*
                   ((($ mclause pattern body failsym) clause)
                    (patenv empty-env)
                    (bp (recur loop
                               ((p pattern))
                               (match p
                                      (($ pvar x)
                                       (when (bound? patenv x)
                                             (syntax-err
                                               (ppat pattern)
                                               "pattern variable ~a repeated"
                                               x))
                                       (let ((b (bind-var x)))
                                         (set! patenv (extend-env patenv x b))
                                         (make-pvar b)))
                                      (($ pobj c args)
                                       (use-var
                                         c
                                         env
                                         context
                                         (lambda (b)
                                           (cond ((boolean? (name-predicate b))
                                                  (syntax-err
                                                    (ppat pattern)
                                                    "~a is not a predicate"
                                                    c))
                                                 ((and (not (eq? b %vector?))
                                                       (not (eq? b %cvector?))
                                                       (not (= (length
                                                                 (cdr (name-predicate
                                                                        b)))
                                                               (length args))))
                                                  (syntax-err
                                                    (ppat pattern)
                                                    "~a requires ~a sub-patterns"
                                                    c
                                                    (length
                                                      (cdr (name-predicate
                                                             b)))))
                                                 (else
                                                  (make-pobj
                                                    b
                                                    (map loop args)))))))
                                      (($ pand pats)
                                       (make-pand (map loop pats)))
                                      (($ pnot pat) (make-pnot (loop pat)))
                                      (($ ppred pred)
                                       (use-var
                                         pred
                                         env
                                         context
                                         (lambda (b)
                                           (unless
                                             (name-predicate b)
                                             (syntax-err
                                               (ppat pattern)
                                               "~a is not a predicate"
                                               pred))
                                           (make-ppred b))))
                                      (($ pany) p)
                                      (($ pelse) p)
                                      (($ pconst c pred)
                                       (use-var
                                         pred
                                         initial-env
                                         context
                                         (lambda (p) (make-pconst c p))))))))
                   (if failsym
                     (let ((b (bind-var failsym)))
                       (when (bound? patenv failsym)
                             (syntax-err
                               (ppat pattern)
                               "fail symbol ~a repeated"
                               failsym))
                       (set! patenv (extend-env patenv failsym b))
                       (make-mclause
                         bp
                         (bind body (join-env env patenv) tenv context)
                         b))
                     (make-mclause
                       bp
                       (bind body (join-env env patenv) tenv context)
                       #f)))))
             (bind-defn
               (lambda (defs env tenv glob)
                 (let* ((newenv empty-env)
                        (newtenv empty-env)
                        (struct-def
                          (lambda (x pure)
                            (when (or (bound? newenv x)
                                      (and glob (bound? initial-env x)))
                                  (syntax-err
                                    #f
                                    "~a defined more than once"
                                    x))
                            (let ((b (bind-var x)))
                              (set-name-primitive! b #t)
                              (set-name-struct! b #t)
                              (set-name-pure! b pure)
                              (set! newenv (extend-env newenv x b))
                              b)))
                        (bind1 (match-lambda
                                 ((and z ($ define x e))
                                  (cond ((not x) z)
                                        ((bound? newenv x)
                                         (if glob
                                           (make-define #f (make-set! x e))
                                           (syntax-err
                                             #f
                                             "~a defined more than once"
                                             x)))
                                        (else
                                         (let ((b (bind-var x)))
                                           (set-name-gdef! b glob)
                                           (set! newenv
                                             (extend-env newenv x b))
                                           (make-define b e)))))
                                 ((and d
                                       ($ defstruct
                                          tag
                                          args
                                          make
                                          pred
                                          get
                                          set
                                          getn
                                          setn
                                          mutable))
                                  (let* ((make (struct-def
                                                 make
                                                 (map not mutable)))
                                         (pred (struct-def pred #t))
                                         (bind-get
                                           (lambda (name n)
                                             (match name
                                                    (($ some x)
                                                     (let ((b (struct-def
                                                                x
                                                                #t)))
                                                       (set-name-selector!
                                                         b
                                                         (lambda (x)
                                                           (make-pobj
                                                             pred
                                                             (map-with-n
                                                               (lambda (_ m)
                                                                 (if (= m n)
                                                                   x
                                                                   (make-pany)))
                                                               get))))
                                                       (some b)))
                                                    (none none))))
                                         (bind-set
                                           (match-lambda
                                             (($ some x)
                                              (some (struct-def x #t)))
                                             (none none)))
                                         (get (map-with-n bind-get get))
                                         (getn (map-with-n bind-get getn))
                                         (set (map bind-set set))
                                         (setn (map bind-set setn))
                                         (_ (when (bound? newtenv tag)
                                                  (syntax-err
                                                    (pdef d)
                                                    "type constructor ~a defined more than once"
                                                    tag)))
                                         (tc (bind-tycon
                                               tag
                                               mutable
                                               (bound? tenv tag)
                                               (lambda args
                                                 (apply syntax-err
                                                        (cons (pdef d)
                                                              args))))))
                                    (set! newtenv (extend-env newtenv tag tc))
                                    (set-name-predicate!
                                      pred
                                      `(,tc ,@(map (lambda (_) (gensym)) get)))
                                    (make-defstruct
                                      tc
                                      args
                                      make
                                      pred
                                      get
                                      set
                                      getn
                                      setn
                                      mutable)))
                                 ((and d ($ datatype dt))
                                  (make-datatype
                                    (maplr (match-lambda
                                             (((tag . args) . bindings)
                                              (when (bound? newtenv tag)
                                                    (syntax-err
                                                      (pdef d)
                                                      "type constructor ~a defined more than once"
                                                      tag))
                                              (let ((tc (bind-tycon
                                                          tag
                                                          (map (lambda (_) #f)
                                                               args)
                                                          (bound? tenv tag)
                                                          (lambda args
                                                            (apply syntax-err
                                                                   (cons (pdef d)
                                                                         args))))))
                                                (set! newtenv
                                                  (extend-env newtenv tag tc))
                                                (cons (cons tc args)
                                                      (maplr (match-lambda
                                                               (($ variant
                                                                   con
                                                                   pred
                                                                   arg-types)
                                                                (let ((make (struct-def
                                                                              con
                                                                              #t))
                                                                      (pred (struct-def
                                                                              pred
                                                                              #t)))
                                                                  (set-name-predicate!
                                                                    pred
                                                                    (cons tc
                                                                          args))
                                                                  (set-name-variant!
                                                                    pred
                                                                    arg-types)
                                                                  (make-variant
                                                                    make
                                                                    pred
                                                                    arg-types))))
                                                             bindings)))))
                                           dt)))))
                        (defs2 (maplr bind1 defs))
                        (newenv2 (join-env env newenv))
                        (newtenv2 (join-env tenv newtenv))
                        (bind2 (match-lambda
                                 ((and ($ define (? name? x) ($ var y)))
                                  (=> fail)
                                  (if (eq? (name-name x) y)
                                    (if (bound? initial-env y)
                                      (make-define
                                        x
                                        (make-var (lookup initial-env y)))
                                      (begin
                                        (printf
                                          "Warning: (define ~a ~a) but ~a is not a primitive~%"
                                          y
                                          y
                                          y)
                                        (fail)))
                                    (fail)))
                                 ((and ($ define x e2) context)
                                  (when (and glob
                                             (name? x)
                                             (bound?
                                               initial-env
                                               (name-name x)))
                                        (printf
                                          "Note: (define ~a ...) hides primitive ~a~%"
                                          (name-name x)
                                          (name-name x)))
                                  (make-define
                                    (or x
                                        (let ((b (bind-var x)))
                                          (set-name-gdef! b glob)
                                          b))
                                    (bind e2 newenv2 newtenv2 context)))
                                 (d d))))
                   (list (maplr bind2 defs2) newenv2 newtenv2))))
             (bind-old
               (lambda (e env)
                 (match e
                        (($ var x)
                         (match (lookup? env (name-name x))
                                (#f (set! unbound (cons e unbound)))
                                (b (when (and (name-primitive b)
                                              (memq x cons-mutators))
                                         (set! cons-mutable #t))
                                   (set-name-occ! b (+ 1 (name-occ b)))
                                   (set-var-name! e b))))
                        (($ set! x _)
                         (match (lookup? env (name-name x))
                                (#f (set! unbound (cons e unbound)))
                                (b (when (name-struct b)
                                         (syntax-err
                                           (pexpr e)
                                           "define-structure identifier ~a may not be assigned"
                                           x))
                                   (when (name-primitive b)
                                         (syntax-err
                                           (pexpr e)
                                           "(set! ~a ...) requires (define ~a ...)"
                                           x
                                           x))
                                   (when (and (not (name-mutated b))
                                              (not (= (name-timestamp b)
                                                      timestamp)))
                                         (syntax-err
                                           (pexpr e)
                                           "(set! ~a ...) missing from compilation unit defining ~a"
                                           x
                                           x))
                                   (set-name-mutated! b #t)
                                   (set-name-occ! b (+ 1 (name-occ b)))
                                   (set-set!-name! e b))))))))
      (match-let
        (((defs env tenv) (bind-defn defs env0 tenv0 #t)))
        (for-each
          (lambda (x) (bind-old x env))
          old-unbound)
        (set-cons-mutability! cons-mutable)
        (set! n-unbound (length unbound))
        (list defs env tenv unbound)))))
(define rebind-var
  (lambda (b)
    (make-name
      (name-name b)
      (name-ty b)
      (name-timestamp b)
      (name-occ b)
      (name-mutated b)
      #f
      #f
      #f
      #f
      #f
      #f
      #f)))
(define warn-unbound
  (lambda (l)
    (let* ((names '())
           (node->name
             (match-lambda
               (($ var x) x)
               (($ set! x _) x)
               (($ pobj x _) x)
               (($ ppred x) x)))
           (warn (lambda (b)
                   (unless
                     (memq (name-name b) names)
                     (set! names (cons (name-name b) names))
                     (printf
                       "Warning: ~a is unbound in "
                       (name-name b))
                     (print-context (pexpr (name-timestamp b)) 2)))))
      (for-each (lambda (x) (warn (node->name x))) l))))
(define name-unbound?
  (lambda (x) (not (number? (name-timestamp x)))))
(define improve-defs
  (lambda (defs)
    (map (match-lambda
           (($ define x e2) (make-define x (improve e2)))
           (x x))
         defs)))
(define improve
  (match-lambda
    (($ match e clauses) (improve-match e clauses))
    (($ if tst thn els) (improve-if tst thn els))
    ((? var? e) e)
    ((? const? e) e)
    (($ lam args e2) (make-lam args (improve e2)))
    (($ vlam args rest e2)
     (make-vlam args rest (improve e2)))
    (($ app (and e1 ($ var x)) args)
     (let ((args (map improve args)))
       (if (and (eq? x %list) (< (length args) conslimit))
         (foldr (lambda (a rest)
                  (make-app (make-var %cons) (list a rest)))
                (make-const '() %null?)
                args)
         (make-app e1 args))))
    (($ app e1 args)
     (make-app (improve e1) (map improve args)))
    (($ begin exps) (make-begin (map improve exps)))
    (($ and exps) (make-and (map improve exps)))
    (($ or exps) (make-or (map improve exps)))
    (($ delay e2) (make-delay (improve e2)))
    (($ set! x e2) (make-set! x (improve e2)))
    (($ let args e2)
     (let ((args (map (match-lambda
                        (($ bind x e) (make-bind x (improve e))))
                      args)))
       (make-let args (improve e2))))
    (($ let* args e2)
     (let ((args (map (match-lambda
                        (($ bind x e) (make-bind x (improve e))))
                      args)))
       (make-let* args (improve e2))))
    (($ letr args e2)
     (let ((args (map (match-lambda
                        (($ bind x e) (make-bind x (improve e))))
                      args)))
       (make-letr args (improve e2))))
    (($ body defs exps)
     (let ((defs (improve-defs defs)))
       (make-body defs (map improve exps))))
    (($ record args)
     (make-record
       (map (match-lambda
              (($ bind x e) (make-bind x (improve e))))
            args)))
    (($ field x e2) (make-field x (improve e2)))
    (($ cast ty e2) (make-cast ty (improve e2)))))
(define improve-if
  (lambda (tst thn els)
    (let ((if->match
            (lambda (x p mk-s thn els)
              (let ((else-pat
                      (match els
                             (($ app ($ var q) _)
                              (if (eq? q %should-never-reach)
                                (make-pelse)
                                (make-pany)))
                             (_ (make-pany)))))
                (make-match
                  (make-var x)
                  (list (make-mclause
                          (mk-s (make-ppred p))
                          (make-body '() (list thn))
                          #f)
                        (make-mclause
                          (mk-s else-pat)
                          (make-body '() (list els))
                          #f)))))))
      (match tst
             (($ app ($ var v) (e))
              (=> fail)
              (if (eq? v %not) (improve-if e els thn) (fail)))
             (($ app ($ var eq) (($ const #f _) val))
              (=> fail)
              (if (or (eq? eq %eq?)
                      (eq? eq %eqv?)
                      (eq? eq %equal?))
                (improve-if val els thn)
                (fail)))
             (($ app ($ var eq) (val ($ const #f _)))
              (=> fail)
              (if (or (eq? eq %eq?)
                      (eq? eq %eqv?)
                      (eq? eq %equal?))
                (improve-if val els thn)
                (fail)))
             (($ app ($ var v) (($ var x)))
              (=> fail)
              (if (and (name-predicate v) (not (name-mutated x)))
                (improve (if->match x v (lambda (x) x) thn els))
                (fail)))
             (($ app ($ var v) (($ app ($ var s) (($ var x)))))
              (=> fail)
              (if (and (name-predicate v)
                       (name-selector s)
                       (not (name-mutated x)))
                (improve
                  (if->match x v (name-selector s) thn els))
                (fail)))
             (($ app ($ var v) (($ var x)))
              (=> fail)
              (if (and (name-selector v) (not (name-mutated x)))
                (improve
                  (if->match
                    x
                    %false-object?
                    (name-selector v)
                    els
                    thn))
                (fail)))
             (($ var v)
              (=> fail)
              (if (not (name-mutated v))
                (improve
                  (if->match
                    v
                    %false-object?
                    (lambda (x) x)
                    els
                    thn))
                (fail)))
             (_ (make-if
                  (improve tst)
                  (improve thn)
                  (improve els)))))))
(define improve-match
  (lambda (e clauses)
    (let ((clauses
            (map (match-lambda
                   (($ mclause p body fail)
                    (make-mclause p (improve body) fail)))
                 clauses)))
      (match e
             (($ var x)
              (if (not (name-mutated x))
                (let ((fix-clause
                        (match-lambda
                          ((and c ($ mclause p e fail))
                           (if (not (uses-x? e x))
                             c
                             (let ((y (rebind-var x)))
                               (make-mclause
                                 (make-flat-pand (list p (make-pvar y)))
                                 (sub e x y)
                                 fail)))))))
                  (make-match e (map fix-clause clauses)))
                (make-match e clauses)))
             (_ (make-match (improve e) clauses))))))
(define uses-x?
  (lambda (e x)
    (recur loop
           ((e e))
           (match e
                  (($ and exps) (ormap loop exps))
                  (($ app fun args)
                   (or (loop fun) (ormap loop args)))
                  (($ begin exps) (ormap loop exps))
                  (($ if e1 e2 e3)
                   (or (loop e1) (loop e2) (loop e3)))
                  (($ lam names body) (loop body))
                  (($ let bindings body)
                   (or (ormap (match-lambda (($ bind _ b) (loop b)))
                              bindings)
                       (loop body)))
                  (($ let* bindings body)
                   (or (ormap (match-lambda (($ bind _ b) (loop b)))
                              bindings)
                       (loop body)))
                  (($ letr bindings body)
                   (or (ormap (match-lambda (($ bind _ b) (loop b)))
                              bindings)
                       (loop body)))
                  (($ or exps) (ormap loop exps))
                  (($ delay e2) (loop e2))
                  (($ set! name exp) (or (eq? x name) (loop exp)))
                  (($ var name) (eq? x name))
                  (($ vlam names name body) (loop body))
                  (($ match exp clauses)
                   (or (loop exp)
                       (ormap (match-lambda
                                (($ mclause p b _) (or (loop p) (loop b))))
                              clauses)))
                  (($ body defs exps)
                   (or (ormap loop defs) (ormap loop exps)))
                  (($ record bindings)
                   (ormap (match-lambda (($ bind _ b) (loop b)))
                          bindings))
                  (($ field _ e) (loop e))
                  (($ cast _ e) (loop e))
                  (($ define _ e) (loop e))
                  ((? defstruct?) #f)
                  ((? datatype?) #f)
                  (($ pand pats) (ormap loop pats))
                  (($ pnot pat) (loop pat))
                  (($ pobj c args) (ormap loop args))
                  (($ ppred pred) (eq? x pred))
                  (_ #f)))))
(define sub
  (lambda (e x to)
    (let ((dos (lambda (y) (if (eq? x y) to y))))
      (recur sub
             ((e e))
             (match e
                    (($ define x e) (make-define x (sub e)))
                    ((? defstruct?) e)
                    ((? datatype?) e)
                    (($ match e clauses)
                     (let ((clauses
                             (map (match-lambda
                                    (($ mclause p e fail)
                                     (make-mclause p (sub e) fail)))
                                  clauses)))
                       (make-match (sub e) clauses)))
                    (($ if tst thn els)
                     (make-if (sub tst) (sub thn) (sub els)))
                    (($ var x) (make-var (dos x)))
                    ((? const? e) e)
                    (($ lam args e2) (make-lam args (sub e2)))
                    (($ vlam args rest e2)
                     (make-vlam args rest (sub e2)))
                    (($ app e1 args)
                     (make-app (sub e1) (map sub args)))
                    (($ begin exps) (make-begin (map sub exps)))
                    (($ and exps) (make-and (map sub exps)))
                    (($ or exps) (make-or (map sub exps)))
                    (($ delay e2) (make-delay (sub e2)))
                    (($ set! x e2) (make-set! (dos x) (sub e2)))
                    (($ let args e2)
                     (let ((args (map (match-lambda
                                        (($ bind x e) (make-bind x (sub e))))
                                      args)))
                       (make-let args (sub e2))))
                    (($ let* args e2)
                     (let ((args (map (match-lambda
                                        (($ bind x e) (make-bind x (sub e))))
                                      args)))
                       (make-let* args (sub e2))))
                    (($ letr args e2)
                     (let ((args (map (match-lambda
                                        (($ bind x e) (make-bind x (sub e))))
                                      args)))
                       (make-letr args (sub e2))))
                    (($ body defs exps)
                     (make-body (map sub defs) (map sub exps)))
                    (($ record args)
                     (make-record
                       (map (match-lambda
                              (($ bind x e) (make-bind x (sub e))))
                            args)))
                    (($ field x e) (make-field x (sub e)))
                    (($ cast ty e) (make-cast ty (sub e))))))))
(define improve-clauses
  (lambda (clauses)
    (recur loop
           ((clauses clauses))
           (match clauses
                  (() '())
                  ((_) clauses)
                  (((and m1 ($ mclause p _ fail)) . rest)
                   (cons m1
                         (if fail
                           (loop rest)
                           (recur loop2
                                  ((clauses (loop rest)))
                                  (match clauses
                                         (() '())
                                         (((and m ($ mclause p2 body2 fail2))
                                           .
                                           r)
                                          (match (improve-by-pattern p2 p)
                                                 (('stop . p)
                                                  (cons (make-mclause
                                                          p
                                                          body2
                                                          fail2)
                                                        r))
                                                 (('redundant . p)
                                                  (unless
                                                    (null? r)
                                                    (printf
                                                      "Warning: redundant pattern ~a~%"
                                                      (ppat p2)))
                                                  (cons (make-mclause
                                                          p
                                                          body2
                                                          fail2)
                                                        r))
                                                 (('continue . p)
                                                  (cons (make-mclause
                                                          p
                                                          body2
                                                          fail2)
                                                        (loop2 r))))))))))))))
(define improve-by-pattern
  (lambda (p2 p1)
    (call-with-current-continuation
      (lambda (k)
        (let* ((reject (lambda () (k (cons 'continue p2))))
               (p1covers #t)
               (p2covers #t)
               (p3 (recur m
                          ((p1 p1) (p2 p2))
                          '(printf "(M ~a ~a)~%" (ppat p1) (ppat p2))
                          (match (cons p1 p2)
                                 ((($ pand (a . _)) . p2) (m a p2))
                                 ((p1 $ pand (a . b))
                                  (make-flat-pand (cons (m p1 a) b)))
                                 ((($ pvar _) . _)
                                  (unless
                                    (or (pvar? p2) (pany? p2))
                                    (set! p2covers #f))
                                  p2)
                                 ((($ pany) . _)
                                  (unless
                                    (or (pvar? p2) (pany? p2))
                                    (set! p2covers #f))
                                  p2)
                                 ((($ pelse) . _)
                                  '(unless
                                     (or (pvar? p2) (pany? p2))
                                     (set! p2covers #f))
                                  p2)
                                 ((_ $ pvar _)
                                  (unless p1covers (reject))
                                  (set! p1covers #f)
                                  (make-flat-pand (list p2 (make-pnot p1))))
                                 ((_ $ pany)
                                  (unless p1covers (reject))
                                  (set! p1covers #f)
                                  (make-flat-pand (list p2 (make-pnot p1))))
                                 ((_ $ pelse)
                                  (unless p1covers (reject))
                                  (set! p1covers #f)
                                  (make-flat-pand (list p2 (make-pnot p1))))
                                 ((($ pconst a _) $ pconst b _)
                                  (unless (equal? a b) (reject))
                                  p2)
                                 ((($ pobj tag1 a) $ pobj tag2 b)
                                  (unless (eq? tag1 tag2) (reject))
                                  (make-pobj tag1 (map2 m a b)))
                                 ((($ ppred tag1) $ ppred tag2)
                                  (unless (eq? tag1 tag2) (reject))
                                  p2)
                                 ((($ ppred tag1) $ pobj tag2 _)
                                  (unless (eq? tag1 tag2) (reject))
                                  (set! p2covers #f)
                                  p2)
                                 ((($ ppred tag1) $ pconst c tag2)
                                  (unless (eq? tag1 tag2) (reject))
                                  (set! p2covers #f)
                                  p2)
                                 (_ (reject))))))
          (cond (p1covers (cons 'redundant p2))
                (p2covers (cons 'stop p3))
                (else (cons 'continue p3))))))))
(define improve-by-noisily
  (lambda (p2 p1)
    (let ((r (improve-by-pattern p2 p1)))
      (printf
        "~a by ~a returns ~a ~a~%"
        (ppat p2)
        (ppat p1)
        (car r)
        (ppat (cdr r))))))
(define make-components
  (lambda (d)
    (let* ((structs
             (filter-map
               (match-lambda ((? define?) #f) (x x))
               d))
           (defs (filter-map
                   (match-lambda ((? define? x) x) (_ #f))
                   d))
           (name-of (match-lambda (($ define x _) x)))
           (ref-of
             (match-lambda
               (($ define _ e) (references e name-gdef))))
           (comp (top-sort defs name-of ref-of)))
      (when #f
            (printf "Components:~%")
            (pretty-print
              (map (lambda (c)
                     (map (match-lambda
                            (($ define x _) (and x (name-name x))))
                          c))
                   comp)))
      (append structs comp))))
(define make-body-components
  (lambda (d)
    (let* ((structs
             (filter-map
               (match-lambda ((? define?) #f) (x x))
               d))
           (defs (filter-map
                   (match-lambda ((? define? x) x) (_ #f))
                   d))
           (name-of (match-lambda (($ define x _) x)))
           (bound (map name-of defs))
           (ref-of
             (match-lambda
               (($ define _ e)
                (references e (lambda (x) (memq x bound))))))
           (comp (top-sort defs name-of ref-of)))
      (when #f
            (printf "Components:~%")
            (pretty-print
              (map (lambda (c)
                     (map (match-lambda
                            (($ define x _) (and x (name-name x))))
                          c))
                   comp)))
      (append structs comp))))
(define make-letrec-components
  (lambda (bindings)
    (let* ((name-of bind-name)
           (bound (map name-of bindings))
           (ref-of
             (match-lambda
               (($ bind _ e)
                (references e (lambda (x) (memq x bound))))))
           (comp (top-sort bindings name-of ref-of)))
      (when #f
            (printf "Letrec Components:~%")
            (pretty-print
              (map (lambda (c)
                     (map (match-lambda (($ bind x _) (pname x))) c))
                   comp)))
      comp)))
(define references
  (lambda (e ref?)
    (recur loop
           ((e e))
           (match e
                  (($ define x e)
                   (if (and x (name-mutated x))
                     (union (set x) (loop e))
                     (loop e)))
                  ((? defstruct?) empty-set)
                  ((? datatype?) empty-set)
                  ((? const?) empty-set)
                  (($ var x) (if (ref? x) (set x) empty-set))
                  (($ lam _ e1) (loop e1))
                  (($ vlam _ _ e1) (loop e1))
                  (($ app e0 args)
                   (foldr union2 (loop e0) (map loop args)))
                  (($ let b e2)
                   (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
                     (foldr union2 (loop e2) (map do-bind b))))
                  (($ let* b e2)
                   (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
                     (foldr union2 (loop e2) (map do-bind b))))
                  (($ letr b e2)
                   (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
                     (foldr union2 (loop e2) (map do-bind b))))
                  (($ body defs exps)
                   (foldr union2
                          empty-set
                          (map loop (append defs exps))))
                  (($ record b)
                   (let ((do-bind (match-lambda (($ bind _ e) (loop e)))))
                     (foldr union2 empty-set (map do-bind b))))
                  (($ field _ e) (loop e))
                  (($ cast _ e) (loop e))
                  (($ and exps)
                   (foldr union2 empty-set (map loop exps)))
                  (($ or exps)
                   (foldr union2 empty-set (map loop exps)))
                  (($ begin exps)
                   (foldr union2 empty-set (map loop exps)))
                  (($ if test then els)
                   (union (loop test) (loop then) (loop els)))
                  (($ delay e) (loop e))
                  (($ set! x body)
                   (union (if (ref? x) (set x) empty-set)
                          (loop body)))
                  (($ match exp clauses)
                   (foldr union2
                          (loop exp)
                          (map (match-lambda (($ mclause _ exp _) (loop exp)))
                               clauses)))))))
(define top-sort
  (lambda (graph name-of references-of)
    (let* ((adj assq)
           (g (map (lambda (x)
                     (list (name-of x)
                           (box (references-of x))
                           (box #f)
                           x))
                   graph))
           (gt (let ((gt (map (match-lambda
                                ((n _ _ name)
                                 (list n (box empty-set) (box #f) n)))
                              g)))
                 (for-each
                   (match-lambda
                     ((n nay _ _)
                      (for-each
                        (lambda (v)
                          (match (adj v gt)
                                 (#f #f)
                                 ((_ b _ _) (set-box! b (cons n (unbox b))))))
                        (unbox nay))))
                   g)
                 gt))
           (visit (lambda (vg)
                    (letrec ((visit (lambda (g l)
                                      (match g
                                             (#f l)
                                             ((n nay mark name)
                                              (if (unbox mark)
                                                l
                                                (begin
                                                  (set-box! mark #t)
                                                  (cons name
                                                        (foldr (lambda (v l)
                                                                 (visit (adj v
                                                                             vg)
                                                                        l))
                                                               l
                                                               (unbox nay))))))))))
                      visit)))
           (visit-gt (visit gt))
           (visit-g (visit g))
           (post (foldr visit-gt '() gt))
           (pre (foldl (lambda (gg l)
                         (match (visit-g (adj gg g) '())
                                (() l)
                                (c (cons c l))))
                       '()
                       post)))
      (reverse pre))))
(define genlet #t)
(define genmatch #t)
(define letonce #f)
(define type-defs
  (lambda (d)
    (for-each
      (match-lambda
        ((? defstruct? b) (type-structure b))
        ((? datatype? b) (type-structure b))
        (c (type-component c #t)))
      (make-components d))
    (close '())))
(define type-structure
  (match-lambda
    (($ defstruct
        x
        _
        make
        pred
        get
        set
        getn
        setn
        mutable)
     (let* ((vars (map (lambda (_) (gensym)) get))
            (make-get-type
              (lambda (getter v)
                (match getter
                       (($ some b)
                        (set-name-ty!
                          b
                          (closeall
                            (r+ initial-type-env `((,x ,@vars) -> ,v)))))
                       (_ #f))))
            (make-set-type
              (lambda (setter v)
                (match setter
                       (($ some b)
                        (set-name-ty!
                          b
                          (closeall
                            (r+ initial-type-env `((,x ,@vars) ,v -> void)))))
                       (_ #f)))))
       (set-name-ty!
         make
         (closeall
           (r+ initial-type-env `(,@vars -> (,x ,@vars)))))
       (set-name-ty!
         pred
         (closeall
           (r+ initial-type-env
               `((+ (,x ,@vars) y) -> bool))))
       (for-each2 make-get-type get vars)
       (for-each2 make-set-type set vars)
       (for-each2 make-get-type getn vars)
       (for-each2 make-set-type setn vars)))
    (($ datatype dt)
     (for-each
       (match-lambda
         ((type . variants)
          (for-each
            (match-lambda
              (($ variant con pred arg-types)
               (set-name-ty!
                 con
                 (closeall
                   (r+ initial-type-env
                       `(,@(cdr arg-types) -> ,type))))
               (set-name-ty!
                 pred
                 (closeall
                   (r+ initial-type-env
                       `((+ ,(name-predicate pred) x) -> bool))))))
            variants)))
       dt))))
(define type-component
  (lambda (component top)
    (when verbose
          (let ((cnames
                  (filter-map
                    (match-lambda (($ define b _) (name-name b)))
                    component)))
            (unless
              (null? cnames)
              (printf "Typing ~a~%" cnames))))
    (let* ((f (match-lambda (($ define b e) (make-bind b e))))
           (bindings (map f component))
           (names (map (match-lambda (($ define b _) (pname b)))
                       component))
           (f1 (match-lambda
                 (($ define b _) (set-name-ty! b (tvar)))))
           (f2 (match-lambda
                 ((and d ($ define b e))
                  (set-define-exp! d (w e names)))))
           (f3 (match-lambda
                 (($ define b e) (unify (name-ty b) (typeof e)))))
           (f4 (match-lambda (($ define b _) (name-ty b))))
           (f5 (lambda (d ts)
                 (match d (($ define b _) (set-name-ty! b ts))))))
      (push-level)
      (for-each f1 component)
      (for-each f2 component)
      (for-each f3 component)
      (for-each limit-expansive component)
      (for-each
        f5
        component
        (close (map f4 component)))
      (pop-level))))
(define w
  (lambda (e component)
    (match e
           (($ const _ pred)
            (make-type
              (r+ initial-type-env (name-predicate pred))
              e))
           (($ var x)
            (unless
              (name-ty x)
              (set-name-ty!
                x
                (if (name-mutated x)
                  (monotvar)
                  (let* ((_1 (push-level))
                         (t (closeall (tvar)))
                         (_2 (pop-level)))
                    t))))
            (if (ts? (name-ty x))
              (match-let*
                ((tynode (make-type #f #f))
                 ((t absv) (instantiate (name-ty x) tynode)))
                (set-type-ty! tynode t)
                (set-type-exp!
                  tynode
                  (match (name-primitive x)
                         ('imprecise
                          (make-check (list absv #f #f #f component) e))
                         ('check
                          (make-check
                            (list (cons top absv) #f #f #f component)
                            e))
                         ('nocheck e)
                         (#t
                          (make-check
                            (list absv (mk-definite-prim t) #f #f component)
                            e))
                         (#f
                          (make-check (list absv #f #f #t component) e))))
                tynode)
              e))
           (($ lam x e1)
            (for-each (lambda (b) (set-name-ty! b (tvar))) x)
            (match-let*
              ((body (w e1 component))
               ((t absv)
                (r+collect
                  initial-type-env
                  `(,@(map name-ty x) -> ,(typeof body)))))
              (make-type
                t
                (make-check
                  (list absv (mk-definite-lam t) #f #f component)
                  (make-lam x body)))))
           (($ vlam x rest e1)
            (for-each (lambda (b) (set-name-ty! b (tvar))) x)
            (match-let*
              ((z (tvar))
               (_ (set-name-ty!
                    rest
                    (r+ initial-type-env `(list ,z))))
               (body (w e1 component))
               ((t absv)
                (r+collect
                  initial-type-env
                  `(,@(map name-ty x) (&list ,z) -> ,(typeof body)))))
              (make-type
                t
                (make-check
                  (list absv (mk-definite-lam t) #f #f component)
                  (make-vlam x rest body)))))
           (($ app e0 args)
            (match-let*
              ((t0 (w e0 component))
               (targs (maplr (lambda (e) (w e component)) args))
               (a* (map (lambda (_) (tvar)) args))
               (b (tvar))
               ((t absv)
                (r-collect initial-type-env `(,@a* -> ,b)))
               (definf (mk-definite-app t)))
              (unify (typeof t0) t)
              (for-each2 unify (map typeof targs) a*)
              (if (syntactically-a-procedure? t0)
                (make-type b (make-app t0 targs))
                (make-type
                  b
                  (make-check
                    (list absv definf #f #f component)
                    (make-app t0 targs))))))
           (($ let b e2)
            (let* ((do-bind
                     (match-lambda
                       (($ bind b e)
                        (if genlet
                          (let* ((_ (push-level))
                                 (e (w e (list (pname b))))
                                 (bind (make-bind b e)))
                            (limit-expansive bind)
                            (set-name-ty! b (car (close (list (typeof e)))))
                            (pop-level)
                            bind)
                          (let ((e (w e component)))
                            (set-name-ty! b (typeof e))
                            (make-bind b e))))))
                   (tb (map do-bind b))
                   (body (w e2 component)))
              (make-let tb body)))
           (($ let* b e2)
            (let* ((do-bind
                     (match-lambda
                       (($ bind b e)
                        (if genlet
                          (let* ((_ (push-level))
                                 (e (w e (list (pname b))))
                                 (bind (make-bind b e)))
                            (limit-expansive bind)
                            (set-name-ty! b (car (close (list (typeof e)))))
                            (pop-level)
                            bind)
                          (let ((e (w e component)))
                            (set-name-ty! b (typeof e))
                            (make-bind b e))))))
                   (tb (maplr do-bind b))
                   (body (w e2 component)))
              (make-let* tb body)))
           (($ letr b e2)
            (let* ((do-comp
                     (lambda (b)
                       (if genlet
                         (let* ((f1 (match-lambda
                                      (($ bind b _) (set-name-ty! b (tvar)))))
                                (names (map (match-lambda
                                              (($ bind b _) (pname b)))
                                            b))
                                (f2 (match-lambda
                                      (($ bind b e)
                                       (make-bind b (w e names)))))
                                (f3 (match-lambda
                                      (($ bind b e)
                                       (unify (name-ty b) (typeof e))
                                       (name-ty b))))
                                (f4 (lambda (bind ts)
                                      (match bind
                                             (($ bind b _)
                                              (set-name-ty! b ts)))))
                                (_1 (push-level))
                                (_2 (for-each f1 b))
                                (tb (maplr f2 b))
                                (_3 (for-each limit-expansive tb))
                                (ts-list (close (maplr f3 tb))))
                           (pop-level)
                           (for-each2 f4 tb ts-list)
                           tb)
                         (let* ((f1 (match-lambda
                                      (($ bind b _) (set-name-ty! b (tvar)))))
                                (f2 (match-lambda
                                      (($ bind b e)
                                       (make-bind b (w e component)))))
                                (f3 (match-lambda
                                      (($ bind b e)
                                       (unify (name-ty b) (typeof e)))))
                                (_1 (for-each f1 b))
                                (tb (maplr f2 b)))
                           (for-each f3 tb)
                           tb))))
                   (comps (make-letrec-components b))
                   (tb (foldr append '() (maplr do-comp comps))))
              (make-letr tb (w e2 component))))
           (($ body defs exps)
            (for-each
              (match-lambda
                ((? defstruct? b) (type-structure b))
                ((? datatype? b) (type-structure b))
                (c (type-component c #f)))
              (make-body-components defs))
            (let ((texps (maplr (lambda (x) (w x component)) exps)))
              (make-body defs texps)))
           (($ and exps)
            (let* ((texps (maplr (lambda (x) (w x component)) exps))
                   (t (match texps
                             (() (r+ initial-type-env 'true))
                             ((e) (typeof e))
                             (_ (let ((a (r+ initial-type-env 'false)))
                                  (unify (typeof (rac texps)) a)
                                  a)))))
              (make-type t (make-and texps))))
           (($ or exps)
            (let* ((texps (maplr (lambda (x) (w x component)) exps))
                   (t (match texps
                             (() (r+ initial-type-env 'false))
                             ((e) (typeof e))
                             (_ (let* ((t-last (typeof (rac texps)))
                                       (but-last (rdc texps))
                                       (a (tvar)))
                                  (for-each
                                    (lambda (e)
                                      (unify (typeof e)
                                             (r+ initial-type-env
                                                 `(+ (not false) ,a))))
                                    but-last)
                                  (unify t-last
                                         (r+ initial-type-env
                                             `(+ (not false) ,a)))
                                  t-last)))))
              (make-type t (make-or texps))))
           (($ begin exps)
            (let ((texps (maplr (lambda (x) (w x component)) exps)))
              (make-begin texps)))
           (($ if test then els)
            (let ((ttest (w test component))
                  (tthen (w then component))
                  (tels (w els component))
                  (a (tvar)))
              (unify (typeof tthen) a)
              (unify (typeof tels) a)
              (make-type a (make-if ttest tthen tels))))
           (($ delay e2)
            (let ((texp (w e2 component)))
              (make-type
                (r+ initial-type-env `(promise ,(typeof texp)))
                (make-delay texp))))
           (($ set! x body)
            (unless (name-ty x) (set-name-ty! x (monotvar)))
            (let* ((body (w body component))
                   (t (if (ts? (name-ty x))
                        (car (instantiate (name-ty x) #f))
                        (name-ty x))))
              (unify t (typeof body))
              (make-type
                (r+ initial-type-env 'void)
                (make-set! x body))))
           (($ record bind)
            (let* ((tbind (map (match-lambda
                                 (($ bind name exp)
                                  (make-bind name (w exp component))))
                               bind))
                   (t (r+ initial-type-env
                          `(record
                             ,@(map (match-lambda
                                      (($ bind name exp)
                                       (list name (typeof exp))))
                                    tbind)))))
              (make-type t (make-record tbind))))
           (($ field name exp)
            (match-let*
              ((texp (w exp component))
               (a (tvar))
               ((t absv)
                (r-collect initial-type-env `(record (,name ,a)))))
              (unify (typeof texp) t)
              (make-type
                a
                (make-check
                  (list absv #f #f #f component)
                  (make-field name texp)))))
           (($ cast (ty t absv) exp)
            (let ((texp (w exp component)) (a (tvar)))
              (unify (r+ initial-type-env `(,(typeof texp) -> ,a))
                     t)
              (make-type
                a
                (make-check
                  (list absv #f #f #f component)
                  (make-cast (list ty t absv) texp)))))
           (($ match exp clauses)
            (for-each
              (match-lambda
                (($ mclause p _ (? name? fail))
                 (set-name-ty!
                   fail
                   (r+ initial-type-env '(a ?-> b))))
                (_ #f))
              clauses)
            (match-let*
              ((iclauses
                 (improve-clauses
                   (append
                     clauses
                     (list (make-mclause (make-pelse) #f #f)))))
               ((tmatch absv precise)
                (w-match (rdc iclauses) (rac iclauses)))
               (texp (w exp component))
               (_ (unify (typeof texp) tmatch))
               (tclauses
                 (maplr (match-lambda
                          (($ mclause p e fail)
                           (make-mclause p (w e component) fail)))
                        clauses))
               (a (tvar)))
              (for-each
                (match-lambda
                  (($ mclause _ e _) (unify (typeof e) a)))
                tclauses)
              (make-type
                a
                (make-check
                  (list absv #f (not precise) #f component)
                  (make-match texp tclauses))))))))
(define w-match
  (lambda (clauses last)
    (letrec ((bindings '())
             (encode
               (match-lambda
                 (($ pand pats) (encode* pats))
                 (x (encode* (list x)))))
             (encode*
               (lambda (pats)
                 (let* ((concrete?
                          (lambda (p)
                            (or (pconst? p) (pobj? p) (ppred? p) (pelse? p))))
                        (var? (lambda (p) (or (pvar? p) (pany? p))))
                        (not-var?
                          (lambda (p)
                            (and (not (pvar? p)) (not (pany? p)))))
                        (t (match (filter concrete? pats)
                                  ((p)
                                   (r+ initial-type-env
                                       (match (template p)
                                              ((x) x)
                                              (x `(+ ,@x)))))
                                  (()
                                   (r+ initial-type-env
                                       `(+ ,@(apply append
                                                    (map template
                                                         (filter
                                                           not-var?
                                                           pats)))
                                           ,@(if (null? (filter var? pats))
                                               '()
                                               (list (out1tvar)))))))))
                   (for-each
                     (match-lambda
                       (($ pvar b)
                        (set! bindings (cons b bindings))
                        (set-name-ty! b (pat-var-bind t))))
                     (filter pvar? pats))
                   t)))
             (template
               (match-lambda
                 ((? pelse?) '())
                 (($ pconst _ pred) (list (name-predicate pred)))
                 ((and pat ($ pobj c args))
                  (list (cond ((or (eq? %vector? c) (eq? %cvector? c))
                               (cons (if (eq? %vector? c) 'vec 'cvec)
                                     (match (maplr encode args)
                                            (() (list (out1tvar)))
                                            ((first . rest)
                                             (list (foldr (lambda (x y)
                                                            (unify x y)
                                                            y)
                                                          first
                                                          rest))))))
                              (else
                               (cons (car (name-predicate c))
                                     (maplr encode args))))))
                 (($ ppred pred)
                  (cond ((eq? pred %boolean?) (list 'true 'false))
                        ((eq? pred %list?) (list `(list ,(out1tvar))))
                        (else
                         (list (cons (car (name-predicate pred))
                                     (maplr (lambda (_) (out1tvar))
                                            (cdr (name-predicate pred))))))))
                 (($ pnot (? pconst?)) '())
                 (($ pnot ($ ppred pred))
                  (cond ((eq? pred %boolean?) '((not true) (not false)))
                        ((eq? pred %procedure?) '((not ?->)))
                        ((eq? pred %list?) '())
                        (else `((not ,(car (name-predicate pred)))))))
                 (($ pnot ($ pobj pred pats))
                  (let ((m (foldr + 0 (map non-triv pats))))
                    (case m
                      ((0) `((not ,(car (name-predicate pred)))))
                      ((1)
                       `((,(car (name-predicate pred))
                          ,@(map (match-lambda
                                   (($ pobj pred _)
                                    `(+ (not ,(car (name-predicate pred)))
                                        ,(out1tvar)))
                                   (($ ppred pred)
                                    `(+ (not ,(car (name-predicate pred)))
                                        ,(out1tvar)))
                                   (_ (out1tvar)))
                                 pats))))
                      (else '()))))))
             (non-triv
               (match-lambda
                 ((? pvar?) 0)
                 ((? pany?) 0)
                 ((? pelse?) 0)
                 ((? pconst?) 2)
                 (($ pobj _ pats) (foldr + 1 (map non-triv pats)))
                 (_ 1)))
             (precise
               (match-lambda
                 ((? pconst?) #f)
                 (($ pand pats) (andmap precise pats))
                 (($ pnot pat) (precise pat))
                 (($ pobj pred pats)
                  (let ((m (foldr + 0 (map non-triv pats))))
                    (case m
                      ((0) #t)
                      ((1) (andmap precise pats))
                      (else #f))))
                 (($ ppred pred) (not (eq? pred %list?)))
                 (_ #t))))
      (push-level)
      (match-let*
        ((precise-match
           (and (andmap
                  (match-lambda (($ mclause _ _ fail) (not fail)))
                  clauses)
                (match last (($ mclause p _ _) (precise p)))))
         (types (maplr (match-lambda (($ mclause p _ _) (encode p)))
                       clauses))
         ((t absv)
          (r-match
            (foldr (lambda (x y) (unify x y) y) (tvar) types))))
        (unify (out1tvar) t)
        (for-each limit-name bindings)
        (for-each2
          set-name-ty!
          bindings
          (close (map name-ty bindings)))
        (pop-level)
        '(pretty-print
           `(match-input
              ,@(map (match-lambda (($ mclause p _ _) (ppat p)))
                     clauses)))
        '(pretty-print
           `(match-type
              ,(ptype t)
              ,@(map (lambda (b) (list (pname b) (ptype (name-ty b))))
                     bindings)))
        (list t absv precise-match)))))
(define syntactically-a-procedure?
  (match-lambda
    (($ type _ e) (syntactically-a-procedure? e))
    (($ check _ e) (syntactically-a-procedure? e))
    (($ var x) (name-primitive x))
    ((? lam?) #t)
    ((? vlam?) #t)
    (($ let _ body)
     (syntactically-a-procedure? body))
    (($ let* _ body)
     (syntactically-a-procedure? body))
    (($ letr _ body)
     (syntactically-a-procedure? body))
    (($ if _ e2 e3)
     (and (syntactically-a-procedure? e2)
          (syntactically-a-procedure? e3)))
    (($ begin exps)
     (syntactically-a-procedure? (rac exps)))
    (($ body _ exps)
     (syntactically-a-procedure? (rac exps)))
    (_ #f)))
(define typeof
  (match-lambda
    (($ type t _) t)
    (($ check _ e) (typeof e))
    (($ let _ body) (typeof body))
    (($ let* _ body) (typeof body))
    (($ letr _ body) (typeof body))
    (($ body _ exps) (typeof (rac exps)))
    (($ begin exps) (typeof (rac exps)))
    (($ var x) (name-ty x))))
(define limit-name
  (lambda (n)
    (when (name-mutated n)
          (unify (name-ty n) (out1tvar)))))
(define limit-expansive
  (letrec ((limit! (lambda (t) (unify t (out1tvar))))
           (expansive-pattern?
             (match-lambda
               ((? pconst?) #f)
               (($ pvar x) (name-mutated x))
               (($ pobj _ pats) (ormap expansive-pattern? pats))
               ((? pany?) #f)
               ((? pelse?) #f)
               (($ pand pats) (ormap expansive-pattern? pats))
               (($ ppred x) (name-mutated x))
               (($ pnot pat) (expansive-pattern? pat))))
           (limit-expr
             (match-lambda
               (($ bind b e)
                (if (name-mutated b)
                  (limit! (typeof e))
                  (limit-expr e)))
               ((? defstruct?) #f)
               ((? datatype?) #f)
               (($ define x e)
                (if (and x (name-mutated x))
                  (limit! (typeof e))
                  (limit-expr e)))
               (($ type
                   t
                   ($ app ($ type _ ($ check _ ($ var x))) exps))
                (cond ((list? (name-pure x))
                       (if (= (length (name-pure x)) (length exps))
                         (for-each2
                           (lambda (pure e)
                             (if pure (limit-expr e) (limit! (typeof e))))
                           (name-pure x)
                           exps)
                         (limit! t)))
                      ((or (eq? #t (name-pure x))
                           (and (eq? 'cons (name-pure x))
                                (not cons-is-mutable)))
                       (for-each limit-expr exps))
                      (else (limit! t))))
               (($ type t ($ app _ _)) (limit! t))
               (($ type t ($ check _ ($ app _ _))) (limit! t))
               (($ delay _) #f)
               (($ type t ($ set! _ _)) (limit! t))
               (($ var _) #f)
               ((? const?) #f)
               (($ lam _ _) #f)
               (($ vlam _ _ _) #f)
               (($ let bind body)
                (limit-expr body)
                (for-each limit-expr bind))
               (($ let* bind body)
                (limit-expr body)
                (for-each limit-expr bind))
               (($ letr bind body)
                (limit-expr body)
                (for-each limit-expr bind))
               (($ body defs exps)
                (for-each limit-expr defs)
                (for-each limit-expr exps))
               (($ and exps) (for-each limit-expr exps))
               (($ or exps) (for-each limit-expr exps))
               (($ begin exps) (for-each limit-expr exps))
               (($ if e1 e2 e3)
                (limit-expr e1)
                (limit-expr e2)
                (limit-expr e3))
               (($ record bind)
                (for-each
                  (match-lambda (($ bind _ e) (limit-expr e)))
                  bind))
               (($ field _ exp) (limit-expr exp))
               (($ cast _ exp) (limit-expr exp))
               (($ match exp clauses)
                (limit-expr exp)
                (for-each
                  (match-lambda
                    (($ mclause pat body fail)
                     (if (or (and fail (name-mutated fail))
                             (expansive-pattern? pat))
                       (limit! (typeof body))
                       (limit-expr body))))
                  clauses))
               (($ type _ e1) (limit-expr e1))
               (($ check _ e1) (limit-expr e1)))))
    limit-expr))
(define unparse
  (lambda (e check-action)
    (letrec ((pbind (match-lambda
                      (($ bind n e) (list (pname n) (pexpr e)))))
             (pexpr (match-lambda
                      ((and x ($ type _ (? check?)))
                       (check-action x pexpr))
                      (($ type _ exp) (pexpr exp))
                      (($ shape t exp) (pexpr exp))
                      (($ define x e)
                       (if (or (not x) (and (name? x) (not (name-name x))))
                         (pexpr e)
                         `(define ,(pname x) ,(pexpr e))))
                      (($ defstruct _ args _ _ _ _ _ _ _)
                       `(check-define-const-structure ,args))
                      (($ datatype d)
                       `(datatype
                          ,@(map (match-lambda
                                   (((tag . args) . bindings)
                                    (cons (cons (ptag tag) args)
                                          (map (match-lambda
                                                 (($ variant _ _ types) types))
                                               bindings))))
                                 d)))
                      (($ and exps) `(and ,@(maplr pexpr exps)))
                      (($ or exps) `(or ,@(maplr pexpr exps)))
                      (($ begin exps) `(begin ,@(maplr pexpr exps)))
                      (($ var x) (pname x))
                      (($ prim x) (pname x))
                      (($ const x _) (pconst x))
                      (($ lam x e1)
                       `(lambda ,(maplr pname x) ,@(pexpr e1)))
                      (($ vlam x rest e1)
                       `(lambda ,(append (maplr pname x) (pname rest))
                          ,@(pexpr e1)))
                      (($ match e1 clauses)
                       (let* ((pclause
                                (match-lambda
                                  (($ mclause p #f #f)
                                   `(,(ppat p) <last clause>))
                                  (($ mclause p exp fail)
                                   (if fail
                                     `(,(ppat p)
                                       (=> ,(pname fail))
                                       ,@(pexpr exp))
                                     `(,(ppat p) ,@(pexpr exp))))))
                              (p1 (pexpr e1)))
                         `(match ,p1 ,@(maplr pclause clauses))))
                      (($ app e1 args)
                       (let* ((p1 (pexpr e1))
                              (pargs (maplr pexpr args))
                              (unkwote
                                (match-lambda
                                  (('quote x) x)
                                  ((? boolean? x) x)
                                  ((? number? x) x)
                                  ((? char? x) x)
                                  ((? string? x) x)
                                  ((? null? x) x)
                                  ((? box? x) x)
                                  ((? vector? x) x))))
                         (cond ((eq? p1 qlist) `',(maplr unkwote pargs))
                               ((eq? p1 qcons)
                                (let ((unq (maplr unkwote pargs)))
                                  `',(cons (car unq) (cadr unq))))
                               ((eq? p1 qbox) (box (unkwote (car pargs))))
                               ((eq? p1 qvector)
                                (list->vector (maplr unkwote pargs)))
                               (else (cons p1 pargs)))))
                      (($ let b e2)
                       (let ((pb (maplr pbind b)))
                         `(let ,pb ,@(pexpr e2))))
                      (($ let* b e2)
                       (let ((pb (maplr pbind b)))
                         `(let* ,pb ,@(pexpr e2))))
                      (($ letr b e2)
                       (let ((pb (maplr pbind b)))
                         `(letrec ,pb ,@(pexpr e2))))
                      (($ body defs exps)
                       (let ((pdefs (maplr pexpr defs)))
                         (append pdefs (maplr pexpr exps))))
                      (($ if e1 e2 e3)
                       (let* ((p1 (pexpr e1)) (p2 (pexpr e2)) (p3 (pexpr e3)))
                         `(if ,p1 ,p2 ,p3)))
                      (($ record bindings)
                       `(record ,@(maplr pbind bindings)))
                      (($ field x e2) `(field ,x ,(pexpr e2)))
                      (($ cast (ty . _) e2) `(: ,ty ,(pexpr e2)))
                      (($ delay e) `(delay ,(pexpr e)))
                      (($ set! x e) `(set! ,(pname x) ,(pexpr e))))))
      (pexpr e))))
(define pexpr
  (lambda (ex)
    (unparse
      ex
      (lambda (e pexpr)
        (match e
               (($ type _ ($ check _ exp)) (pexpr exp)))))))
(define pdef pexpr)
(define ppat
  (match-lambda
    (($ pconst x _) (pconst x))
    (($ pvar x) (pname x))
    (($ pany) '_)
    (($ pelse) 'else)
    (($ pnot pat) `(not ,(ppat pat)))
    (($ pand pats) `(and ,@(maplr ppat pats)))
    (($ ppred pred)
     (match (pname pred)
            ('false-object? #f)
            ('true-object? #t)
            ('null? '())
            (x `(? ,x))))
    (($ pobj tag args)
     (match (cons (pname tag) args)
            (('box? x) (box (ppat x)))
            (('pair? x y) (cons (ppat x) (ppat y)))
            (('vector? . x) (list->vector (maplr ppat x)))
            ((tg . _) `($ ,(strip-? tg) ,@(maplr ppat args)))))))
(define strip-?
  (lambda (s)
    (let* ((str (symbol->string s))
           (n (string-length str)))
      (if (or (zero? n)
              (not (char=? #\? (string-ref str (- n 1)))))
        s
        (string->symbol (substring str 0 (- n 1)))))))
(define pname
  (match-lambda
    ((? name? x) (or (name-name x) '<expr>))
    ((? symbol? x) x)))
(define ptag
  (match-lambda
    ((? k? k) (k-name k))
    ((? symbol? x) x)))
(define pconst
  (match-lambda
    ((? symbol? x) `',x)
    ((? boolean? x) x)
    ((? number? x) x)
    ((? char? x) x)
    ((? string? x) x)
    ((? null? x) `',x)))
(define check
  (lambda (file)
    (output-checked file '() type-check?)))
(define profcheck
  (lambda (file)
    (output-checked #f '() type-check?)
    (output-checked
      #f
      (make-counters total-possible)
      type-check?)))
(define fullcheck
  (lambda (file)
    (let ((check? (lambda (_) #t)))
      (output-checked #f '() check?)
      (output-checked
        #f
        (make-counters total-possible)
        check?))))
(define make-counters
  (lambda (n)
    (let* ((init `(define check-counters (make-vector ,n 0)))
           (sum '(define check-total
                   (lambda ()
                     (let ((foldr (lambda (f i l)
                                    (recur loop
                                           ((l l))
                                           (match l
                                                  (() i)
                                                  ((x . y) (f x (loop y))))))))
                       (foldr + 0 (vector->list check-counters))))))
           (incr '(extend-syntax
                    (check-increment-counter)
                    ((check-increment-counter c)
                     (vector-set!
                       check-counters
                       c
                       (+ 1 (vector-ref check-counters c)))))))
      (list init sum incr))))
(define output-checked
  (lambda (file header check-test)
    (set! summary '())
    (set! total-possible 0)
    (set! total-cast 0)
    (set! total-err 0)
    (set! total-any 0)
    (let ((doit (lambda ()
                  (when (string? file)
                        (printf
                          ";; Generated by Soft Scheme ~a~%"
                          st:version)
                        (printf ";; (st:control")
                        (for-each
                          (lambda (x) (printf " '~a" x))
                          (show-controls))
                        (printf ")~%")
                        (unless
                          (= 0 n-unbound)
                          (printf
                            ";; CAUTION: ~a unbound references, this code is not safe~%"
                            n-unbound))
                        (printf "~%")
                        (for-each pretty-print header))
                  (for-each
                    (lambda (exp)
                      (match exp
                             (($ define x _)
                              (set! n-possible 0)
                              (set! n-clash 0)
                              (set! n-err 0)
                              (set! n-match 0)
                              (set! n-inexhaust 0)
                              (set! n-prim 0)
                              (set! n-lam 0)
                              (set! n-app 0)
                              (set! n-field 0)
                              (set! n-cast 0)
                              (if file
                                (pretty-print (pcheck exp check-test))
                                (pcheck exp check-test))
                              (make-summary-line x)
                              (set! total-possible
                                (+ total-possible n-possible))
                              (set! total-cast (+ total-cast n-cast))
                              (set! total-err (+ total-err n-err))
                              (set! total-any
                                (+ total-any
                                   n-match
                                   n-inexhaust
                                   n-prim
                                   n-lam
                                   n-app
                                   n-field
                                   n-cast)))
                             (_ (when file
                                      (pretty-print
                                        (pcheck exp check-test))))))
                    tree)
                  (when (string? file)
                        (newline)
                        (newline)
                        (print-summary "; ")))))
      (if (string? file)
        (begin
          (delete-file file)
          (with-output-to-file file doit))
        (doit)))))
(define total-possible 0)
(define total-err 0)
(define total-cast 0)
(define total-any 0)
(define n-possible 0)
(define n-clash 0)
(define n-err 0)
(define n-match 0)
(define n-inexhaust 0)
(define n-prim 0)
(define n-lam 0)
(define n-app 0)
(define n-field 0)
(define n-cast 0)
(define summary '())
(define make-summary-line
  (lambda (x)
    (let ((total (+ n-match
                    n-inexhaust
                    n-prim
                    n-lam
                    n-app
                    n-field
                    n-cast)))
      (unless
        (= 0 total)
        (let* ((s (sprintf
                    "~a~a "
                    (padr (pname x) 16)
                    (padl total 2)))
               (s (cond ((< 0 n-inexhaust)
                         (sprintf
                           "~a (~a match ~a inexhaust)"
                           s
                           n-match
                           n-inexhaust))
                        ((< 0 n-match)
                         (sprintf "~a (~a match)" s n-match))
                        (else s)))
               (s (if (< 0 n-prim)
                    (sprintf "~a (~a prim)" s n-prim)
                    s))
               (s (if (< 0 n-field)
                    (sprintf "~a (~a field)" s n-field)
                    s))
               (s (if (< 0 n-lam)
                    (sprintf "~a (~a lambda)" s n-lam)
                    s))
               (s (if (< 0 n-app) (sprintf "~a (~a ap)" s n-app) s))
               (s (if (< 0 n-err)
                    (sprintf "~a (~a ERROR)" s n-err)
                    s))
               (s (if (< 0 n-cast)
                    (sprintf "~a (~a TYPE)" s n-cast)
                    s)))
          (set! summary (cons s summary)))))))
(define print-summary
  (lambda (hdr)
    (for-each
      (lambda (s) (printf "~a~a~%" hdr s))
      (reverse summary))
    (printf
      "~a~a~a "
      hdr
      (padr "TOTAL CHECKS" 16)
      (padl total-any 2))
    (printf
      " (of ~s is ~s%)"
      total-possible
      (if (= 0 total-possible)
        0
        (string->number
          (chop-number
            (exact->inexact
              (* (/ total-any total-possible) 100))
            4))))
    (when (< 0 total-err)
          (printf " (~s ERROR)" total-err))
    (when (< 0 total-cast)
          (printf " (~s TYPE)" total-cast))
    (printf "~%")))
(define padl
  (lambda (arg n)
    (let ((s (sprintf "~a" arg)))
      (recur loop
             ((s s))
             (if (< (string-length s) n)
               (loop (string-append " " s))
               s)))))
(define padr
  (lambda (arg n)
    (let ((s (sprintf "~a" arg)))
      (recur loop
             ((s s))
             (if (< (string-length s) n)
               (loop (string-append s " "))
               s)))))
(define chop-number
  (lambda (x n)
    (substring
      (sprintf "~s00000000000000000000" x)
      0
      (- n 1))))
(define pcheck
  (lambda (ex check-test)
    (unparse
      ex
      (lambda (e pexpr)
        (match e
               ((and z ($ type _ ($ check inf ($ var x))))
                (cond ((name-primitive x)
                       (set! n-possible (+ 1 n-possible))
                       (match (check-test inf)
                              (#f (pname x))
                              ('def
                               (set! n-err (+ 1 n-err))
                               (set! n-prim (+ 1 n-prim))
                               `(,(symbol-append "CHECK-" (pname x))
                                 ,(tree-index z)
                                 ',(string->symbol "ERROR")))
                              (_ (set! n-prim (+ 1 n-prim))
                                 `(,(symbol-append "CHECK-" (pname x))
                                   ,(tree-index z)))))
                      ((name-unbound? x) `(check-bound ,(pname x)))
                      (else
                       (if (check-test inf)
                         (begin
                           (set! n-clash (+ 1 n-clash))
                           `(,(string->symbol "CLASH")
                             ,(pname x)
                             ,(tree-index z)))
                         (pname x)))))
               ((and z
                     ($ type _ ($ check inf (and m ($ lam x e1)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       ('def
                        (set! n-err (+ 1 n-err))
                        (set! n-lam (+ 1 n-lam))
                        `(,(string->symbol "CHECK-lambda")
                          (,(tree-index z) ',(string->symbol "ERROR"))
                          ,(map pname x)
                          ,@(pexpr e1)))
                       (_ (set! n-lam (+ 1 n-lam))
                          `(,(string->symbol "CHECK-lambda")
                            (,(tree-index z))
                            ,(map pname x)
                            ,@(pexpr e1)))))
               ((and z
                     ($ type
                        _
                        ($ check inf (and m ($ vlam x rest e1)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       ('def
                        (set! n-err (+ 1 n-err))
                        (set! n-lam (+ 1 n-lam))
                        `(,(string->symbol "CHECK-lambda")
                          (,(tree-index z) ',(string->symbol "ERROR"))
                          ,(append (map pname x) (pname rest))
                          ,@(pexpr e1)))
                       (_ (set! n-lam (+ 1 n-lam))
                          `(,(string->symbol "CHECK-lambda")
                            (,(tree-index z))
                            ,(append (map pname x) (pname rest))
                            ,@(pexpr e1)))))
               ((and z
                     ($ type _ ($ check inf (and m ($ app e1 args)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       ('def
                        (set! n-err (+ 1 n-err))
                        (set! n-app (+ 1 n-app))
                        `(,(string->symbol "CHECK-ap")
                          (,(tree-index z) ',(string->symbol "ERROR"))
                          ,(pexpr e1)
                          ,@(map pexpr args)))
                       (_ (set! n-app (+ 1 n-app))
                          (let ((p1 (pexpr e1)))
                            `(,(string->symbol "CHECK-ap")
                              (,(tree-index z))
                              ,p1
                              ,@(map pexpr args))))))
               ((and z
                     ($ type _ ($ check inf (and m ($ field x e1)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       ('def
                        (set! n-err (+ 1 n-err))
                        (set! n-field (+ 1 n-field))
                        `(,(string->symbol "CHECK-field")
                          (,(tree-index z) ',(string->symbol "ERROR"))
                          ,x
                          ,(pexpr e1)))
                       (_ (set! n-field (+ 1 n-field))
                          `(,(string->symbol "CHECK-field")
                            (,(tree-index z))
                            ,x
                            ,(pexpr e1)))))
               ((and z
                     ($ type
                        _
                        ($ check inf (and m ($ cast (x . _) e1)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       (_ (set! n-cast (+ 1 n-cast))
                          `(,(string->symbol "CHECK-:")
                            (,(tree-index z))
                            ,x
                            ,(pexpr e1)))))
               ((and z
                     ($ type
                        _
                        ($ check inf (and m ($ match e1 clauses)))))
                (set! n-possible (+ 1 n-possible))
                (match (check-test inf)
                       (#f (pexpr m))
                       (inx (let* ((pclause
                                     (match-lambda
                                       (($ mclause p exp fail)
                                        (if fail
                                          `(,(ppat p)
                                            (=> ,(pname fail))
                                            ,@(pexpr exp))
                                          `(,(ppat p) ,@(pexpr exp))))))
                                   (p1 (pexpr e1)))
                              (if (eq? 'inexhaust inx)
                                (begin
                                  (set! n-inexhaust (+ 1 n-inexhaust))
                                  `(,(string->symbol "CHECK-match")
                                    (,(tree-index z)
                                     ,(string->symbol "INEXHAUST"))
                                    ,p1
                                    ,@(maplr pclause clauses)))
                                (begin
                                  (set! n-match (+ 1 n-match))
                                  `(,(string->symbol "CHECK-match")
                                    (,(tree-index z))
                                    ,p1
                                    ,@(maplr pclause clauses)))))))))))))
(define tree-index-list '())
(define reinit-output!
  (lambda () (set! tree-index-list '())))
(define tree-index
  (lambda (syntax)
    (match (assq syntax tree-index-list)
           (#f
            (let ((n (length tree-index-list)))
              (set! tree-index-list
                (cons (cons syntax n) tree-index-list))
              n))
           ((_ . n) n))))
(define tree-unindex
  (lambda (n)
    (let ((max (length tree-index-list)))
      (when (<= max n)
            (use-error "Invalid CHECK number ~a" n))
      (car (list-ref tree-index-list (- (- max 1) n))))))
(define cause
  (lambda ()
    (for-each
      (lambda (def)
        (for-each pretty-print (exp-cause def)))
      tree)))
(define cause*
  (lambda names
    (if (null? names)
      (for-each
        (lambda (def)
          (for-each pretty-print (exp-cause def)))
        tree)
      (for-each
        (match-lambda
          ((? symbol? dname)
           (for-each
             pretty-print
             (exp-cause (find-global dname)))))
        names))))
(define exp-cause
  (let ((sum (lambda (exps)
               (foldr (lambda (x y) (append (exp-cause x) y))
                      '()
                      exps)))
        (src (lambda (inf)
               (let ((nonlocal (map tree-index (check-sources inf))))
                 (if (type-check1? inf)
                   (cons (check-local-sources inf) nonlocal)
                   nonlocal)))))
    (match-lambda
      ((and z ($ type ty ($ check inf ($ var x))))
       (if (name-primitive x)
         (if (type-check? inf)
           (list `((,(symbol-append 'check- (pname x))
                    ,(tree-index z))
                   ,@(src inf)))
           '())
         (if (type-check1? inf)
           (list `((clash ,(pname x) ,(tree-index z)) ,@(src inf)))
           '())))
      ((and z ($ type ty ($ check inf ($ lam x e1))))
       (append
         (if (type-check? inf)
           (list `((check-lambda ,(tree-index z) ,(map pname x) ...)
                   ,@(src inf)))
           '())
         (exp-cause e1)))
      ((and z
            ($ type ty ($ check inf ($ vlam x rest e1))))
       (append
         (if (type-check? inf)
           (list `((check-lambda
                     ,(tree-index z)
                     ,(append (map pname x) (pname rest))
                     ...)
                   ,@(src inf)))
           '())
         (exp-cause e1)))
      ((and z ($ type _ ($ check inf ($ app e1 args))))
       (append
         (if (type-check? inf)
           (list `((check-ap ,(tree-index z)) ,@(src inf)))
           '())
         (exp-cause e1)
         (sum args)))
      ((and z ($ type _ ($ check inf ($ field x e1))))
       (append
         (if (type-check? inf)
           (list `((check-field ,(tree-index z) ,x ...)
                   ,@(src inf)))
           '())
         (exp-cause e1)))
      ((and z
            ($ type _ ($ check inf ($ cast (x . _) e1))))
       (append
         (if (type-check? inf)
           (list `((check-: ,(tree-index z) ,x ...) ,@(src inf)))
           '())
         (exp-cause e1)))
      ((and z
            ($ type
               _
               ($ check inf (and m ($ match e1 clauses)))))
       (append
         (if (type-check? inf)
           (list `((check-match ,(tree-index z) ...) ,@(src inf)))
           '())
         (exp-cause m)))
      (($ define _ e) (exp-cause e))
      ((? defstruct?) '())
      ((? datatype?) '())
      (($ app e1 args) (sum (cons e1 args)))
      (($ match exp clauses)
       (foldr (lambda (x y)
                (append
                  (match x (($ mclause _ e _) (exp-cause e)))
                  y))
              (exp-cause exp)
              clauses))
      (($ var _) '())
      (($ and exps) (sum exps))
      (($ begin exps) (sum exps))
      ((? const?) '())
      (($ if test then els)
       (append
         (exp-cause test)
         (exp-cause then)
         (exp-cause els)))
      (($ let bindings body)
       (foldr (lambda (x y)
                (append (match x (($ bind _ e) (exp-cause e))) y))
              (exp-cause body)
              bindings))
      (($ let* bindings body)
       (foldr (lambda (x y)
                (append (match x (($ bind _ e) (exp-cause e))) y))
              (exp-cause body)
              bindings))
      (($ letr bindings body)
       (foldr (lambda (x y)
                (append (match x (($ bind _ e) (exp-cause e))) y))
              (exp-cause body)
              bindings))
      (($ body defs exps) (sum (append defs exps)))
      (($ or exps) (sum exps))
      (($ delay e) (exp-cause e))
      (($ set! var body) (exp-cause body))
      (($ record bindings)
       (foldr (lambda (x y)
                (append (match x (($ bind _ e) (exp-cause e))) y))
              '()
              bindings))
      (($ type _ exp) (exp-cause exp)))))
(define display-type tidy)
(define type
  (lambda names
    (if (null? names)
      (for-each globaldef tree)
      (for-each
        (match-lambda
          ((? symbol? x)
           (match (lookup? global-env x)
                  (#f (use-error "~a is not defined" x))
                  (ty (pretty-print
                        `(,x : ,(display-type (name-ty ty)))))))
          ((? number? n)
           (let* ((ty (check-type (tree-unindex n)))
                  (type (display-type ty)))
             (pretty-print `(,n : ,type))))
          (_ (use-error
               "arguments must be identifiers or CHECK numbers")))
        names))))
(define localtype
  (lambda names
    (if (null? names)
      (for-each localdef tree)
      (for-each
        (lambda (x) (localdef (find-global x)))
        names))))
(define find-global
  (lambda (name)
    (let ((d (ormap (match-lambda
                      ((and d ($ define x _))
                       (and (eq? name (name-name x)) d))
                      (_ #f))
                    tree)))
      (unless d (use-error "~a is not defined" name))
      d)))
(define globaldef
  (lambda (e)
    (match e
           (($ define x _)
            (let ((type (display-type (name-ty x))))
              (pretty-print `(,(pname x) : ,type))))
           (_ #f))))
(define localdef
  (lambda (e) (pretty-print (expdef e))))
(define expdef
  (let* ((show (lambda (x)
                 `(,(pname x) : ,(display-type (name-ty x)))))
         (pbind (match-lambda
                  (($ bind x e) `(,(show x) ,(expdef e))))))
    (match-lambda
      (($ define x e)
       (if (or (not x) (and (name? x) (not (name-name x))))
         (expdef e)
         `(define ,(show x) ,(expdef e))))
      ((? defstruct? d) (pdef d))
      ((? datatype? d) (pdef d))
      (($ and exps) `(and ,@(maplr expdef exps)))
      (($ app fun args)
       `(,(expdef fun) ,@(maplr expdef args)))
      (($ begin exps) `(begin ,@(maplr expdef exps)))
      (($ const c _) (pconst c))
      (($ if test then els)
       `(if ,(expdef test) ,(expdef then) ,(expdef els)))
      (($ lam params body)
       `(lambda ,(map show params) ,@(expdef body)))
      (($ vlam params rest body)
       `(lambda ,(append (map show params) (show rest))
          ,@(expdef body)))
      (($ let bindings body)
       `(let ,(map pbind bindings) ,@(expdef body)))
      (($ let* bindings body)
       `(let* ,(map pbind bindings) ,@(expdef body)))
      (($ letr bindings body)
       `(letrec ,(map pbind bindings) ,@(expdef body)))
      (($ body defs exps)
       (let ((pdefs (maplr expdef defs)))
         (append pdefs (maplr expdef exps))))
      (($ record bindings)
       `(record ,@(maplr pbind bindings)))
      (($ field x e) `(field ,x ,(expdef e)))
      (($ cast (ty . _) e) `(: ,ty ,(expdef e)))
      (($ or exps) `(or ,@(maplr expdef exps)))
      (($ delay e) `(delay ,(expdef e)))
      (($ set! x body)
       `(set! ,(pname x) ,(expdef body)))
      (($ var x) (pname x))
      (($ match e1 clauses)
       (let* ((pclause
                (match-lambda
                  (($ mclause p exp fail)
                   (if fail
                     `(,(expdef p) (=> ,(pname fail)) ,@(expdef exp))
                     `(,(expdef p) ,@(expdef exp))))))
              (p1 (expdef e1)))
         `(match ,p1 ,@(maplr pclause clauses))))
      (($ pconst x _) (pconst x))
      (($ pvar x) (show x))
      (($ pany) '_)
      (($ pelse) 'else)
      (($ pnot pat) `(not ,(expdef pat)))
      (($ pand pats) `(and ,@(maplr expdef pats)))
      (($ ppred pred)
       (match (pname pred)
              ('false-object? #f)
              ('true-object? #t)
              ('null? '())
              (x `(? ,x))))
      (($ pobj tag args)
       (match (cons (pname tag) args)
              (('pair? x y) (cons (expdef x) (expdef y)))
              (('box? x) (box (expdef x)))
              (('vector? . x) (list->vector (maplr expdef x)))
              ((tg . _)
               `($ ,(strip-? tg) ,@(maplr expdef args)))))
      (($ type _ exp) (expdef exp))
      (($ check _ exp) (expdef exp)))))
(define check-type
  (match-lambda
    (($ type ty ($ check inf ($ var x))) ty)
    (($ type ty ($ check inf ($ lam x e1))) ty)
    (($ type ty ($ check inf ($ vlam x rest e1))) ty)
    (($ type _ ($ check inf ($ app e1 args)))
     (typeof e1))
    (($ type _ ($ check inf ($ field x e1)))
     (typeof e1))
    (($ type _ ($ check inf ($ cast (x . _) e1)))
     (typeof e1))
    (($ type _ ($ check inf ($ match e1 clauses)))
     (typeof e1))))
(define tree '())
(define global-env empty-env)
(define verbose #f)
(define times #t)
(define benchmarking #f)
(define cons-mutators '(set-car! set-cdr!))
(define st:check
  (lambda args
    (parameterize
      ((print-level #f)
       (print-length #f)
       (pretty-maximum-lines #f))
      (let ((output (apply do-soft args)))
        (when output
              (printf
                "Typed program written to file ~a~%"
                output))))))
(define st:run
  (lambda (file)
    (parameterize
      ((optimize-level 3))
      (when benchmarking
            (printf "Reloading slow CHECKs...~%")
            (load (string-append
                    installation-directory
                    "checklib.scm"))
            (set! benchmarking #f))
      (load file))))
(define st:bench
  (lambda (file)
    (parameterize
      ((optimize-level 3))
      (unless
        benchmarking
        (unless
          fastlibrary-file
          (use-error
            "No benchmarking mode in this version"))
        (printf "Reloading fast CHECKs...~%")
        (load (string-append
                installation-directory
                fastlibrary-file))
        (set! benchmarking #t))
      (load file))))
(define st:
  (lambda args
    (parameterize
      ((print-level #f)
       (print-length #f)
       (pretty-maximum-lines #f))
      (let ((output (apply do-soft args)))
        (cond ((not output)
               (use-error "Output file name required to run"))
              ((= 0 n-unbound)
               (printf
                 "Typed program written to file ~a, executing ...~%"
                 output)
               (flush-output)
               (st:run output))
              (else
               (printf
                 "Typed program written to file ~a, not executing (unbound refs)~%"
                 output)))))))
(define do-soft
  (match-lambda*
    ((input (? string? output))
     (when (strip-suffix output)
           (use-error
             "output file name cannot end in .ss or .scm"))
     (cond ((string? input)
            (soft-files (list input) output)
            output)
           ((and (list? input) (andmap string? input))
            (soft-files input output)
            output)
           (else (soft-def input output) output)))
    ((input #f)
     (cond ((string? input) (soft-files (list input) #f) #f)
           ((and (list? input) (andmap string? input))
            (soft-files input #f)
            #f)
           (else (soft-def input #f) #f)))
    ((input)
     (cond ((string? input)
            (let ((o (string-append
                       (or (strip-suffix input) input)
                       ".soft")))
              (soft-files (list input) o)
              o))
           ((and (list? input) (andmap string? input))
            (use-error "Output file name required"))
           (else (soft-def input #t) #f)))
    (else (use-error
            "Input must be a file name or list of file names"))))
(define rawmode #f)
(define st:control
  (lambda args
    (let ((dbg (match-lambda
                 ('raw
                  (set! display-type ptype)
                  (set! rawmode #t))
                 ('!raw
                  (set! display-type tidy)
                  (set! rawmode #f))
                 ('verbose (set! verbose #t))
                 ('!verbose (set! verbose #f))
                 ('times (set! times #t))
                 ('!times (set! times #f))
                 ('partial (set! fullsharing #f))
                 ('!partial (set! fullsharing #t))
                 ('pseudo (set! pseudo pseudo-subtype))
                 ('!pseudo (set! pseudo #f))
                 ('populated (set! populated #t))
                 ('!populated (set! populated #f))
                 ('matchst (set! matchst #t))
                 ('!matchst (set! matchst #f))
                 ('genmatch (set! genmatch #t))
                 ('!genmatch (set! genmatch #f))
                 ('letonce (set! letonce #t))
                 ('!letonce (set! letonce #f))
                 ('global-error (set! global-error #t))
                 ('!global-error (set! global-error #f))
                 ('share (set! share #t))
                 ('!share (set! share #f))
                 ('flags (set! flags #t))
                 ('!flags (set! flags #f))
                 ('depths (set! dump-depths #t))
                 ('!depths (set! dump-depths #f))
                 ('match (set! keep-match #t))
                 ('!match (set! keep-match #f))
                 (x (printf "Error: unknown debug switch ~a~%" x)
                    (st:control)))))
      (if (null? args)
        (begin
          (printf "Current values:")
          (for-each
            (lambda (x) (printf " ~a" x))
            (show-controls))
          (printf "~%"))
        (for-each dbg args)))))
(define show-controls
  (lambda ()
    (list (if rawmode 'raw '!raw)
          (if verbose 'verbose '!verbose)
          (if times 'times '!times)
          (if share 'share '!share)
          (if flags 'flags '!flags)
          (if dump-depths 'depths '!depths)
          (if fullsharing '!partial 'partial)
          (if pseudo 'pseudo '!pseudo)
          (if populated 'populated '!populated)
          (if letonce 'letonce '!letonce)
          (if matchst 'matchst '!matchst)
          (if genmatch 'genmatch '!genmatch)
          (if global-error 'global-error '!global-error)
          (if keep-match 'match '!match))))
(define soft-def
  (lambda (exp output)
    (reinit-macros!)
    (reinit-types!)
    (reinit-output!)
    (set! visible-time 0)
    (match-let*
      ((before-parse (cpu-time))
       (defs (parse-def exp))
       (before-bind (cpu-time))
       ((defs env tenv unbound)
        (bind-defs
          defs
          initial-env
          initial-type-env
          '()
          0))
       (_ (warn-unbound unbound))
       (_ (if cons-is-mutable
            (printf
              "Note: use of ~a, treating cons as MUTABLE~%"
              cons-mutators)
            (printf
              "Note: no use of ~a, treating cons as immutable~%"
              cons-mutators)))
       (before-improve (cpu-time))
       (defs (improve-defs defs))
       (before-typecheck (cpu-time))
       (_ (type-check defs))
       (_ (set! global-env env))
       (before-output (cpu-time))
       (_ (check output))
       (_ (print-summary ""))
       (before-end (cpu-time)))
      (when times
            (printf
              "~a seconds parsing,~%"
              (exact->inexact
                (* (- before-bind before-parse)
                   clock-granularity)))
            (printf
              "~a seconds binding,~%"
              (exact->inexact
                (* (- before-improve before-bind)
                   clock-granularity)))
            (printf
              "~a seconds improving,~%"
              (exact->inexact
                (* (- before-typecheck before-improve)
                   clock-granularity)))
            (printf
              "~a seconds type checking,~%"
              (exact->inexact
                (* (- (- before-output before-typecheck)
                      visible-time)
                   clock-granularity)))
            (printf
              "~a seconds setting visibility,~%"
              (exact->inexact
                (* visible-time clock-granularity)))
            (printf
              "~a seconds writing output,~%"
              (exact->inexact
                (* (- before-end before-output)
                   clock-granularity)))
            (printf
              "~a seconds in total.~%"
              (exact->inexact
                (* (- before-end before-parse) clock-granularity)))))))
(define type-check
  (lambda (defs)
    (set! tree defs)
    (type-defs defs)
    defs))
(define soft-files
  (lambda (files output)
    (let ((contents
            (map (lambda (f) `(begin ,@(readfile f))) files)))
      (soft-def `(begin ,@contents) output))))
(define strip-suffix
  (lambda (name)
    (let ((n (string-length name)))
      (or (and (<= 3 n)
               (equal? ".ss" (substring name (- n 3) n))
               (substring name 0 (- n 3)))
          (and (<= 4 n)
               (equal? ".scm" (substring name (- n 4) n))
               (substring name 0 (- n 4)))))))
(define st:deftype
  (match-lambda*
    (((? symbol? x) ? list? mutability)
     (=> fail)
     (if (andmap boolean? mutability)
       (deftype x mutability)
       (fail)))
    (args (use-error
            "Invalid command ~a"
            `(st:deftype ,@args)))))
(define st:defprim
  (match-lambda*
    (((? symbol? x) type) (defprim x type 'impure))
    (((? symbol? x) type (? symbol? mode))
     (defprim x type mode))
    (args (use-error
            "Invalid command ~a"
            `(st:defprim ,@args)))))
(define st:help
  (lambda ()
    (printf
      "Commands for Soft Scheme (~a)~%"
      st:version)
    (printf
      "  (st:         file (output))    type check file and execute~%")
    (printf
      "  (st:type     (name))           print types of global defs~%")
    (printf
      "  (st:check    file (output))    type check file~%")
    (printf
      "  (st:run      file)             execute type checked file~%")
    (printf
      "  (st:bench    file)             execute type checked file fast~%")
    (printf
      "  (st:ltype    (name))           print types of local defs~%")
    (printf
      "  (st:cause)                     print cause of CHECKs~%")
    (printf
      "  (st:summary)                   print summary of CHECKs~%")
    (printf
      "  (st:help)                      prints this message~%")
    (printf
      "  (st:defprim  name type (mode)) define a new primitive~%")
    (printf
      "  (st:deftype  name bool ...)    define a new type constructor~%")
    (printf
      "  (st:control  flag ...)         set internal flags~%")
    (printf
      "For more info, see ftp://ftp.nj.nec.com/pub/wright/ssmanual/softscheme.html~%")
    (printf
      "Copyright (c) 1993, 1994, 1995 by Andrew K. Wright under the~%")
    (printf
      "terms of the Gnu Public License. No warranties of any kind apply.~%")))
(define st:type type)
(define st:ltype localtype)
(define st:cause cause)
(define st:summary
  (lambda () (print-summary "")))
(define init!
  (lambda ()
    (when customization-file
          (load (string-append
                  installation-directory
                  customization-file)))
    (let ((softrc
            (string-append home-directory "/.softschemerc")))
      (when (file-exists? softrc) (load softrc)))
    (set! global-env initial-env)
    (st:help)))
(init!)