ost-positive-fixnum) val)
   ((< &range-max val) +inf.0)
   ((< val &range-min) &range-min)
   (else val)))

(define-inlinable (make-type-entry type min max)
  (vector type (clamp-min min) (clamp-max max)))

(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0))

(define* (var-type-entry typeset var #:optional (default all-types-entry))
  (intmap-ref typeset var (lambda (_) default)))

(define (var-type typeset var)
  (type-entry-type (var-type-entry typeset var)))
(define (var-min typeset var)
  (type-entry-min (var-type-entry typeset var)))
(define (var-max typeset var)
  (type-entry-max (var-type-entry typeset var)))

;; Is the type entry A contained entirely within B?
(define (type-entry<=? a b)
  (match (cons a b)
    ((#(a-type a-min a-max) . #(b-type b-min b-max))
     (and (eqv? b-type (logior a-type b-type))
          (<= b-min a-min)
          (>= b-max a-max)))))

(define (type-entry-union a b)
  (cond
   ((type-entry<=? b a) a)
   ((type-entry<=? a b) b)
   (else (make-type-entry
          (logior (type-entry-type a) (type-entry-type b))
          (min (type-entry-min a) (type-entry-min b))
          (max (type-entry-max a) (type-entry-max b))))))

(define (type-entry-saturating-union a b)
  (cond
   ((type-entry<=? b a) a)
   (else
    (make-type-entry
     (logior (type-entry-type a) (type-entry-type b))
     (let ((a-min (type-entry-min a))
           (b-min (type-entry-min b)))
       (cond
        ((not (< b-min a-min)) a-min)
        ((< 0 b-min) 0)
        ((< &range-min b-min) &range-min)
        (else -inf.0)))
     (let ((a-max (type-entry-max a))
           (b-max (type-entry-max b)))
       (cond
        ((not (> b-max a-max)) a-max)
        ((> *max-size-t* b-max) *max-size-t*)
        ((> &range-max b-max) &range-max)
        (else +inf.0)))))))

(define (type-entry-intersection a b)
  (cond
   ((type-entry<=? a b) a)
   ((type-entry<=? b a) b)
   (else (make-type-entry
          (logand (type-entry-type a) (type-entry-type b))
          (max (type-entry-min a) (type-entry-min b))
          (min (type-entry-max a) (type-entry-max b))))))

(define (adjoin-var typeset var entry)
  (intmap-add typeset var entry type-entry-union))

(define (restrict-var typeset var entry)
  (intmap-add typeset var entry type-entry-intersection))

(define (constant-type val)
  "Compute the type and range of VAL.  Return three values: the type,
minimum, and maximum."
  (define (return type val)
    (if val
        (make-type-entry type val val)
        (make-type-entry type -inf.0 +inf.0)))
  (cond
   ((number? val)
    (cond
     ((exact-integer? val) (return &exact-integer val))
     ((eqv? (imag-part val) 0)
      (if (nan? val)
          (make-type-entry &flonum -inf.0 +inf.0)
          (make-type-entry
           (if (exact? val) &fraction &flonum)
           (if (rational? val) (inexact->exact (floor val)) val)
           (if (rational? val) (inexact->exact (ceiling val)) val))))
     (else (return &complex #f))))
   ((eq? val '()) (return &null #f))
   ((eq? val #nil) (return &nil #f))
   ((eq? val #t) (return &true #f))
   ((eq? val #f) (return &false #f))
   ((char? val) (return &char (char->integer val)))
   ((eqv? val *unspecified*) (return &unspecified #f))
   ((symbol? val) (return &symbol #f))
   ((keyword? val) (return &keyword #f))
   ((pair? val) (return &pair #f))
   ((vector? val) (return &vector (vector-length val)))
   ((string? val) (return &string (string-length val)))
   ((bytevector? val) (return &bytevector (bytevector-length val)))
   ((bitvector? val) (return &bitvector (bitvector-length val)))
   ((array? val) (return &array (array-rank val)))
   ((syntax? val) (return &syntax 0))
   ((not (variable-bound? (make-variable val))) (return &unbound #f))

   (else (error "unhandled constant" val))))

(define *type-checkers* (make-hash-table))
(define *type-inferrers* (make-hash-table))

(define-syntax-rule (define-type-helper name)
  (define-syntax-parameter name
    (lambda (stx)
      (syntax-violation 'name
                        "macro used outside of define-type"
                        stx))))
(define-type-helper define!)
(define-type-helper restrict!)
(define-type-helper &type)
(define-type-helper &min)
(define-type-helper &max)

;; Accessors to use in type inferrers where you know that the values
;; must be in some range for the computation to proceed (not throw an
;; error).  Note that these accessors should be used even for &u64 and
;; &s64 values, whose definitions you would think would be apparent
;; already.  However it could be that the graph isn't sorted, so we see
;; a use before a definition, in which case we need to clamp the generic
;; limits to the &u64/&s64 range.
(define-syntax-rule (&min/0 x) (max (&min x) 0))
(define-syntax-rule (&max/u64 x) (min (&max x) &u64-max))
(define-syntax-rule (&min/s64 x) (max (&min x) &s64-min))
(define-syntax-rule (&max/s64 x) (min (&max x) &s64-max))
(define-syntax-rule (&max/size x) (min (&max x) *max-size-t*))

(define-syntax-rule (define-type-checker (name arg ...) body ...)
  (hashq-set!
   *type-checkers*
   'name
   (lambda (typeset arg ...)
     (syntax-parameterize
         ((&type (syntax-rules () ((_ val) (var-type typeset val))))
          (&min  (syntax-rules () ((_ val) (var-min typeset val))))
          (&max  (syntax-rules () ((_ val) (var-max typeset val)))))
       body ...))))

(define-syntax-rule (check-type arg type min max)
  ;; If the arg is negative, it is a closure variable.
  (and (>= arg 0)
       (zero? (logand (lognot type) (&type arg)))
       (<= min (&min arg))
       (<= (&max arg) max)))

(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...)
  (hashq-set!
   *type-inferrers*
   'name
   (lambda (in succ var ...)
     (let ((out in))
       (syntax-parameterize
           ((define!
              (syntax-rules ()
                ((_ val type min max)
                 (set! out (adjoin-var out val
                                       (make-type-entry type min max))))))
            (restrict!
             (syntax-rules ()
               ((_ val type min max)
                (set! out (restrict-var out val
                                        (make-type-entry type min max))))))
            (&type (syntax-rules () ((_ val) (var-type in val))))
            (&min  (syntax-rules () ((_ val) (var-min in val))))
            (&max  (syntax-rules () ((_ val) (var-max in val)))))
         body ...
         out)))))

(define-syntax-rule (define-type-inferrer (name arg ...) body ...)
  (define-type-inferrer* (name succ arg ...) body ...))

(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...)
  (define-type-inferrer* (name succ arg ...)
    (let ((true? (not (zero? succ))))
      body ...)))

(define-syntax define-simple-type-checker
  (lambda (x)
    (define (parse-spec l)
      (syntax-case l ()
        (() '())
        (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
        (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
        ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
    (syntax-case x ()
      ((_ (name arg-spec ...) result-spec ...)
       (with-syntax
           (((arg ...) (generate-temporaries #'(arg-spec ...)))
            (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))))
         #'(define-type-checker (name arg ...)
             (and (check-type arg arg-type arg-min arg-max)
                  ...)))))))

(define-syntax define-simple-type-inferrer
  (lambda (x)
    (define (parse-spec l)
      (syntax-case l ()
        (() '())
        (((type min max) . l) (cons #'(type min max) (parse-spec #'l)))
        (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l)))
        ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l)))))
    (syntax-case x ()
      ((_ (name arg-spec ...) result-spec ...)
       (with-syntax
           (((arg ...) (generate-temporaries #'(arg-spec ...)))
            (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))
            ((res ...) (generate-temporaries #'(result-spec ...)))
            (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...))))
         #'(define-type-inferrer (name arg ... res ...)
             (restrict! arg arg-type arg-min arg-max)
             ...
             (define! res res-type res-min res-max)
             ...))))))

(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...)
  (begin
    (define-simple-type-checker (name arg-spec ...))
    (define-simple-type-inferrer (name arg-spec ...) result-spec ...)))

(define-syntax-rule (define-simple-types
                      ((name arg-spec ...) result-spec ...)
                      ...)
  (begin
    (define-simple-type (name arg-spec ...) result-spec ...)
    ...))

(define-syntax-rule (define-type-checker-aliases orig alias ...)
  (let ((check (hashq-ref *type-checkers* 'orig)))
    (hashq-set! *type-checkers* 'alias check)
    ...))
(define-syntax-rule (define-type-inferrer-aliases orig alias ...)
  (let ((check (hashq-ref *type-inferrers* 'orig)))
    (hashq-set! *type-inferrers* 'alias check)
    ...))
(define-syntax-rule (define-type-aliases orig alias ...)
  (begin
    (define-type-checker-aliases orig alias ...)
    (define-type-inferrer-aliases orig alias ...)))