chez-openbsd/mats/record.ms

;;; record.ms
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;; 
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;; http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define $mpf32 (min (most-positive-fixnum) (- (ash 1 29) 1)))
(define $mnf32 (max (most-negative-fixnum) (- (ash 1 29))))

(define $mpf64 (min (most-positive-fixnum) (- (ash 1 60) 1)))
(define $mnf64 (max (most-negative-fixnum) (- (ash 1 60))))

(mat record1
  (begin
    (define-record fudge ((immutable double-float a)))
    (andmap procedure? (list make-fudge fudge? fudge-a)))
  (error? (make-fudge 3))
  (error? (fudge-a 3))
)

(mat record2
  (begin
    (define fudge (make-record-type "fudge" '((immutable double-float a))))
    (record-type-descriptor? fudge))
  (begin
    (define make-fudge (record-constructor fudge))
    (procedure? make-fudge))
  (error? (make-fudge 3))
  (error? ((csv7:record-field-accessor fudge 'a) 3))
  (error? (make-record-type "fudge" '((immutable double-float a) . b)))
  (error? (make-record-type "fudge"
            (let ([x (list '(immutable a) '(immutable b) '(immutable c))])
              (set-cdr! (cddr x) (cdr x))
              x)))
)

(mat type-descriptor
  (let ()
    (define-record foo ())
    (record-type-descriptor? (type-descriptor foo)))
  (error? (type-descriptor 3))
  (error? (type-descriptor car))
)

(mat record3
  (begin
    (define-record fudge ((immutable a)))
    (andmap procedure? (list make-fudge fudge? fudge-a)))
  (begin
    (define x (make-fudge 3))
    (fudge? x))
  (eqv? (fudge-a x) 3)
  (error? (set-fudge-a! x x))
  (eqv? (fudge-a x) 3)
  (let ()
    (define-record fudge ((immutable a)))
    (and (andmap procedure? (list make-fudge fudge? fudge-a))
         (let ((x (make-fudge 3)))
           (and (fudge? x)
                (eqv? (fudge-a x) 3)
                (eqv? (fudge-a x) 3)))))
)

(mat record4
  (begin
    (define-record fudge ((a)))
    (andmap procedure? (list make-fudge fudge? fudge-a set-fudge-a!)))
  (begin
    (define x (make-fudge 3))
    (fudge? x))
  (eqv? (fudge-a x) 3)
  (error? (set-fudge-a! 3 x))
  (begin (set-fudge-a! x x) (eqv? (fudge-a x) x))
  #;(equal? (format "~s" x) "#0=#[fudge #0#]")
  (begin
    (define-record fudge ((mutable a)))
    (andmap procedure? (list make-fudge fudge? fudge-a set-fudge-a!)))
  (begin
    (define x (make-fudge 3))
    (fudge? x))
  (eqv? (fudge-a x) 3)
  (begin (set-fudge-a! x x) (eqv? (fudge-a x) x))
  #;(equal? (format "~s" x) "#0=#[fudge #0#]")
)

(mat record5
  (begin
    (define-record fudge ((mutable a) (mutable double-float b)))
    (andmap procedure?
      (list make-fudge fudge? fudge-a set-fudge-a! fudge-b set-fudge-b!)))
  (begin
    (define x (make-fudge 'a 3.4))
    (fudge? x))
  (eqv? (begin (set-fudge-b! x 4.4) (fudge-b x)) 4.4)
  #;(equal? (format "~s" x) "#[fudge a 4.4]")
  (begin
    (collect (collect-maximum-generation))
    (set-fudge-a! x (cons 3 4))
    (let ((p (weak-cons (fudge-a x) #f)))
      (collect)
      (and (eq? (car p) (fudge-a x))
           (begin (collect)
                  (eq? (car p) (fudge-a x))
                  (equal? (car p) '(3 . 4))))))
  (error? (set-fudge-b! x 4))
  (begin
    (define-record fudge ((a) (double-float b)))
    (andmap procedure?
      (list make-fudge fudge? fudge-a set-fudge-a! fudge-b set-fudge-b!)))
  (begin
    (define x (make-fudge 'a 3.4))
    (fudge? x))
  (eqv? (begin (set-fudge-b! x 4.4) (fudge-b x)) 4.4)
  #;(equal? (format "~s" x) "#[fudge a 4.4]")
  (begin
    (collect (collect-maximum-generation))
    (set-fudge-a! x (cons 3 4))
    (let ((p (weak-cons (fudge-a x) #f)))
      (collect)
      (and (eq? (car p) (fudge-a x))
           (begin (collect)
                  (eq? (car p) (fudge-a x))
                  (equal? (car p) '(3 . 4))))))
  (error? (set-fudge-b! x 4))
)

(mat record6
  (begin
    (define-record bar ((immutable a) (immutable integer-32 b))
      (((immutable c) (+ a b)) ((immutable double-float d) (+ a b c))))
    (andmap procedure? (list make-bar bar? bar-a bar-b bar-c bar-d)))
  (begin
    (define x (make-bar 9.0 23))
    (and (bar? x)
         #;(equal? (format "~s" x) "#[bar 9.0 23 32.0 64.0]")))
  (eqv? (bar-d x) 64.0)
  (eqv? (bar-b x) 23)
  (let ((y (make-bar 9.0 $mpf32)))
    (eqv? (bar-b y) $mpf32))
  (let ((y (make-bar 9.0 (+ $mpf32 1))))
    (eqv? (bar-b y) (+ $mpf32 1)))
  (let ((y (make-bar 9.0 $mnf32)))
    (eqv? (bar-b y) $mnf32))
  (let ((y (make-bar 9.0 (- $mnf32 1))))
    (eqv? (bar-b y) (- $mnf32 1)))
  (let ((y (make-bar 9.0 #x7fffffff)))
    (eqv? (bar-b y) #x7fffffff))
  (let ((y (make-bar 9.0 #x-80000000)))
    (eqv? (bar-b y) #x-80000000))
  (error? (make-bar 9.0 #x100000000))
  (error? (make-bar 9.0 #x-80000001))
  (error? (make-bar 9.0 23.0))
 ; now that we allow 2^(b-1)..2^b-1
  (let ((y (make-bar 9.0 #x80000000)))
    (eqv? (bar-b y) #x-80000000))
  (let ((y (make-bar 9.0 #xffffffff)))
    (eqv? (bar-b y) #x-1))

 ; make sure we can use modifiers and types as field names
  (equal?
    (let ()
      (define-record foo ((mutable mutable) (immutable int) (immutable integer-32) integer-8))
      (let ([x (make-foo 3 4 5 6)])
        (set-foo-mutable! x 75)
        (list ($record->vector x) (foo-mutable x) (foo-int x) (foo-integer-32 x) (foo-integer-8 x))))
    '(#(foo 75 4 5 6) 75 4 5 6))
  (equal?
    (let ()
      (define foo (make-record-type "hello" '((mutable mutable) (immutable int) (immutable integer-32) integer-8)))
      (let ([x ((record-constructor foo) 3 4 5 6)])
        ((csv7:record-field-mutator foo 'mutable) x 75)
        (list ($record->vector x)
              ((csv7:record-field-accessor foo 'mutable) x)
              ((csv7:record-field-accessor foo 'int) x)
              ((csv7:record-field-accessor foo 'integer-32) x)
              ((csv7:record-field-accessor foo 'integer-8) x))))
    '(#(hello 75 4 5 6) 75 4 5 6))
)

(mat record7
  (begin
    (define-record bar ((immutable a) (immutable unsigned-32 b))
      ((c (+ a b)) ((double-float d) (+ a b c))))
    (andmap procedure? (list make-bar bar? bar-a bar-b bar-c bar-d)))
  (begin
    (define x (make-bar 9.0 23))
    (and (bar? x)
         #;(equal? (format "~s" x) "#[bar 9.0 23 32.0 64.0]")))
  (eqv? (bar-d x) 64.0)
  (eqv? (bar-b x) 23)
  (let ((y (make-bar 9.0 $mpf32)))
    (eqv? (bar-b y) $mpf32))
  (let ((y (make-bar 9.0 (+ $mpf32 1))))
    (eqv? (bar-b y) (+ $mpf32 1)))
  (let ((y (make-bar 9.0 #x7fffffff)))
    (eqv? (bar-b y) #x7fffffff))
  (let ((y (make-bar 9.0 #x80000000)))
    (eqv? (bar-b y) #x80000000))
  (let ((y (make-bar 9.0 #xffffffff)))
    (eqv? (bar-b y) #xffffffff))
  (error? (make-bar 9.0 #x100000000))
  (error? (make-bar 9.0 #x-ffffffff))
  (error? (make-bar 9.0 23.0))
 ; now that we allow 2^(b-1)..2^b-1
  (let ([y (make-bar 9.0 $mnf32)])
    (eqv? (bar-b y) (+ #x100000000 $mnf32)))
  (let ([y (make-bar 9.0 (- $mnf32 1))])
    (eqv? (bar-b y) (+ #x100000000 (- $mnf32 1))))
  (let ([y (make-bar 9.0 -1)])
    (eqv? (bar-b y) #xffffffff))
  (let ([y (make-bar 9.0 #x-80000000)])
    (eqv? (bar-b y) #x80000000))
)

(mat record8
  (let ()
    (define small
      (make-record-type "small"
        (append '((immutable double-float x))
                (map (lambda (x) (gensym)) (make-list 3))
                '((mutable y)))))
    (let ()
      (define make-small (record-constructor small))
      (define small-x (csv7:record-field-accessor small 'x))
      (define small-y (csv7:record-field-accessor small 'y))
      (define set-small-y! (csv7:record-field-mutator small 'y))
      (record-reader 'small small)
      (let ((x (apply make-small (cons 3.4 (make-list 4 'odyssey)))))
        (and (eqv? (string-length (format "~s" x)) 44)
             (begin
               (collect (collect-maximum-generation))
               (set-small-y! x (cons 3 4))
               (let ((p (weak-cons (small-y x) #f)))
                 (collect)
                 (and (eq? (car p) (small-y x))
                      (begin
                        (collect)
                        (eq? (car p) (small-y x))))))))))
  (let ()
    (define huge
      (make-record-type "huge"
        (append '((immutable double-float x))
                (map (lambda (x) (gensym)) (make-list 2000))
                '(y))))
    (let ()
      (define make-huge (record-constructor huge))
      (define huge-x (csv7:record-field-accessor huge 'x))
      (define huge-y (csv7:record-field-accessor huge 'y))
      (define set-huge-y! (csv7:record-field-mutator huge 'y))
      (record-reader 'huge huge)
      (let ((x (apply make-huge (cons 3.4 (make-list 2001 'odyssey)))))
        (and (eqv? (string-length (format "~s" x)) 16019)
             (begin
               (collect (collect-maximum-generation))
               (set-huge-y! x (cons 3 4))
               (let ((p (weak-cons (huge-y x) #f)))
                 (collect)
                 (and (eq? (car p) (huge-y x))
                      (begin
                        (collect)
                        (eq? (car p) (huge-y x))))))))))
)

(mat record9
  (record-type-descriptor? (make-record-type "fudge" '()))
  (begin
    (define fudge (make-record-type "fudge" '((mutable a))))
    (define make-fudge (record-constructor fudge))
    (define fudge? (record-predicate fudge))
    (define fudge.a (csv7:record-field-accessor fudge 'a))
    (define x (make-fudge 3))
    (and (record-type-descriptor? fudge) (fudge? x)))
  (eqv? (fudge.a x) 3)
  (begin
    (define set-fudge.a! (csv7:record-field-mutator fudge 'a))
    (set-fudge.a! x x)
    (eqv? (fudge.a x) x))
  (begin (record-reader 'fudge fudge) #t)
  (begin
    (define y (read (open-input-string "#[fudge 77]")))
    (and (fudge? y)
         (eqv? (fudge.a y) 77)))
  (eq? (record-reader 'fudge) fudge)
  (eq? (record-reader fudge) 'fudge)
  (begin (record-reader 'fudge #f) #t) ; pass name
  (not (record-reader fudge))
  (not (record-reader 'fudge))
  (begin (record-reader 'fudge fudge) #t)
  (eq? (record-reader 'fudge) fudge)
  (eq? (record-reader fudge) 'fudge)
  (error? (record-reader #f))
  (error? (record-reader #f 'fudge))
  (error? (record-reader fudge 'fudge))
  (error? (record-reader #f #f))
  (error? (record-reader 'fudge 'candy))
  (error? (record-reader fudge fudge))
  (begin (record-reader fudge #f) #t) ; pass rtd
  (not (record-reader fudge))
  (not (record-reader 'fudge))
  (begin
    (define fudge (make-record-type "fudge" '((a))))
    (define make-fudge (record-constructor fudge))
    (define fudge? (record-predicate fudge))
    (define fudge.a (csv7:record-field-accessor fudge 'a))
    (define x (make-fudge 3))
    (and (record-type-descriptor? fudge) (fudge? x)))
  (eqv? (fudge.a x) 3)
  (begin
    (define set-fudge.a! (csv7:record-field-mutator fudge 'a))
    (set-fudge.a! x x)
    (eqv? (fudge.a x) x))
  (begin (record-reader 'fudge fudge) #t)
  (begin
    (define y (read (open-input-string "#[fudge 77]")))
    (and (fudge? y)
         (eqv? (fudge.a y) 77)))
)

(mat record10
  (begin
    (define bar (make-record-type "bar"
                  '((immutable a) (mutable b) (immutable c))))
    (define make-bar (record-constructor bar))
    (define bar? (record-predicate bar))
    (define bar.a (csv7:record-field-accessor bar 'a))
    (define bar.b (csv7:record-field-accessor bar 'b))
    (define bar.c (csv7:record-field-accessor bar 'c))
    (define x (make-bar 3 4 5))
    (bar? x))
  (eqv? (bar.b x) 4)
  (begin
    (define set-bar.b! (csv7:record-field-mutator bar 'b))
    (procedure? set-bar.b!))
  (error? (define set-bar.a! (csv7:record-field-mutator bar 'a)))
  (error? (define set-bar.c! (csv7:record-field-mutator bar 'c)))
  (begin (record-reader 'bar bar) #t)
  (let ((x (read (open-input-string "#1=#[bar a #1# c]"))))
    (and (bar? x) (eq? (bar.b x) x)))
  (let ((x (read (open-input-string "#[bar #1=a b #1#]"))))
    (and (bar? x)
         (eq? (bar.a x) 'a)
         (eq? (bar.a x) (bar.c x))
         (eq? (bar.b x) 'b)))
  (error? (read (open-input-string "#1=#[bar a b #1#]")))
  (error? (read (open-input-string "#1=#[bar #1# b c]")))
  (bar? (read (open-input-string "#[bar #1# b #1=a]")))
  (equal?
    (with-output-to-string
      (lambda ()
        (let ([pred (begin
                      (display "one\n")
                      (record-predicate
                        (begin
                          (display "two\n")
                          (make-record-type '#{foo bje68fdhbe06wod3-a} '(x)))))])
          (printf "~s\n" (pred 17))
          (printf "~s\n" (pred ((record-constructor (make-record-type '#{foo bje68fdhbe06wod3-a} '(x))) 55))))))
    "one\ntwo\n#f\n#t\n")
)

#;(mat record11
  (let ()
    (define froz
      (rec froz
        (make-record-type "froz" '((immutable a) (immutable b))
          (lambda (x p wr)
            (define froz.a (csv7:record-field-accessor froz 'a))
            (wr `(* hi john ,(froz.a x) *) p)))))
    (equal? (format "~s" ((record-constructor froz) 1 2))
            "(* hi john 1 *)"))
)

(mat record12
   (begin
     (define-record $tree ((immutable left) (immutable node) (immutable right)))
     (record-type-descriptor? (type-descriptor $tree)))
   ($tree? (make-$tree 3 4 5))
   (let ((tr (make-$tree 'a 'b 'c)))
      (and (eq? ($tree-left tr) 'a)
           (eq? ($tree-node tr) 'b)
           (eq? ($tree-right tr) 'c)))
   (begin
     (define-record $tree ((left) (node) (right)))
     (record-type-descriptor? (type-descriptor $tree)))
   ($tree? (make-$tree 3 4 5))
   (let ((tr (make-$tree 'a 'b 'c)))
      (and (eq? ($tree-left tr) 'a)
           (eq? ($tree-node tr) 'b)
           (eq? ($tree-right tr) 'c)))
   (begin
     (define-record $tree (left node right))
     (record-type-descriptor? (type-descriptor $tree)))
   ($tree? (make-$tree 3 4 5))
   (let ((tr (make-$tree 'a 'b 'c)))
      (and (eq? ($tree-left tr) 'a)
           (eq? ($tree-node tr) 'b)
           (eq? ($tree-right tr) 'c)))
   (begin
     (define-record $tree ((left) (immutable node) (right)))
     (record-type-descriptor? (type-descriptor $tree)))
   ($tree? (make-$tree 3 4 5))
   (let ((tr (make-$tree 'a 'b 'c)))
      (and (eq? ($tree-left tr) 'a)
           (eq? ($tree-node tr) 'b)
           (eq? ($tree-right tr) 'c)))
   (begin
     (define-record pare ((mutable kar) kdr)
       (((scheme-object original-kar) kar) ((mutable original-kdr) kdr)))
     (record-type-descriptor? (type-descriptor pare)))
   (andmap procedure?
           (list make-pare
                 pare?
                 pare-kar
                 pare-kdr
                 pare-original-kar
                 pare-original-kdr
                 set-pare-kar!
                 set-pare-kdr!
                 set-pare-original-kar!
                 set-pare-original-kdr!))
   (pare? (make-pare 3 4))
   (eq? (pare-kar (make-pare 'a 'b)) 'a)
   (eq? (pare-kdr (make-pare 'a 'b)) 'b)
   (eq? (pare-original-kar (make-pare 'a 'b)) 'a)
   (eq? (pare-original-kdr (make-pare 'a 'b)) 'b)
   (let ((p (make-pare 'a 'b)))
      (set-pare-kar! p 'c)
      (set-pare-kdr! p 'd)
      (and (eq? (pare-kar p) 'c)
           (eq? (pare-kdr p) 'd)
           (eq? (pare-original-kar p) 'a)
           (eq? (pare-original-kdr p) 'b)))
 )

(mat record13
  (begin
    (define-record stretch-string ((integer-32 length) (fill))
      ([(string) (make-string length fill)]))
    (define stretch-string-ref
      (lambda (s i)
        (let ([n (stretch-string-length s)])
          (when (>= i n) (stretch-stretch-string! s (+ i 1) n))
          (string-ref (stretch-string-string s) i))))
    (define stretch-string-set!
      (lambda (s i c)
        (let ([n (stretch-string-length s)])
          (when (>= i n) (stretch-stretch-string! s (+ i 1) n))
          (string-set! (stretch-string-string s) i c))))
    (define stretch-string-fill!
      (lambda (s c)
        (string-fill! (stretch-string-string s) c)
        (set-stretch-string-fill! s c)))
    (define stretch-stretch-string!
      (lambda (s i n)
        (set-stretch-string-length! s i)
        (let ([str (stretch-string-string s)]
              [fill (stretch-string-fill s)])
          (let ([xtra (make-string (- i n) fill)])
            (set-stretch-string-string! s
              (string-append str xtra))))))
    (define ss (make-stretch-string 2 #\X))
    (stretch-string? ss))
  
  (equal? (stretch-string-string ss) "XX")
  (eqv? (stretch-string-ref ss 3) #\X)
  (eqv? (stretch-string-length ss) 4)
  (equal? (stretch-string-string ss) "XXXX")
  
  (begin
    (stretch-string-fill! ss #\@)
    (equal? (stretch-string-string ss) "@@@@"))
  (eqv? (stretch-string-ref ss 5) #\@)
  (equal? (stretch-string-string ss) "@@@@@@")
  
  (begin
    (stretch-string-set! ss 7 #\=)
    (eqv? (stretch-string-length ss) 8))
  (equal? (stretch-string-string ss) "@@@@@@@=")
)

(mat record14
  (begin
    (define-record froz
      ((immutable a) (immutable b))
      (((immutable c) (+ a b)))
      (#;(print-method
         (lambda (x p wr)
           (wr `(* hi john ,(froz-c x) *) p)))))
    (froz? (make-froz 17 23)))
  #;(equal? (format "~s" (make-froz 17 23)) "(* hi john 40 *)")
  (eqv? (froz-a (make-froz 17 23)) 17)
  (let ()
    (define-record pair ((mutable car) (immutable cdr))
      ()
      (#;(print-method
         (lambda (x p wr)
           (display "(" p) ; )
           (wr (car x) p)
           (display " . " p)
           (wr (cdr x) p) ; (
           (display ")" p)))
       (constructor cons)
       (prefix "")))
    (and (pair? (cons 3 4))
         (not (pair? '(3 . 4)))
         (eq? (car (cons 3 4)) 3)
         (eq? (cdr (cons 3 4)) 4)
         #;(equal? (format "~s" (cons 3 (cons 4 '()))) "(3 . (4 . ()))")
         #;(let ((x (cons 3 4)))
           (set-car! x x)
           (equal? (format "~s" x) "#0=(#0# . 4)"))))
)

(mat record15
  (equal? (let ()
            (define-record foo ((mutable a)))
            (let ((x (make-foo '*)))
              (record-reader 'foo (record-rtd x))
              (set-foo-a! x x)
              (parameterize ((print-graph #t))
                (let ((p (open-output-string)))
                  (pretty-print x p)
                  (get-output-string p)))))
          (format "#0=#[foo #0#]~%"))
  (equal? (let ((* "*"))
            (define-record foo (a))
            (let ((x (make-foo *)) (y (make-foo *)))
              (record-reader 'foo (record-rtd x))
              (parameterize ((print-graph #t))
                (format "~s" (list x y)))))
          "(#[foo #0=\"*\"] #[foo #0#])")
)

(mat record16
  (begin
    (define-record bazar ((immutable a) (mutable b) (immutable c))
      ()
      ((prefix "bazar.") #;(reader-name "bazar")))
    (define x (make-bazar 3 4 5))
    (bazar? x))
  (eqv? (bazar.b x) 4)
  (procedure? set-bazar.b!)
  (eqv? (record-reader 'bazar (record-rtd x)) (void))
  (let ((x (read (open-input-string "#1=#[bazar a #1# c]"))))
    (and (bazar? x) (eq? (bazar.b x) x)))
  (let ((x (read (open-input-string "#[bazar #1=a b #1#]"))))
    (and (bazar? x)
         (eq? (bazar.a x) 'a)
         (eq? (bazar.a x) (bazar.c x))
         (eq? (bazar.b x) 'b)))
  (error? (read (open-input-string "#1=#[bazar a b #1#]")))
  (error? (read (open-input-string "#1=#[bazar #1# b c]")))
  (bazar? (read (open-input-string "#[bazar #1# b #1=a]")))
)

(mat record17
  (let ()
    (define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
    (let ()
      (define r (make-f 1 2 3))
      (and (f? r) (equal? '(3 2 1) (list (f-z r) (f-y r) (f-x r))))))
  (let ()
    (define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
    (let ()
      (define r (make-f 1 2 3))
      (set-f-x! r 72)
      (set-f-y! r 73)
      (set-f-z! r 74)
      (and (f? r) (equal? '(74 73 72) (list (f-z r) (f-y r) (f-x r))))))
  (let ()
    (define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
    (let ()
      (define r (make-f 1 2 3))
      (set-f-x! r -72)
      (set-f-y! r -73)
      (set-f-z! r -74)
      (and (f? r) (equal? '(-74 -73 -72) (list (f-z r) (f-y r) (f-x r))))))
  (begin
    (define-record $froz
      ((unsigned-8 x) (double-float y) (single-float z) (unsigned-16 w)))
    (procedure? make-$froz))
  (error? (make-$froz 256 2.5 3.5 0))
  (let ([y (make-$froz -1 2.5 3.5 0)])
    (eqv? ($froz-x y) (+ #x100 -1)))
  (error? (make-$froz -129 2.5 3.5 0))
  (error? (make-$froz 0 2.5 3.5 #x10000))
  (let ([y (make-$froz 0 2.5 3.5 -1)])
    (eqv? ($froz-w y) (+ #x10000 -1)))
  (error? (make-$froz 0 2.5 3.5 #x-8001))
  (error? (make-$froz 0 2 3.5 0))
  (error? (make-$froz 0 2.5 3 0))
  (begin (define $rfroz (make-$froz 1 2.5 3.5 4)) ($froz? $rfroz))
  (eqv? ($froz-x $rfroz) 1)
  (eqv? ($froz-y $rfroz) 2.5)
  (eqv? ($froz-z $rfroz) 3.5)
  (eqv? ($froz-w $rfroz) 4)
  (eqv? (set-$froz-x! $rfroz 2) (void))
  (eqv? (set-$froz-y! $rfroz 2.75) (void))
  (eqv? (set-$froz-z! $rfroz 3.75) (void))
  (eqv? (set-$froz-w! $rfroz 5) (void))
  (eqv? ($froz-x $rfroz) 2)
  (eqv? ($froz-y $rfroz) 2.75)
  (eqv? ($froz-z $rfroz) 3.75)
  (eqv? ($froz-w $rfroz) 5)
  (eqv? (set-$froz-z! $rfroz #b11e111111111) (void))
  (eqv? ($froz-z $rfroz) +inf.0)
  (eqv? (set-$froz-z! $rfroz #b11e-111111111) (void))
  (eqv? ($froz-z $rfroz) 0.0)
  (begin
    (set-$froz-x! $rfroz -1)
    (eqv? ($froz-x $rfroz) (+ #x100 -1)))
  (error? (set-$froz-x! $rfroz 256))
  (error? (set-$froz-x! $rfroz #x-81))
  (error? (set-$froz-y! $rfroz 2))
  (error? (set-$froz-z! $rfroz 2))
  (error? (set-$froz-w! $rfroz #x-8001))
  (begin
    (set-$froz-w! $rfroz -1)
    (eqv? ($froz-w $rfroz) (+ #x10000 -1)))
  (error? (set-$froz-w! $rfroz #x10000))
  (begin
    (define-record $froz ((integer-8 x) (integer-16 w)))
    (procedure? make-$froz))
  (error? (make-$froz 256 0))
  (let ([y (make-$froz #x80 #x8000)])
    (and (eqv? ($froz-x y) #x-80)
         (eqv? ($froz-w y) #x-8000)))
  (error? (make-$froz -129 0))
  (error? (make-$froz 0 #x10000))
  (error? (make-$froz 0 #x-8001))
  (begin (define $rfroz (make-$froz 1 4)) ($froz? $rfroz))
  (eqv? ($froz-x $rfroz) 1)
  (eqv? ($froz-w $rfroz) 4)
  (eqv? (set-$froz-x! $rfroz 2) (void))
  (eqv? (set-$froz-w! $rfroz 5) (void))
  (eqv? ($froz-x $rfroz) 2)
  (eqv? ($froz-w $rfroz) 5)
  (begin (set-$froz-x! $rfroz #xff)
         (set-$froz-w! $rfroz #xffff)
         (eqv? ($froz-x $rfroz) -1)
         (eqv? ($froz-w $rfroz) -1))
  (error? (set-$froz-x! $rfroz 256))
  (error? (set-$froz-x! $rfroz -129))
  (error? (set-$froz-w! $rfroz #x10000))
  (error? (set-$froz-w! $rfroz #x-8001))
)

(mat record18
  (let* ([size 200]
         [ls (map (lambda (x)
                    (let ([name (gensym)])
                      (case (random 6)
                        [(0) `(immutable ,name)]
                        [(1) `(mutable ,name)]
                        [(2) `(integer-32 ,name)]
                        [(3) `(double-float ,name)]
                        [(4) `(single-float ,name)]
                        [(5) `(immutable unsigned-16 ,name)])))
                  (make-list size))])
    (define another
      (lambda (type)
        (case type
          [(scheme-object) (substring "xxlovelyxx" 2 8)]
          [(integer-32)
           (case (random 10)
             [(0) 0]
             [(1) 1]
             [(2) -1]
             [(3) $mpf32]
             [(4) $mnf32]
             [(5) (+ $mpf32 1)]
             [(6) (- $mnf32 1)]
             [(7) #x7fffffff]
             [(8) #x-80000000]
             [(9) (- (random #x100000000) #x80000000)])]
          [(unsigned-16)
           (case (random 6)
             [(0) 0]
             [(1) 1]
             [(2) #x7fff]
             [(3) #x8000]
             [(4) #xffff]
             [(5) (random #x10000)])]
          [(double-float) (if (zero? (random 1)) (random 1e15) (- (random 1e15)))]
          [(single-float) (inexact (random #e1e7))]
          [else (errorf #f "unexpected type ~s" type)])))
    (let ([rtd (make-record-type "big" ls)])
      (let ([accessors (map (lambda (x) (csv7:record-field-accessor rtd x))
                            (csv7:record-type-field-names rtd))]
            [mutators (map (lambda (x)
                             (and (csv7:record-field-mutable? rtd x)
                                  (csv7:record-field-mutator rtd x)))
                            (csv7:record-type-field-names rtd))]
            [vals (map another (map cadr (csv7:record-type-field-decls rtd)))])
        (let ([inst (apply (record-constructor rtd) vals)])
          (let f ((n 2000) (vals vals))
            (unless (= n 0)
              (if (= (modulo n 20) 0) (collect))
              (f (- n 1)
                 (map (lambda (acc mut! val type)
                        (let ([ival (acc inst)])
                          (unless (and (eqv? ival val)
                                       (or (not (string? ival))
                                           (string=? ival "lovely")))
                            (errorf #f "unexpected value ~s; should have been ~s"
                              ival val)))
                        (if (and mut! (= (random 10) 3))
                            (let ([nval (another type)])
                              (mut! inst nval)
                              nval)
                            val))
                       accessors
                       mutators
                       vals
                       (map cadr (csv7:record-type-field-decls rtd)))))))))
    #t)
)

(mat foreign-data
  (begin
    (module ($fd-unaligned-integers $fd-unaligned-floats)
      (define-syntax define-constant
        (syntax-rules (machine-type)
          [(_ machine-type y) (begin)]
          [(_ x y) (define x y)]))
      (define-syntax features
        (syntax-rules ()
          [(_ x ...) (begin)]))
      (define-syntax constant
        (syntax-rules ()
          [(_ x) x]))
      (define-syntax constant-case
        (syntax-rules (else)
          [(_ const [(k ...) e1 e2 ...] ... [else ee1 ee2 ...])
           (meta-cond
             [(memv (constant const) '(k ...)) e1 e2 ...]
             ...
             [else ee1 ee2 ...])]
          [(_ const [(k ...) e1 e2 ...] ...)
           (meta-cond
             [(memv (constant const) '(k ...)) e1 e2 ...]
             ...
             [else (syntax-error const
                     (format "unhandled value ~s" (constant const)))])]))
      (define-syntax include-from-s
        (lambda (x)
          (syntax-case x ()
            [(k ?path)
             (string? (datum ?path))
             (let ([s-path (format "~a/../s/~a" *mats-dir* (datum ?path))])
               (datum->syntax #'k `(include ,s-path)))])))
      (include-from-s "machine.def")
     ; all this work for two constants:
      (define $fd-unaligned-integers (constant unaligned-integers))
      (define $fd-unaligned-floats (constant unaligned-floats)))
    (define ($fd-make-min bytes) (- (ash (expt 256 bytes) -1)))
    (define ($fd-make-max bytes) (- (expt 256 bytes) 1))
    (define $fd-addr-min ($fd-make-min (foreign-sizeof 'void*)))
    (define $fd-addr-max ($fd-make-max (foreign-sizeof 'void*)))
    (define $fd-int-min ($fd-make-min (foreign-sizeof 'int)))
    (define $fd-int-max ($fd-make-max (foreign-sizeof 'int)))
    (define $fd-short-min ($fd-make-min (foreign-sizeof 'short)))
    (define $fd-short-max ($fd-make-max (foreign-sizeof 'short)))
    (define $fd-long-min ($fd-make-min (foreign-sizeof 'long)))
    (define $fd-long-max ($fd-make-max (foreign-sizeof 'long)))
    (define $fd-long-long-min ($fd-make-min (foreign-sizeof 'long-long)))
    (define $fd-long-long-max ($fd-make-max (foreign-sizeof 'long-long)))
    (define $fd-char-max ($fd-make-max 1))
    (define $fd-wchar-max (min ($fd-make-max (foreign-sizeof 'wchar)) #x10ffff))
    (define $fd-i8-min ($fd-make-min 1))
    (define $fd-i8-max ($fd-make-max 1))
    (define $fd-i16-min ($fd-make-min 2))
    (define $fd-i16-max ($fd-make-max 2))
    (define $fd-i32-min ($fd-make-min 4))
    (define $fd-i32-max ($fd-make-max 4))
    (define $fd-i64-min ($fd-make-min 8))
    (define $fd-i64-max ($fd-make-max 8))
    #t)
 ; foreign-alloc
  (error? ; not a positive fixnum
    (foreign-alloc 0))
  (error? ; not a positive fixnum
    (foreign-alloc (+ (most-positive-fixnum) 1)))
  (error? ; not a positive fixnum
    (foreign-alloc -5))
  (error? ; not a positive fixnum
    (foreign-alloc 17.0))
 ; foreign-free
  (error? ; invalid address
    (foreign-free 17.0))
  (error? ; invalid address
    (foreign-free (- $fd-addr-min 1)))
  (error? ; invalid address
    (foreign-free (+ $fd-addr-max 1)))
  (equal?
    (let ([x (foreign-alloc 16)])
      (list
        (<= 0 x $fd-addr-max)
        (foreign-free x)))
   (list #t (void)))
  ; foreign-ref
  (begin
    (define $max-uptr+1
      (cond
        [(fx= (fixnum-width) 30) #x100000000]
        [(fx= (fixnum-width) 61) #x10000000000000000]
        [else ($oops '$raw-fd-a "unexpected fixnum-width ~s" (fixnum-width))]))
    #t)
  (error? ; invalid address
    (foreign-ref 'integer-32 $max-uptr+1 0))
  (error? ; invalid address
    (foreign-ref 'integer-32 (- $max-uptr+1) 100))
  (error? ; invalid offset
    (foreign-ref 'integer-32 0 (+ (most-positive-fixnum) 1)))
  (error? ; invalid addr + offset
    (foreign-ref 'integer-32 (- $max-uptr+1 4) 4))
  (error? ; invalid addr + offset for 4-byte type
    (foreign-ref 'integer-32 (- $max-uptr+1 8) 6))
  (error? ; invalid address
    (foreign-set! 'integer-32 $max-uptr+1 0 7))
  (error? ; invalid address
    (foreign-set! 'integer-32 (- $max-uptr+1) 100 7))
  (error? ; invalid offset
    (foreign-set! 'integer-32 0 (+ (most-positive-fixnum) 1) 7))
  (error? ; invalid addr + offset
    (foreign-set! 'integer-32 (- $max-uptr+1 4) 4 7))
  (error? ; invalid addr + offset for 4-byte type
    (foreign-set! 'integer-32 (- $max-uptr+1 8) 6 7))
  (meta-cond
    [(fx= (fixnum-width) 30)
     (define $real-fd-a (foreign-alloc (+ 40 7)))
     (define $fd-a (logand (+ $real-fd-a 7) -8))
     (define $raw-fd-a (ash (if (>= $fd-a (expt 2 31)) (- $fd-a (expt 2 32)) $fd-a) -2))
     (and
       (<= 0 $fd-a $fd-addr-max)
       (fixnum? $raw-fd-a))]
    [(fx= (fixnum-width) 61)
     (define $real-fd-a (foreign-alloc (+ 40 7)))
     (define $fd-a (logand (+ $real-fd-a 7) -8))
     (define $raw-fd-a (ash (if (>= $fd-a (expt 2 63)) (- $fd-a (expt 2 64)) $fd-a) -3))
     (and
       (<= 0 $fd-a $fd-addr-max)
       (fixnum? $raw-fd-a))]
    [else ($oops '$raw-fd-a "unexpected fixnum-width ~s" (fixnum-width))])
  (error? ; invalid type
    (foreign-ref 'aint $fd-a 0))
  (error? ; invalid type
    (foreign-ref 'ptr $fd-a 0))
  (error? ; invalid type
    (foreign-ref 'scheme-object $fd-a 0))
  (begin
    (define $fd-f (lambda () (foreign-ref 'ptr $fd-a 0)))
    (procedure? $fd-f))
  (error? ; invalid type
    ($fd-f))
  (begin
    (define $fd-f (lambda (x) (foreign-ref x $fd-a 0)))
    (procedure? $fd-f))
  (error? ; invalid type
    ($fd-f 'ptr))
  (error? ; invalid address
    (foreign-ref 'int 7.5 0))
  (error? ; invalid address
    (foreign-ref 'int (- $fd-addr-min 1) 0))
  (error? ; invalid address
    (foreign-ref 'int (+ $fd-addr-max 1) 0))
  (error? ; not a fixnum
    (foreign-ref 'int $fd-a 0.0))
  (error? ; not a fixnum
    (foreign-ref 'int $fd-a (+ (most-positive-fixnum) 1)))
  (error? ; not a fixnum
    (foreign-ref 'int $fd-a (- (most-negative-fixnum) 1)))
 ; foreign-set!
  (error? ; invalid type
    (foreign-set! 'aint $fd-a 0 17))
  (error? ; invalid type
    (foreign-set! 'ptr $fd-a 0 17))
  (error? ; invalid type
    (foreign-set! 'scheme-object $fd-a 0 17))
  (begin
    (define $fd-f (lambda () (foreign-set! 'ptr $fd-a 0 17)))
    (procedure? $fd-f))
  (error? ; invalid type
    ($fd-f))
  (begin
    (define $fd-f (lambda (x) (foreign-set! x $fd-a 0 17)))
    (procedure? $fd-f))
  (error? ; invalid type
    ($fd-f 'ptr))
  (error? ; invalid address
    (foreign-set! 'int 7.5 0 17))
  (error? ; invalid address
    (foreign-set! 'int (- $fd-addr-min 1) 0 17))
  (error? ; invalid address
    (foreign-set! 'int (+ $fd-addr-max 1) 0 17))
  (error? ; not a fixnum
    (foreign-set! 'int $fd-a 0.0 17))
  (error? ; not a fixnum
    (foreign-set! 'int $fd-a (+ (most-positive-fixnum) 1) 17))
  (error? ; not a fixnum
    (foreign-set! 'int $fd-a (- (most-negative-fixnum) 1) 17))
 ; integer-8/unsigned-8
  (error? ; invalid value for type
    (foreign-set! 'integer-8 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'integer-8 $fd-a 0 (- $fd-i8-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'integer-8 $fd-a 0 (+ $fd-i8-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-8 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-8 $fd-a 0 (- $fd-i8-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-8 $fd-a 0 (+ $fd-i8-max 1)))
  (equal?
    (begin
      (foreign-set! 'integer-8 $fd-a 3 255)
      (list (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 3)))
    '(-1 255))
  (equal?
    (begin
      (foreign-set! 'unsigned-8 $fd-a 5 -5)
      (list (foreign-ref 'integer-8 $fd-a 5)
            (foreign-ref 'unsigned-8 $fd-a 5)))
    '(-5 251))
  (equal?
    (begin
      (foreign-set! 'integer-8 $fd-a 0 #x-80)
      (foreign-set! 'integer-8 $fd-a 1 0)
      (foreign-set! 'integer-8 $fd-a 2 #x7f)
      (foreign-set! 'integer-8 $fd-a 3 #x80)
      (foreign-set! 'integer-8 $fd-a 4 #xff)
      (list (foreign-ref 'integer-8 $fd-a 0)
            (foreign-ref 'integer-8 $fd-a 1)
            (foreign-ref 'integer-8 $fd-a 2)
            (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'integer-8 $fd-a 4)
            (foreign-ref 'unsigned-8 $fd-a 0)
            (foreign-ref 'unsigned-8 $fd-a 1)
            (foreign-ref 'unsigned-8 $fd-a 2)
            (foreign-ref 'unsigned-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
  (equal?
    (begin
      (foreign-set! 'unsigned-8 $fd-a 0 #x-80)
      (foreign-set! 'unsigned-8 $fd-a 1 0)
      (foreign-set! 'unsigned-8 $fd-a 2 #x7f)
      (foreign-set! 'unsigned-8 $fd-a 3 #x80)
      (foreign-set! 'unsigned-8 $fd-a 4 #xff)
      (list (foreign-ref 'integer-8 $fd-a 0)
            (foreign-ref 'integer-8 $fd-a 1)
            (foreign-ref 'integer-8 $fd-a 2)
            (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'integer-8 $fd-a 4)
            (foreign-ref 'unsigned-8 $fd-a 0)
            (foreign-ref 'unsigned-8 $fd-a 1)
            (foreign-ref 'unsigned-8 $fd-a 2)
            (foreign-ref 'unsigned-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
 ; integer-16/unsigned-16
  (error? ; invalid value for type
    (foreign-set! 'integer-16 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'integer-16 $fd-a 0 (- $fd-i16-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'integer-16 $fd-a 0 (+ $fd-i16-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-16 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-16 $fd-a 0 (- $fd-i16-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-16 $fd-a 0 (+ $fd-i16-max 1)))
  (equal?
    (begin
      (foreign-set! 'integer-16 $fd-a 2 #xabcd)
      (list (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 2)))
    `(,(- #xabcd #x10000) #xabcd))
  (equal?
    (begin
      (foreign-set! 'unsigned-16 $fd-a 2 -5321)
      (list (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 2)))
    `(-5321 ,(+ -5321 #x10000)))
  (equal?
    (begin
      (foreign-set! 'integer-16 $fd-a 0 #x-8000)
      (foreign-set! 'integer-16 $fd-a 2 0)
      (foreign-set! 'integer-16 $fd-a 4 #x7fff)
      (foreign-set! 'integer-16 $fd-a 6 #x8000)
      (foreign-set! 'integer-16 $fd-a 8 #xffff)
      (list (foreign-ref 'integer-16 $fd-a 0)
            (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'integer-16 $fd-a 4)
            (foreign-ref 'integer-16 $fd-a 6)
            (foreign-ref 'integer-16 $fd-a 8)
            (foreign-ref 'unsigned-16 $fd-a 0)
            (foreign-ref 'unsigned-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 4)
            (foreign-ref 'unsigned-16 $fd-a 6)
            (foreign-ref 'unsigned-16 $fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-16 $fd-a 0 #x-8000)
      (foreign-set! 'unsigned-16 $fd-a 2 0)
      (foreign-set! 'unsigned-16 $fd-a 4 #x7fff)
      (foreign-set! 'unsigned-16 $fd-a 6 #x8000)
      (foreign-set! 'unsigned-16 $fd-a 8 #xffff)
      (list (foreign-ref 'integer-16 $fd-a 0)
            (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'integer-16 $fd-a 4)
            (foreign-ref 'integer-16 $fd-a 6)
            (foreign-ref 'integer-16 $fd-a 8)
            (foreign-ref 'unsigned-16 $fd-a 0)
            (foreign-ref 'unsigned-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 4)
            (foreign-ref 'unsigned-16 $fd-a 6)
            (foreign-ref 'unsigned-16 $fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
 ; integer-32/unsigned-32
  (error? ; invalid value for type
    (foreign-set! 'integer-32 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'integer-32 $fd-a 0 (- $fd-i32-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'integer-32 $fd-a 0 (+ $fd-i32-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-32 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-32 $fd-a 0 (- $fd-i32-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-32 $fd-a 0 (+ $fd-i32-max 1)))
  (equal?
    (begin
      (foreign-set! 'integer-32 $fd-a 0 #x-80000000)
      (foreign-set! 'integer-32 $fd-a 4 0)
      (foreign-set! 'integer-32 $fd-a 8 #x7fffffff)
      (foreign-set! 'integer-32 $fd-a 12 #x80000000)
      (foreign-set! 'integer-32 $fd-a 16 #xffffffff)
      (list (foreign-ref 'integer-32 $fd-a 0)
            (foreign-ref 'integer-32 $fd-a 4)
            (foreign-ref 'integer-32 $fd-a 8)
            (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'integer-32 $fd-a 16)
            (foreign-ref 'unsigned-32 $fd-a 0)
            (foreign-ref 'unsigned-32 $fd-a 4)
            (foreign-ref 'unsigned-32 $fd-a 8)
            (foreign-ref 'unsigned-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-32 $fd-a 0 #x-80000000)
      (foreign-set! 'unsigned-32 $fd-a 4 0)
      (foreign-set! 'unsigned-32 $fd-a 8 #x7fffffff)
      (foreign-set! 'unsigned-32 $fd-a 12 #x80000000)
      (foreign-set! 'unsigned-32 $fd-a 16 #xffffffff)
      (list (foreign-ref 'integer-32 $fd-a 0)
            (foreign-ref 'integer-32 $fd-a 4)
            (foreign-ref 'integer-32 $fd-a 8)
            (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'integer-32 $fd-a 16)
            (foreign-ref 'unsigned-32 $fd-a 0)
            (foreign-ref 'unsigned-32 $fd-a 4)
            (foreign-ref 'unsigned-32 $fd-a 8)
            (foreign-ref 'unsigned-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (foreign-set! 'integer-32 $fd-a 12 #xabcd1234)
      (list (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 12)))
    `(,(- #xabcd1234 #x100000000) #xabcd1234))
  (equal?
    (begin
      (foreign-set! 'unsigned-32 $fd-a 12 #x-765321ab)
      (list (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 12)))
    `(#x-765321ab ,(+ #x-765321ab #x100000000)))
 ; integer-64/unsigned-64
  (error? ; invalid value for type
    (foreign-set! 'integer-64 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'integer-64 $fd-a 0 (- $fd-i64-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'integer-64 $fd-a 0 (+ $fd-i64-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-64 $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-64 $fd-a 0 (- $fd-i64-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-64 $fd-a 0 (+ $fd-i64-max 1)))
  (equal?
    (begin
      (foreign-set! 'integer-64 $fd-a 16 #xabcd1234ffee8765)
      (list (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
    `(,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765
      ,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765))
  (equal?
    (begin
      (foreign-set! 'unsigned-64 $fd-a 16 #x-765321ab4c8e9de1)
      (list (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
    `(#x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
      #x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
  (equal?
    (begin
      (foreign-set! 'integer-64 $fd-a 0 #x-8000000000000000)
      (foreign-set! 'integer-64 $fd-a 8 0)
      (foreign-set! 'integer-64 $fd-a 16 #x7fffffffffffffff)
      (foreign-set! 'integer-64 $fd-a 24 #x8000000000000000)
      (foreign-set! 'integer-64 $fd-a 32 #xffffffffffffffff)
      (list (foreign-ref 'integer-64 $fd-a 0)
            (foreign-ref 'integer-64 $fd-a 8)
            (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'integer-64 $fd-a 24)
            (foreign-ref 'integer-64 $fd-a 32)
            (foreign-ref 'unsigned-64 $fd-a 0)
            (foreign-ref 'unsigned-64 $fd-a 8)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 24)
            (foreign-ref 'unsigned-64 $fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-64 $fd-a 0 #x-8000000000000000)
      (foreign-set! 'unsigned-64 $fd-a 8 0)
      (foreign-set! 'unsigned-64 $fd-a 16 #x7fffffffffffffff)
      (foreign-set! 'unsigned-64 $fd-a 24 #x8000000000000000)
      (foreign-set! 'unsigned-64 $fd-a 32 #xffffffffffffffff)
      (list (foreign-ref 'integer-64 $fd-a 0)
            (foreign-ref 'integer-64 $fd-a 8)
            (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'integer-64 $fd-a 24)
            (foreign-ref 'integer-64 $fd-a 32)
            (foreign-ref 'unsigned-64 $fd-a 0)
            (foreign-ref 'unsigned-64 $fd-a 8)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 24)
            (foreign-ref 'unsigned-64 $fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
 ; iptr/uptr
  (error? ; invalid value for type
    (foreign-set! 'iptr $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'iptr $fd-a 0 (- $fd-addr-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'iptr $fd-a 0 (+ $fd-addr-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'uptr $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'uptr $fd-a 0 (- $fd-addr-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'uptr $fd-a 0 (+ $fd-addr-max 1)))
  (case $fd-addr-max
    [(#xffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'iptr $fd-a 12 #xabcd1234)
           (list (foreign-ref 'iptr $fd-a 12)
                 (foreign-ref 'uptr $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(,(- #xabcd1234 #x100000000)
           #xabcd1234
           ,(- #xabcd1234 #x100000000)
           #xabcd1234))
       (equal?
         (begin
           (foreign-set! 'uptr $fd-a 12 #x-765321ab)
           (list (foreign-ref 'iptr $fd-a 12)
                 (foreign-ref 'uptr $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(#x-765321ab
          ,(+ #x-765321ab #x100000000)
          #x-765321ab
          ,(+ #x-765321ab #x100000000))))]
    [(#xffffffffffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'iptr $fd-a 16 #xabcd1234ffee8765)
           (list (foreign-ref 'iptr $fd-a 16)
                 (foreign-ref 'uptr $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765
           ,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765))
       (equal?
         (begin
           (foreign-set! 'uptr $fd-a 16 #x-765321ab4c8e9de1)
           (list (foreign-ref 'iptr $fd-a 16)
                 (foreign-ref 'uptr $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(#x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
           #x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
       (equal?
         (begin
           (foreign-set! 'void* $fd-a 16 #x-765321ab4c8e9de1)
           (list (foreign-ref 'iptr $fd-a 16)
                 (foreign-ref 'void* $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(#x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
           #x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
    [else (error 'foreign-data-mat "unexpected $fd-addr-max ~s" $fd-addr-max)])
 ; int/unsigned
  (error? ; invalid value for type
    (foreign-set! 'int $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'int $fd-a 0 (- $fd-int-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'int $fd-a 0 (+ $fd-int-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned $fd-a 0 (- $fd-int-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned $fd-a 0 (+ $fd-int-max 1)))
  (case $fd-int-max
    [(#xffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'int $fd-a 0 #x-80000000)
           (foreign-set! 'int $fd-a 4 0)
           (foreign-set! 'int $fd-a 8 #x7fffffff)
           (foreign-set! 'int $fd-a 12 #x80000000)
           (foreign-set! 'int $fd-a 16 #xffffffff)
           (list (foreign-ref 'int $fd-a 0)
                 (foreign-ref 'int $fd-a 4)
                 (foreign-ref 'int $fd-a 8)
                 (foreign-ref 'int $fd-a 12)
                 (foreign-ref 'int $fd-a 16)
                 (foreign-ref 'unsigned $fd-a 0)
                 (foreign-ref 'unsigned $fd-a 4)
                 (foreign-ref 'unsigned $fd-a 8)
                 (foreign-ref 'unsigned $fd-a 12)
                 (foreign-ref 'unsigned $fd-a 16)))
         `(#x-80000000 0 #x7fffffff #x-80000000 -1
           #x80000000 0 #x7fffffff #x80000000 #xffffffff))
       (equal?
         (begin
           (foreign-set! 'unsigned $fd-a 0 #x-80000000)
           (foreign-set! 'unsigned $fd-a 4 0)
           (foreign-set! 'unsigned $fd-a 8 #x7fffffff)
           (foreign-set! 'unsigned $fd-a 12 #x80000000)
           (foreign-set! 'unsigned $fd-a 16 #xffffffff)
           (list (foreign-ref 'int $fd-a 0)
                 (foreign-ref 'int $fd-a 4)
                 (foreign-ref 'int $fd-a 8)
                 (foreign-ref 'int $fd-a 12)
                 (foreign-ref 'int $fd-a 16)
                 (foreign-ref 'unsigned $fd-a 0)
                 (foreign-ref 'unsigned $fd-a 4)
                 (foreign-ref 'unsigned $fd-a 8)
                 (foreign-ref 'unsigned $fd-a 12)
                 (foreign-ref 'unsigned $fd-a 16)))
         `(#x-80000000 0 #x7fffffff #x-80000000 -1
           #x80000000 0 #x7fffffff #x80000000 #xffffffff))
       (equal?
         (begin
           (foreign-set! 'unsigned-int $fd-a 0 #x-80000000)
           (foreign-set! 'unsigned-int $fd-a 4 0)
           (foreign-set! 'unsigned-int $fd-a 8 #x7fffffff)
           (foreign-set! 'unsigned-int $fd-a 12 #x80000000)
           (foreign-set! 'unsigned-int $fd-a 16 #xffffffff)
           (list (foreign-ref 'int $fd-a 0)
                 (foreign-ref 'int $fd-a 4)
                 (foreign-ref 'int $fd-a 8)
                 (foreign-ref 'int $fd-a 12)
                 (foreign-ref 'int $fd-a 16)
                 (foreign-ref 'unsigned-int $fd-a 0)
                 (foreign-ref 'unsigned-int $fd-a 4)
                 (foreign-ref 'unsigned-int $fd-a 8)
                 (foreign-ref 'unsigned-int $fd-a 12)
                 (foreign-ref 'unsigned-int $fd-a 16)))
         `(#x-80000000 0 #x7fffffff #x-80000000 -1
           #x80000000 0 #x7fffffff #x80000000 #xffffffff))
       (equal?
         (begin
           (foreign-set! 'int $fd-a 12 #xabcd1234)
           (list (foreign-ref 'int $fd-a 12)
                 (foreign-ref 'unsigned $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(,(- #xabcd1234 #x100000000)
           #xabcd1234
           ,(- #xabcd1234 #x100000000)
           #xabcd1234))
       (equal?
         (begin
           (foreign-set! 'unsigned $fd-a 12 #x-765321ab)
           (list (foreign-ref 'int $fd-a 12)
                 (foreign-ref 'unsigned $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(#x-765321ab
          ,(+ #x-765321ab #x100000000)
          #x-765321ab
          ,(+ #x-765321ab #x100000000))))]
    [else (error 'foreign-data-mat "unexpected $fd-int-max ~s" $fd-int-max)])
 ; short/unsigned-short
  (error? ; invalid value for type
    (foreign-set! 'short $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'short $fd-a 0 (- $fd-short-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'short $fd-a 0 (+ $fd-short-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-short $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-short $fd-a 0 (- $fd-short-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-short $fd-a 0 (+ $fd-short-max 1)))
  (case $fd-short-max
    [(#xffff)
     (and
       (equal?
         (begin
           (foreign-set! 'short $fd-a 0 #x-8000)
           (foreign-set! 'short $fd-a 2 0)
           (foreign-set! 'short $fd-a 4 #x7fff)
           (foreign-set! 'short $fd-a 6 #x8000)
           (foreign-set! 'short $fd-a 8 #xffff)
           (list (foreign-ref 'short $fd-a 0)
                 (foreign-ref 'short $fd-a 2)
                 (foreign-ref 'short $fd-a 4)
                 (foreign-ref 'short $fd-a 6)
                 (foreign-ref 'short $fd-a 8)
                 (foreign-ref 'unsigned-short $fd-a 0)
                 (foreign-ref 'unsigned-short $fd-a 2)
                 (foreign-ref 'unsigned-short $fd-a 4)
                 (foreign-ref 'unsigned-short $fd-a 6)
                 (foreign-ref 'unsigned-short $fd-a 8)))
         `(#x-8000 0 #x7fff #x-8000 -1
           #x8000 0 #x7fff #x8000 #xffff))
       (equal?
         (begin
           (foreign-set! 'unsigned-short $fd-a 0 #x-8000)
           (foreign-set! 'unsigned-short $fd-a 2 0)
           (foreign-set! 'unsigned-short $fd-a 4 #x7fff)
           (foreign-set! 'unsigned-short $fd-a 6 #x8000)
           (foreign-set! 'unsigned-short $fd-a 8 #xffff)
           (list (foreign-ref 'short $fd-a 0)
                 (foreign-ref 'short $fd-a 2)
                 (foreign-ref 'short $fd-a 4)
                 (foreign-ref 'short $fd-a 6)
                 (foreign-ref 'short $fd-a 8)
                 (foreign-ref 'unsigned-short $fd-a 0)
                 (foreign-ref 'unsigned-short $fd-a 2)
                 (foreign-ref 'unsigned-short $fd-a 4)
                 (foreign-ref 'unsigned-short $fd-a 6)
                 (foreign-ref 'unsigned-short $fd-a 8)))
         `(#x-8000 0 #x7fff #x-8000 -1
           #x8000 0 #x7fff #x8000 #xffff))
       (equal?
         (begin
           (foreign-set! 'short $fd-a 2 #xabcd)
           (list (foreign-ref 'short $fd-a 2)
                 (foreign-ref 'unsigned-short $fd-a 2)
                 (foreign-ref 'integer-16 $fd-a 2)
                 (foreign-ref 'unsigned-16 $fd-a 2)))
         `(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
       (equal?
         (begin
           (foreign-set! 'unsigned-short $fd-a 2 -5321)
           (list (foreign-ref 'short $fd-a 2)
                 (foreign-ref 'unsigned-short $fd-a 2)
                 (foreign-ref 'integer-16 $fd-a 2)
                 (foreign-ref 'unsigned-16 $fd-a 2)))
         `(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
    [else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)])
 ; long/unsigned-long
  (error? ; invalid value for type
    (foreign-set! 'long $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'long $fd-a 0 (- $fd-long-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'long $fd-a 0 (+ $fd-long-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long $fd-a 0 (- $fd-long-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long $fd-a 0 (+ $fd-long-max 1)))
  (case $fd-long-max
    [(#xffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'long $fd-a 0 #x-80000000)
           (foreign-set! 'long $fd-a 4 0)
           (foreign-set! 'long $fd-a 8 #x7fffffff)
           (foreign-set! 'long $fd-a 12 #x80000000)
           (foreign-set! 'long $fd-a 16 #xffffffff)
           (list (foreign-ref 'long $fd-a 0)
                 (foreign-ref 'long $fd-a 4)
                 (foreign-ref 'long $fd-a 8)
                 (foreign-ref 'long $fd-a 12)
                 (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 0)
                 (foreign-ref 'unsigned-long $fd-a 4)
                 (foreign-ref 'unsigned-long $fd-a 8)
                 (foreign-ref 'unsigned-long $fd-a 12)
                 (foreign-ref 'unsigned-long $fd-a 16)))
         `(#x-80000000 0 #x7fffffff #x-80000000 -1
           #x80000000 0 #x7fffffff #x80000000 #xffffffff))
       (equal?
         (begin
           (foreign-set! 'unsigned-long $fd-a 0 #x-80000000)
           (foreign-set! 'unsigned-long $fd-a 4 0)
           (foreign-set! 'unsigned-long $fd-a 8 #x7fffffff)
           (foreign-set! 'unsigned-long $fd-a 12 #x80000000)
           (foreign-set! 'unsigned-long $fd-a 16 #xffffffff)
           (list (foreign-ref 'long $fd-a 0)
                 (foreign-ref 'long $fd-a 4)
                 (foreign-ref 'long $fd-a 8)
                 (foreign-ref 'long $fd-a 12)
                 (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 0)
                 (foreign-ref 'unsigned-long $fd-a 4)
                 (foreign-ref 'unsigned-long $fd-a 8)
                 (foreign-ref 'unsigned-long $fd-a 12)
                 (foreign-ref 'unsigned-long $fd-a 16)))
         `(#x-80000000 0 #x7fffffff #x-80000000 -1
           #x80000000 0 #x7fffffff #x80000000 #xffffffff))
       (equal?
         (begin
           (foreign-set! 'long $fd-a 12 #xabcd1234)
           (list (foreign-ref 'long $fd-a 12)
                 (foreign-ref 'unsigned-long $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(,(- #xabcd1234 #x100000000)
           #xabcd1234
           ,(- #xabcd1234 #x100000000)
           #xabcd1234))
       (equal?
         (begin
           (foreign-set! 'unsigned-long $fd-a 12 #x-765321ab)
           (list (foreign-ref 'long $fd-a 12)
                 (foreign-ref 'unsigned-long $fd-a 12)
                 (foreign-ref 'integer-32 $fd-a 12)
                 (foreign-ref 'unsigned-32 $fd-a 12)))
         `(#x-765321ab
          ,(+ #x-765321ab #x100000000)
          #x-765321ab
          ,(+ #x-765321ab #x100000000))))]
    [(#xffffffffffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'long $fd-a 0 #x-8000000000000000)
           (foreign-set! 'long $fd-a 8 0)
           (foreign-set! 'long $fd-a 16 #x7fffffffffffffff)
           (foreign-set! 'long $fd-a 24 #x8000000000000000)
           (foreign-set! 'long $fd-a 32 #xffffffffffffffff)
           (list (foreign-ref 'long $fd-a 0)
                 (foreign-ref 'long $fd-a 8)
                 (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'long $fd-a 24)
                 (foreign-ref 'long $fd-a 32)
                 (foreign-ref 'unsigned-long $fd-a 0)
                 (foreign-ref 'unsigned-long $fd-a 8)
                 (foreign-ref 'unsigned-long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 24)
                 (foreign-ref 'unsigned-long $fd-a 32)))
         `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
           #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
       (equal?
         (begin
           (foreign-set! 'unsigned-long $fd-a 0 #x-8000000000000000)
           (foreign-set! 'unsigned-long $fd-a 8 0)
           (foreign-set! 'unsigned-long $fd-a 16 #x7fffffffffffffff)
           (foreign-set! 'unsigned-long $fd-a 24 #x8000000000000000)
           (foreign-set! 'unsigned-long $fd-a 32 #xffffffffffffffff)
           (list (foreign-ref 'long $fd-a 0)
                 (foreign-ref 'long $fd-a 8)
                 (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'long $fd-a 24)
                 (foreign-ref 'long $fd-a 32)
                 (foreign-ref 'unsigned-long $fd-a 0)
                 (foreign-ref 'unsigned-long $fd-a 8)
                 (foreign-ref 'unsigned-long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 24)
                 (foreign-ref 'unsigned-long $fd-a 32)))
         `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
           #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
       (equal?
         (begin
           (foreign-set! 'long $fd-a 16 #xabcd1234ffee8765)
           (list (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765
           ,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765))
       (equal?
         (begin
           (foreign-set! 'unsigned-long $fd-a 16 #x-765321ab4c8e9de1)
           (list (foreign-ref 'long $fd-a 16)
                 (foreign-ref 'unsigned-long $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(#x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
           #x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
    [else (error 'foreign-data-mat "unexpected $fd-long-max ~s" $fd-long-max)])
 ; long-long/unsigned-long-long
  (error? ; invalid value for type
    (foreign-set! 'long-long $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'long-long $fd-a 0 (- $fd-long-long-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'long-long $fd-a 0 (+ $fd-long-long-max 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long-long $fd-a 0 17.0))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long-long $fd-a 0 (- $fd-long-long-min 1)))
  (error? ; invalid value for type
    (foreign-set! 'unsigned-long-long $fd-a 0 (+ $fd-long-long-max 1)))
  (case $fd-long-long-max
    [(#xffffffffffffffff)
     (and
       (equal?
         (begin
           (foreign-set! 'long-long $fd-a 0 #x-8000000000000000)
           (foreign-set! 'long-long $fd-a 8 0)
           (foreign-set! 'long-long $fd-a 16 #x7fffffffffffffff)
           (foreign-set! 'long-long $fd-a 24 #x8000000000000000)
           (foreign-set! 'long-long $fd-a 32 #xffffffffffffffff)
           (list (foreign-ref 'long-long $fd-a 0)
                 (foreign-ref 'long-long $fd-a 8)
                 (foreign-ref 'long-long $fd-a 16)
                 (foreign-ref 'long-long $fd-a 24)
                 (foreign-ref 'long-long $fd-a 32)
                 (foreign-ref 'unsigned-long-long $fd-a 0)
                 (foreign-ref 'unsigned-long-long $fd-a 8)
                 (foreign-ref 'unsigned-long-long $fd-a 16)
                 (foreign-ref 'unsigned-long-long $fd-a 24)
                 (foreign-ref 'unsigned-long-long $fd-a 32)))
         `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
           #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
       (equal?
         (begin
           (foreign-set! 'unsigned-long-long $fd-a 0 #x-8000000000000000)
           (foreign-set! 'unsigned-long-long $fd-a 8 0)
           (foreign-set! 'unsigned-long-long $fd-a 16 #x7fffffffffffffff)
           (foreign-set! 'unsigned-long-long $fd-a 24 #x8000000000000000)
           (foreign-set! 'unsigned-long-long $fd-a 32 #xffffffffffffffff)
           (list (foreign-ref 'long-long $fd-a 0)
                 (foreign-ref 'long-long $fd-a 8)
                 (foreign-ref 'long-long $fd-a 16)
                 (foreign-ref 'long-long $fd-a 24)
                 (foreign-ref 'long-long $fd-a 32)
                 (foreign-ref 'unsigned-long-long $fd-a 0)
                 (foreign-ref 'unsigned-long-long $fd-a 8)
                 (foreign-ref 'unsigned-long-long $fd-a 16)
                 (foreign-ref 'unsigned-long-long $fd-a 24)
                 (foreign-ref 'unsigned-long-long $fd-a 32)))
         `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
           #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
       (equal?
         (begin
           (foreign-set! 'long-long $fd-a 16 #xabcd1234ffee8765)
           (list (foreign-ref 'long-long $fd-a 16)
                 (foreign-ref 'unsigned-long-long $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765
           ,(- #xabcd1234ffee8765 #x10000000000000000)
           #xabcd1234ffee8765))
       (equal?
         (begin
           (foreign-set! 'unsigned-long-long $fd-a 16 #x-765321ab4c8e9de1)
           (list (foreign-ref 'long-long $fd-a 16)
                 (foreign-ref 'unsigned-long-long $fd-a 16)
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
                 (if (eq? (native-endianness) 'little)
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 16)
                       (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                     (logor
                       (foreign-ref 'unsigned-32 $fd-a 20)
                       (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
         `(#x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
           #x-765321ab4c8e9de1
           ,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
    [else (error 'foreign-data-mat "unexpected $fd-long-long-max ~s" $fd-long-long-max)])
 ; char
  (error? ; invalid value for type
    (foreign-set! 'char $fd-a 0 17))
  (error? ; invalid value for type
    (foreign-set! 'char $fd-a 0 (integer->char (+ $fd-char-max 1))))
  (case $fd-char-max
    [(#xff)
     (and
       (equal?
         (begin
           (foreign-set! 'char $fd-a 2 #\xed)
           (list (foreign-ref 'char $fd-a 2)
                 (foreign-ref 'unsigned-8 $fd-a 2)))
         `(#\xed #xed))
       (equal?
         (begin
           (foreign-set! 'char $fd-a 3 (integer->char 0))
           (list (foreign-ref 'char $fd-a 3)
                 (foreign-ref 'unsigned-8 $fd-a 3)))
         `(#\nul 0))
       (equal?
         (begin
           (foreign-set! 'char $fd-a 3 (integer->char $fd-char-max))
           (list (foreign-ref 'char $fd-a 3)
                 (foreign-ref 'unsigned-8 $fd-a 3)))
         `(,(integer->char $fd-char-max) ,$fd-char-max)))]
    [else (error 'foreign-data-mat "unexpected $fd-char-max ~s" $fd-char-max)])
 ; wchar
  (error? ; invalid value for type
    (foreign-set! 'wchar $fd-a 0 17))
  (or (= $fd-wchar-max #x10ffff)
      (guard (c [#t])
        (foreign-set! 'wchar $fd-a 0 (integer->char (+ $fd-wchar-max 1)))
        #f))
  (case $fd-wchar-max
    [(#xffff)
     (and
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 2 #\xedac)
           (list (foreign-ref 'wchar $fd-a 2)
                 (foreign-ref 'unsigned-16 $fd-a 2)))
         `(#\xedac #xedac))
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 2 (integer->char 0))
           (list (foreign-ref 'wchar $fd-a 2)
                 (foreign-ref 'unsigned-16 $fd-a 2)))
         `(#\nul 0))
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 2 (integer->char $fd-wchar-max))
           (list (foreign-ref 'wchar $fd-a 2)
                 (foreign-ref 'unsigned-16 $fd-a 2)))
         `(,(integer->char $fd-wchar-max) ,$fd-wchar-max)))]
    [(#x10ffff)
     (and
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 4 #\x10edac)
           (list (foreign-ref 'wchar $fd-a 4)
                 (foreign-ref 'unsigned-32 $fd-a 4)))
         `(#\x10edac #x10edac))
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 4 (integer->char 0))
           (list (foreign-ref 'wchar $fd-a 4)
                 (foreign-ref 'unsigned-32 $fd-a 4)))
         `(#\nul 0))
       (equal?
         (begin
           (foreign-set! 'wchar $fd-a 4 (integer->char $fd-wchar-max))
           (list (foreign-ref 'wchar $fd-a 4)
                 (foreign-ref 'unsigned-32 $fd-a 4)))
         `(,(integer->char $fd-wchar-max) ,$fd-wchar-max)))]
    [else (error 'foreign-data-mat "unexpected $fd-wchar-max ~s" $fd-wchar-max)])
 ; boolean
  (equal?
    (begin
      (foreign-set! 'boolean $fd-a 0 #t)
      (foreign-set! 'boolean $fd-a 8 #f)
      (foreign-set! 'boolean $fd-a 16 0)
      (foreign-set! 'int $fd-a 24 64)
      (list
        (foreign-ref 'boolean $fd-a 0)
        (foreign-ref 'boolean $fd-a 8)
        (foreign-ref 'boolean $fd-a 16)
        (foreign-ref 'boolean $fd-a 24)
        (foreign-ref 'int $fd-a 0)
        (foreign-ref 'int $fd-a 8)
        (foreign-ref 'int $fd-a 16)
        (foreign-ref 'int $fd-a 24)))
    '(#t #f #t #t 1 0 1 64))
 ; fixnum
  (error? ; invalid value for type
    (foreign-set! 'fixnum $fd-a 0 2/3))
  (error? ; invalid value for type
    (foreign-set! 'fixnum $fd-a 0 (+ (greatest-fixnum) 1)))
  (error? ; invalid value for type
    (foreign-set! 'fixnum $fd-a 0 (- (least-fixnum) 1)))
  (equal?
    (begin
      (foreign-set! 'fixnum $fd-a 0 (greatest-fixnum))
      (foreign-set! 'fixnum $fd-a 8 (least-fixnum))
      (foreign-set! 'fixnum $fd-a 16 0)
      (foreign-set! 'fixnum $fd-a 24 (quotient (greatest-fixnum) 2))
      (list
        (foreign-ref 'fixnum $fd-a 0)
        (foreign-ref 'fixnum $fd-a 8)
        (foreign-ref 'fixnum $fd-a 16)
        (foreign-ref 'fixnum $fd-a 24)))
    `(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
 ; float / single-float
  (error? ; invalid value for type
    (foreign-set! 'float $fd-a 0 17))
  (error? ; invalid value for type
    (foreign-set! 'single-float $fd-a 0 17))
  (equal?
    (begin
      (foreign-set! 'float $fd-a 12 7.5)
      (list (foreign-ref 'float $fd-a 12)
            (foreign-ref 'single-float $fd-a 12)))
    '(7.5 7.5))
  (equal?
    (begin
      (foreign-set! 'single-float $fd-a 12 7.5)
      (list (foreign-ref 'float $fd-a 12)
            (foreign-ref 'single-float $fd-a 12)))
    '(7.5 7.5))
 ; double / double-float
  (error? ; invalid value for type
    (foreign-set! 'double $fd-a 0 17))
  (error? ; invalid value for type
    (foreign-set! 'double-float $fd-a 0 17))
  (equal?
    (begin
      (foreign-set! 'double $fd-a 8 -5.4)
      (list (foreign-ref 'double $fd-a 8)
            (foreign-ref 'double-float $fd-a 8)))
    '(-5.4 -5.4))
  (equal?
    (begin
      (foreign-set! 'double-float $fd-a 8 -5.4)
      (list (foreign-ref 'double $fd-a 8)
            (foreign-ref 'double-float $fd-a 8)))
    '(-5.4 -5.4))
 ; spot check unaligned ref/set
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (foreign-set! 'unsigned-32 $fd-a 13 #x-765321ab)
          (list (foreign-ref 'integer-32 $fd-a 13)
                (foreign-ref 'unsigned-32 $fd-a 13)))
        `(#x-765321ab ,(+ #x-765321ab #x100000000))))
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (foreign-set! 'integer-64 $fd-a 17 #xabcd1234ffee8765)
          (list (foreign-ref 'integer-64 $fd-a 17)
                (foreign-ref 'unsigned-64 $fd-a 17)
                (if (eq? (native-endianness) 'little)
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 17)
                      (ash (foreign-ref 'integer-32 $fd-a 21) 32))
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 21)
                      (ash (foreign-ref 'integer-32 $fd-a 17) 32)))
                (if (eq? (native-endianness) 'little)
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 17)
                      (ash (foreign-ref 'unsigned-32 $fd-a 21) 32))
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 21)
                      (ash (foreign-ref 'unsigned-32 $fd-a 17) 32)))))
        `(,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765
          ,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765)))
  (or (not $fd-unaligned-integers)
      (case $fd-short-max
        [(#xffff)
         (and
           (equal?
             (begin
               (foreign-set! 'short $fd-a 3 #xabcd)
               (list (foreign-ref 'short $fd-a 3)
                     (foreign-ref 'unsigned-short $fd-a 3)
                     (foreign-ref 'integer-16 $fd-a 3)
                     (foreign-ref 'unsigned-16 $fd-a 3)))
             `(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
           (equal?
             (begin
               (foreign-set! 'unsigned-short $fd-a 3 -5321)
               (list (foreign-ref 'short $fd-a 3)
                     (foreign-ref 'unsigned-short $fd-a 3)
                     (foreign-ref 'integer-16 $fd-a 3)
                     (foreign-ref 'unsigned-16 $fd-a 3)))
             `(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
        [else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (foreign-set! 'float $fd-a 6 7.5)
          (list (foreign-ref 'float $fd-a 6)
                (foreign-ref 'single-float $fd-a 6)))
        '(7.5 7.5)))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (foreign-set! 'double-float $fd-a 5 -5.4)
          (list (foreign-ref 'double $fd-a 5)
                (foreign-ref 'double-float $fd-a 5)))
        '(-5.4 -5.4)))
 ; $object-ref
  (equal?
    (begin
      (foreign-set! 'integer-8 $fd-a 3 255)
      (list (#%$object-ref 'integer-8 $raw-fd-a 3)
            (#%$object-ref 'unsigned-8 $raw-fd-a 3)))
    '(-1 255))
  (equal?
    (begin
      (foreign-set! 'unsigned-8 $fd-a 5 -5)
      (list (#%$object-ref 'integer-8 $raw-fd-a 5)
            (#%$object-ref 'unsigned-8 $raw-fd-a 5)))
    '(-5 251))
  (equal?
    (begin
      (foreign-set! 'integer-8 $fd-a 0 #x-80)
      (foreign-set! 'integer-8 $fd-a 1 0)
      (foreign-set! 'integer-8 $fd-a 2 #x7f)
      (foreign-set! 'integer-8 $fd-a 3 #x80)
      (foreign-set! 'integer-8 $fd-a 4 #xff)
      (list (#%$object-ref 'integer-8 $raw-fd-a 0)
            (#%$object-ref 'integer-8 $raw-fd-a 1)
            (#%$object-ref 'integer-8 $raw-fd-a 2)
            (#%$object-ref 'integer-8 $raw-fd-a 3)
            (#%$object-ref 'integer-8 $raw-fd-a 4)
            (#%$object-ref 'unsigned-8 $raw-fd-a 0)
            (#%$object-ref 'unsigned-8 $raw-fd-a 1)
            (#%$object-ref 'unsigned-8 $raw-fd-a 2)
            (#%$object-ref 'unsigned-8 $raw-fd-a 3)
            (#%$object-ref 'unsigned-8 $raw-fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
  (equal?
    (begin
      (foreign-set! 'unsigned-8 $fd-a 0 #x-80)
      (foreign-set! 'unsigned-8 $fd-a 1 0)
      (foreign-set! 'unsigned-8 $fd-a 2 #x7f)
      (foreign-set! 'unsigned-8 $fd-a 3 #x80)
      (foreign-set! 'unsigned-8 $fd-a 4 #xff)
      (list (#%$object-ref 'integer-8 $raw-fd-a 0)
            (#%$object-ref 'integer-8 $raw-fd-a 1)
            (#%$object-ref 'integer-8 $raw-fd-a 2)
            (#%$object-ref 'integer-8 $raw-fd-a 3)
            (#%$object-ref 'integer-8 $raw-fd-a 4)
            (#%$object-ref 'unsigned-8 $raw-fd-a 0)
            (#%$object-ref 'unsigned-8 $raw-fd-a 1)
            (#%$object-ref 'unsigned-8 $raw-fd-a 2)
            (#%$object-ref 'unsigned-8 $raw-fd-a 3)
            (#%$object-ref 'unsigned-8 $raw-fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
 ; integer-16/unsigned-16
  (equal?
    (begin
      (foreign-set! 'integer-16 $fd-a 2 #xabcd)
      (list (#%$object-ref 'integer-16 $raw-fd-a 2)
            (#%$object-ref 'unsigned-16 $raw-fd-a 2)))
    `(,(- #xabcd #x10000) #xabcd))
  (equal?
    (begin
      (foreign-set! 'unsigned-16 $fd-a 2 -5321)
      (list (#%$object-ref 'integer-16 $raw-fd-a 2)
            (#%$object-ref 'unsigned-16 $raw-fd-a 2)))
    `(-5321 ,(+ -5321 #x10000)))
  (equal?
    (begin
      (foreign-set! 'integer-16 $fd-a 0 #x-8000)
      (foreign-set! 'integer-16 $fd-a 2 0)
      (foreign-set! 'integer-16 $fd-a 4 #x7fff)
      (foreign-set! 'integer-16 $fd-a 6 #x8000)
      (foreign-set! 'integer-16 $fd-a 8 #xffff)
      (list (#%$object-ref 'integer-16 $raw-fd-a 0)
            (#%$object-ref 'integer-16 $raw-fd-a 2)
            (#%$object-ref 'integer-16 $raw-fd-a 4)
            (#%$object-ref 'integer-16 $raw-fd-a 6)
            (#%$object-ref 'integer-16 $raw-fd-a 8)
            (#%$object-ref 'unsigned-16 $raw-fd-a 0)
            (#%$object-ref 'unsigned-16 $raw-fd-a 2)
            (#%$object-ref 'unsigned-16 $raw-fd-a 4)
            (#%$object-ref 'unsigned-16 $raw-fd-a 6)
            (#%$object-ref 'unsigned-16 $raw-fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-16 $fd-a 0 #x-8000)
      (foreign-set! 'unsigned-16 $fd-a 2 0)
      (foreign-set! 'unsigned-16 $fd-a 4 #x7fff)
      (foreign-set! 'unsigned-16 $fd-a 6 #x8000)
      (foreign-set! 'unsigned-16 $fd-a 8 #xffff)
      (list (#%$object-ref 'integer-16 $raw-fd-a 0)
            (#%$object-ref 'integer-16 $raw-fd-a 2)
            (#%$object-ref 'integer-16 $raw-fd-a 4)
            (#%$object-ref 'integer-16 $raw-fd-a 6)
            (#%$object-ref 'integer-16 $raw-fd-a 8)
            (#%$object-ref 'unsigned-16 $raw-fd-a 0)
            (#%$object-ref 'unsigned-16 $raw-fd-a 2)
            (#%$object-ref 'unsigned-16 $raw-fd-a 4)
            (#%$object-ref 'unsigned-16 $raw-fd-a 6)
            (#%$object-ref 'unsigned-16 $raw-fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
 ; integer-32/unsigned-32
  (equal?
    (begin
      (foreign-set! 'integer-32 $fd-a 0 #x-80000000)
      (foreign-set! 'integer-32 $fd-a 4 0)
      (foreign-set! 'integer-32 $fd-a 8 #x7fffffff)
      (foreign-set! 'integer-32 $fd-a 12 #x80000000)
      (foreign-set! 'integer-32 $fd-a 16 #xffffffff)
      (list (#%$object-ref 'integer-32 $raw-fd-a 0)
            (#%$object-ref 'integer-32 $raw-fd-a 4)
            (#%$object-ref 'integer-32 $raw-fd-a 8)
            (#%$object-ref 'integer-32 $raw-fd-a 12)
            (#%$object-ref 'integer-32 $raw-fd-a 16)
            (#%$object-ref 'unsigned-32 $raw-fd-a 0)
            (#%$object-ref 'unsigned-32 $raw-fd-a 4)
            (#%$object-ref 'unsigned-32 $raw-fd-a 8)
            (#%$object-ref 'unsigned-32 $raw-fd-a 12)
            (#%$object-ref 'unsigned-32 $raw-fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-32 $fd-a 0 #x-80000000)
      (foreign-set! 'unsigned-32 $fd-a 4 0)
      (foreign-set! 'unsigned-32 $fd-a 8 #x7fffffff)
      (foreign-set! 'unsigned-32 $fd-a 12 #x80000000)
      (foreign-set! 'unsigned-32 $fd-a 16 #xffffffff)
      (list (#%$object-ref 'integer-32 $raw-fd-a 0)
            (#%$object-ref 'integer-32 $raw-fd-a 4)
            (#%$object-ref 'integer-32 $raw-fd-a 8)
            (#%$object-ref 'integer-32 $raw-fd-a 12)
            (#%$object-ref 'integer-32 $raw-fd-a 16)
            (#%$object-ref 'unsigned-32 $raw-fd-a 0)
            (#%$object-ref 'unsigned-32 $raw-fd-a 4)
            (#%$object-ref 'unsigned-32 $raw-fd-a 8)
            (#%$object-ref 'unsigned-32 $raw-fd-a 12)
            (#%$object-ref 'unsigned-32 $raw-fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (foreign-set! 'integer-32 $fd-a 12 #xabcd1234)
      (list (#%$object-ref 'integer-32 $raw-fd-a 12)
            (#%$object-ref 'unsigned-32 $raw-fd-a 12)))
    `(,(- #xabcd1234 #x100000000) #xabcd1234))
  (equal?
    (begin
      (foreign-set! 'unsigned-32 $fd-a 12 #x-765321ab)
      (list (#%$object-ref 'integer-32 $raw-fd-a 12)
            (#%$object-ref 'unsigned-32 $raw-fd-a 12)))
    `(#x-765321ab ,(+ #x-765321ab #x100000000)))
 ; integer-64/unsigned-64
  (equal?
    (begin
      (foreign-set! 'integer-64 $fd-a 16 #xabcd1234ffee8765)
      (list (#%$object-ref 'integer-64 $raw-fd-a 16)
            (#%$object-ref 'unsigned-64 $raw-fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 16)
                  (ash (#%$object-ref 'integer-32 $raw-fd-a 20) 32))
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 20)
                  (ash (#%$object-ref 'integer-32 $raw-fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 16)
                  (ash (#%$object-ref 'unsigned-32 $raw-fd-a 20) 32))
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 20)
                  (ash (#%$object-ref 'unsigned-32 $raw-fd-a 16) 32)))))
    `(,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765
      ,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765))
  (equal?
    (begin
      (foreign-set! 'unsigned-64 $fd-a 16 #x-765321ab4c8e9de1)
      (list (#%$object-ref 'integer-64 $raw-fd-a 16)
            (#%$object-ref 'unsigned-64 $raw-fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 16)
                  (ash (#%$object-ref 'integer-32 $raw-fd-a 20) 32))
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 20)
                  (ash (#%$object-ref 'integer-32 $raw-fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 16)
                  (ash (#%$object-ref 'unsigned-32 $raw-fd-a 20) 32))
                (logor
                  (#%$object-ref 'unsigned-32 $raw-fd-a 20)
                  (ash (#%$object-ref 'unsigned-32 $raw-fd-a 16) 32)))))
    `(#x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
      #x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
  (equal?
    (begin
      (foreign-set! 'integer-64 $fd-a 0 #x-8000000000000000)
      (foreign-set! 'integer-64 $fd-a 8 0)
      (foreign-set! 'integer-64 $fd-a 16 #x7fffffffffffffff)
      (foreign-set! 'integer-64 $fd-a 24 #x8000000000000000)
      (foreign-set! 'integer-64 $fd-a 32 #xffffffffffffffff)
      (list (#%$object-ref 'integer-64 $raw-fd-a 0)
            (#%$object-ref 'integer-64 $raw-fd-a 8)
            (#%$object-ref 'integer-64 $raw-fd-a 16)
            (#%$object-ref 'integer-64 $raw-fd-a 24)
            (#%$object-ref 'integer-64 $raw-fd-a 32)
            (#%$object-ref 'unsigned-64 $raw-fd-a 0)
            (#%$object-ref 'unsigned-64 $raw-fd-a 8)
            (#%$object-ref 'unsigned-64 $raw-fd-a 16)
            (#%$object-ref 'unsigned-64 $raw-fd-a 24)
            (#%$object-ref 'unsigned-64 $raw-fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
  (equal?
    (begin
      (foreign-set! 'unsigned-64 $fd-a 0 #x-8000000000000000)
      (foreign-set! 'unsigned-64 $fd-a 8 0)
      (foreign-set! 'unsigned-64 $fd-a 16 #x7fffffffffffffff)
      (foreign-set! 'unsigned-64 $fd-a 24 #x8000000000000000)
      (foreign-set! 'unsigned-64 $fd-a 32 #xffffffffffffffff)
      (list (#%$object-ref 'integer-64 $raw-fd-a 0)
            (#%$object-ref 'integer-64 $raw-fd-a 8)
            (#%$object-ref 'integer-64 $raw-fd-a 16)
            (#%$object-ref 'integer-64 $raw-fd-a 24)
            (#%$object-ref 'integer-64 $raw-fd-a 32)
            (#%$object-ref 'unsigned-64 $raw-fd-a 0)
            (#%$object-ref 'unsigned-64 $raw-fd-a 8)
            (#%$object-ref 'unsigned-64 $raw-fd-a 16)
            (#%$object-ref 'unsigned-64 $raw-fd-a 24)
            (#%$object-ref 'unsigned-64 $raw-fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
 ; fixnum
  (equal?
    (begin
      (foreign-set! 'fixnum $fd-a 0 (greatest-fixnum))
      (foreign-set! 'fixnum $fd-a 8 (least-fixnum))
      (foreign-set! 'fixnum $fd-a 16 0)
      (foreign-set! 'fixnum $fd-a 24 (quotient (greatest-fixnum) 2))
      (list
        (#%$object-ref 'fixnum $raw-fd-a 0)
        (#%$object-ref 'fixnum $raw-fd-a 8)
        (#%$object-ref 'fixnum $raw-fd-a 16)
        (#%$object-ref 'fixnum $raw-fd-a 24)))
    `(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
 ; single-float
  (equal?
    (begin
      (foreign-set! 'single-float $fd-a 12 7.5)
      (#%$object-ref 'single-float $raw-fd-a 12))
    7.5)
 ; double-float
  (equal?
    (begin
      (foreign-set! 'double-float $fd-a 8 -5.4)
      (#%$object-ref 'double-float $raw-fd-a 8))
    -5.4)
 ; spot check unaligned ref/set
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (foreign-set! 'unsigned-32 $fd-a 13 #x-765321ab)
          (list (#%$object-ref 'integer-32 $raw-fd-a 13)
                (#%$object-ref 'unsigned-32 $raw-fd-a 13)))
        `(#x-765321ab ,(+ #x-765321ab #x100000000))))
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (foreign-set! 'integer-64 $fd-a 17 #xabcd1234ffee8765)
          (list (#%$object-ref 'integer-64 $raw-fd-a 17)
                (#%$object-ref 'unsigned-64 $raw-fd-a 17)
                (if (eq? (native-endianness) 'little)
                    (logor
                      (#%$object-ref 'unsigned-32 $raw-fd-a 17)
                      (ash (#%$object-ref 'integer-32 $raw-fd-a 21) 32))
                    (logor
                      (#%$object-ref 'unsigned-32 $raw-fd-a 21)
                      (ash (#%$object-ref 'integer-32 $raw-fd-a 17) 32)))
                (if (eq? (native-endianness) 'little)
                    (logor
                      (#%$object-ref 'unsigned-32 $raw-fd-a 17)
                      (ash (#%$object-ref 'unsigned-32 $raw-fd-a 21) 32))
                    (logor
                      (#%$object-ref 'unsigned-32 $raw-fd-a 21)
                      (ash (#%$object-ref 'unsigned-32 $raw-fd-a 17) 32)))))
        `(,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765
          ,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765)))
  (or (not $fd-unaligned-integers)
      (case $fd-short-max
        [(#xffff)
         (and
           (equal?
             (begin
               (foreign-set! 'short $fd-a 3 #xabcd)
               (list (#%$object-ref 'short $raw-fd-a 3)
                     (#%$object-ref 'unsigned-short $raw-fd-a 3)
                     (#%$object-ref 'integer-16 $raw-fd-a 3)
                     (#%$object-ref 'unsigned-16 $raw-fd-a 3)))
             `(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
           (equal?
             (begin
               (foreign-set! 'unsigned-short $fd-a 3 -5321)
               (list (#%$object-ref 'short $raw-fd-a 3)
                     (#%$object-ref 'unsigned-short $raw-fd-a 3)
                     (#%$object-ref 'integer-16 $raw-fd-a 3)
                     (#%$object-ref 'unsigned-16 $raw-fd-a 3)))
             `(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
        [else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (foreign-set! 'single-float $fd-a 6 7.5)
          (#%$object-ref 'single-float $raw-fd-a 6))
        7.5))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (foreign-set! 'double-float $fd-a 5 -5.4)
          (#%$object-ref 'double-float $raw-fd-a 5))
        -5.4))

 ; $object-set!
  (equal?
    (begin
      (#%$object-set! 'integer-8 $raw-fd-a 3 255)
      (list (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 3)))
    '(-1 255))
  (equal?
    (begin
      (#%$object-set! 'unsigned-8 $raw-fd-a 5 -5)
      (list (foreign-ref 'integer-8 $fd-a 5)
            (foreign-ref 'unsigned-8 $fd-a 5)))
    '(-5 251))
  (equal?
    (begin
      (#%$object-set! 'integer-8 $raw-fd-a 0 #x-80)
      (#%$object-set! 'integer-8 $raw-fd-a 1 0)
      (#%$object-set! 'integer-8 $raw-fd-a 2 #x7f)
      (#%$object-set! 'integer-8 $raw-fd-a 3 #x80)
      (#%$object-set! 'integer-8 $raw-fd-a 4 #xff)
      (list (foreign-ref 'integer-8 $fd-a 0)
            (foreign-ref 'integer-8 $fd-a 1)
            (foreign-ref 'integer-8 $fd-a 2)
            (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'integer-8 $fd-a 4)
            (foreign-ref 'unsigned-8 $fd-a 0)
            (foreign-ref 'unsigned-8 $fd-a 1)
            (foreign-ref 'unsigned-8 $fd-a 2)
            (foreign-ref 'unsigned-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
  (equal?
    (begin
      (#%$object-set! 'unsigned-8 $raw-fd-a 0 #x-80)
      (#%$object-set! 'unsigned-8 $raw-fd-a 1 0)
      (#%$object-set! 'unsigned-8 $raw-fd-a 2 #x7f)
      (#%$object-set! 'unsigned-8 $raw-fd-a 3 #x80)
      (#%$object-set! 'unsigned-8 $raw-fd-a 4 #xff)
      (list (foreign-ref 'integer-8 $fd-a 0)
            (foreign-ref 'integer-8 $fd-a 1)
            (foreign-ref 'integer-8 $fd-a 2)
            (foreign-ref 'integer-8 $fd-a 3)
            (foreign-ref 'integer-8 $fd-a 4)
            (foreign-ref 'unsigned-8 $fd-a 0)
            (foreign-ref 'unsigned-8 $fd-a 1)
            (foreign-ref 'unsigned-8 $fd-a 2)
            (foreign-ref 'unsigned-8 $fd-a 3)
            (foreign-ref 'unsigned-8 $fd-a 4)))
    `(#x-80 0 #x7f #x-80 -1
      #x80 0 #x7f #x80 #xff))
 ; integer-16/unsigned-16
  (equal?
    (begin
      (#%$object-set! 'integer-16 $raw-fd-a 2 #xabcd)
      (list (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 2)))
    `(,(- #xabcd #x10000) #xabcd))
  (equal?
    (begin
      (#%$object-set! 'unsigned-16 $raw-fd-a 2 -5321)
      (list (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 2)))
    `(-5321 ,(+ -5321 #x10000)))
  (equal?
    (begin
      (#%$object-set! 'integer-16 $raw-fd-a 0 #x-8000)
      (#%$object-set! 'integer-16 $raw-fd-a 2 0)
      (#%$object-set! 'integer-16 $raw-fd-a 4 #x7fff)
      (#%$object-set! 'integer-16 $raw-fd-a 6 #x8000)
      (#%$object-set! 'integer-16 $raw-fd-a 8 #xffff)
      (list (foreign-ref 'integer-16 $fd-a 0)
            (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'integer-16 $fd-a 4)
            (foreign-ref 'integer-16 $fd-a 6)
            (foreign-ref 'integer-16 $fd-a 8)
            (foreign-ref 'unsigned-16 $fd-a 0)
            (foreign-ref 'unsigned-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 4)
            (foreign-ref 'unsigned-16 $fd-a 6)
            (foreign-ref 'unsigned-16 $fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
  (equal?
    (begin
      (#%$object-set! 'unsigned-16 $raw-fd-a 0 #x-8000)
      (#%$object-set! 'unsigned-16 $raw-fd-a 2 0)
      (#%$object-set! 'unsigned-16 $raw-fd-a 4 #x7fff)
      (#%$object-set! 'unsigned-16 $raw-fd-a 6 #x8000)
      (#%$object-set! 'unsigned-16 $raw-fd-a 8 #xffff)
      (list (foreign-ref 'integer-16 $fd-a 0)
            (foreign-ref 'integer-16 $fd-a 2)
            (foreign-ref 'integer-16 $fd-a 4)
            (foreign-ref 'integer-16 $fd-a 6)
            (foreign-ref 'integer-16 $fd-a 8)
            (foreign-ref 'unsigned-16 $fd-a 0)
            (foreign-ref 'unsigned-16 $fd-a 2)
            (foreign-ref 'unsigned-16 $fd-a 4)
            (foreign-ref 'unsigned-16 $fd-a 6)
            (foreign-ref 'unsigned-16 $fd-a 8)))
    `(#x-8000 0 #x7fff #x-8000 -1
      #x8000 0 #x7fff #x8000 #xffff))
 ; integer-32/unsigned-32
  (equal?
    (begin
      (#%$object-set! 'integer-32 $raw-fd-a 0 #x-80000000)
      (#%$object-set! 'integer-32 $raw-fd-a 4 0)
      (#%$object-set! 'integer-32 $raw-fd-a 8 #x7fffffff)
      (#%$object-set! 'integer-32 $raw-fd-a 12 #x80000000)
      (#%$object-set! 'integer-32 $raw-fd-a 16 #xffffffff)
      (list (foreign-ref 'integer-32 $fd-a 0)
            (foreign-ref 'integer-32 $fd-a 4)
            (foreign-ref 'integer-32 $fd-a 8)
            (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'integer-32 $fd-a 16)
            (foreign-ref 'unsigned-32 $fd-a 0)
            (foreign-ref 'unsigned-32 $fd-a 4)
            (foreign-ref 'unsigned-32 $fd-a 8)
            (foreign-ref 'unsigned-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (#%$object-set! 'unsigned-32 $raw-fd-a 0 #x-80000000)
      (#%$object-set! 'unsigned-32 $raw-fd-a 4 0)
      (#%$object-set! 'unsigned-32 $raw-fd-a 8 #x7fffffff)
      (#%$object-set! 'unsigned-32 $raw-fd-a 12 #x80000000)
      (#%$object-set! 'unsigned-32 $raw-fd-a 16 #xffffffff)
      (list (foreign-ref 'integer-32 $fd-a 0)
            (foreign-ref 'integer-32 $fd-a 4)
            (foreign-ref 'integer-32 $fd-a 8)
            (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'integer-32 $fd-a 16)
            (foreign-ref 'unsigned-32 $fd-a 0)
            (foreign-ref 'unsigned-32 $fd-a 4)
            (foreign-ref 'unsigned-32 $fd-a 8)
            (foreign-ref 'unsigned-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 16)))
    `(#x-80000000 0 #x7fffffff #x-80000000 -1
      #x80000000 0 #x7fffffff #x80000000 #xffffffff))
  (equal?
    (begin
      (#%$object-set! 'integer-32 $raw-fd-a 12 #xabcd1234)
      (list (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 12)))
    `(,(- #xabcd1234 #x100000000) #xabcd1234))
  (equal?
    (begin
      (#%$object-set! 'unsigned-32 $raw-fd-a 12 #x-765321ab)
      (list (foreign-ref 'integer-32 $fd-a 12)
            (foreign-ref 'unsigned-32 $fd-a 12)))
    `(#x-765321ab ,(+ #x-765321ab #x100000000)))
 ; integer-64/unsigned-64
  (equal?
    (begin
      (#%$object-set! 'integer-64 $raw-fd-a 16 #xabcd1234ffee8765)
      (list (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
    `(,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765
      ,(- #xabcd1234ffee8765 #x10000000000000000)
      #xabcd1234ffee8765))
  (equal?
    (begin
      (#%$object-set! 'unsigned-64 $raw-fd-a 16 #x-765321ab4c8e9de1)
      (list (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'integer-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'integer-32 $fd-a 16) 32)))
            (if (eq? (native-endianness) 'little)
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 16)
                  (ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
                (logor
                  (foreign-ref 'unsigned-32 $fd-a 20)
                  (ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
    `(#x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)
      #x-765321ab4c8e9de1
      ,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
  (equal?
    (begin
      (#%$object-set! 'integer-64 $raw-fd-a 0 #x-8000000000000000)
      (#%$object-set! 'integer-64 $raw-fd-a 8 0)
      (#%$object-set! 'integer-64 $raw-fd-a 16 #x7fffffffffffffff)
      (#%$object-set! 'integer-64 $raw-fd-a 24 #x8000000000000000)
      (#%$object-set! 'integer-64 $raw-fd-a 32 #xffffffffffffffff)
      (list (foreign-ref 'integer-64 $fd-a 0)
            (foreign-ref 'integer-64 $fd-a 8)
            (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'integer-64 $fd-a 24)
            (foreign-ref 'integer-64 $fd-a 32)
            (foreign-ref 'unsigned-64 $fd-a 0)
            (foreign-ref 'unsigned-64 $fd-a 8)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 24)
            (foreign-ref 'unsigned-64 $fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
  (equal?
    (begin
      (#%$object-set! 'unsigned-64 $raw-fd-a 0 #x-8000000000000000)
      (#%$object-set! 'unsigned-64 $raw-fd-a 8 0)
      (#%$object-set! 'unsigned-64 $raw-fd-a 16 #x7fffffffffffffff)
      (#%$object-set! 'unsigned-64 $raw-fd-a 24 #x8000000000000000)
      (#%$object-set! 'unsigned-64 $raw-fd-a 32 #xffffffffffffffff)
      (list (foreign-ref 'integer-64 $fd-a 0)
            (foreign-ref 'integer-64 $fd-a 8)
            (foreign-ref 'integer-64 $fd-a 16)
            (foreign-ref 'integer-64 $fd-a 24)
            (foreign-ref 'integer-64 $fd-a 32)
            (foreign-ref 'unsigned-64 $fd-a 0)
            (foreign-ref 'unsigned-64 $fd-a 8)
            (foreign-ref 'unsigned-64 $fd-a 16)
            (foreign-ref 'unsigned-64 $fd-a 24)
            (foreign-ref 'unsigned-64 $fd-a 32)))
    `(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
      #x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
 ; fixnum
  (equal?
    (begin
      (#%$object-set! 'fixnum $raw-fd-a 0 (greatest-fixnum))
      (#%$object-set! 'fixnum $raw-fd-a 8 (least-fixnum))
      (#%$object-set! 'fixnum $raw-fd-a 16 0)
      (#%$object-set! 'fixnum $raw-fd-a 24 (quotient (greatest-fixnum) 2))
      (list
        (foreign-ref 'fixnum $fd-a 0)
        (foreign-ref 'fixnum $fd-a 8)
        (foreign-ref 'fixnum $fd-a 16)
        (foreign-ref 'fixnum $fd-a 24)))
    `(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
 ; single-float
  (equal?
    (begin
      (#%$object-set! 'single-float $raw-fd-a 12 7.5)
      (foreign-ref 'single-float $fd-a 12))
    7.5)
 ; double-float
  (equal?
    (begin
      (#%$object-set! 'double-float $raw-fd-a 8 -5.4)
      (foreign-ref 'double-float $fd-a 8))
    -5.4)
 ; spot check unaligned ref/set
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (#%$object-set! 'unsigned-32 $raw-fd-a 13 #x-765321ab)
          (list (foreign-ref 'integer-32 $fd-a 13)
                (foreign-ref 'unsigned-32 $fd-a 13)))
        `(#x-765321ab ,(+ #x-765321ab #x100000000))))
  (or (not $fd-unaligned-integers)
      (equal?
        (begin
          (#%$object-set! 'integer-64 $raw-fd-a 17 #xabcd1234ffee8765)
          (list (foreign-ref 'integer-64 $fd-a 17)
                (foreign-ref 'unsigned-64 $fd-a 17)
                (if (eq? (native-endianness) 'little)
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 17)
                      (ash (foreign-ref 'integer-32 $fd-a 21) 32))
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 21)
                      (ash (foreign-ref 'integer-32 $fd-a 17) 32)))
                (if (eq? (native-endianness) 'little)
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 17)
                      (ash (foreign-ref 'unsigned-32 $fd-a 21) 32))
                    (logor
                      (foreign-ref 'unsigned-32 $fd-a 21)
                      (ash (foreign-ref 'unsigned-32 $fd-a 17) 32)))))
        `(,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765
          ,(- #xabcd1234ffee8765 #x10000000000000000)
          #xabcd1234ffee8765)))
  (or (not $fd-unaligned-integers)
      (case $fd-short-max
        [(#xffff)
         (and
           (equal?
             (begin
               (#%$object-set! 'short $raw-fd-a 3 #xabcd)
               (list (foreign-ref 'short $fd-a 3)
                     (foreign-ref 'unsigned-short $fd-a 3)
                     (foreign-ref 'integer-16 $fd-a 3)
                     (foreign-ref 'unsigned-16 $fd-a 3)))
             `(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
           (equal?
             (begin
               (#%$object-set! 'unsigned-short $raw-fd-a 3 -5321)
               (list (foreign-ref 'short $fd-a 3)
                     (foreign-ref 'unsigned-short $fd-a 3)
                     (foreign-ref 'integer-16 $fd-a 3)
                     (foreign-ref 'unsigned-16 $fd-a 3)))
             `(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
        [else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (#%$object-set! 'single-float $raw-fd-a 6 7.5)
          (foreign-ref 'single-float $fd-a 6))
        7.5))
  (or (not $fd-unaligned-floats)
      (equal?
        (begin
          (#%$object-set! 'double-float $raw-fd-a 5 -5.4)
          (foreign-ref 'double-float $fd-a 5))
        -5.4))

 ; this needs to be done last
  (begin
    (set! $raw-fd-a #f)
    (set! $fd-a #f)
    (foreign-free $real-fd-a)
    (set! $real-fd-a #f)
    #t)
 )

(mat $integer-xxx?
  (not (#%$integer-8? 'a))
  (not (#%$integer-16? '3.4))
  (not (#%$integer-32? '3/4))
  (not (#%$integer-64? '4+3i))
  (not (#%$integer-8? #x-10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-8? #x-81))
  (#%$integer-8? #x-80)
  (#%$integer-8? #x-1)
  (#%$integer-8? #x7f)
  (#%$integer-8? #x80)
  (#%$integer-8? #xff)
  (not (#%$integer-8? #x100))
  (not (#%$integer-8? #x+10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-16? #x-10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-16? #x-8001))
  (#%$integer-16? #x-8000)
  (#%$integer-16? #x-1)
  (#%$integer-16? #x7fff)
  (#%$integer-16? #x8000)
  (#%$integer-16? #xffff)
  (not (#%$integer-16? #x10000))
  (not (#%$integer-16? #x+10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-32? #x-10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-32? #x-80000001))
  (#%$integer-32? #x-80000000)
  (#%$integer-32? #x-1)
  (#%$integer-32? #x7fffffff)
  (#%$integer-32? #x80000000)
  (#%$integer-32? #xffffffff)
  (not (#%$integer-32? #x100000000))
  (not (#%$integer-32? #x+10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-64? #x-10000000000000000000000000000000000000000000000000000000000000000))
  (not (#%$integer-64? #x-8000000000000001))
  (#%$integer-64? #x-8000000000000000)
  (#%$integer-64? #x-1)
  (#%$integer-64? #x7fffffffffffffff)
  (#%$integer-64? #x8000000000000000)
  (#%$integer-64? #xffffffffffffffff)
  (not (#%$integer-64? #x10000000000000000))
  (not (#%$integer-64? #x+10000000000000000000000000000000000000000000000000000000000000000))
)

(mat object-address
  (equal?
    (with-interrupts-disabled ; or lock r
      (let ()
        (import $system)
        (define-syntax record-field-address
          (lambda (x)
            (define-syntax datum
              (syntax-rules ()
                [(_ x) (syntax-object->datum #'x)]))
            (define rtd-flds
              (csv7:record-field-accessor
                (record-rtd (make-record-type "foo" '()))
                'flds))
            ; fld structure is vector:  #5(fld name mutable type offset)
            (define fld-check
              (lambda (who x)
                (unless (and (vector? x)
                             (= (vector-length x) 5)
                             (eq? (vector-ref x 0) 'fld))
                  (errorf who "~s is not a fld" x))))
            (define fld-name
              (lambda (x) (fld-check 'fld-name x) (vector-ref x 1)))
            (define fld-mutable?
              (lambda (x) (fld-check 'fld-mutable? x) (vector-ref x 2)))
            (define fld-type
              (lambda (x) (fld-check 'fld-type x) (vector-ref x 3)))
            (define fld-byte
              (lambda (x) (fld-check 'fld-byte x) (vector-ref x 4)))
            (syntax-case x ()
              [(_ recid record field-name)
               (and (identifier? #'recid) (identifier? #'field-name))
               (lambda (r)
                 (let ([rinfo (r #'recid)])
                   (unless (and (pair? rinfo)
                                (eq? (car rinfo) '#{record val9xfsq6oa12q4-a})
                                (record-type-descriptor? (cadr rinfo)))
                     (syntax-error #'recid "unrecognized record"))
                   (let ([rtd (cadr rinfo)])
                     (with-syntax ([offset
                                    (or (let ([field-name (datum field-name)])
                                          (ormap
                                            (lambda (fld)
                                              (and (eq? (fld-name fld) field-name)
                                                   (fld-byte fld)))
                                            (rtd-flds rtd)))
                                        (syntax-error
                                          "unrecognized field name"
                                          #'field-name))])
                       #'($object-address record offset)))))])))
        (define-record foo ((integer-32 x) (double-float y)))
        (let* ([r (make-foo 666 66.6)]
               [x (record-field-address foo r x)]
               [y (record-field-address foo r y)])
          (let ([t1 (foreign-ref 'integer-32 x 0)]
                [t2 (foreign-ref 'double-float y 0)])
            (foreign-set! 'integer-32 x 0 -1)
            (foreign-set! 'double-float y 0 .25)
            (list t1 t2 (foo-x r) (foo-y r))))))
    '(666 66.6 -1 .25))
  (#%$address-in-heap? (#%$object-address cons 0))
  (not (#%$address-in-heap? 0))
)

(mat record-inheritance
  (equal?
    (let ()
      (define-record soy ([double-float milk]))
      (define-record toast soy (y))
      (let ([x (make-toast #0=3.4 #1="hello")])
        (list (soy-milk x) (toast-y x))))
    '(#0# #1#))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record soy ([double-float milk]))
           (define-record toast soy (y))
           (let ([x (make-toast 3.4 "hello")])
             (list (soy-milk x) (toast-y x))))))
    `(let ([x (let ([y (#3%$record ',record-type-descriptor? . ,list?)])
                (#3%$object-set! 'double-float y ,fixnum? 3.4)
                y)])
       (#2%list
           (#3%$object-ref 'double-float x ,fixnum?)
           (#3%$object-ref 'scheme-object x ,fixnum?))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record soy ([double-float milk]))
           (define-record toast soy (y))
           (let ([x (make-toast 3.4 "hello")])
             (list (soy-milk x) (toast-y x))))))
    `(let ([x (let ([y (#3%$record ',record-type-descriptor? . ,list?)])
                (#3%$object-set! 'double-float y ,fixnum? 3.4)
                y)])
       (#3%list
         (#3%$object-ref 'double-float x ,fixnum?)
         (#3%$object-ref 'scheme-object x ,fixnum?))))
  (let ()
    (define-record p (x))
    (define-record c p (x))
    (let ()
      (define prtd (record-rtd (make-p 1)))
      (define crtd (record-rtd (make-c 1 2)))
      (let ()
        (define px1a (csv7:record-field-accessor prtd 'x))
        (define px1b (csv7:record-field-accessor prtd 0))
        (define cx1b (csv7:record-field-accessor crtd 0))
        (define cx2a (csv7:record-field-accessor crtd 'x))
        (define cx2b (csv7:record-field-accessor crtd 1))
        (define d1 (cons 1 2))
        (define d2 (cons 3 4))
        (let ()
          (define r (make-c d1 d2))
          (and (eq? (p-x r) d1)
               (eq? (px1a r) (p-x r))
               (eq? (px1b r) (p-x r))
               (eq? (cx1b r) (p-x r))
               (eq? (c-x r) d2)
               (eq? (cx2a r) (c-x r))
               (eq? (cx2b r) (c-x r)))))))
  (let ()
    (define-record p (x))
    (define-record c p (x))
    (record-reader 'c (record-rtd (make-c 1 2)))
    (let ([r1 (read (open-input-string "#[c #0=(a b) #0#]"))]
          [r2 (read (open-input-string "#0=#[c #0# 0]"))]
          [r3 (read (open-input-string "#0=#[c 0 #0#]"))]
          [r4 (read (open-input-string "#0=#[c #0# #0#]"))])
      (and (eq? (p-x r1) (c-x r1))
           (eq? (p-x r2) r2)
           (eq? (c-x r2) 0)
           (eq? (p-x r3) 0)
           (eq? (c-x r3) r3)
           (eq? (p-x r4) r4)
           (eq? (c-x r4) r4))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record p (x))
           (define-record c p (x))
           (record-reader 'c (record-rtd (make-c 1 2)))
           (let ([r1 (read (open-input-string "#[c #0=(a b) #0#]"))]
                 [r2 (read (open-input-string "#0=#[c #0# 0]"))]
                 [r3 (read (open-input-string "#0=#[c 0 #0#]"))]
                 [r4 (read (open-input-string "#0=#[c #0# #0#]"))])
             (and (eq? (p-x r1) (c-x r1))
                  (eq? (p-x r2) r2)
                  (eq? (c-x r2) 0)
                  (eq? (p-x r3) 0)
                  (eq? (c-x r3) r3)
                  (eq? (p-x r4) r4)
                  (eq? (c-x r4) r4))))))
    `(begin
       (#3%record-reader 'c ',record-type-descriptor?)
       (let ([r1 (#3%read (#3%open-input-string "#[c #0=(a b) #0#]"))]
             [r2 (#3%read (#3%open-input-string "#0=#[c #0# 0]"))]
             [r3 (#3%read (#3%open-input-string "#0=#[c 0 #0#]"))]
             [r4 (#3%read (#3%open-input-string "#0=#[c #0# #0#]"))])
         (if (#3%eq?
               (#3%$object-ref 'scheme-object r1 ,fixnum?)
               (#3%$object-ref 'scheme-object r1 ,fixnum?))
             (if (#3%eq? (#3%$object-ref 'scheme-object r2 ,fixnum?) r2)
                 (if (#3%eq? (#3%$object-ref 'scheme-object r2 ,fixnum?) 0)
                     (if (#3%eq? (#3%$object-ref 'scheme-object r3 ,fixnum?) 0)
                         (if (#3%eq? (#3%$object-ref 'scheme-object r3 ,fixnum?) r3)
                             (if (#3%eq? (#3%$object-ref 'scheme-object r4 ,fixnum?) r4)
                                 (#3%eq? (#3%$object-ref 'scheme-object r4 ,fixnum?) r4)
                                 #f)
                             #f)
                         #f)
                     #f)
                 #f)
             #f))))
)

(mat record-writer
  (equal?
    (with-output-to-string
      (lambda ()
        (define-record-type sp (fields lat))
        (record-writer (type-descriptor sp)
          (lambda (x p w) (w (sp-lat x) p)))
        (pretty-print (list (make-sp 'ugh)))))
    "(ugh)\n")
  (error? ; 'sp is not an rtd
    (with-output-to-string
      (lambda ()
        (define-record-type sp (fields lat))
        (record-writer 'sp
          (lambda (x p w) (w (sp-lat x) p))))))
  (error? ; "oops" is not a procedure
    (with-output-to-string
      (lambda ()
        (define-record-type sp (fields lat))
        (record-writer (type-descriptor sp) "oops"))))
  (error? ; ugh is not a textual output port
    (with-output-to-string
      (lambda ()
        (define-record-type sp (fields lat))
        (record-writer (type-descriptor sp)
          (lambda (x p w) (w p (sp-lat x))))
        (pretty-print (list (make-sp 'ugh))))))
  (error? ; procedure not a textual output port
    (with-output-to-string
      (lambda ()
        (define-record-type sp (fields lat))
        (record-writer (type-descriptor sp)
          (lambda (x p w) (w (sp-lat x) w)))
        (pretty-print (list (make-sp 'ugh))))))
  (begin
    (define-record $froz (a b) ([c (+ a b)]))
    (define-record $fruz $froz (d))
    (define-record $friz $fruz ())
    (define-record $fraz $friz ())
    (record-writer (type-descriptor $fraz)
      (lambda (x p wr)
        (display "<fraz>" p)))
    (record-writer (type-descriptor $froz)
      (lambda (x p wr)
        (wr `(* hi john ,($froz-c x) *) p)))
    (and (equal? (format "~s" (make-$froz 17 23)) "(* hi john 40 *)")
         (equal? (format "~s" (make-$fruz 17 24 37)) "(* hi john 41 *)")
         (equal? (format "~s" (make-$friz 17 25 38)) "(* hi john 42 *)")
         (equal? (format "~s" (make-$fraz 17 26 39)) "<fraz>")))
  (begin
    (record-writer (type-descriptor $froz)
      (lambda (x p wr)
        (fprintf p "<$froz c=~s>" ($froz-c x))))
    (and (equal? (format "~s" (make-$froz 18 23)) "<$froz c=41>")
         (equal? (format "~s" (make-$fruz 18 24 37)) "<$froz c=42>")
         (equal? (format "~s" (make-$friz 18 25 38)) "<$froz c=43>")
         (equal? (format "~s" (make-$fraz 18 26 39)) "<fraz>")))
  (begin
    (record-writer (type-descriptor $fruz)
      (lambda (x p wr)
        (fprintf p "<$fruz d=~s>" ($fruz-d x))))
    (and (equal? (format "~s" (make-$froz 19 23)) "<$froz c=42>")
         (equal? (format "~s" (make-$fruz 19 24 37)) "<$fruz d=37>")
         (equal? (format "~s" (make-$friz 19 25 38)) "<$fruz d=38>")
         (equal? (format "~s" (make-$fraz 18 26 39)) "<fraz>")))
  (let ()
    (define-record pair ((mutable car) (immutable cdr))
      ()
      ((constructor cons) (prefix "")))
    (record-writer (type-descriptor pair)
      (lambda (x p wr)
        (display "(" p) ; )
        (wr (car x) p)
        (display " . " p)
        (wr (cdr x) p) ; (
        (display ")" p)))
    (and (pair? (cons 3 4))
         (not (pair? '(3 . 4)))
         (eq? (car (cons 3 4)) 3)
         (eq? (cdr (cons 3 4)) 4)
         (equal? (format "~s" (cons 3 (cons 4 '()))) "(3 . (4 . ()))")
         (let ((x (cons 3 4)))
           (set-car! x x)
           (equal? (format "~s" x) "#0=(#0# . 4)"))))
)

(mat record-equal/hash
  (begin
    (define (equiv? v1 v2)
      (and (equal? v1 v2)
           (= (equal-hash v1) (equal-hash v2))
           (let ([ht (make-hashtable equal-hash equal?)])
             (hashtable-set! ht v1 "yes")
             (equal? "yes" (hashtable-ref ht v2 "no")))))
    
    (define (not-equiv? v1 v2)
      (and (not (equal? v1 v2))
           (let ([ht (make-hashtable equal-hash equal?)])
             (hashtable-set! ht v1 "yes")
             (equal? "no" (hashtable-ref ht v2 "no")))))

    (define-record-type E+H$a
      (fields (mutable x)
              (immutable y)))

    (define-record-type E+H$a+
      (parent E+H$a)
      (fields (mutable z)))

    (define-record-type E+H$b
      (fields (immutable x)
              (mutable y))
      (opaque #t))

    (define-record-type E+H$b+
      (parent E+H$b)
      (fields (mutable z))
      (opaque #t))

    (define (E+H$a-equal? a1 a2 eql?)
      (eql? (E+H$a-x a1) (E+H$a-x a2)))
    (define (E+H$a-hash a hc)
      (hc (E+H$a-x a)))

    (define (E+H$b-equal? b1 b2 eql?)
      (eql? (E+H$b-y b1) (E+H$b-y b2)))
    (define (E+H$b-hash b hc)
      (hc (E+H$b-y b)))

    (define cyclic-E+H$a1 (make-E+H$a 1 2))
    (E+H$a-x-set! cyclic-E+H$a1 cyclic-E+H$a1)
    (define cyclic-E+H$a2 (make-E+H$a 1 2))
    (E+H$a-x-set! cyclic-E+H$a2 cyclic-E+H$a2)

    (define cyclic-E+H$b+1 (make-E+H$b+ 1 2 3))
    (define cyclic-E+H$b+2 (make-E+H$b+ 1 2 3))
    (E+H$b-y-set! cyclic-E+H$b+1 (list 1 2 3 (box cyclic-E+H$b+2)))
    (E+H$b-y-set! cyclic-E+H$b+2 (list 1 2 3 (box cyclic-E+H$b+1)))

    #t)

  (not-equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
  (not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))

  (not (record-type-equal-procedure (record-type-descriptor E+H$a)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$a)))
  (not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
  (not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
  (not (record-type-equal-procedure (record-type-descriptor E+H$b)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$b)))

  (begin
    (record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
    (record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
    #t)

  (eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
  (eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)
  (not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
  (eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a 1 2)) E+H$a-equal?)
  (eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
  (eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
  (eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
  (eq? (record-hash-procedure (make-E+H$a 1 2)) E+H$a-hash)
  (eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)
  (not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
  
  (equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
  (equiv? (make-E+H$a 1 2) (make-E+H$a 1 3))
  
  (equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
  (equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
  
  (not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a 1 2))
  (not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a+ 1 2 4))

  (not (equiv? (make-E+H$a 1 2) (make-E+H$b 1 2)))

  (not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
  (not-equiv? (make-E+H$b+ 1 2 3) (make-E+H$b+ 1 2 3))

  (not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
  (not (record-type-equal-procedure (record-type-descriptor E+H$b)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$b)))

  (begin
    (record-type-equal-procedure (record-type-descriptor E+H$b+) E+H$b-equal?)
    (record-type-hash-procedure (record-type-descriptor E+H$b+) E+H$b-hash)
    #t)

  (not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
  (equiv? (make-E+H$b+ 0 2 4) (make-E+H$b+ 1 2 3))

  (equiv? cyclic-E+H$a1 cyclic-E+H$a2)
  (equiv? cyclic-E+H$a1 (make-E+H$a cyclic-E+H$a2 3))

  (equiv? cyclic-E+H$b+1 cyclic-E+H$b+2)

  (begin
    (record-type-equal-procedure (record-type-descriptor E+H$a+) E+H$a-equal?)
    (record-type-hash-procedure (record-type-descriptor E+H$a+) E+H$a-hash)
    #t)

  (eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
  (eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)

  (equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
  (not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
  (not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))

  (begin
    (record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
    (record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
    #t)

  (not (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)))

  (equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
  (not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
  (not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))

  (begin
    (record-type-equal-procedure (record-type-descriptor E+H$a+) #f)
    (record-type-hash-procedure (record-type-descriptor E+H$a+) #f)
    #t)

  (not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
  (not (record-type-hash-procedure (record-type-descriptor E+H$a+)))

  (eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
  (eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)

  (equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
  (equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
  (equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))

  (error? ; not an rtd
    (record-type-equal-procedure 7))
  (error? ; not an rtd
    (record-type-equal-procedure 7 (lambda (x y e?) #f)))
  (error? ; not a procedure or #f
    (record-type-equal-procedure (record-type-descriptor E+H$a+) 7))
  (error? ; not an rtd
    (record-type-hash-procedure 7))
  (error? ; not an rtd
    (record-type-hash-procedure 7 (lambda (x y e?) #f)))
  (error? ; not a procedure or #f
    (record-type-hash-procedure (record-type-descriptor E+H$a+) 7))
  (error? ; not a record
    (record-equal-procedure 7 (make-E+H$a 1 2)))
  (error? ; not a record
    (record-equal-procedure (make-E+H$a 1 2) 7))
  (error? ; not a record
    (record-hash-procedure 7))

  ; csug examples
  (begin
    (define-record marble (color quality))
    #t)

  (not (record-type-equal-procedure (record-type-descriptor marble)))
  (not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'medium)))
  (not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)))

  ; Treat marbles as equal when they have the same color
  (begin
    (record-type-equal-procedure (record-type-descriptor marble)
      (lambda (m1 m2 eql?)
        (eql? (marble-color m1) (marble-color m2))))
    (record-type-hash-procedure (record-type-descriptor marble)
      (lambda (m hash)
        (hash (marble-color m))))
    #t)

  (equal? (make-marble 'blue 'medium) (make-marble 'blue 'high))
  (not (equal? (make-marble 'red 'high) (make-marble 'blue 'high)))

  (begin
    (define ht (make-hashtable equal-hash equal?))
    (hashtable-set! ht (make-marble 'blue 'medium) "glass")
    #t)

  (equal? (hashtable-ref ht (make-marble 'blue 'high) #f) "glass")

  (begin
    (define-record shooter marble (size))
    #t)

  (equal? (make-marble 'blue 'medium) (make-shooter 'blue 'large 17)) ;=> #t
  (equal? (make-shooter 'blue 'large 17) (make-marble 'blue 'medium)) ;=> #t
  (equal? (hashtable-ref ht (make-shooter 'blue 'high 17) #f) "glass")

  (begin
    (define-record-type node
      (nongenerative)
      (fields (mutable left) (mutable right)))
    (record-type-equal-procedure (record-type-descriptor node)
      (lambda (x y e?)
        (and
          (e? (node-left x) (node-left y))
          (e? (node-right x) (node-right y)))))
    (record-type-hash-procedure (record-type-descriptor marble)
      (lambda (x hash)
        (+ (hash (node-left x)) (hash (node-right x)) 23)))
    (define graph1
      (let ([x (make-node "a" (make-node #f "b"))])
        (node-left-set! (node-right x) x)
        x))
    (define graph2
      (let ([x (make-node "a" (make-node (make-node "a" #f) "b"))])
        (node-right-set! (node-left (node-right x)) (node-right x))
        x))
    (define graph3
      (let ([x (make-node "a" (make-node #f "c"))])
        (node-left-set! (node-right x) x)
        x))
    #t)

  (equal? graph1 graph2)
  (not (equal? graph1 graph3))
  (not (equal? graph2 graph3))

  (begin
    (define h (make-hashtable equal-hash equal?))
    (hashtable-set! h graph1 #t)
    #t)

  (hashtable-ref h graph1 #f)
  (hashtable-ref h graph2 #f)
  (not (hashtable-ref h graph3 #f))

  (begin
    (define record-hash
      (lambda (x hash)
        (let ([rtd (record-rtd x)])
          (do ([field-name* (csv7:record-type-field-names rtd) (cdr field-name*)]
               [i 0 (fx+ i 1)]
               [h 0 (+ h (hash ((csv7:record-field-accessor rtd i) x)))])
            ((null? field-name*) h)))))
    (define record-equal?
      (lambda (x y e?)
        (let ([rtd (record-rtd x)])
          (and (eq? (record-rtd y) rtd)
               (let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
                 (or (null? field-name*)
                     (and (let ([accessor (csv7:record-field-accessor rtd i)])
                            (e? (accessor x) (accessor y)))
                          (f (cdr field-name*) (fx+ i 1)))))))))
    (define equiv?
      (lambda (x y)
        (parameterize ([default-record-equal-procedure record-equal?])
          (equal? x y))))
    (define equiv-hash
      (lambda (x)
        (parameterize ([default-record-hash-procedure record-hash])
          (equal-hash x))))
    (define-record-type frob (fields (mutable q)))
    (define-record-type frub (fields (mutable x) y z))
    (define frob-hash
      (lambda (x hash)
        (raise 'frob-hash)))
    (define frob-equal?
      (lambda (x y e?)
        #f))
    (define rthp
      (lambda (rtd)
        (case-lambda
          [() (record-type-hash-procedure rtd)]
          [(x) (record-type-hash-procedure rtd x)])))
    (define rtep
      (lambda (rtd)
        (case-lambda
          [() (record-type-equal-procedure rtd)]
          [(x) (record-type-equal-procedure rtd x)])))
    #t)
  (not (record-type-equal-procedure (record-type-descriptor frob)))
  (not (record-type-hash-procedure (record-type-descriptor frob)))
  (not (record-type-equal-procedure (record-type-descriptor frub)))
  (not (record-type-hash-procedure (record-type-descriptor frub)))
  (equal?
    (parameterize ([(rthp (record-type-descriptor frob)) record-hash])
      (list
        (record-hash-procedure (make-frob #\q))
        (record-hash-procedure (make-frub 1 2 3))))
    (list record-hash #f))
  (equal?
    (parameterize ([(rtep (record-type-descriptor frob)) record-equal?])
      (list
        (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
        (record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
        (record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
        (record-equal-procedure (make-frob #\q) (make-frob #\q))))
    (list #f #f #f record-equal?))
  (equal?
    (parameterize ([default-record-hash-procedure record-hash])
      (list
        (record-hash-procedure (make-frob #\q))
        (record-hash-procedure (make-frub 1 2 3))))
    (list record-hash record-hash))
  (equal?
    (parameterize ([default-record-equal-procedure record-equal?])
      (list
        (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
        (record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
        (record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
        (record-equal-procedure (make-frob #\q) (make-frob #\q))))
    (list record-equal? record-equal? record-equal? record-equal?))
  (equal?
    (parameterize ([default-record-hash-procedure record-hash]
                   [(rthp (record-type-descriptor frob)) frob-hash])
      (list
        (record-hash-procedure (make-frob #\q))
        (record-hash-procedure (make-frub 1 2 3))))
    (list frob-hash record-hash))
  (equal?
    (parameterize ([default-record-equal-procedure record-equal?]
                   [(rtep (record-type-descriptor frob)) frob-equal?])
      (list
        (record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
        (record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
        (record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
        (record-equal-procedure (make-frob #\q) (make-frob #\q))))
    (list record-equal? #f #f frob-equal?))
  ((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
    (parameterize ([default-record-hash-procedure record-hash])
      (equal-hash (vector 1 2 (make-frub 1 2 3) 5 (make-frob #\q) 7))))
  (eq?
    (guard (c [(eq? c 'frob-hash) 'yup] [else (raise c)])
      (parameterize ([default-record-hash-procedure record-hash]
                     [(rthp (record-type-descriptor frob)) frob-hash])
        (equal-hash (list "hello" (make-frob #\q)))))
    'yup)
  ((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
    (parameterize ([default-record-hash-procedure record-hash]
                   [(rthp (record-type-descriptor frob)) frob-hash])
      (equal-hash (vector 1 2 (make-frub 1 2 3) 5 6))))
  (equiv? (make-frob #\q) (make-frob #\q))
  (equiv? (make-frub 1 2 3) (make-frub 1 2 3))
  (not (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
         (equiv? (make-frob #\q) (make-frob #\q))))
  (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
    (equiv? (make-frub 1 2 3) (make-frub 1 2 3)))
  (equal?
    (let ([ht (make-hashtable equiv-hash equiv?)])
      (hashtable-set! ht (make-frob #\q) 'one)
      (hashtable-set! ht (make-frub 1 2 3) 'two)
      (hashtable-set! ht (make-frub 'a 'b 'c) 'three)
      (list
        (hashtable-ref ht (make-frob #\q) #f)
        (hashtable-ref ht (make-frub 1 2 3) #f)
        (hashtable-ref ht (make-frub 'a 'b 'c) #f)
        (hashtable-ref ht (make-frub 'x 'y 'z) #f)))
    '(one two three #f))
)

(mat record19
 ; test ellipses in init expressions
  (equal?
    (let ()
      (define-record foo ()
        ([a (let ()
              (define-syntax f
                (syntax-rules ()
                  [(_ b ...) (list 'b ...)]))
              (f 1 2 3))]))
      (foo-a (make-foo)))
    '(1 2 3))
)

(mat record20
 ; test argument-name handing in generated record constructors
  (equal?
    (let ()
      (define foo
        (make-record-type "foo"
          '((integer-32 fixnum?)
          (double-float flonum?)
          unless
          unless)))
      (let ()
        (define make-foo (record-constructor foo))
        (define foo? (record-predicate foo))
        (define foo.0 (csv7:record-field-accessor foo 'fixnum?))
        (define foo.1 (csv7:record-field-accessor foo 'flonum?))
        (define foo.2 (csv7:record-field-accessor foo 2))
        (define foo.3 (csv7:record-field-accessor foo 3))
        (let ([x (make-foo 1 3.0 'a 'b)])
          (list (foo? x)
                (foo.0 x)
                (foo.1 x)
                (foo.2 x)
                (foo.3 x)))))
    '(#t 1 3.0 a b))
  (equal?
    (let ([foo (make-record-type "foo" '(a a a))])
      (define make-foo (record-constructor foo))
      (define foo? (record-predicate foo))
      (define foo.0 (csv7:record-field-accessor foo 0))
      (define foo.1 (csv7:record-field-accessor foo 1))
      (define foo.2 (csv7:record-field-accessor foo 2))
      (let ([x (make-foo 'a 'b 'c)])
        (list (foo? x)
              (foo.0 x)
              (foo.1 x)
              (foo.2 x))))
    '(#t a b c))
  (equal?
    (let* ([names '(a a a a a a a a a a a a)]
           [foo (make-record-type "foo" names)])
      (define make-foo (record-constructor foo))
      (define foo? (record-predicate foo))
      (define foos (let ([n (length names)])
                     (let f ([i 0])
                       (if (= i n)
                           '()
                           (cons (csv7:record-field-accessor foo i)
                                 (f (+ i 1)))))))
      (let ([x (make-foo 1 2 3 4 5 6 7 8 9 10 11 12)])
        (cons (foo? x) (map (lambda (p) (p x)) foos))))
    '(#t 1 2 3 4 5 6 7 8 9 10 11 12))
  (equal?
    (let* ([foo (make-record-type "foo" '((integer-32 a)))]
           [bar (make-record-type foo "bar" '((double-float a)))])
      (define make-bar (record-constructor bar))
      (define bar? (record-predicate bar))
      (define bar.0 (csv7:record-field-accessor bar 0))
      (define bar.1 (csv7:record-field-accessor bar 1))
      (let ([x (make-bar 17 23.5)])
        (list (bar? x) (bar.0 x) (bar.1 x))))
    '(#t 17 23.5))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let* ([foo (make-record-type "foo" '((integer-32 a)))]
                [bar (make-record-type foo "bar" '((double-float a)))])
           (define make-bar (record-constructor bar))
           (define bar? (record-predicate bar))
           (define bar.0 (csv7:record-field-accessor bar 0))
           (define bar.1 (csv7:record-field-accessor bar 1))
           (let ([x (make-bar 17 23.5)])
             (list (bar? x) (bar.0 x) (bar.1 x))))))
    `(let ([x (let ([y (#3%$record (#2%make-record-type (#2%make-record-type "foo" '((integer-32 a))) "bar" '((double-float a))) . ,list?)])
                (#3%$object-set! 'double-float y ,fixnum? 23.5)
                (#3%$object-set! 'integer-32 y ,fixnum? 17)
                y)])
       (#2%list
         #t
         (#3%$object-ref 'integer-32 x ,fixnum?)
         (#3%$object-ref 'double-float x ,fixnum?))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let* ([foo (make-record-type "foo" '((integer-32 a)))]
                [bar (make-record-type foo "bar" '((double-float a)))])
           (define make-bar (record-constructor bar))
           (define bar? (record-predicate bar))
           (define bar.0 (csv7:record-field-accessor bar 0))
           (define bar.1 (csv7:record-field-accessor bar 1))
           (let ([x (make-bar 17 23.5)])
             (list (bar? x) (bar.0 x) (bar.1 x))))))
    `(let ([x (let ([y (#3%$record (#3%make-record-type (#3%make-record-type "foo" '((integer-32 a))) "bar" '((double-float a))) . ,list?)])
                (#3%$object-set! 'double-float y ,fixnum? 23.5)
                (#3%$object-set! 'integer-32 y ,fixnum? 17)
                y)])
       (#3%list
         #t
         (#3%$object-ref 'integer-32 x ,fixnum?)
         (#3%$object-ref 'double-float x ,fixnum?))))
)

(mat record21 ; duplicate field names and invalid field syntax
  (error? ; duplicate field name
    (define-record foo (x x)))
  (error? ; duplicate field name
    (define-record foo (x (mutable x))))
  (error? ; duplicate field name
    (define-record foo (x) ([x 3])))
  (error? ; duplicate field name
    (define-record foo (x) ([(immutable x) 3])))
  (error? ; duplicate field name
    (define-record foo () ([x 4] [x 3])))
  (error? ; duplicate field name
    (define-record foo () ([x 4] [(immutable x) 3])))
  (error? ; invalid field syntax
    (define-record foo ([x 4])))
  (error? ; invalid field syntax
    (define-record foo ([(mutable foo) 3])))
  (error? ; duplicate field name
   ; would be okay if we used field name rather than record name as template
   ; for generated accessor and mutator identifiers
    (equal?
      (let ()
        (define-syntax a
          (syntax-rules ()
            [(_ name fld get)
             (begin
               (define-record name (fld x) () ([prefix ""]))
               (define get x))]))
        (a rt x g)
        (let ([r (make-rt 3 4)])
          (list (x r) (g r))))
      '(3 4)))
)

(mat record22 ; make sure inlined record routines make proper checks
  (eqv?
    (let ()
      (define ty (make-record-type "bar" '((mutable q))))
      (define q! (csv7:record-field-mutator ty 'q))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 0) x)))
    'hello)
  (error?
    (let ()
      (define ty (make-record-type "bar" '((immutable q))))
      (define q! (csv7:record-field-mutator ty 'q))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 0) x))))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((immutable q))))
      (define q! (csv7:record-field-mutator ty 'q))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 0) x))))
  (error?
    (let ()
      (define ty (make-record-type "bar" '((mutable q))))
      (define q! (csv7:record-field-mutator ty 'q))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 'z) x))))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((mutable q))))
      (define q! (csv7:record-field-mutator ty 'q))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 'z) x))))
  (error?
    (let ()
      (define ty (make-record-type "bar" '((mutable q))))
      (define q! (csv7:record-field-mutator ty 'z))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 0) x))))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((mutable q))))
      (define q! (csv7:record-field-mutator ty 'z))
      (let ([x ((record-constructor ty) 3)])
        (q! x 'hello)
        ((csv7:record-field-accessor ty 0) x))))
  (error?
    (let ()
      (define ty (make-record-type "bar" '((mutable q))))
      (csv7:record-field-accessible? ty 3)))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((mutable q))))
      (csv7:record-field-accessible? ty 3)))
  (equal?
    (let ([n 0])
      (define ty (make-record-type "bar" '((mutable q))))
      (let ([b (csv7:record-field-accessible? (begin (set! n (+ n 5)) ty) (begin (set! n (+ n 12)) 0))])
        (cons b n)))
    '(#t . 17))
  (error?
    (let ()
      (define ty (make-record-type "bar" '((mutable q))))
      (csv7:record-field-mutable? ty 'notq)))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((mutable q))))
      (csv7:record-field-mutable? ty 'notq)))
  (error?
    (let ()
      (define ty (make-record-type "bar" '((mutable creepy q))))
      (csv7:record-field-mutable? ty 'notq)))
  (procedure?
    (lambda ()
      (define ty (make-record-type "bar" '((mutable creepy q))))
      (csv7:record-field-mutable? ty 'notq)))
  (error?
    (let ()
      (define-record bar ((immutable creepy q)))
      (make-bar 3)))
  (error?
    (lambda ()
      (define-record bar ((immutable creepy q)))
      (make-bar 3)))
)

(mat record23 ; test general make-record-type interface
  (equal?
    (let ()
      (define enum-base-rtd
        (make-record-type ; not sealed, not opaque
          #!base-rtd                    ; undocumented $base-rtd
          '#{enum b9s78zmm79qs7j22-a}   ; make enum-base-rtd type nongenerative
          '((immutable sym->index) (immutable index->sym))))
      (define get-sym->index
        (csv7:record-field-accessor enum-base-rtd 'sym->index))
      (define get-index->sym
        (csv7:record-field-accessor enum-base-rtd 'index->sym))
      (define enum-parent-rtd ; not sealed, not opaque
        (make-record-type "enum-parent" '((immutable members))))
      (define get-members (csv7:record-field-accessor enum-parent-rtd 'members))
    
      (let ([this-enum-rtd
             (#%$make-record-type enum-base-rtd enum-parent-rtd "enum"
               '()               ; no fields to add
               #t                ; sealed
               #f                ; not opaque
               '*sym->index*     ; extras (tacked onto end of rtd)
               '*index->sym*)])  ; i.e., static (per enumeration type) fields
        (let ([make-this-enum (record-constructor this-enum-rtd)])
    
          (let ([enum (make-this-enum '*members*)])
            (let ([rtd (record-rtd enum)])
              (list
                (get-members enum)
                (get-sym->index rtd)
                (get-index->sym rtd)))))))
    '(*members* *sym->index* *index->sym*))
  (error? ; cannot extend sealed record type
    (let ([rtd1 (#%$make-record-type #!base-rtd #f "foo" '() #t #f '())])
      (#%$make-record-type #!base-rtd rtd1 "bar" '() #f #f '())))
)

(mat record25
 ; test generic C aliases for specific types
  (begin
    (define-record r25-bar ((int a) (unsigned b) (unsigned-int c)
                            (short d) (unsigned-short e)
                            (long f) (unsigned-long g)
                            (iptr h) (uptr i)
                            (float j) (double k)
                            (ptr l) (char m) (wchar n) (fixnum o)
                            (void* p) (boolean q)
                            (long-long r) (unsigned-long-long s)))
    #t)
  (error? (make-r25-bar 1.0 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2.0 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 'three 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 1/4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 "five" 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 '(6) 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 '#(a b c d e f g) 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 'ate 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 #\9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0+0.0i 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12.0 13))
  (error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13.0))
  (begin
    (define r25-x (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
    (and (r25-bar? r25-x) (not (r25-bar? '(foo)))))
  (error? (set-r25-bar-a! r25-x 3.0))
  (eq? (set-r25-bar-a! r25-x (+ (r25-bar-a r25-x) 73)) (void))
  (error? (set-r25-bar-b! r25-x 3.0))
  (eq? (set-r25-bar-b! r25-x (+ (r25-bar-b r25-x) 73)) (void))
  (error? (set-r25-bar-c! r25-x 3.0))
  (eq? (set-r25-bar-c! r25-x (+ (r25-bar-c r25-x) 73)) (void))
  (error? (set-r25-bar-d! r25-x 3.0))
  (eq? (set-r25-bar-d! r25-x (+ (r25-bar-d r25-x) 73)) (void))
  (error? (set-r25-bar-e! r25-x 3.0))
  (eq? (set-r25-bar-e! r25-x (+ (r25-bar-e r25-x) 73)) (void))
  (error? (set-r25-bar-f! r25-x 3.0))
  (eq? (set-r25-bar-f! r25-x (- (r25-bar-f r25-x) 73)) (void))
  (error? (set-r25-bar-g! r25-x 3.0))
  (eq? (set-r25-bar-g! r25-x (+ (r25-bar-g r25-x) 73)) (void))
  (error? (set-r25-bar-h! r25-x 3.0))
  (eq? (set-r25-bar-h! r25-x (+ (r25-bar-h r25-x) 73)) (void))
  (error? (set-r25-bar-i! r25-x 3.0))
  (eq? (set-r25-bar-i! r25-x (+ (r25-bar-i r25-x) 73)) (void))
  (error? (set-r25-bar-j! r25-x 3))
  (eq? (set-r25-bar-j! r25-x (+ (r25-bar-j r25-x) 73)) (void))
  (error? (set-r25-bar-k! r25-x 3))
  (eq? (set-r25-bar-k! r25-x (+ (r25-bar-k r25-x) 73)) (void))
  (eq? (set-r25-bar-l! r25-x (cons (r25-bar-l r25-x) 73)) (void))
  (error? (set-r25-bar-m! r25-x 3.0))
  (eq? (set-r25-bar-m! r25-x (integer->char (+ (char->integer (r25-bar-m r25-x)) 1))) (void))
  (error? (set-r25-bar-n! r25-x 3.0))
  (eq? (set-r25-bar-n! r25-x (integer->char (+ (char->integer (r25-bar-n r25-x)) 1))) (void))
  (error? (set-r25-bar-o! r25-x 3.0))
  (eq? (set-r25-bar-o! r25-x (+ (r25-bar-o r25-x) 73)) (void))
  (error? (set-r25-bar-p! r25-x 3.0))
  (eq? (set-r25-bar-p! r25-x (+ (r25-bar-p r25-x) 73)) (void))
  (eq? (set-r25-bar-q! r25-x (not (r25-bar-q r25-x))) (void))
  (error? (set-r25-bar-r! r25-x 3.0))
  (eq? (set-r25-bar-r! r25-x (- (r25-bar-r r25-x) 73)) (void))
  (error? (set-r25-bar-s! r25-x 3.0))
  (eq? (set-r25-bar-s! r25-x (+ (r25-bar-s r25-x) 73)) (void))
  (equal?
    (list
      (r25-bar-a r25-x)
      (r25-bar-b r25-x)
      (r25-bar-c r25-x)
      (r25-bar-d r25-x)
      (r25-bar-e r25-x)
      (r25-bar-f r25-x)
      (r25-bar-g r25-x)
      (r25-bar-h r25-x)
      (r25-bar-i r25-x)
      (r25-bar-j r25-x)
      (r25-bar-k r25-x)
      (r25-bar-l r25-x)
      (r25-bar-m r25-x)
      (r25-bar-n r25-x)
      (r25-bar-o r25-x)
      (r25-bar-p r25-x)
      (r25-bar-q r25-x)
      (r25-bar-r r25-x)
      (r25-bar-s r25-x))
    '(74 75 76 77 78 -67 80 81 82 83.0 84.0 (blue . 73) #\b #\x3bc 148 #xc7c7c810 #f -61 86))
  (error? (set-r25-bar-a! r25-x (expt 256 (foreign-sizeof 'int))))
  (error? (set-r25-bar-a! r25-x (- -1 (ash (expt 256 (foreign-sizeof 'int)) -1))))
  (begin
    (define ($test-int x size get put)
      (let* ([n10000 (expt 256 size)]
             [nffff (- n10000 1)]
             [n8000 (ash n10000 -1)]
             [n7fff (- n8000 1)]
             [n-8000 (- n8000)]
             [n-8001 (- n-8000 1)])
        (and
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n10000) #f))
          (eq? (put x nffff) (void))
          (eqv? (get x) -1)
          (eq? (put x n8000) (void))
          (eqv? (get x) n-8000)
          (eq? (put x n7fff) (void))
          (eqv? (get x) n7fff)
          (eq? (put x 0) (void))
          (eqv? (get x) 0)
          (eq? (put x -1) (void))
          (eqv? (get x) -1)
          (eq? (put x n-8000) (void))
          (eqv? (get x) n-8000)
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
          (eqv? (get x) n-8000))))
    (define ($test-uint x size get put)
      (let* ([n10000 (expt 256 size)]
             [nffff (- n10000 1)]
             [n8000 (ash n10000 -1)]
             [n7fff (- n8000 1)]
             [n-8000 (- n8000)]
             [n-8001 (- n-8000 1)])
        (and
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n10000) #f))
          (eq? (put x nffff) (void))
          (eqv? (get x) nffff)
          (eq? (put x n8000) (void))
          (eqv? (get x) n8000)
          (eq? (put x n7fff) (void))
          (eqv? (get x) n7fff)
          (eq? (put x 0) (void))
          (eqv? (get x) 0)
          (eq? (put x -1) (void))
          (eqv? (get x) nffff)
          (eq? (put x n-8000) (void))
          (eqv? (get x) n8000)
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
          (eqv? (get x) n8000))))
    (define ($test-fixnum x get put)
      (let ([n8000 (+ (greatest-fixnum) 1)]
            [n7fff (greatest-fixnum)]
            [n-8000 (least-fixnum)]
            [n-8001 (- (least-fixnum) 1)])
        (and
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n8000) #f))
          (eq? (put x n7fff) (void))
          (eqv? (get x) n7fff)
          (eq? (put x 0) (void))
          (eqv? (get x) 0)
          (eq? (put x -1) (void))
          (eqv? (get x) -1)
          (eq? (put x n-8000) (void))
          (eqv? (get x) n-8000)
          (or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
          (eqv? (get x) n-8000))))
    #t)
  ($test-int r25-x (foreign-sizeof 'int) r25-bar-a set-r25-bar-a!)
  ($test-uint r25-x (foreign-sizeof 'unsigned) r25-bar-b set-r25-bar-b!)
  ($test-uint r25-x (foreign-sizeof 'unsigned-int) r25-bar-c set-r25-bar-c!)
  ($test-int r25-x (foreign-sizeof 'short) r25-bar-d set-r25-bar-d!)
  ($test-uint r25-x (foreign-sizeof 'unsigned-short) r25-bar-e set-r25-bar-e!)
  ($test-int r25-x (foreign-sizeof 'long) r25-bar-f set-r25-bar-f!)
  ($test-uint r25-x (foreign-sizeof 'unsigned-long) r25-bar-g set-r25-bar-g!)
  ($test-int r25-x (foreign-sizeof 'long-long) r25-bar-r set-r25-bar-r!)
  ($test-uint r25-x (foreign-sizeof 'unsigned-long-long) r25-bar-s set-r25-bar-s!)
  ($test-int r25-x (foreign-sizeof 'iptr) r25-bar-h set-r25-bar-h!)
  ($test-uint r25-x (foreign-sizeof 'uptr) r25-bar-i set-r25-bar-i!)
  ($test-fixnum r25-x r25-bar-o set-r25-bar-o!)
  ($test-uint r25-x (foreign-sizeof 'void*) r25-bar-p set-r25-bar-p!)
)

(mat fasl-records
  ; make sure we can fasl out cyclic record type descriptors
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(define $fsr-a
             (let ()
               (define-syntax a
                 (lambda (x)
                   (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
                                  "rtd1" '((mutable q)) #f #f)]
                          [rtd2 (#%$make-record-type rtd1 #!base-rtd
                                  "rtd2" '() #f #f #f)])
                     ((record-mutator rtd1 0) rtd2 rtd2)
                     #`(quote #,rtd2))))
               a))))
      'replace)
    (load "testfile.ss")
    #t)
  (eq?
    ((record-accessor (record-rtd $fsr-a) 0) $fsr-a)
    $fsr-a)
  (begin
    (separate-compile "testfile")
    (load "testfile.so")
    #t)
  (eq?
    ((record-accessor (record-rtd $fsr-a) 0) $fsr-a)
    $fsr-a)
  ; ... even when cycle involves the record's base rtd
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(define $fsr-b
             (let ()
               (define-syntax a
                 (lambda (x)
                   (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
                                  "rtd1" '((mutable q)) #f #f)]
                          [rtd2 (#%$make-record-type rtd1 #!base-rtd
                                  "rtd2" '() #f #f #f)]
                          [rtd3 (#%$make-record-type rtd2 #!base-rtd
                                  "rtd3" '() #f #f)])
                     ((record-mutator rtd1 0) rtd2 rtd3)
                     #`(quote #,rtd3))))
               a))))
      'replace)
    (load "testfile.ss")
    #t)
  (eq?
    ((record-accessor (record-rtd (record-rtd $fsr-b)) 0) (record-rtd $fsr-b))
    $fsr-b)
  (begin
    (separate-compile "testfile")
    (load "testfile.so")
    #t)
  (eq?
    ((record-accessor (record-rtd (record-rtd $fsr-b)) 0) (record-rtd $fsr-b))
    $fsr-b)
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(define $fsr-c
             (let ()
               (define-syntax a
                 (lambda (x)
                   (let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
                                  "rtd1" '((mutable q)) #f #f)]
                          [rtd2 (#%$make-record-type rtd1 #!base-rtd
                                  "rtd2" '() #f #f #f)]
                          [rtd3 (#%$make-record-type rtd2 #f
                                  "rtd3" '((immutable a)) #f #f)])
                     ((record-mutator rtd1 0) rtd2 ((record-constructor rtd3) 23))
                     #`(quote #,rtd3))))
               a))))
      'replace)
    (load "testfile.ss")
    #t)
  (record?
    ((record-accessor (record-rtd (record-rtd $fsr-c)) 0) (record-rtd $fsr-c))
    $fsr-c)
  (begin
    (separate-compile "testfile")
    (load "testfile.so")
    #t)
  (record?
    ((record-accessor (record-rtd (record-rtd $fsr-c)) 0) (record-rtd $fsr-c))
    $fsr-c)
  ; fasl out typed fields
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(define $fsr-d-inst
             (let ()
               (define-syntax a
                 (lambda (x)
                   (define-record $fsr-d ((immutable integer-32 a) (mutable unsigned-40 b)))
                   #`(quote #,(make-$fsr-d #x1234abcd #xfedcba6543))))
               a))))
      'replace)
    (load "testfile.ss")
    #t)
  (eqv?
    ((record-accessor (record-rtd $fsr-d-inst) 0) $fsr-d-inst)
    #x1234abcd)
  (eqv?
    ((record-accessor (record-rtd $fsr-d-inst) 1) $fsr-d-inst)
    #xfedcba6543)
  (begin
    (separate-compile "testfile")
    (load "testfile.so")
    #t)
  (eqv?
    ((record-accessor (record-rtd $fsr-d-inst) 0) $fsr-d-inst)
    #x1234abcd)
  (eqv?
    ((record-accessor (record-rtd $fsr-d-inst) 1) $fsr-d-inst)
    #xfedcba6543)
  (begin
    (with-output-to-file "testfile.ss"
      (lambda ()
        (pretty-print
          '(eval-when (compile load)
             (define-record $fsr-e
               ((immutable integer-8 i8)
                (immutable integer-16 i16)
                (immutable integer-24 i24)
                (immutable integer-32 i32)
                (immutable integer-40 i40)
                (immutable integer-48 i48)
                (immutable integer-56 i56)
                (immutable integer-64 i64)
                (immutable unsigned-8 u8)
                (immutable unsigned-16 u16)
                (immutable unsigned-24 u24)
                (immutable unsigned-32 u32)
                (immutable unsigned-40 u40)
                (immutable unsigned-48 u48)
                (immutable unsigned-56 u56)
                (immutable unsigned-64 u64)
                (immutable char c)
                (immutable single-float sf)
                (immutable wchar wc)
                (immutable double-float df)
                (immutable fixnum f)))))
        (pretty-print
          '(define $fsr-e-inst1
             (let-syntax ([a (lambda (x)
                               #`'#,(make-$fsr-e 0 -1 0 -1 0 -1 0 -1
                                      0 #xffff 0 #xffffffff 0 #xffffffffffff
                                      0 #xffffffffffffffff
                                      #\nul 3.14 #\x3bc -3.14 0))])
               a)))
        (pretty-print
          '(define $fsr-e-inst2
             (let-syntax ([a (lambda (x)
                               #`'#,(make-$fsr-e -1 0 -1 0 -1 0 -1 0
                                      #xff 0 #xffffff 0 #xffffffffff 0
                                      #xffffffffffffff 0
                                      #\a -3.14 #\nul 3.14 -1))])
               a)))
        (pretty-print
          '(define $fsr-e-inst3
             (let-syntax ([a (lambda (x)
                               #`'#,(make-$fsr-e
                                      #x7f #x-8000 #x7fffff #x-80000000
                                      #x7fffffffff #x-800000000000
                                      #x7fffffffffffff #x-8000000000000000
                                      #x7f #x8000 #x7fffff #x80000000
                                      #x7fffffffff #x800000000000
                                      #x7fffffffffffff #x8000000000000000
                                      #\a +inf.0 #\nul -0.0 -1))])
               a)))
        (pretty-print
          '(define $fsr-e-inst4
             (let-syntax ([a (lambda (x)
                               #`'#,(make-$fsr-e
                                      #x-80 #x7fff #x-800000 #x7fffffff
                                      #x-8000000000 #x7fffffffffff
                                      #x-80000000000000 #x7fffffffffffffff
                                      #x80 #x7fff #x800000 #x7fffffff
                                      #x8000000000 #x7fffffffffff
                                      #x80000000000000 #x7fffffffffffffff
                                      #\a +0.0 #\nul +inf.0 -1))])
               a))))
      'replace)
    #t)
  (begin
    (separate-compile "testfile")
    (load "testfile.so")
    #t)
  ($fsr-e? $fsr-e-inst1)
  ($fsr-e? $fsr-e-inst2)
  ($fsr-e? $fsr-e-inst3)
  ($fsr-e? $fsr-e-inst4)
  (equal?
    ($record->vector $fsr-e-inst1)
    ($record->vector
      (make-$fsr-e 0 -1 0 -1 0 -1 0 -1
        0 #xffff 0 #xffffffff 0 #xffffffffffff
        0 #xffffffffffffffff
        #\nul 3.14 #\x3bc -3.14 0)))
  (equal?
    ($record->vector $fsr-e-inst2)
    ($record->vector
      (make-$fsr-e -1 0 -1 0 -1 0 -1 0
        #xff 0 #xffffff 0 #xffffffffff 0
        #xffffffffffffff 0
        #\a -3.14 #\nul 3.14 -1)))
  (equal?
    ($record->vector $fsr-e-inst3)
    ($record->vector
      (make-$fsr-e
        #x7f #x-8000 #x7fffff #x-80000000
        #x7fffffffff #x-800000000000
        #x7fffffffffffff #x-8000000000000000
        #x7f #x8000 #x7fffff #x80000000
        #x7fffffffff #x800000000000
        #x7fffffffffffff #x8000000000000000
        #\a +inf.0 #\nul -0.0 -1)))
  (equal?
    ($record->vector $fsr-e-inst4)
    ($record->vector
      (make-$fsr-e
        #x-80 #x7fff #x-800000 #x7fffffff
        #x-8000000000 #x7fffffffffff
        #x-80000000000000 #x7fffffffffffffff
        #x80 #x7fff #x800000 #x7fffffff
        #x8000000000 #x7fffffffffff
        #x80000000000000 #x7fffffffffffffff
        #\a +0.0 #\nul +inf.0 -1)))
  )

(mat record?
  (eq? (record? 3) #f)
  (eq? (record? 'a) #f)
  (eq? (record? '#(1 2 3)) #f)
  (eq? (record? (make-record-type "foo" '())) #t)
  (eq? (record? ((record-constructor (make-record-type "foo" '())))) #t)
  (equal?
    (let ([rtd1 (make-record-type "foo" '())]
          [rtd2 (make-record-type "bar" '())])
      (let ([rtd3 (make-record-type rtd1 "xfoo" '())])
        (list (record? ((record-constructor rtd1)) rtd1)
              (record? ((record-constructor rtd1)) rtd2)
              (record? ((record-constructor rtd1)) rtd3)
              (record? ((record-constructor rtd3)) rtd1)
              (record? ((record-constructor rtd3)) rtd2)
              (record? ((record-constructor rtd3)) rtd3))))
    '(#t #f #f #t #f #t))
  (error? (record? 3 4))
  (error? (record? ((record-constructor (make-record-type "foo" '()))) 'a))
  (error? (record? ((record-constructor (make-record-type "foo" '()))) '#(1)))
  (let ()
    (define-record-type A)
    (define-record-type B (parent A))
    (define-record-type C (parent B))
    (define-record-type D (parent C) (sealed #t))
    (define-record-type E (parent C) (opaque #t))
    (define a (make-A))
    (define b (make-B))
    (define c (make-C))
    (define d (make-D))
    (define e (make-E))
    (define Atd (record-type-descriptor A))
    (define Btd (record-type-descriptor B))
    (define Ctd (record-type-descriptor C))
    (define Dtd (record-type-descriptor D))
    (define Etd (record-type-descriptor E))
    (and
      (equal?
        (list (record? 3) (record? a) (record? b) (record? c) (record? d) (record? e))
        '(#f #t #t #t #t #f))
      (equal?
        (let ()
          (import (rnrs))
          (list (record? 3) (record? a) (record? b) (record? c) (record? d) (record? e)))
        '(#f #t #t #t #t #f))
      (equal?
        (list (record? 3 Atd) (record? a Atd) (record? b Atd) (record? c Atd) (record? d Atd) (record? e Atd))
        '(#f #t #t #t #t #t))
      (equal?
        (list (record? 3 Btd) (record? a Btd) (record? b Btd) (record? c Btd) (record? d Btd) (record? e Btd))
        '(#f #f #t #t #t #t))
      (equal?
        (list (record? 3 Ctd) (record? a Ctd) (record? b Ctd) (record? c Ctd) (record? d Ctd) (record? e Ctd))
        '(#f #f #f #t #t #t))
      (equal?
        (list (record? 3 Dtd) (record? a Dtd) (record? b Dtd) (record? c Dtd) (record? d Dtd) (record? e Dtd))
        '(#f #f #f #f #t #f))
      (equal?
        (list (record? 3 Etd) (record? a Etd) (record? b Etd) (record? c Etd) (record? d Etd) (record? e Etd))
        '(#f #f #f #f #f #t))
      (equal?
        (let ([record? #%$sealed-record?])
          (list (record? 3 Dtd) (record? a Dtd) (record? b Dtd) (record? c Dtd) (record? d Dtd) (record? e Dtd)))
        '(#f #f #f #f #t #f))))
)

(mat record-type-mismatch
  (begin
    (define-record-type flotsam
      (nongenerative #{flotsam flotsam})
      (fields x y))
    #t)
  (record-type-descriptor?
    (make-record-type '#{flotsam flotsam} '((immutable x) (immutable y))))
  (error? ; different parent
    (begin
      (define-record-type pflotsam (nongenerative pflotsam))
      (define-record-type flotsam
        (nongenerative #{flotsam flotsam})
        (parent pflotsam)
        (fields x y))))
  (error? ; different fields
    (define-record-type flotsam
      (nongenerative #{flotsam flotsam})
      (fields x y z)))
  (error? ; different fields
    (make-record-type '#{flotsam flotsam} '((int x) y)))
  (error? ; different mutability
    (define-record-type flotsam
      (nongenerative #{flotsam flotsam})
      (fields (mutable x) y)))
  (error? ; different flags
    (define-record-type flotsam
      (nongenerative #{flotsam flotsam})
      (sealed #t)
      (fields x y)))
  (error? ; different flags
    (define-record-type flotsam
      (nongenerative #{flotsam flotsam})
      (opaque #t)
      (fields x y)))
)

(mat r6rs-records-procedural
  ((lambda (x)
     (and (list? x)
          (record? (car x))
          (equal?
            (cdr x)
            '(765 45 25 #t #t #f #f #t #t #f foo bar #1(x) #2(y z) #f #t
                  (#t #f) (#f #f) (#f #t) #t pluto))))
    (let ()
      (define prtd
        (make-record-type-descriptor 'foo #f #f #f #f
          '#((mutable x))))
      (define rtd
        (make-record-type-descriptor 'bar prtd 'pluto #t #f
          '#((mutable y) (immutable z))))
      (define rcd (make-record-constructor-descriptor rtd #f #f))
      (define rc (r6rs:record-constructor rcd))
      (define foo-x (record-accessor prtd 0))
      (define foo-x! (record-mutator prtd 0))
      (define bar-y (record-accessor rtd 0))
      (define bar-y! (record-mutator rtd 0))
      (define bar-z (record-accessor rtd 1))
      (define x (rc 17 20 25))
      (bar-y! x (+ (bar-y x) (bar-z x)))
      (foo-x! x (* (bar-y x) (foo-x x)))
      (list x (foo-x x) (bar-y x) (bar-z x)
        (record-type-descriptor? rtd)
        (record-constructor-descriptor? rcd)
        (record-type-descriptor? rcd)
        (record-constructor-descriptor? rtd)
        (record-field-mutable? prtd 0)
        (record-field-mutable? rtd 0)
        (record-field-mutable? rtd 1)
        (record-type-name prtd)
        (record-type-name rtd)
        (record-type-field-names prtd)
        (record-type-field-names rtd)
        (eq? (record-rtd x) prtd)
        (eq? (record-rtd x) rtd)
        (list (record-type-generative? prtd) (record-type-generative? rtd))
        (list (record-type-opaque? prtd) (record-type-opaque? rtd))
        (list (record-type-sealed? prtd) (record-type-sealed? rtd))
        (gensym? (record-type-uid prtd))
        (record-type-uid rtd))))

  (equal?
    (parameterize ([current-output-port (open-output-string)])
      (define a-rtd (make-record-type-descriptor 'a #f #f #f #f
                      '#((mutable x))))
      (define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
                      '#((immutable x) (mutable y))))
      (define a? (record-predicate a-rtd))
      (define b? (record-predicate b-rtd))
      (define a-x (record-accessor a-rtd 0))
      (define a-x! (record-mutator a-rtd 0))
      (define b-x (record-accessor b-rtd 0))
      (define b-y (record-accessor b-rtd 1))
      (define b-y! (record-mutator b-rtd 1))
      (define (a->list b)
        (if (b? b)
            (list (a-x b) (b-x b) (b-y b))
            (list (a-x b))))
      (define a-rcd0 (make-record-constructor-descriptor a-rtd #f #f))
      (define b-rcd0 (make-record-constructor-descriptor b-rtd #f #f))
      #;(define make-a0 (r6rs:record-constructor a-rcd0))
      #;(define make-b0 (r6rs:record-constructor b-rcd0))
      (define make-a0 (record-constructor a-rcd0)) ; should handle rcd too
      (define make-b0 (record-constructor b-rcd0)) ; should handle rcd too
      (define b-rcd1 (make-record-constructor-descriptor b-rtd a-rcd0 #f))
      (define make-b1 (r6rs:record-constructor b-rcd1))
      (define a-rcd2
        (make-record-constructor-descriptor a-rtd #f
          (lambda (p)
            (lambda (x y)
              (let ([r (p (- x y))])
                (printf "make-a2: ~s\n" (a->list r))
                (a-x r)
                r)))))
      (define make-a2 (r6rs:record-constructor a-rcd2))
      (let ([ls (map a->list (list
                               (make-a0 3)
                               (make-b0 4 5 6)
                               (make-b1 7 8 9)
                               (make-a2 10 11)))])
        (cons (get-output-string (current-output-port)) ls)))
    '("make-a2: (-1)\n" (3) (4 5 6) (7 8 9) (-1)))

  (equal?
    (parameterize ([current-output-port (open-output-string)])
      (define a-rtd (make-record-type-descriptor 'a #f #f #f #f
                      '#((mutable x))))
      (define a? (record-predicate a-rtd))
      (define a-x (record-accessor a-rtd 0))
      (define (a->list b) (list (a-x b)))
      (define-syntax echo
        (syntax-rules ()
          [(_ s e) (begin (printf "~a in\n" s)
                     (let ([x e])
                       (printf "~a out: ~s\n" s (record? x))
                       x))]))
      (define a-rcd
        (make-record-constructor-descriptor a-rtd #f
          (lambda (m) (lambda (q t) (echo "A" (m (* q t)))))))
      (define make-a (r6rs:record-constructor a-rcd))
      (let ([ls (map a->list (list (make-a 3 4)))])
        (cons (get-output-string (current-output-port)) ls)))
    '("A in\nA out: #t\n" (12)))

  (equal?
    (parameterize ([current-output-port (open-output-string)])
      (define a-rtd (make-record-type-descriptor 'a #f #f #f #f
                      '#((mutable x))))
      (define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
                      '#((immutable x) (mutable y))))
      (define a? (record-predicate a-rtd))
      (define b? (record-predicate b-rtd))
      (define a-x (record-accessor a-rtd 0))
      (define a-x! (record-mutator a-rtd 0))
      (define b-x (record-accessor b-rtd 0))
      (define b-y (record-accessor b-rtd 1))
      (define b-y! (record-mutator b-rtd 1))
      (define (a->list b)
        (if (b? b)
            (list (a-x b) (b-x b) (b-y b))
            (list (a-x b))))
      (define-syntax echo
        (syntax-rules ()
          [(_ s e) (begin (printf "~a in\n" s)
                     (let ([x e])
                       (printf "~a out: ~s\n" s (record? x))
                       x))]))
      (define a-rcd
        (make-record-constructor-descriptor a-rtd #f
          (lambda (m) (lambda (q) (echo "A" (m (* q q)))))))
      (define b-rcd
        (make-record-constructor-descriptor b-rtd a-rcd
          (lambda (m) (lambda (q) (echo "B" ((m q) (- q) (/ q)))))))
      (define make-b (r6rs:record-constructor b-rcd))
      (let ([ls (map a->list (list (make-b 3)))])
        (cons (get-output-string (current-output-port)) ls)))
    '("B in\nA in\nA out: #t\nB out: #t\n" (9 -3 1/3)))

  (equal?
    (parameterize ([current-output-port (open-output-string)])
      (define a-rtd (make-record-type-descriptor 'a #f #f #f #f
                      '#((mutable x))))
      (define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
                      '#((immutable x) (mutable y))))
      (define c-rtd (make-record-type-descriptor 'c b-rtd #f #f #f
                      '#((immutable z) (mutable w))))
      (define a? (record-predicate a-rtd))
      (define b? (record-predicate b-rtd))
      (define c? (record-predicate c-rtd))
      (define a-x (record-accessor a-rtd 0))
      (define a-x! (record-mutator a-rtd 0))
      (define b-x (record-accessor b-rtd 0))
      (define b-y (record-accessor b-rtd 1))
      (define b-y! (record-mutator b-rtd 1))
      (define c-z (record-accessor c-rtd 0))
      (define c-w (record-accessor c-rtd 1))
      (define c-w! (record-mutator c-rtd 1))
      (define (a->list b)
        (if (c? b)
            (list (a-x b) (b-x b) (b-y b) (c-z b) (c-w b))
            (if (b? b)
                (list (a-x b) (b-x b) (b-y b))
                (list (a-x b)))))
      (define-syntax echo
        (syntax-rules ()
          [(_ s e) (begin (printf "~a in\n" s)
                     (let ([x e])
                       (printf "~a out: ~s\n" s (record? x))
                       x))]))
      (define a-rcd
        (make-record-constructor-descriptor a-rtd #f
          (lambda (m) (lambda (q) (echo "A" (m (* q q)))))))
      (define b-rcd
        (make-record-constructor-descriptor b-rtd a-rcd
          (lambda (m) (lambda (q) (echo "B" ((m q) (- q) (/ q)))))))
      (define c-rcd
        (make-record-constructor-descriptor c-rtd b-rcd
          (lambda (m)
            (lambda (q t)
              (echo "C" ((m (+ q t)) (* q t) (cons q t)))))))
      (define make-c (r6rs:record-constructor c-rcd))
      (let ([ls (map a->list (list (make-c 3 4)))])
        (cons (get-output-string (current-output-port)) ls)))
    '("C in\nB in\nA in\nA out: #t\nB out: #t\nC out: #t\n"
       (49 -7 1/7 12 (3 . 4))))
  (error? ; rtd/rcd mismatch
    (let ()
      (define-syntax rtd1 (lambda (x) #`'#,(make-record-type "foo" '(x))))
      (define-syntax rtd2 (lambda (x) #`'#,(make-record-type rtd1 "bar" '(y))))
      (define-syntax rtd3 (lambda (x) #`'#,(make-record-type "foo2" '(a b))))
      (define-syntax rtd4 (lambda (x) #`'#,(make-record-type rtd3 "bar2" '(c d))))
      (define rcd1
        (make-record-constructor-descriptor rtd1 #f
          (lambda (n) (lambda (q) (n (* q q))))))
      (define rcd3
        (make-record-constructor-descriptor rtd3 rcd1
          (lambda (p) (lambda (t u v) ((p t u) v 0)))))
      (define cons3 (r6rs:record-constructor rcd3))
      (cons3 1 2 3)))

 ; make sure appropriate error checking is done for protocols
  (error? ; not a procedure (parent protocol)
    (let ([pprot (cons 'ugly 'ducking)]
          [cprot (lambda (p) (lambda (x y) ((p x 0 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; not a procedure (child protocol)
    (let ([pprot (lambda (n) n)]
          [cprot 'flimflam])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; not a procedure (returned from parent protocol)
    (let ([pprot (lambda (n) 'not-a-procedure)]
          [cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; not a procedure (returned from child protocol)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) 'spam)])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to parent protocol)
    (let ([pprot (lambda (n) n)]
          [cprot (lambda (p) (lambda (x y) ((p x 0 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to parent protocol)
    (let ([pprot (lambda (n) n)]
          [cprot (lambda (p) (lambda (x y) ((p x) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to parent protocol)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) (lambda (x y) ((p x 17 'xtra) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to parent protocol)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) (lambda (x y) ((p x) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to child constructor)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1))))
  (error? ; wrong number of arguments (to child constructor)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2 3))))
  (error? ; wrong number of arguments (to parent "new" procedure)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w "what?")))]
          [cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))
  (error? ; wrong number of arguments (to child "new" procedure)
    (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
          [cprot (lambda (p) (lambda (x y) ((p x 17) y '#(oops))))])
      (define prtd (make-record-type "parent" '(x y)))
      (define crtd (make-record-type prtd "child" '(z)))
      (define prcd (make-record-constructor-descriptor prtd #f pprot))
      (define crcd (make-record-constructor-descriptor crtd prcd cprot))
      (define pcons (r6rs:record-constructor prcd))
      (define ccons (r6rs:record-constructor crcd))
      (list (pcons 1 2) (ccons 1 2))))

 ; make sure we can use modifiers and types as field names
  (equal?
    (let ()
      (define foo (make-record-type-descriptor 'umph #f #f #f #f '#((mutable mutable) (immutable int) (immutable integer-32))))
      (let ([x ((r6rs:record-constructor (make-record-constructor-descriptor foo #f #f)) 3 4 5)])
        ((record-mutator foo 0) x 75)
        (list ($record->vector x)
              ((record-accessor foo 0) x)
              ((record-accessor foo 1) x)
              ((record-accessor foo 2) x))))
    '(#(umph 75 4 5) 75 4 5))

 ; optimization tests---observe with expand/optimize
  (equal?
    (map $record->vector
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd (make-record-constructor-descriptor prtd #f #f))
        (define crcd (make-record-constructor-descriptor crtd #f #f))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2 3))))
    '(#(parent 1 2) #(child 1 2 3)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd (make-record-constructor-descriptor prtd #f #f))
            (define crcd (make-record-constructor-descriptor crtd #f #f))
            (define pcons (r6rs:record-constructor prcd))
            (define ccons (r6rs:record-constructor crcd))
            (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd (make-record-constructor-descriptor prtd #f #f))
            (define crcd (make-record-constructor-descriptor crtd #f #f))
            (define pcons (r6rs:record-constructor prcd))
            (define ccons (r6rs:record-constructor crcd))
            (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
 ; same as set above except with r6rs:record-constructor
 ; replaced by record:constructor, which should handle rcds
  (equal?
    (map $record->vector
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd (make-record-constructor-descriptor prtd #f #f))
        (define crcd (make-record-constructor-descriptor crtd #f #f))
        (define pcons (record-constructor prcd))
        (define ccons (record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2 3))))
    '(#(parent 1 2) #(child 1 2 3)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd (make-record-constructor-descriptor prtd #f #f))
            (define crcd (make-record-constructor-descriptor crtd #f #f))
            (define pcons (record-constructor prcd))
            (define ccons (record-constructor crcd))
            (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd (make-record-constructor-descriptor prtd #f #f))
            (define crcd (make-record-constructor-descriptor crtd #f #f))
            (define pcons (record-constructor prcd))
            (define ccons (record-constructor crcd))
            (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
  (equal?
    (map $record->vector
      ; same thing except supplying prcd in place of #f, which should
      ; result in the same residual code
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd (make-record-constructor-descriptor prtd #f #f))
        (define crcd (make-record-constructor-descriptor crtd prcd #f))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2 3))))
    '(#(parent 1 2) #(child 1 2 3)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f #f))
           (define crcd
             (make-record-constructor-descriptor crtd prcd #f))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f #f))
           (define crcd
             (make-record-constructor-descriptor crtd prcd #f))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2 3)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 2 3)))))
  (equal?
    (map $record->vector
     ; test with variables bound to protocol lambda expressions
      (let ([pprot (lambda (n) n)]
            [cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd (make-record-constructor-descriptor prtd #f pprot))
        (define crcd (make-record-constructor-descriptor crtd prcd cprot))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 1 2) #(child 1 0 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([pprot (lambda (n) n)]
               [cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define crcd
             (make-record-constructor-descriptor crtd prcd cprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 0 2)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([pprot (lambda (n) n)]
               [cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define crcd
             (make-record-constructor-descriptor crtd prcd cprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 0 2)))))
  (begin (define $global 'worldwide) #t)
  (equal?
    (map $record->vector
     ; same but with a global variable in place of the constant 0
      (let ([pprot (lambda (n) n)]
            [cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd (make-record-constructor-descriptor prtd #f pprot))
        (define crcd (make-record-constructor-descriptor crtd prcd cprot))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 1 2) #(child 1 worldwide 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([pprot (lambda (n) n)]
               [cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define crcd
             (make-record-constructor-descriptor crtd prcd cprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 $global 2)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([pprot (lambda (n) n)]
               [cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define crcd
             (make-record-constructor-descriptor crtd prcd cprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
           (#3%list
             (#3%$record prtd 1 2)
             (#3%$record crtd 1 $global 2)))))
  (equal?
    (map $record->vector
     ; same but with a outer lexical variable in place of the constant 0
      (let ([lex $global])
        (let ([pprot (lambda (n) n)]
              [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define prcd (make-record-constructor-descriptor prtd #f pprot))
          (define crcd (make-record-constructor-descriptor crtd prcd cprot))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (list (pcons 1 2) (ccons 1 2)))))
    '(#(parent 1 2) #(child 1 worldwide 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) n)]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(let ([lex $global])
       (let ([prtd (#2%make-record-type "parent" '(x y))])
         (let ([crtd (#2%make-record-type prtd "child" '(z))])
           (#2%list
             (#3%$record prtd 1 2)
             (#3%$record crtd 1 lex 2))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) n)]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(let ([lex $global])
       (let ([prtd (#3%make-record-type "parent" '(x y))])
         (let ([crtd (#3%make-record-type prtd "child" '(z))])
           (#3%list
             (#3%$record prtd 1 2)
             (#3%$record crtd 1 lex 2))))))
  (equal?
    (map $record->vector
     ; same but slightly more complicated parent protocol
      (let ([lex $global])
        (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
              [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define prcd (make-record-constructor-descriptor prtd #f pprot))
          (define crcd (make-record-constructor-descriptor crtd prcd cprot))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (list (pcons 1 2) (ccons 1 2)))))
    '(#(parent 8 2) #(child 8 worldwide 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(let ([lex $global])
       (let ([prtd (#2%make-record-type "parent" '(x y))])
         (let ([crtd (#2%make-record-type prtd "child" '(z))])
           (#2%list
             (#3%$record prtd 8 2)
             (#3%$record crtd 8 lex 2))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(let ([lex $global])
       (let ([prtd (#3%make-record-type "parent" '(x y))])
         (let ([crtd (#3%make-record-type prtd "child" '(z))])
           (#3%list
             (#3%$record prtd 8 2)
             (#3%$record crtd 8 lex 2))))))
  (equal?
    (map $record->vector
     ; same but ignore one of the parent args
      (let ([lex $global])
        (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
              [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define prcd (make-record-constructor-descriptor prtd #f pprot))
          (define crcd (make-record-constructor-descriptor crtd prcd cprot))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (list (pcons 1 2) (ccons 1 2)))))
    '(#(parent 8 53) #(child 8 53 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(begin $global
       (let ([prtd (#2%make-record-type "parent" '(x y))])
         (let ([crtd (#2%make-record-type prtd "child" '(z))])
           (#2%list
             (#3%$record prtd 8 53)
             (#3%$record crtd 8 53 2))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ([lex $global])
           (let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
                 [cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
             (define prtd (make-record-type "parent" '(x y)))
             (define crtd (make-record-type prtd "child" '(z)))
             (define prcd
               (make-record-constructor-descriptor prtd #f pprot))
             (define crcd
               (make-record-constructor-descriptor crtd prcd cprot))
             (define pcons (r6rs:record-constructor prcd))
             (define ccons (r6rs:record-constructor crcd))
             (list (pcons 1 2) (ccons 1 2))))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 53)
           (#3%$record crtd 8 53 2)))))
  (equal?
    (map $record->vector
     ; same thing except pprot and cprot lambda expressions
     ; appear directly in the calls to m-r-c-d
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd
          (make-record-constructor-descriptor prtd #f
            (lambda (n) n)))
        (define crcd
          (make-record-constructor-descriptor crtd prcd
            (lambda (p) (lambda (x y) ((p x 0) y)))))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 1 2) #(child 1 0 2)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f (lambda (n) n)))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x 0) y)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 0 2)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f (lambda (n) n)))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x 0) y)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 1 2)
           (#3%$record crtd 1 0 2)))))
  (equal?
    (map $record->vector
     ; same thing except with slightly more complicated parent protocol
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd
          (make-record-constructor-descriptor prtd #f
            (lambda (n) (lambda (z w) (n (+ z 7) w)))))
        (define crcd
          (make-record-constructor-descriptor crtd prcd
            (lambda (p) (lambda (x y) ((p x y) 0)))))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) 0)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) 0)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equal?
    (map $record->vector
     ; same thing but ignore one of the parent args
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd
          (make-record-constructor-descriptor prtd #f
            (lambda (n) (lambda (z w) (n (+ z 7) 53)))))
        (define crcd
          (make-record-constructor-descriptor crtd prcd
            (lambda (p) (lambda (x y) ((p x y) 0)))))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons (r6rs:record-constructor crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 53) #(child 8 53 0)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) 53)))))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) 0)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 53)
           (#3%$record crtd 8 53 0)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) 53)))))
           (define crcd
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) 0)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 53)
           (#3%$record crtd 8 53 0)))))
  (equal?
    (map $record->vector
     ; same thing except don't give a name to the child rcd
     ; surprisingly, this folds up because the call to r6rs:record-constructor
     ; (as with any primitive call) gets pushed into the letrec produced by
     ; make-record-constructor-descriptor
     ; > (print-gensym #f)
     ; > (new-cafe expand/optimize)
     ; >> (#%r6rs:record-constructor (letrec ((x (lambda (n) n))) (foo x)))
     ; (letrec ([x (lambda (n) n)]) (#2%r6rs:record-constructor (foo x)))
     ; >> (#%car (letrec ((x (lambda (n) n))) (foo x)))
     ; (letrec ([x (lambda (n) n)]) (#2%car (foo x)))
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define prcd
          (make-record-constructor-descriptor prtd #f
            (lambda (n) (lambda (z w) (n (+ z 7) w)))))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons
          (r6rs:record-constructor
            (make-record-constructor-descriptor crtd prcd
              (lambda (p) (lambda (x y) ((p x y) 0))))))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 crtd
                 prcd
                 (lambda (p) (lambda (x y) ((p x y) 0))))))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor
               prtd
               #f
               (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 crtd
                 prcd
                 (lambda (p) (lambda (x y) ((p x y) 0))))))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equal?
    (map $record->vector
     ; same thing except give pprot a name
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
        (define prcd (make-record-constructor-descriptor prtd #f pprot))
        (define pcons (r6rs:record-constructor prcd))
        (define ccons
          (r6rs:record-constructor
            (make-record-constructor-descriptor crtd prcd
              (lambda (p) (lambda (x y) ((p x y) 0))))))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 crtd
                 prcd
                 (lambda (p) (lambda (x y) ((p x y) 0))))))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
           (define prcd
             (make-record-constructor-descriptor prtd #f pprot))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 crtd
                 prcd
                 (lambda (p) (lambda (x y) ((p x y) 0))))))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equal?
    (map $record->vector
     ; push our luck: don't give a name to parent rcd either.
     ; this one doesn't fold up.  to fix it, we'd need to (a)
     ; pull the inner m-r-c-d call and outer protocol expr into a
     ; let or letrec wrapping the outer m-r-c-d call, and (b)
     ; pull the bindings for both outside of the r6rs:r-c call ...
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define pcons
          (r6rs:record-constructor
            (make-record-constructor-descriptor prtd #f
              (lambda (n) (lambda (z w) (n (+ z 7) w))))))
        (define ccons
          (r6rs:record-constructor
            (make-record-constructor-descriptor crtd
              (make-record-constructor-descriptor prtd #f
                (lambda (n) (lambda (z w) (n (+ z 7) w))))
              (lambda (p) (lambda (x y) ((p x y) 0))))))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equal?
    (map $record->vector
     ; ... like this (at optimize-level 3, anyway)
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define pcons
          (r6rs:record-constructor
            (make-record-constructor-descriptor prtd #f
              (lambda (n) (lambda (z w) (n (+ z 7) w))))))
        (define ccons
          (let ([prcd (make-record-constructor-descriptor prtd #f
                        (lambda (n) (lambda (z w) (n (+ z 7) w))))]
                [cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
            (r6rs:record-constructor
              (make-record-constructor-descriptor crtd prcd cprot))))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define pcons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 prtd
                 #f
                 (lambda (n) (lambda (z w) (n (+ z 7) w))))))
           (define ccons
             (let ([prcd (make-record-constructor-descriptor
                           prtd
                           #f
                           (lambda (n) (lambda (z w) (n (+ z 7) w))))]
                   [cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
               (r6rs:record-constructor
                 (make-record-constructor-descriptor crtd prcd cprot))))
           (list (pcons 1 2) (ccons 1 2)))))
   ; this is now as good as it gets at optimize-level 2
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define pcons
             (r6rs:record-constructor
               (make-record-constructor-descriptor
                 prtd
                 #f
                 (lambda (n) (lambda (z w) (n (+ z 7) w))))))
           (define ccons
             (let ([prcd (make-record-constructor-descriptor
                           prtd
                           #f
                           (lambda (n) (lambda (z w) (n (+ z 7) w))))]
                   [cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
               (r6rs:record-constructor
                 (make-record-constructor-descriptor crtd prcd cprot))))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 0)))))
  (equal?
    (map $record->vector
     ; ... this isn't good enough
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define pcons
          (r6rs:record-constructor
            (make-record-constructor-descriptor prtd #f
              (lambda (n) (lambda (z w) (n (+ z 7) w))))))
        (define ccons
          (let ([tmp (make-record-constructor-descriptor crtd
                       (make-record-constructor-descriptor prtd #f
                         (lambda (n) (lambda (z w) (n (+ z 7) w))))
                       (lambda (p) (lambda (x y) ((p x y) 0))))])
            (r6rs:record-constructor tmp)))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 0)))
  (equal?
    (map $record->vector
     ; try some with inlining
      (let ()
        (define prtd (make-record-type "parent" '(x y)))
        (define crtd (make-record-type prtd "child" '(z)))
        (define (make-prcd f) (make-record-constructor-descriptor prtd #f f))
        (define prcd (make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
        (define (make-crcd z)
          (make-record-constructor-descriptor crtd prcd
            (lambda (p) (lambda (x y) ((p x y) z)))))
        (define crcd (make-crcd -17))
        (define (make-pcons) (r6rs:record-constructor prcd))
        (define pcons (make-pcons))
        (define (make-ccons x) (r6rs:record-constructor x))
        (define ccons (make-ccons crcd))
        (list (pcons 1 2) (ccons 1 2))))
    '(#(parent 8 2) #(child 8 2 -17)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define (make-prcd f)
             (make-record-constructor-descriptor prtd #f f))
           (define prcd
             (make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define (make-crcd z)
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) z)))))
           (define crcd (make-crcd -17))
           (define (make-pcons) (r6rs:record-constructor prcd))
           (define pcons (make-pcons))
           (define (make-ccons x) (r6rs:record-constructor x))
           (define ccons (make-ccons crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#2%make-record-type "parent" '(x y))])
       (let ([crtd (#2%make-record-type prtd "child" '(z))])
         (#2%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 -17)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define (make-prcd f)
             (make-record-constructor-descriptor prtd #f f))
           (define prcd
             (make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
           (define (make-crcd z)
             (make-record-constructor-descriptor
               crtd
               prcd
               (lambda (p) (lambda (x y) ((p x y) z)))))
           (define crcd (make-crcd -17))
           (define (make-pcons) (r6rs:record-constructor prcd))
           (define pcons (make-pcons))
           (define (make-ccons x) (r6rs:record-constructor x))
           (define ccons (make-ccons crcd))
           (list (pcons 1 2) (ccons 1 2)))))
    '(let ([prtd (#3%make-record-type "parent" '(x y))])
       (let ([crtd (#3%make-record-type prtd "child" '(z))])
         (#3%list
           (#3%$record prtd 8 2)
           (#3%$record crtd 8 2 -17)))))
  (equal?
    (parameterize ([print-vector-length #f])
      (with-output-to-string
       ; more elaborate test with side effects
        (lambda ()
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define prcd
            (make-record-constructor-descriptor prtd #f
              (rec pprot
                (lambda (new)
                  (lambda (x n m)
                    (let ([r (new x (+ n m))])
                      (pretty-print `(parent ,($record->vector r)))
                      r))))))
          (define crcd
            (make-record-constructor-descriptor crtd prcd
              (rec cprot
                (lambda (p)
                  (lambda (z x n m)
                    (let ([r ((p x n m) z)])
                      (pretty-print `(child ,($record->vector r)))
                      r))))))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (pretty-print ($record->vector (pcons 1 2 3)))
          (pretty-print ($record->vector (ccons 1 2 3 4))))))
    "(parent #(parent 1 5))\n#(parent 1 5)\n(parent #(child 2 7 1))\n(child #(child 2 7 1))\n#(child 2 7 1)\n")
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f
               (rec pprot
                 (lambda (new)
                   (lambda (x n m)
                     (let ([r (new x (+ n m))])
                       (pretty-print `(parent ,($record->vector r)))
                       r))))))
           (define crcd
             (make-record-constructor-descriptor crtd prcd
               (rec cprot
                 (lambda (p)
                   (lambda (z x n m)
                     (let ([r ((p x n m) z)])
                       (pretty-print `(child ,($record->vector r)))
                       r))))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (pretty-print ($record->vector (pcons 1 2 3)))
           (pretty-print ($record->vector (ccons 1 2 3 4))))))
    '(lambda ()
       (let ([prtd (#2%make-record-type "parent" '(x y))])
         (let ([crtd (#2%make-record-type prtd "child" '(z))])
           (#2%pretty-print
             ($record->vector
               (let ([r (#3%$record prtd 1 5)])
                 (#2%pretty-print (#2%list 'parent ($record->vector r)))
                 r)))
           (#2%pretty-print
             ($record->vector
               (let ([r (let ([r (#3%$record crtd 2 7 1)])
                          (#2%pretty-print (#2%list 'parent ($record->vector r)))
                          r)])
                 (#2%pretty-print (#2%list 'child ($record->vector r)))
                 r)))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define prcd
             (make-record-constructor-descriptor prtd #f
               (rec pprot
                 (lambda (new)
                   (lambda (x n m)
                     (let ([r (new x (+ n m))])
                       (pretty-print `(parent ,($record->vector r)))
                       r))))))
           (define crcd
             (make-record-constructor-descriptor crtd prcd
               (rec cprot
                 (lambda (p)
                   (lambda (z x n m)
                     (let ([r ((p x n m) z)])
                       (pretty-print `(child ,($record->vector r)))
                       r))))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (pretty-print ($record->vector (pcons 1 2 3)))
           (pretty-print ($record->vector (ccons 1 2 3 4))))))
    '(lambda ()
       (let ([prtd (#3%make-record-type "parent" '(x y))])
         (let ([crtd (#3%make-record-type prtd "child" '(z))])
           (#3%pretty-print
             ($record->vector
               (let ([r (#3%$record prtd 1 5)])
                 (#3%pretty-print (#3%list 'parent ($record->vector r)))
                 r)))
           (#3%pretty-print
             ($record->vector
               (let ([r (let ([r (#3%$record crtd 2 7 1)])
                          (#3%pretty-print (#3%list 'parent ($record->vector r)))
                          r)])
                 (#3%pretty-print (#3%list 'child ($record->vector r)))
                 r)))))))
  (equal?
    (parameterize ([print-vector-length #f])
      (with-output-to-string
       ; adding a grandchild
        (lambda ()
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define gcrtd (make-record-type crtd "grand-child" '(w)))
          (define prcd
            (make-record-constructor-descriptor prtd #f
              (rec pprot
                (lambda (new)
                  (lambda (x n m)
                    (let ([r (new x (+ n m))])
                      (pretty-print `(parent ,($record->vector r)))
                      r))))))
          (define crcd
            (make-record-constructor-descriptor crtd prcd
              (rec cprot
                (lambda (p)
                  (lambda (z x n m)
                    (let ([r ((p x n m) z)])
                      (pretty-print `(child ,($record->vector r)))
                      r))))))
          (define gcrcd
            (make-record-constructor-descriptor gcrtd crcd
              (rec gcprot
                (lambda (p)
                  (lambda (w x q z)
                    (let ([r ((p z x q 7) (* w 3))])
                      (pretty-print `(grand-child ,($record->vector r)))
                      r))))))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (define gccons (r6rs:record-constructor gcrcd))
          (pretty-print ($record->vector (pcons 1 2 3)))
          (pretty-print ($record->vector (ccons 1 2 3 4)))
          (pretty-print ($record->vector (gccons 1 2 3 4))))))
    (format "~
      (parent #(parent 1 5))\n~
      #(parent 1 5)\n~
      (parent #(child 2 7 1))\n~
      (child #(child 2 7 1))\n~
      #(child 2 7 1)\n~
      (parent #(grand-child 2 10 4 3))\n~
      (child #(grand-child 2 10 4 3))\n~
      (grand-child #(grand-child 2 10 4 3))\n~
      #(grand-child 2 10 4 3)\n"))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define gcrtd (make-record-type crtd "grand-child" '(w)))
           (define prcd
             (make-record-constructor-descriptor prtd #f
               (rec pprot
                 (lambda (new)
                   (lambda (x n m)
                     (let ([r (new x (+ n m))])
                       (pretty-print `(parent ,($record->vector r)))
                       r))))))
           (define crcd
             (make-record-constructor-descriptor crtd prcd
               (rec cprot
                 (lambda (p)
                   (lambda (z x n m)
                     (let ([r ((p x n m) z)])
                       (pretty-print `(child ,($record->vector r)))
                       r))))))
           (define gcrcd
             (make-record-constructor-descriptor gcrtd crcd
               (rec gcprot
                 (lambda (p)
                   (lambda (w x q z)
                     (let ([r ((p z x q 7) (* w 3))])
                       (pretty-print `(grand-child ,($record->vector r)))
                       r))))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (define gccons (r6rs:record-constructor gcrcd))
           (pretty-print ($record->vector (pcons 1 2 3)))
           (pretty-print ($record->vector (ccons 1 2 3 4)))
           (pretty-print ($record->vector (gccons 1 2 3 4))))))
    '(lambda ()
       (let ([prtd (#2%make-record-type "parent" '(x y))])
         (let ([crtd (#2%make-record-type prtd "child" '(z))])
           (let ([gcrtd (#2%make-record-type crtd "grand-child" '(w))])
             (#2%pretty-print
               ($record->vector
                 (let ([r (#3%$record prtd 1 5)])
                   (#2%pretty-print (#2%list 'parent ($record->vector r)))
                   r)))
             (#2%pretty-print
               ($record->vector
                 (let ([r (let ([r (#3%$record crtd 2 7 1)])
                            (#2%pretty-print (#2%list 'parent ($record->vector r)))
                            r)])
                   (#2%pretty-print (#2%list 'child ($record->vector r)))
                   r)))
             (#2%pretty-print
               ($record->vector
                 (let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)])
                                     (#2%pretty-print (#2%list 'parent ($record->vector r)))
                                     r)])
                            (#2%pretty-print (#2%list 'child ($record->vector r)))
                            r)])
                   (#2%pretty-print (#2%list 'grand-child ($record->vector r)))
                   r))))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define prtd (make-record-type "parent" '(x y)))
           (define crtd (make-record-type prtd "child" '(z)))
           (define gcrtd (make-record-type crtd "grand-child" '(w)))
           (define prcd
             (make-record-constructor-descriptor prtd #f
               (rec pprot
                 (lambda (new)
                   (lambda (x n m)
                     (let ([r (new x (+ n m))])
                       (pretty-print `(parent ,($record->vector r)))
                       r))))))
           (define crcd
             (make-record-constructor-descriptor crtd prcd
               (rec cprot
                 (lambda (p)
                   (lambda (z x n m)
                     (let ([r ((p x n m) z)])
                       (pretty-print `(child ,($record->vector r)))
                       r))))))
           (define gcrcd
             (make-record-constructor-descriptor gcrtd crcd
               (rec gcprot
                 (lambda (p)
                   (lambda (w x q z)
                     (let ([r ((p z x q 7) (* w 3))])
                       (pretty-print `(grand-child ,($record->vector r)))
                       r))))))
           (define pcons (r6rs:record-constructor prcd))
           (define ccons (r6rs:record-constructor crcd))
           (define gccons (r6rs:record-constructor gcrcd))
           (pretty-print ($record->vector (pcons 1 2 3)))
           (pretty-print ($record->vector (ccons 1 2 3 4)))
           (pretty-print ($record->vector (gccons 1 2 3 4))))))
    '(lambda ()
       (let ([prtd (#3%make-record-type "parent" '(x y))])
         (let ([crtd (#3%make-record-type prtd "child" '(z))])
           (let ([gcrtd (#3%make-record-type crtd "grand-child" '(w))])
             (#3%pretty-print
               ($record->vector
                 (let ([r (#3%$record prtd 1 5)])
                   (#3%pretty-print (#3%list 'parent ($record->vector r)))
                   r)))
             (#3%pretty-print
               ($record->vector
                 (let ([r (let ([r (#3%$record crtd 2 7 1)])
                            (#3%pretty-print (#3%list 'parent ($record->vector r)))
                            r)])
                   (#3%pretty-print (#3%list 'child ($record->vector r)))
                   r)))
             (#3%pretty-print
               ($record->vector
                 (let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)])
                                     (#3%pretty-print (#3%list 'parent ($record->vector r)))
                                     r)])
                            (#3%pretty-print (#3%list 'child ($record->vector r)))
                            r)])
                   (#3%pretty-print (#3%list 'grand-child ($record->vector r)))
                   r))))))))
  (error? ; given prcd is not for parent rtd
    (parameterize ([print-vector-length #f])
      (with-output-to-string
       ; adding a grandchild
        (lambda ()
          (define prtd (make-record-type "parent" '(x y)))
          (define crtd (make-record-type prtd "child" '(z)))
          (define gcrtd (make-record-type prtd "grand-child" '(w)))
          (define prcd
            (make-record-constructor-descriptor prtd #f
              (rec pprot
                (lambda (new)
                  (lambda (x n m)
                    (let ([r (new x (+ n m))])
                      (pretty-print `(parent ,($record->vector r)))
                      r))))))
          (define crcd
            (make-record-constructor-descriptor crtd prcd
              (rec cprot
                (lambda (p)
                  (lambda (z x n m)
                    (let ([r ((p x n m) z)])
                      (pretty-print `(child ,($record->vector r)))
                      r))))))
          (define gcrcd
            (make-record-constructor-descriptor gcrtd crcd
              (rec gcprot
                (lambda (p)
                  (lambda (w x q z)
                    (let ([r ((p z x q 7) (* w 3))])
                      (pretty-print `(grand-child ,($record->vector r)))
                      r))))))
          (define pcons (r6rs:record-constructor prcd))
          (define ccons (r6rs:record-constructor crcd))
          (define gccons (r6rs:record-constructor gcrcd))
          (pretty-print ($record->vector (pcons 1 2 3)))
          (pretty-print ($record->vector (ccons 1 2 3 4)))
          (pretty-print ($record->vector (gccons 1 2 3 4)))))))
  (eqv?
    (make-record-type-descriptor 'foo #f '#{rats c7ajhty66y4x1og-a} #f #f '#())
    (make-record-type-descriptor 'bar #f '#{rats c7ajhty66y4x1og-a} #f #f '#()))
  (eqv?
    (let ()
      (define rtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
      (record-type-sealed? rtd))
    #f)
  (eqv?
    (let ()
      (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
      (record-type-sealed? rtd))
    #t)
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
           (record-type-sealed? rtd))))
    '(begin
       (#2%make-record-type-descriptor 'bar #f #f #t #f '#0())
       #t))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
           (record-type-sealed? rtd))))
    '#t)
  (eqv?
    (let ()
      (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
      (record? ((record-constructor rtd))))
    #t)
  (eqv?
    (let ()
      (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
      (r6rs:record? ((record-constructor rtd))))
    #t)
  (eqv?
    (let ()
      (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
      (record? ((record-constructor rtd)) rtd))
    #t)
  (eqv?
    (let ()
      (define prtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
      (define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
      (record? ((record-constructor crtd)) prtd))
    #t)
  (error? ; parent sealed
    (let ()
      (define prtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
      (define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
      (record? ((record-constructor crtd)) prtd)))
  (eqv?
    (let ()
      (define prtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
      (define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
      (define xrtd (make-record-type-descriptor 'poo #f #f #f #f '#()))
      (record? ((record-constructor xrtd)) prtd))
    #f)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (define rtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
           (record? x rtd))))
    '(lambda (x)
       (#3%record? x (#2%make-record-type-descriptor 'bar #f #f #f #f '#()))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
           (record? x rtd))))
    '(lambda (x)
       (#3%$sealed-record? x (#2%make-record-type-descriptor 'bar #f #f #t #f '#0()))))
)

(mat r6rs-records-procedural2
  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
        (write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17)))))
    "abcde17")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
           (write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17))))))
    '(lambda ()
       (#2%write 'a)
       (#2%write 'b)
       (#2%write 'c)
       (#2%write (begin (#2%write 'd) (#2%write 'e) 17))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
           (write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17))))))
    '(lambda ()
       (#3%write 'a)
       (#3%write 'b)
       (#3%write 'c)
       (#3%write (begin (#3%write 'd) (#3%write 'e) 17))))

  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
                ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17)))))
    "abcbc17")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
                   ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
    '(lambda ()
       (#2%write 'a)
       (#2%write
         (begin
           (#2%write 'b)
           (#2%write 'c)
           (#2%write 'b)
           (#2%write 'c)
           17))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
                   ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
    '(lambda ()
       (#3%write 'a)
       (#3%write
         (begin
           (#3%write 'b)
           (#3%write 'c)
           (#3%write 'b)
           (#3%write 'c)
           17))))

  ((lambda (x y) (and (member x y) #t))
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
        (define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
        (write
          (let ([r qr])
            ((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
            ((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r)))))
    '("bcbc17" "bcbc23"))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
           (define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
           (write
             (let ([r qr])
               ((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
               ((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r))))))
    `(lambda ()
       (#2%write
         (begin
           (#2%write 'b)
           (#2%write 'c)
           (#3%$object-set! 'scheme-object ',record? ,fixnum? 23)
           (#2%write 'b)
           (#2%write 'c)
           17))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
           (define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
           (write
             (let ([r qr])
               ((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
               ((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r))))))
    `(lambda ()
       (#3%write
         (begin
           (#3%write 'b)
           (#3%write 'c)
           (#3%$object-set! 'scheme-object ',record? ,fixnum? 23)
           (#3%write 'b)
           (#3%write 'c)
           17))))

  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
                ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17)))))
    "abcbc#t")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
                   ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
    '(lambda ()
       (#2%write 'a)
       (#2%write
         (begin
           (#2%write 'b)
           (#2%write 'c)
           (#2%write 'b)
           (#2%write 'c)
           #t))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
                   ((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
    '(lambda ()
       (#3%write 'a)
       (#3%write
         (begin
           (#3%write 'b)
           (#3%write 'c)
           (#3%write 'b)
           (#3%write 'c)
           #t))))

  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
        (define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
        (define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
        (write (a x))))
    "abcdefg17")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
           (define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
           (define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
           (write (a x)))))
    '(lambda ()
       (#2%write 'a)
       (#2%write 'b)
       (#2%write 'c)
       (#2%write 'd)
       (#2%write 'e)
       (#2%write 'f)
       (#2%write 'g)
       (#2%write 17)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
           (define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
           (define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
           (write (a x)))))
    '(lambda ()
       (#3%write 'a)
       (#3%write 'b)
       (#3%write 'c)
       (#3%write 'd)
       (#3%write 'e)
       (#3%write 'f)
       (#3%write 'g)
       (#3%write 17)))

  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
        (define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
        (write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17)))))
    "abcdef17")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
           (define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
           (write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17))))))
    '(lambda ()
       (#2%write 'a)
       (#2%write 'b)
       (#2%write 'c)
       (#2%write 'd)
       (#2%write (begin (#2%write 'e) (#2%write 'f) 17))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
           (define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
           (write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17))))))
    '(lambda ()
       (#3%write 'a)
       (#3%write 'b)
       (#3%write 'c)
       (#3%write 'd)
       (#3%write (begin (#3%write 'e) (#3%write 'f) 17))))

  (equal?
    (with-output-to-string
      (lambda ()
        (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
        (define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
        (define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
        (define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
        (define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
        (write (list rcd1 rcd2))))
    "abab(#<record constructor descriptor> #<record constructor descriptor>)")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
           (define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
           (define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
           (write (list rcd1 rcd2)))))
    `(lambda ()
       (#2%write 'a)
       (#2%write 'b)
       (#2%write 'a)
       (#2%write 'b)
       (#2%write
         (#2%list
           ',record-constructor-descriptor?
           ',record-constructor-descriptor?))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
           (define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
           (define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
           (define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
           (define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
           (write (list rcd1 rcd2)))))
    `(lambda ()
       (#3%write 'a)
       (#3%write 'b)
       (#3%write 'a)
       (#3%write 'b)
       (#3%write
         (#3%list
           ',record-constructor-descriptor?
           ',record-constructor-descriptor?))))

  ; test cross-library optimization of record definitions
  (begin
    (with-output-to-file "testfile-rrp1.ss"
      (lambda ()
        (pretty-print 
          '(library (testfile-rrp1)
             (export 
               make-bar bar? bar-x
               make-foo foo? foo-x foo-y foo-x-set!
               bar-inst foo-inst)
             (import (chezscheme))
             (define-record-type bar (fields x))
             (define-record-type foo (parent bar) (fields (mutable x) y)
               (protocol (lambda (pargs->new) (lambda (y z) ((pargs->new z) 17 y)))))
             (define bar-inst (make-bar 7))
             (define foo-inst (make-foo 13 11)))))
      'replace)
    #t)
  ; first, the control, with cp0 disabled
  (begin
    (load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([enable-cp0 #f]) (eval x))))
    #t)
  (equal?
    (let ()
      (define ugh
        (lambda (x)
          (import (testfile-rrp1))
          (let ([b (make-bar 23)] [f (make-foo 31 41)])
            (foo-x-set! f 37) 
            (list
              (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
              (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
              (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
              (foo-x f) (foo-x foo-inst)
              (foo-y f) (foo-y foo-inst)))))
      (ugh 19))
    '(#f #f #t #f #t #f #t #t #t #t 23 41 11 7 37 17 31 13))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    '(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([b ((#3%$top-level-value 'make-bar) 23)]
               [f ((#3%$top-level-value 'make-foo) 31 41)])
           ((#3%$top-level-value 'foo-x-set!) f 37)
           (#2%list
             ((#3%$top-level-value 'foo?) x)
             ((#3%$top-level-value 'foo?) b)
             ((#3%$top-level-value 'foo?) f)
             ((#3%$top-level-value 'foo?) (#3%$top-level-value 'bar-inst))
             ((#3%$top-level-value 'foo?) (#3%$top-level-value 'foo-inst))
             ((#3%$top-level-value 'bar?) x)
             ((#3%$top-level-value 'bar?) b)
             ((#3%$top-level-value 'bar?) f)
             ((#3%$top-level-value 'bar?) (#3%$top-level-value 'bar-inst))
             ((#3%$top-level-value 'bar?) (#3%$top-level-value 'foo-inst))
             ((#3%$top-level-value 'bar-x) b)
             ((#3%$top-level-value 'bar-x) f)
             ((#3%$top-level-value 'bar-x) (#3%$top-level-value 'foo-inst))
             ((#3%$top-level-value 'bar-x) (#3%$top-level-value 'bar-inst))
             ((#3%$top-level-value 'foo-x) f)
             ((#3%$top-level-value 'foo-x) (#3%$top-level-value 'foo-inst))
             ((#3%$top-level-value 'foo-y) f)
             ((#3%$top-level-value 'foo-y) (#3%$top-level-value 'foo-inst)))))))
  ; now with cp0 enabled and optimize-level 2...also need compiler or cross-library optimization won't occur
  (begin
    (load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) (eval x))))
    #t)
  (equal?
    (let ()
      (define ugh
        (lambda (x)
          (import (testfile-rrp1))
          (let ([b (make-bar 23)] [f (make-foo 31 41)])
            (foo-x-set! f 37) 
            (list
              (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
              (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
              (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
              (foo-x f) (foo-x foo-inst)
              (foo-y f) (foo-y foo-inst)))))
      (ugh 19))
    '(#f #f #t #f #t #f #t #t #t #t 23 41 11 7 37 17 31 13))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#2%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (let ([g4 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g4 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g4 ,fixnum?))
             (let ([g4 (#3%$top-level-value 'bar-inst)])
               (if (#3%record? g4 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g4 ,fixnum?))
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (let ([g3 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g3 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'foo-x g3 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g3 ,fixnum?))
             31
             (let ([g2 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g2 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'foo-y g2 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g2 ,fixnum?)))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#3%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (let ([g4 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g4 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g4 ,fixnum?))
             (let ([g4 (#3%$top-level-value 'bar-inst)])
               (if (#3%record? g4 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g4 ,fixnum?))
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (let ([g3 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g3 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'foo-x g3 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g3 ,fixnum?))
             31
             (let ([g2 (#3%$top-level-value 'foo-inst)])
               (if (#3%record? g2 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'foo-y g2 ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g2 ,fixnum?)))))))
  ; now with cp0 enabled and optimize-level 3...also need compiler or cross-library optimization won't occur
  (begin
    (load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) (eval x))))
    #t)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#2%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             31
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#3%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             31
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
  ; now compiling to / loading from a file with cp0 enabled and optimize-level 3
  (begin
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (compile-library "testfile-rrp1.ss"))
    (load-library "testfile-rrp1.so")
    #t)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#2%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             31
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (x)
           (import (testfile-rrp1))
           (let ([b (make-bar 23)] [f (make-foo 31 41)])
             (foo-x-set! f 37) 
             (list
               (foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
               (bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
               (bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
               (foo-x f) (foo-x foo-inst)
               (foo-y f) (foo-y foo-inst))))))
    `(begin
       (#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
       (lambda (x)
         (let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
           (#3%$object-set! 'scheme-object f ,fixnum? 37)
           (#3%list (#3%record? x ',record-type-descriptor?) #f
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
             (#3%record? x ',record-type-descriptor?) #t
             #t
             (#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
             (#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
             41
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
             (#3%$object-ref 'scheme-object f ,fixnum?)
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
             31
             (#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
  ;; regression tests for cp0 handling of record-mutator when handed a
  ;; (record-rtd rtd expr) directly.
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define build-box
             (lambda (name k)
               (let ([gs (gensym (symbol->string name))])
                 (define-syntax mrtd
                   (identifier-syntax
                     (make-record-type-descriptor
                       name #f gs #f #f '#((mutable x)))))
                 (k (record-constructor 
                      (make-record-constructor-descriptor mrtd #f #f))
                   (record-predicate mrtd)
                   (record-accessor mrtd 0)
                   (record-mutator mrtd 0)))))
           (build-box 'record-box
             (lambda (box box? unbox set-box!)
               (let ([b (box 4)])
                 (set-box! b (* 3 (unbox b)))
                 (list (box? b) (unbox b))))))))
    `(let ([gs (#2%gensym "record-box")])
       (let ([g5 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
             [g6 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
             [g4 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))])
         (let ([b ((#2%record-constructor
                     (#2%make-record-constructor-descriptor
                       (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))
                       #f #f))
                   4)])
           (let ([g7 (#2%* 3
                       (begin
                         (if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
                         (#3%$object-ref 'scheme-object b ,fixnum?)))])
             (if (#3%record? b g4) (#2%void) (#3%$record-oops 'set-box! b g4))
             (#3%$object-set! 'scheme-object b ,fixnum? g7))
           (#2%list
             (#3%record? b g5)
             (begin
               (if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
               (#3%$object-ref 'scheme-object b ,fixnum?)))))))
    (equal?
      (let ()
        (define build-box
          (lambda (name k)
            (let ([gs (gensym (symbol->string name))])
              (define-syntax mrtd
                (identifier-syntax
                  (make-record-type-descriptor
                    name #f gs #f #f '#((mutable x)))))
              (k (record-constructor 
                   (make-record-constructor-descriptor mrtd #f #f))
                (record-predicate mrtd)
                (record-accessor mrtd 0)
                (record-mutator mrtd 0)))))
        (build-box 'record-box
          (lambda (box box? unbox set-box!)
            (let ([b (box 4)])
              (set-box! b (* 3 (unbox b)))
              (list (box? b) (unbox b))))))
      '(#t 12))
    (equivalent-expansion?
      (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
        (expand/optimize
          '(let ()
             (define useless
               (lambda (name)
                 (record-mutator (make-record-type-descriptor
                                   name #f #f #f #f '#((mutable x))) 0)))
             (procedure? (useless 'useless-box-setter)))))
      `(#2%procedure?
         (let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))])
           (lambda (g1 g2)
             (if (#3%record? g1 g0)
                 (#2%void)
                 (#3%$record-oops 'moi g1 g0))
             (#3%$object-set! 'scheme-object g1 ,fixnum? g2)))))
    (let ()
      (define useless
        (lambda (name)
          (record-mutator (make-record-type-descriptor
                            name #f #f #f #f '#((mutable x))) 0)))
      (procedure? (useless 'useless-box-setter)))
)

(mat r6rs-records-syntactic
 ; adapted from r6rs
  (begin
    (define-record-type point (fields x y))
    #t)
  (error? ; invalid syntax
    point)
  (error? ; wrong number of arguments
    (make-point))
  (error? ; wrong number of arguments
    (make-point 3))
  (error? ; wrong number of arguments
    (make-point 3 4 5))
  (begin
    (define p (make-point 3 4))
    #t)
  (error? ; wrong number of arguments
    (point?))
  (error? ; wrong number of arguments
    (point? p p))
  (point? p)
  (not (point? '(3 . 4)))
  (not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
  (error? ; unbound
    (point-x-set! p 17))
  (error? ; unbound
    (point-y-set! p 17))
  (eqv? (point-x p) 3)
  (eqv? (point-y p) 4)
  (error? ; wrong number of arguments
    (point-x))
  (error? ; wrong number of arguments
    (point-y p p))
  (not (eq? p (make-point 3 4)))
  (not (record-field-mutable? (record-type-descriptor point) 0))
  (not (record-field-mutable? (record-type-descriptor point) 1))
  (error? (record-mutator (record-type-descriptor point) 0))
  (error? (record-mutator (record-type-descriptor point) 1))

  (let ()
    (define-record-type point (fields x y))
    (define p (make-point 3 4))
    (and
      (point? p)
      (not (point? '(3 . 4)))
      (not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
      (eqv? (point-x p) 3)
      (eqv? (point-y p) 4)
      (not (eq? p (make-point 3 4)))))

  (begin (set! make-point values) #t)
  (begin
    (define-record-type (point make-point point?)
      (fields 
        (immutable x point-x)
        (immutable y point-y)))
    #t)
  (error? ; invalid syntax
    point)
  (error? ; wrong number of arguments
    (make-point))
  (error? ; wrong number of arguments
    (make-point 3))
  (error? ; wrong number of arguments
    (make-point 3 4 5))
  (begin
    (define p (make-point 3 4))
    #t)
  (error? ; wrong number of arguments
    (point?))
  (error? ; wrong number of arguments
    (point? p p))
  (point? p)
  (not (point? '(3 . 4)))
  (not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
  (error? ; unbound
    (point-x-set! p 17))
  (error? ; unbound
    (point-y-set! p 17))
  (eqv? (point-x p) 3)
  (eqv? (point-y p) 4)
  (error? ; wrong number of arguments
    (point-x))
  (error? ; wrong number of arguments
    (point-y p p))
  (not (eq? p (make-point 3 4)))

  (begin
    (define-record-type widget (fields x))
    #t)
  (begin
    (define-record-type frob
      (fields (mutable widget))
      (protocol
        (lambda (p)
          (lambda (n) (p (make-widget n))))))
    #t)
  (begin
    (define f (make-frob 17))
    #t)
  (frob? f)
  (widget? (frob-widget f))
  (error? ; wrong number of arguments
    (frob-widget-set!))
  (error? ; wrong number of arguments
    (frob-widget-set! f))
  (error? ; wrong number of arguments
    (frob-widget-set! f f f))
  (eqv? (frob-widget-set! f (list (frob-widget f))) (void))
  (pair? (frob-widget f))
  (not (widget? (frob-widget f)))

  (begin (set! make-frob values) #t)
  (begin
    (define-record-type (frob make-frob frob?)
      (fields (mutable widget
                       frob-widget
                       frob-widget-set!))
      (protocol
        (lambda (p)
          (lambda (n) (p (make-widget n))))))
    #t)
  (begin
    (define f (make-frob 17))
    #t)
  (frob? f)
  (widget? (frob-widget f))
  (error? ; wrong number of arguments
    (frob-widget-set!))
  (error? ; wrong number of arguments
    (frob-widget-set! f))
  (error? ; wrong number of arguments
    (frob-widget-set! f f f))
  (eqv? (frob-widget-set! f (list (frob-widget f))) (void))
  (pair? (frob-widget f))
  (not (widget? (frob-widget f)))

  (begin (set! make-frob values) #t)
  (begin
    (define-record-type frob
      (fields (mutable widget getwid setwid!))
      (protocol
        (lambda (p)
          (lambda (n) (p (make-widget n))))))
    #t)
  (begin
    (define f (make-frob 17))
    #t)
  (frob? f)
  (widget? (getwid f))
  (error? ; wrong number of arguments
    (setwid!))
  (error? ; wrong number of arguments
    (setwid! f))
  (error? ; wrong number of arguments
    (setwid! f f f))
  (eqv? (setwid! f (list (getwid f))) (void))
  (pair? (getwid f))
  (not (widget? (getwid f)))

  (begin
    (define-record-type (point make-point point?)
      (fields (immutable x point-x)
              (mutable y point-y set-point-y!))
      (nongenerative
        point-4893d957-e00b-11d9-817f-00111175eb9e))
    (define-record-type (cpoint make-cpoint cpoint?)
      (parent point)
      (protocol
       (lambda (n)
         (lambda (x y c) 
           ((n x y) (color->rgb c)))))
      (fields
        (mutable rgb cpoint-rgb cpoint-rgb-set!)))
    (define (color->rgb c)
      (cons 'rgb c))
    (define p1 (make-point 1 2))
    (define p2 (make-cpoint 3 4 'red))
    #t)
  (point? p1)
  (point? p2)
  (not (point? (vector)))
  (not (point? (cons 'a 'b)))
  (not (cpoint? p1))
  (cpoint? p2)
  (eqv? (point-x p1) 1)
  (eqv? (point-y p1) 2)
  (eqv? (point-x p2) 3)
  (eqv? (point-y p2) 4)
  (equal? (cpoint-rgb p2) '(rgb . red))
  (eqv? (set-point-y! p1 17) (void))
  (eqv? (point-y p1) 17)
  (record-type-descriptor? (record-rtd p1))

  (begin
    (define-record-type (ex1 make-ex1 ex1?)
      (protocol (lambda (p) (lambda a (p a))))
      (fields (immutable f ex1-f)))
    (define ex1-i1 (make-ex1 1 2 3))
    #t)
  (equal? (ex1-f ex1-i1) '(1 2 3))

  (begin
    (define-record-type (ex2 make-ex2 ex2?)
      (protocol
        (lambda (p) (lambda (a . b) (p a b))))
      (fields (immutable a ex2-a)
              (immutable b ex2-b)))
    (define ex2-i1 (make-ex2 1 2 3))
    #t)

  (eqv? (ex2-a ex2-i1) 1)
  (equal? (ex2-b ex2-i1) '(2 3))

  (not (record-type-opaque? (record-type-descriptor ex2)))
  (not (record-type-sealed? (record-type-descriptor ex2)))
  (record? ex2-i1)
  (r6rs:record? ex2-i1)

  (begin
    (define *ex3-instance* #f)
    (define-record-type ex3
      (parent cpoint)
      (protocol
       (lambda (n)
         (lambda (x y t)
           (let ((r ((n x y 'red) t)))
             (set! *ex3-instance* r)
             r))))
      (fields 
       (mutable thickness))
      (sealed #t) (opaque #t))
    (define ex3-i1 (make-ex3 1 2 17))
    #t)
  (ex3? ex3-i1)
  (equal? (cpoint-rgb ex3-i1) '(rgb . red))
  (eqv? (ex3-thickness ex3-i1) 17)
  (begin
    (ex3-thickness-set! ex3-i1 18)
    #t)
  (eqv? (ex3-thickness ex3-i1) 18)
  (eqv? *ex3-instance* ex3-i1)

  (record-type-opaque? (record-type-descriptor ex3))
  (record-type-sealed? (record-type-descriptor ex3))
  (not (r6rs:record? ex3-i1))
  (not (record? ex3-i1))
  (error? ; not a record
    (record-rtd ex3-i1))
  (error? ; not a record
    (record-rtd ex3-i1))
  (error? ; parent record type is sealed
    (define-record-type ex3xxx (parent ex3)))
  (record-type-descriptor? (record-type-descriptor ex3))
  (record-constructor-descriptor? (record-constructor-descriptor ex3))
  (equal?
    (parameterize ([print-gensym 'pretty])
      (with-output-to-string
        (lambda ()
          (define-record-type f (fields x))
          (define-record-type g (fields y) (parent f) (opaque #t))
          (define-record-type h (fields z) (parent g) (opaque #t))
          (let ([fx (make-f 'a)] [gx (make-g 'a 'b)] [hx (make-h 'a 'b 'c)])
            (write fx)
            (write gx)
            (write hx)
            (record-writer (record-type-descriptor f)
              (lambda (x p wr)
                (display "#<an f>" p)))
            (record-writer (record-type-descriptor g)
              (lambda (x p wr)
                (display "#<a g>" p)))
            (record-writer (record-type-descriptor h)
              (lambda (x p wr)
                (display "#<an h x=" p)
                (wr (f-x x) p)
                (display " y=" p)
                (wr (g-y x) p)
                (display " z=" p)
                (wr (h-z x) p)
                (display ">" p)))
            (write fx)
            (write gx)
            (write hx)))))
    "#[#:f a]#<g>#<h>#<an f>#<a g>#<an h x=a y=b z=c>")
  (equal?
    (let ()
      (define-record-type f (fields x))
      (define-record-type g (fields y) (parent f) (opaque #t))
      (define-record-type h (fields z) (parent g) (opaque #t))
      (list
        ($record->vector
          (with-input-from-string
            (with-output-to-string
              (lambda () (write (make-f "hello"))))
            read))
        ($record->vector
          (with-input-from-string
            (format "#[~s k]"
              (record-type-uid (record-type-descriptor f)))
            read))
        ($record->vector
          (with-input-from-string
            (format "#[~s k 9]"
              (record-type-uid (record-type-descriptor g)))
            read))
        ($record->vector
          (with-input-from-string
            (format "#[~s opaque? no problem]"
              (record-type-uid (record-type-descriptor h)))
            read))))
    '(#(f "hello")
      #(f k)
      #(g k 9)
      #(h opaque? no problem)))

  (begin
    (define-record-type (unit-vector
                         make-unit-vector
                         unit-vector?)
      (protocol
       (lambda (p)
         (lambda (x y z)
           (let ((length 
                   (sqrt (+ (* x x)
                            (* y y)
                            (* z z)))))
             (p (/ x length)
                (/ y length)
                (/ z length))))))
      (fields (immutable x unit-vector-x)
              (immutable y unit-vector-y)
              (immutable z unit-vector-z)))
    (define uv (make-unit-vector 3 4 0))
    #t)
  (unit-vector? uv)
  (eqv? (unit-vector-x uv) 3/5)
  (eqv? (unit-vector-y uv) 4/5)
  (eqv? (unit-vector-z uv) 0)

 ; to avoid gensyms in error messages, hence problems diffing mat output
  (begin (print-record #f) #t)

 ; test generativity
  (error? ; not a point
    (let f ([x #f])
      (define-record-type point (fields x y))
      (if x 
          (point-x x)
          (f (make-point 3 4)))))

  (not (let f ([x #f])
         (define-record-type point (fields x y))
         (if x 
             (point? x)
             (f (make-point 3 4)))))

  (begin
    (define ($f p)
      (define-record-type point (fields x y))
      (if (eq? p 'make) (make-point 3 4) (point? p)))
    (not ($f ($f 'make))))

  (eqv?
    (let f ([x #f])
      (define-record-type point (fields x y) (nongenerative))
      (if x 
          (point-x x)
          (f (make-point 3 4))))
    3)

  (let f ([x #f])
    (define-record-type point (fields x y) (nongenerative))
    (if x 
        (point? x)
        (f (make-point 3 4))))

  (begin
    (define ($f p)
      (define-record-type point (fields x y) (nongenerative))
      (if (eq? p 'make) (make-point 3 4) (point? p)))
    ($f ($f 'make)))

  (eqv?
    (let f ([x #f])
      (define-record-type point (fields x y) (nongenerative spam))
      (if x 
          (point-x x)
          (f (make-point 3 4))))
    3)

  (error? ; not a point
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red)))))

  (error? ; not a cpoint
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red)))))

  (eqv?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red))))
    3)

  (error? ; not a cpoint
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red)))))

  (error? ; incompatible record type
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint (nongenerative)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red)))))

  (error? ; incompatible record type
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint (nongenerative)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red)))))

  (eqv?
    (let ()
      (define-record-type point (fields x y))
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type cpoint (nongenerative)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (point-x x)
            (f (make-cpoint 3 4 'red)))))
    3)

  (equal?
    (let ()
      (define-record-type point (fields x y))
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type cpoint (nongenerative)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (cpoint-rgb x)
            (f (make-cpoint 3 4 'red)))))
    '(rgb . red))

  (eqv?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative))
      (define-record-type cpoint (nongenerative)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red))))
    3)

  (equal?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative))
      (define-record-type cpoint (nongenerative)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red))))
    '(rgb . red))

  (eqv?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative point0001))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red))))
    3)

  (error? ; not a cpoint
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative point0002))
      (define-record-type cpoint
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red)))))

  (error? ; incompatible record type
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint (nongenerative cpoint0003)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red)))))

  (error? ; incompatible record type
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y))
      (define-record-type cpoint (nongenerative cpoint0004)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red)))))

  (eqv?
    (let ()
      (define-record-type point (fields x y))
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type cpoint (nongenerative cpoint0005)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (point-x x)
            (f (make-cpoint 3 4 'red)))))
    3)

  (equal?
    (let ()
      (define-record-type point (fields x y))
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type cpoint (nongenerative cpoint0006)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (cpoint-rgb x)
            (f (make-cpoint 3 4 'red)))))
    '(rgb . red))

  (eqv?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative point0007))
      (define-record-type cpoint (nongenerative cpoint0008)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (point-x x)
          (f (make-cpoint 3 4 'red))))
    3)

  (equal?
    (let f ([x #f])
      (define (color->rgb c) (cons 'rgb c))
      (define-record-type point (fields x y) (nongenerative point0009))
      (define-record-type cpoint (nongenerative cpoint0010)
        (parent point)
        (fields (mutable rgb))
        (protocol
          (lambda (n)
            (lambda (x y c) 
              ((n x y) (color->rgb c))))))
      (if x 
          (cpoint-rgb x)
          (f (make-cpoint 3 4 'red))))
    '(rgb . red))

 ; make sure we can use arbitrary symbols as uids w/o destroying bindings
  (equal?
    ($record->vector
      (let ()
        (define-record-type foo (fields x) (nongenerative cons))
        (make-foo (cons 17 3))))
    '#(foo (17 . 3)))
  (equal? (cons 17 3) '(17 . 3))

 ; make sure we can use modifiers and types as field names
  (equal?
    (let ()
      (define-record-type foo (fields (mutable mutable) (immutable int) (immutable char) (mutable integer-32)))
      (let ([x (make-foo 3 4 5 6)])
        (foo-mutable-set! x 75)
        (list ($record->vector x) (foo-mutable x) (foo-int x) (foo-char x) (foo-integer-32 x))))
    '(#(foo 75 4 5 6) 75 4 5 6))

  (begin (print-record #t) (print-record))

 ; optimization tests---observe with expand/optimize
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; try define-record-type
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point (fields x y))
        (define-record-type cpoint
          (parent point)
          (fields (mutable rgb)))
        (if x 
            (list x (cpoint? x) (make-point -8 -15))
            (f (make-cpoint 3 4 (color->rgb 'red))))))
    '(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb)))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 (color->rgb 'red)))))))
    '(lambda ()
       (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
                    #f #f #f '#2((immutable x) (immutable y))
                    'define-record-type)])
         (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                      #f #f #f '#1((mutable rgb))
                      'define-record-type)])
           (if x
               (#2%list x (#3%record? x rtd) (#3%$record rtd -8 -15))
               (f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb)))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 (color->rgb 'red)))))))
      '(lambda ()
         (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
                      #f #f #f '#2((immutable x) (immutable y))
                      'define-record-type)])
           (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                        #f #f #f '#1((mutable rgb))
                        'define-record-type)])
             (if x
                 (#3%list x (#3%record? x rtd) (#3%$record rtd -8 -15))
                 (f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; same but nongenerative w/accessor call
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point (fields x y) (nongenerative))
        (define-record-type cpoint
          (nongenerative)
          (parent point)
          (fields (mutable rgb)))
        (if x 
            (list x (cpoint-rgb x) (make-point -8 -15))
            (f (make-cpoint 3 4 (color->rgb 'red))))))
    '(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y) (nongenerative))
           (define-record-type cpoint
             (nongenerative)
             (parent point)
             (fields (mutable rgb)))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 (color->rgb 'red)))))))
    `(lambda ()
       (if x
           (#2%list
             x
             (let ([g12 x])
               (if (#3%record? g12 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'cpoint-rgb g12
                     ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g12 ,fixnum?))
             ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y) (nongenerative))
           (define-record-type cpoint
             (nongenerative)
             (parent point)
             (fields (mutable rgb)))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 (color->rgb 'red)))))))
    `(lambda ()
       (if x
           (#3%list x (#3%$object-ref 'scheme-object x ,fixnum?) ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; same but with child protocol
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point (fields x y))
        (define-record-type cpoint
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (list x (cpoint? x) (make-point -8 -15))
            (f (make-cpoint 3 4 'red)))))
    '(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    '(lambda ()
       (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
                    #f #f #f '#2((immutable x) (immutable y))
                    'define-record-type)])
         (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                      #f #f #f '#1((mutable rgb))
                      'define-record-type)])
           (if x
               (#2%list x
                 (#3%record? x rtd)
                 (#3%$record rtd -8 -15))
               (f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    '(lambda ()
       (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
                    #f #f #f '#2((immutable x) (immutable y))
                    'define-record-type)])
         (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                      #f #f #f '#1((mutable rgb))
                      'define-record-type)])
           (if x
               (#3%list x
                 (#3%record? x rtd)
                 (#3%$record rtd -8 -15))
               (f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; same but nongenerative w/accessor call
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point (fields x y) (nongenerative point0009))
        (define-record-type cpoint (nongenerative cpoint0010)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (list x (cpoint-rgb x) (make-point -8 -15))
            (f (make-cpoint 3 4 'red)))))
    '(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y) (nongenerative point0009))
           (define-record-type cpoint (nongenerative cpoint0010)
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    `(lambda ()
       (if x
           (#2%list
             x
             (let ([g35 x])
               (if (#3%record? g35 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'cpoint-rgb g35
                     ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g35 ,fixnum?))
             ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point (fields x y) (nongenerative point0009))
           (define-record-type cpoint (nongenerative cpoint0010)
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    `(lambda ()
       (if x
           (#3%list
             x
             (#3%$object-ref 'scheme-object x ,fixnum?)
             ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; same as two above but with trivial parent protocol
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point
          (fields x y)
          (protocol (lambda (n) n)))
        (define-record-type cpoint
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (list x (cpoint? x) (make-point -8 -15))
            (f (make-cpoint 3 4 'red)))))
    '(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point
             (fields x y)
             (protocol (lambda (n) n)))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                    (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    '(lambda ()
       (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
                    #f #f #f '#2((immutable x) (immutable y))
                    'define-record-type)])
         (let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                      #f #f #f '#1((mutable rgb))
                      'define-record-type)])
           (if x
               (#2%list
                 x
                 (#3%record? x rtd)
                 (#3%$record rtd -8 -15))
               (f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point
             (fields x y)
             (protocol (lambda (n) n)))
           (define-record-type cpoint
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                    (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint? x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    '(lambda ()
       (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
                    #f #f #f '#2((immutable x) (immutable y))
                    'define-record-type)])
         (let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
                      #f #f #f '#1((mutable rgb))
                      'define-record-type)])
           (if x
               (#3%list x
                 (#3%record? x rtd)
                 (#3%$record rtd -8 -15))
               (f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
  (equal?
    (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
     ; same but nongenerative w/accessor call
      (let f ([x #f])
        (define (color->rgb c) (cons 'rgb c))
        (define-record-type point
          (fields x y)
          (nongenerative point0009)
          (protocol (lambda (n) n)))
        (define-record-type cpoint (nongenerative cpoint0010)
          (parent point)
          (fields (mutable rgb))
          (protocol
            (lambda (n)
              (lambda (x y c) 
                ((n x y) (color->rgb c))))))
        (if x 
            (list x (cpoint-rgb x) (make-point -8 -15))
            (f (make-cpoint 3 4 'red)))))
    '(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point
             (fields x y)
             (nongenerative point0009)
             (protocol (lambda (n) n)))
           (define-record-type cpoint (nongenerative cpoint0010)
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    `(lambda ()
       (if x
           (#2%list
             x
             (let ([g57 x])
               (if (#3%record? g57 ',record-type-descriptor?)
                   (#2%void)
                   (#3%$record-oops 'cpoint-rgb g57
                     ',record-type-descriptor?))
               (#3%$object-ref 'scheme-object g57 ,fixnum?))
             ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda ()
           (define (color->rgb c) (cons 'rgb c))
           (define-record-type point
             (fields x y)
             (nongenerative point0009)
             (protocol (lambda (n) n)))
           (define-record-type cpoint (nongenerative cpoint0010)
             (parent point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) (color->rgb c))))))
           (if x 
               (list x (cpoint-rgb x) (make-point -8 -15))
               (f (make-cpoint 3 4 'red))))))
    `(lambda ()
       (if x
           (#3%list x
             (#3%$object-ref 'scheme-object x ,fixnum?)
             ',record?)
           (f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
  (begin
   ; test global define-record-type
    (define ($color->rgb c) (cons 'rgb c))
    (define-record-type ($point $make-point $point?)
      (fields x y))
    (define-record-type ($cpoint $make-cpoint $cpoint?)
      (parent $point)
      (fields (mutable rgb)))
    (equal?
      (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
        (let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
          (list x ($cpoint-rgb x) ($make-point -8 -15))))
      '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(begin
          ; test global define-record-type
           (define ($color->rgb c) (cons 'rgb c))
           (define-record-type ($point $make-point $point?)
             (fields x y))
           (define-record-type ($cpoint $make-cpoint $cpoint?)
             (parent $point)
             (fields (mutable rgb)))
           (equal?
             (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
               (let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
                 (list x ($cpoint-rgb x) ($make-point -8 -15))))
             '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
    `(begin
       (set! $color->rgb (lambda (c) (#2%cons 'rgb c)))
       (set! $make-point
         (lambda (g73 g74)
           (#3%$record ',record-type-descriptor? g73 g74)))
       (set! $point?
         (lambda (g72)
           (#3%record? g72 ',record-type-descriptor?)))
       (set! $point-x
         (lambda (g71)
           (if (#3%record? g71 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g71
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g71 ,fixnum?)))
       (set! $point-y
         (lambda (g70)
           (if (#3%record? g70 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g70
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g70 ,fixnum?)))
       (set! $make-cpoint
         (lambda (g67 g68 g69)
           (#3%$record ',record-type-descriptor? g67 g68 g69)))
       (set! $cpoint?
         (lambda (g66)
           (#3%record? g66 ',record-type-descriptor?)))
       (set! $cpoint-rgb
         (lambda (g65)
           (if (#3%record? g65 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g65
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g65 ,fixnum?)))
       (set! $cpoint-rgb-set!
         (lambda (g63 g64)
           (if (#3%record? g63 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g63
                 ',record-type-descriptor?))
           (#3%$object-set! 'scheme-object g63 ,fixnum? g64)))
       (#2%equal?
         (#2%map
           (lambda (x) (if (#2%$record? x) ($record->vector x) x))
           (let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
             (#2%list x ($cpoint-rgb x) ($make-point -8 -15))))
         '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(begin
          ; test global define-record-type
           (define ($color->rgb c) (cons 'rgb c))
           (define-record-type ($point $make-point $point?)
             (fields x y))
           (define-record-type ($cpoint $make-cpoint $cpoint?)
             (parent $point)
             (fields (mutable rgb)))
           (equal?
             (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
               (let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
                 (list x ($cpoint-rgb x) ($make-point -8 -15))))
             '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
    `(begin
       (set! $color->rgb (lambda (c) (#3%cons 'rgb c)))
       (set! $make-point
         (lambda (g109 g110)
           (#3%$record ',record-type-descriptor? g109 g110)))
       (set! $point?
         (lambda (g108)
           (#3%record? g108 ',record-type-descriptor?)))
       (set! $point-x
         (lambda (g107) (#3%$object-ref 'scheme-object g107 ,fixnum?)))
       (set! $point-y
         (lambda (g106) (#3%$object-ref 'scheme-object g106 ,fixnum?)))
       (set! $make-cpoint
         (lambda (g103 g104 g105)
           (#3%$record ',record-type-descriptor? g103 g104 g105)))
       (set! $cpoint?
         (lambda (g102)
           (#3%record? g102 ',record-type-descriptor?)))
       (set! $cpoint-rgb
         (lambda (g101)
           (#3%$object-ref 'scheme-object g101 ,fixnum?)))
       (set! $cpoint-rgb-set!
         (lambda (g99 g100)
           (#3%$object-set! 'scheme-object g99 ,fixnum? g100)))
       (#3%equal?
         (#3%map
           (lambda (x) (if (#3%$record? x) ($record->vector x) x))
           (let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
             (#3%list x ($cpoint-rgb x) ($make-point -8 -15))))
         '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
  (begin
   ; test global define-record-type
    (define ($color->rgb c) (cons 'rgb c))
    (define-record-type ($point $make-point $point?)
      (fields x y)
      (protocol (lambda (n) n)))
    (define-record-type ($cpoint $make-cpoint $cpoint?)
      (parent $point)
      (fields (mutable rgb))
      (protocol
        (lambda (n)
          (lambda (x y c) 
            ((n x y) ($color->rgb c))))))
    (equal?
      (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
        (let ([x ($make-cpoint 3 4 'red)])
          (list x ($cpoint-rgb x) ($make-point -8 -15))))
      '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(begin
          ; test global define-record-type
           (define ($color->rgb c) (cons 'rgb c))
           (define-record-type ($point $make-point $point?)
             (fields x y)
             (protocol (lambda (n) n)))
           (define-record-type ($cpoint $make-cpoint $cpoint?)
             (parent $point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) ($color->rgb c))))))
           (equal?
             (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
               (let ([x ($make-cpoint 3 4 'red)])
                 (list x ($cpoint-rgb x) ($make-point -8 -15))))
             '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
    `(begin
       (set! $color->rgb (lambda (c) (#2%cons 'rgb c)))
       (letrec ([g7 (lambda (n) n)])
         (#3%$set-top-level-value! 'rcd1
           (#3%$make-record-constructor-descriptor
             ',record-type-descriptor? #f g7 'define-record-type)))
       (set! $make-point (#2%r6rs:record-constructor (#2%$top-level-value 'rcd1)))
       (set! $point?
         (lambda (g153)
           (#3%record? g153 ',record-type-descriptor?)))
       (set! $point-x
         (lambda (g152)
           (if (#3%record? g152 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g152
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g152 ,fixnum?)))
       (set! $point-y
         (lambda (g151)
           (if (#3%record? g151 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g151
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g151 ,fixnum?)))
       (#3%$set-top-level-value! 'rcd2
         (#2%$make-record-constructor-descriptor
           ',record-type-descriptor? (#2%$top-level-value 'rcd1)
           (lambda (n) (lambda (x y c) ((n x y) ($color->rgb c))))
           'define-record-type))
       (set! $make-cpoint (#2%r6rs:record-constructor (#2%$top-level-value 'rcd2)))
       (set! $cpoint?
         (lambda (g150)
           (#3%record? g150 ',record-type-descriptor?)))
       (set! $cpoint-rgb
         (lambda (g149)
           (if (#3%record? g149 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g149
                 ',record-type-descriptor?))
           (#3%$object-ref 'scheme-object g149 ,fixnum?)))
       (set! $cpoint-rgb-set!
         (lambda (g147 g148)
           (if (#3%record? g147 ',record-type-descriptor?)
               (#2%void)
               (#3%$record-oops 'moi g147
                 ',record-type-descriptor?))
           (#3%$object-set! 'scheme-object g147 ,fixnum? g148)))
       (#2%equal?
         (#2%map
           (lambda (x) (if (#2%$record? x) ($record->vector x) x))
           (let ([x ($make-cpoint 3 4 'red)])
             (#2%list x ($cpoint-rgb x) ($make-point -8 -15))))
         '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(begin
          ; test global define-record-type
           (define ($color->rgb c) (cons 'rgb c))
           (define-record-type ($point $make-point $point?)
             (fields x y)
             (protocol (lambda (n) n)))
           (define-record-type ($cpoint $make-cpoint $cpoint?)
             (parent $point)
             (fields (mutable rgb))
             (protocol
               (lambda (n)
                 (lambda (x y c) 
                   ((n x y) ($color->rgb c))))))
           (equal?
             (map (lambda (x) (if (#%$record? x) ($record->vector x) x))
               (let ([x ($make-cpoint 3 4 'red)])
                 (list x ($cpoint-rgb x) ($make-point -8 -15))))
             '(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
    `(begin
       (set! $color->rgb (lambda (c) (#3%cons 'rgb c)))
       (letrec ([g7 (lambda (n) n)])
         (#3%$set-top-level-value! 'rcd1
           (#3%$make-record-constructor-descriptor
             ',record-type-descriptor? #f g7 'define-record-type)))
       (set! $make-point (#3%r6rs:record-constructor (#3%$top-level-value 'rcd1)))
       (set! $point?
         (lambda (g129)
           (#3%record? g129 ',record-type-descriptor?)))
       (set! $point-x
         (lambda (g128) (#3%$object-ref 'scheme-object g128 ,fixnum?)))
       (set! $point-y
         (lambda (g127) (#3%$object-ref 'scheme-object g127 ,fixnum?)))
       (#3%$set-top-level-value! 'rcd2
         (#3%$make-record-constructor-descriptor ',record-type-descriptor?
           (#3%$top-level-value 'rcd1)
           (lambda (n) (lambda (x y c) ((n x y) ($color->rgb c))))
           'define-record-type))
       (set! $make-cpoint (#3%r6rs:record-constructor (#3%$top-level-value 'rcd2)))
       (set! $cpoint?
         (lambda (g126)
           (#3%record? g126 ',record-type-descriptor?)))
       (set! $cpoint-rgb
         (lambda (g125)
           (#3%$object-ref 'scheme-object g125 ,fixnum?)))
       (set! $cpoint-rgb-set!
         (lambda (g123 g124)
           (#3%$object-set! 'scheme-object g123 ,fixnum? g124)))
       (#3%equal?
         (#3%map
           (lambda (x) (if (#3%$record? x) ($record->vector x) x))
           (let ([x ($make-cpoint 3 4 'red)])
             (#3%list x ($cpoint-rgb x) ($make-point -8 -15))))
         '(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
  (error? ; can't handle define-record-type parent
    (let ()
      (define-record-type fratrat)
      (define-record dormy fratrat ())))
  (error? ; can't handle define-record parent
    (let ()
      (define-record fratrat ())
      (define-record-type dormy (parent fratrat))))
  (equal?
    (let ()
      (define-record fratrat ())
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
      (let ([x (make-fratrat)] [y (make-dormy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))
    '(#t #f #t #t))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ())
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
           (let ([x (make-fratrat)] [y (make-dormy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))))
    `(begin
       (#2%$make-record-type-descriptor #!base-rtd 'dormy
         ',record-type-descriptor? #f #f #f '#0()
         'define-record-type)
       (#2%list #t #f #t #t)))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ())
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
           (let ([x (make-fratrat)] [y (make-dormy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))))
    `(#3%list #t #f #t #t))
  (equal?
    (let ()
      (define-record fratrat (x))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y))))
    '(#t #f #t #t 17 23 creepy))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat (x))
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y)))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'dormy
                  ',record-type-descriptor? #f #f #f
                  '#1((immutable y)) 'define-record-type)])
       (let ([x (#3%$record ',record-type-descriptor? 17)]
             [y (#3%$record rtd 23 'creepy)])
         (#2%list #t #f #t #t
           (#3%$object-ref 'scheme-object x ,fixnum?)
           (#3%$object-ref 'scheme-object y ,fixnum?)
           'creepy))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat (x))
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y)))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'dormy
                  ',record-type-descriptor? #f #f #f
                  '#1((immutable y)) 'define-record-type)])
       (let ([x (#3%$record ',record-type-descriptor? 17)]
             [y (#3%$record rtd 23 'creepy)])
         (#3%list #t #f #t #t
           (#3%$object-ref 'scheme-object x ,fixnum?)
           (#3%$object-ref 'scheme-object y ,fixnum?)
           'creepy))))
  (equal?
    (let () ; add a protocol
      (define-record fratrat (x))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y))
        (protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
      (let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y))))
    '(#t #f #t #t 17 23 (23 creepy)))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat (x))
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y))
             (protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
           (let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'dormy
                  ',record-type-descriptor? #f #f #f
                  '#1((immutable y)) 'define-record-type)])
       (let ([x (#3%$record ',record-type-descriptor? 17)]
             [y (#3%$record rtd 23 '(23 creepy))])
         (#2%list #t #f #t #t
           (#3%$object-ref 'scheme-object x ,fixnum?)
           (#3%$object-ref 'scheme-object y ,fixnum?)
           '(23 creepy)))))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat (x))
           (define-record-type dormy
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y))
             (protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
           (let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'dormy
                  ',record-type-descriptor? #f #f #f
                  '#1((immutable y)) 'define-record-type)])
       (let ([x (#3%$record ',record-type-descriptor? 17)]
             [y (#3%$record rtd 23 '(23 creepy))])
         (#3%list #t #f #t #t
           (#3%$object-ref 'scheme-object x ,fixnum?)
           (#3%$object-ref 'scheme-object y ,fixnum?)
           '(23 creepy)))))
  (error? ; m-r-c-d can't handle non-scheme-object fields
    (let ()
      (define-record fratrat ((immutable integer-32 x)))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (equal?
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (nongenerative)
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y))))
    '(#t #f #t #t 17 23 creepy))
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ((immutable x)))
           (define-record-type dormy
             (nongenerative)
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y)))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(#2%list #t #f #t #t 17 23 'creepy))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ((immutable x)))
           (define-record-type dormy
             (nongenerative)
             (parent-rtd
               (type-descriptor fratrat)
               (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
             (fields (immutable y)))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(#3%list #t #f #t #t 17 23 'creepy))
  (equal?
    (let ()
      (define-record fratrat ((immutable x)))
      (define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-0} '((immutable y))))
      (define make-dormy (record-constructor dormy))
      (define dormy? (record-predicate dormy))
      (define dormy-y (record-accessor dormy 0))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y))))
    '(#t #f #t #t 17 23 creepy))
  (equivalent-expansion? ; optimize-level 2 expansion of above (note dormy gensym must be different)
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ((immutable x)))
           (define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-1} '((immutable y))))
           (define make-dormy (record-constructor dormy))
           (define dormy? (record-predicate dormy))
           (define dormy-y (record-accessor dormy 0))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(#2%list #t #f #t #t 17 23 'creepy))
  (equivalent-expansion? ; optimize-level 2 expansion of above (note dormy gensym must be different)
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record fratrat ((immutable x)))
           (define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-2} '((immutable y))))
           (define make-dormy (record-constructor dormy))
           (define dormy? (record-predicate dormy))
           (define dormy-y (record-accessor dormy 0))
           (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
             (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
               (fratrat-x x) (fratrat-x y) (dormy-y y))))))
    `(#3%list #t #f #t #t 17 23 'creepy))
  (error? ; can't have both parent and parent-rtd
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have both parent and parent-rtd
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (parent fratrat2)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two parent-rtd clauses
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (parent-rtd
          (type-descriptor fratrat)
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two parent clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (parent fratrat2)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two fields clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (fields z)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two nongenerative clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (nongenerative)
        (nongenerative spam-for-dinner)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two sealed? clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (sealed #t)
        (sealed #t)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two opaque? clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (opaque #t)
        (opaque #t)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; can't have two protocol clauses
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (protocol values)
        (protocol (lambda (x) x))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; protocol expression doesn't evaluate to a procedure
    (let ()
      (define-record-type fratrat2 (fields (immutable x)))
      (define-record-type dormy
        (parent fratrat2)
        (protocol 'whoops!)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; not an rcd
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd
          (type-descriptor fratrat)
          'rats)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (error? ; not an rtd
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd 'rats
          (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (fratrat-x y) (dormy-y y)))))
  (equal?
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd #f #f)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (dormy-y y))))
    '(#t #f #f #t 17 creepy))
  (equal?
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd (record-type-descriptor fratrat) #f)
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (dormy-y y))))
    '(#t #f #t #t 17 creepy))
  (error? ; "can't specify rcd w/o rtd"
    (let ()
      (define-record fratrat ((immutable x)))
      (define-record-type dormy
        (parent-rtd #f (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
        (fields (immutable y)))
      (let ([x (make-fratrat 17)] [y (make-dormy 'creepy)])
        (list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
          (fratrat-x x) (dormy-y y)))))
  (error? ; invalid syntax
    (define-record-type (fields x)))
  (error? ; invalid clause
    (define-record-type foo (x)))
  (error? ; invalid clause
    (define-record-type foo (fields . x)))
  (error? ; invalid field
    (define-record-type foo (fields (mutable flyboy flyboy))))
  (error? ; invalid field
    (define-record-type foo (fields (immutable flyboy flyboy flyboy!))))
  (error? ; invalid field
    (define-record-type foo (fields (ugly flyboy))))
  (error? ; invalid clause
    (define-record-type foo (nongenerative 'spam)))
  (error? ; cannot handle record name defined by define-record
    (let ()
      (define-record frob ())
      (record-constructor-descriptor frob)))
  (error? ; invalid protocol value
    (define-record-type frob (protocol 'oops)))
  (let ()
    (define-record-type foo (nongenerative #{rats c9zu8koxo8gppgp-a}))
    (define-record-type bar (nongenerative #{rats c9zu8koxo8gppgp-a}))
    (and
      (eqv? (type-descriptor foo) (type-descriptor bar))
      (foo? (make-bar))
      (bar? (make-foo))))

 ; test for appropriate choice of pretty names for uids
  ((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
    (let ()
      (define-record-type foo)
      (record-type-uid (record-type-descriptor foo)))
    "foo")

 ; test for appropriate choice of pretty names for uids
  ((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
    (let ()
      (define-record-type (foo xfoo yfoo))
      (record-type-uid (record-type-descriptor foo)))
    "foo")

 ; test for appropriate choice of pretty names for uids
  ((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
    (let ()
      (define-record-type foo (nongenerative))
      (record-type-uid (record-type-descriptor foo)))
    "foo")

 ; test for appropriate choice of pretty names for uids
  ((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
    (let ()
      (define-record-type (foo xfoo yfoo) (nongenerative))
      (record-type-uid (record-type-descriptor foo)))
    "foo")

  (eqv?
    (let ()
      (define-record-type bar)
      (record-type-sealed? (record-type-descriptor bar)))
    #f)
  (eqv?
    (let ()
      (define-record-type bar (sealed #t))
      (record-type-sealed? (record-type-descriptor bar)))
    #t)
  (equivalent-expansion? ; optimize-level 2 expansion of above
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type bar (sealed #t))
           (record-type-sealed? (record-type-descriptor bar)))))
    '(begin
       (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #t #f '#() 'define-record-type)
       #t))
  (equivalent-expansion? ; optimize-level 3 expansion of above
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type bar (sealed #t))
           (record-type-sealed? (record-type-descriptor bar)))))
    '#t)
  (eqv?
    (let ()
      (define-record-type bar (sealed #t))
      (record? (make-bar)))
    #t)
  (eqv?
    (let ()
      (define-record-type bar (sealed #t))
      (r6rs:record? (make-bar)))
    #t)
  (eqv?
    (let ()
      (define-record-type bar (sealed #t))
      (record? (make-bar) (record-type-descriptor bar)))
    #t)
  (eqv?
    (let ()
      (define-record-type prnt)
      (define-record-type chld (parent prnt))
      (record? (make-chld) (record-type-descriptor prnt)))
    #t)
  (error? ; parent sealed
    (let ()
      (define-record-type prnt (sealed #t))
      (define-record-type chld (parent prnt))
      (record? (make-chld) (record-type-descriptor prnt))))
  (eqv?
    (let ()
      (define-record-type prnt)
      (define-record-type chld (parent prnt))
      (define-record-type xftr)
      (record? (make-xftr) (record-type-descriptor prnt)))
    #f)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
      (expand/optimize
        '(lambda (x)
           (define-record-type bar)
           (record? x (record-type-descriptor bar)))))
    '(lambda (x)
       (#3%record? x (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #f #f '#() 'define-record-type))))

  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
      (expand/optimize
        '(lambda (x)
           (define-record-type bar (sealed #t))
           (record? x (record-type-descriptor bar)))))
    '(lambda (x)
       (#3%$sealed-record? x (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #t #f '#() 'define-record-type))))

  (equal?
    ($record->vector
      (let ()
        (define-record-type A
          (nongenerative)
          (fields))
        (define-record-type B
          (nongenerative)
          (parent A)
          (fields z)
          (protocol (lambda (make) (lambda (z) ((make) z)))))
        (define-record-type C
          (nongenerative)
          (parent B)
          (fields)
          (protocol (lambda (make) (lambda (z) ((make z))))))
        (make-C 4)))
    '#(C 4))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type A
             (nongenerative)
             (fields))
           (define-record-type B
             (nongenerative)
             (parent A)
             (fields z)
             (protocol (lambda (make) (lambda (z) ((make) z)))))
           (define-record-type C
             (nongenerative)
             (parent B)
             (fields)
             (protocol (lambda (make) (lambda (z) ((make z))))))
           (make-C 4))))
    `',record?)

  (equal?
    ($record->vector
      (let ()
        (define-record-type A
          (nongenerative)
          (fields))
        (define-record-type B
          (nongenerative)
          (parent A)
          (fields z)
          (protocol (lambda (make) (lambda () ((make) 0)))))
        (define-record-type C
          (nongenerative)
          (parent B)
          (fields)
          (protocol (lambda (make) (lambda () ((make))))))
        (make-C)))
    '#(C 0))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type A
             (nongenerative)
             (fields))
           (define-record-type B
             (nongenerative)
             (parent A)
             (fields z)
             (protocol (lambda (make) (lambda () ((make) 0)))))
           (define-record-type C
             (nongenerative)
             (parent B)
             (fields)
             (protocol (lambda (make) (lambda () ((make))))))
           (make-C))))
    `',record?)

  (equal?
    ($record->vector
      (let ()
        (define-record-type A
          (nongenerative)
          (fields))
        (define-record-type B
          (nongenerative)
          (parent A)
          (fields z)
          (protocol (lambda (make) (lambda (z) ((make) z)))))
        (define-record-type C
          (nongenerative)
          (parent B)
          (fields w)
          (protocol (lambda (make) (lambda (z) ((make z) 0)))))
        (make-C 4)))
    '#(C 4 0))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type A
             (nongenerative)
             (fields))
           (define-record-type B
             (nongenerative)
             (parent A)
             (fields z)
             (protocol (lambda (make) (lambda (z) ((make) z)))))
           (define-record-type C
             (nongenerative)
             (parent B)
             (fields w)
             (protocol (lambda (make) (lambda (z) ((make z) 0)))))
           (make-C 4))))
    `',record?)

  (equal?
    ($record->vector
      (let ()
        (define-record-type A
          (nongenerative)
          (fields))
        (define-record-type B
          (nongenerative)
          (parent A)
          (fields z)
          (protocol (lambda (make) (lambda (z) ((make) z)))))
        (define-record-type C
          (nongenerative)
          (parent B)
          (fields w q1 q2 q3)
          (protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
        (make-C 4)))
    '#(C 4 0 1 2 3))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type A
             (nongenerative)
             (fields))
           (define-record-type B
             (nongenerative)
             (parent A)
             (fields z)
             (protocol (lambda (make) (lambda (z) ((make) z)))))
           (define-record-type C
             (nongenerative)
             (parent B)
             (fields w q1 q2 q3)
             (protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
           (make-C 4))))
    `',record?)

 ; try hierarchy of five levels
  (equal?
    ($record->vector
      (let ()
        (define-record-type A
          (nongenerative)
          (fields))
        (define-record-type B
          (nongenerative)
          (parent A)
          (fields z)
          (protocol (lambda (make) (lambda (z) ((make) z)))))
        (define-record-type C
          (nongenerative)
          (parent B)
          (fields w q1 q2 q3)
          (protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
        (define-record-type D
          (nongenerative)
          (parent C)
          (fields w)
          (protocol (lambda (make) (lambda (z w/2) ((make z) (* w/2 2))))))
        (define-record-type E
          (nongenerative)
          (parent D)
          (fields w)
          (protocol (lambda (make) (lambda (z a b) ((make z (/ a 5)) (+ a b))))))
        (make-E 3 7 11)))
    '#(E 3 0 1 2 3 14/5 18))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type A
             (nongenerative)
             (fields))
           (define-record-type B
             (nongenerative)
             (parent A)
             (fields z)
             (protocol (lambda (make) (lambda (z) ((make) z)))))
           (define-record-type C
             (nongenerative)
             (parent B)
             (fields w q1 q2 q3)
             (protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
           (define-record-type D
             (nongenerative)
             (parent C)
             (fields w)
             (protocol (lambda (make) (lambda (z w/2) ((make z) (* w/2 2))))))
           (define-record-type E
             (nongenerative)
             (parent D)
             (fields w)
             (protocol (lambda (make) (lambda (z a b) ((make z (/ a 5)) (+ a b))))))
           (make-E 3 7 11))))
    `',record?)

  (begin
    (module ($drt-foo1)
      (define-record-type $drt-foo1
        (protocol (lambda (new) (lambda () (new))))))
    (define-record-type $drt-bar1
      (parent $drt-foo1)
      (protocol (lambda (make-new) (lambda () ((make-new))))))
    ($drt-bar1? (make-$drt-bar1)))
  ($drt-bar1? (make-$drt-bar1))

  (begin
    (define $drt-false #f)
    (module ($drt-foo2)
      (define-record-type $drt-foo2
        (parent-rtd $drt-false $drt-false)
        (protocol (lambda (new) (lambda () (new))))))
    (define-record-type $drt-bar2
      (parent $drt-foo2)
      (protocol (lambda (make-new) (lambda () ((make-new))))))
    ($drt-bar2? (make-$drt-bar2)))
  ($drt-bar2? (make-$drt-bar2))

  ; make sure record accessor isn't folded when applied to
  ; the wrong type of constant argument
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (b)
           (let ([x 'x])
             (define-record-type frob (nongenerative) (fields x))
             (if b (frob-x x) 72)))))
    `(lambda (b)
       (if b
           (begin
             (#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
             (#3%$object-ref 'scheme-object 'x ,fixnum?))
           72)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (b)
           (let ([x 'x])
             (define-record-type frob (nongenerative) (fields x))
             (if b (frob-x x) 72)))))
    `(lambda (b)
       (if b
           (#3%$object-ref 'scheme-object 'x ,fixnum?)
           72)))
  ; ensure we're checking to make sure field names, accessors, and
  ; mutators are identifiers
  (error? ; invalid field spec
    (define-record-type foo (fields 876)))
  (error? ; invalid field spec
    (define-record-type foo (fields (mutable (x)))))
  (error? ; invalid field spec
    (define-record-type foo (fields (immutable "spam"))))
  (error? ; invalid field spec
    (define-record-type foo (fields (immutable (x) foo-x))))
  (error? ; invalid accessor name
    (define-record-type foo (fields (immutable x (foo-x)))))
  (error? ; invalid field spec
    (define-record-type foo (fields (mutable (x) foo-x foo-x!))))
  (error? ; invalid accessor name
    (define-record-type foo (fields (mutable x (foo-x) foo-x!))))
  (error? ; invalid accessor name
    (define-record-type foo (fields (mutable x foo-x (foo-x!)))))
)

(mat define-record-type-extensions
  (error? ; nongenerative clause missing
    (parameterize ([require-nongenerative-clause #t])
      (eval '
        (let ()
          (define-record-type foo)
          make-foo))))
  (procedure?
    (parameterize ([require-nongenerative-clause #t])
      (eval '
        (let ()
          (define-record-type foo (nongenerative #f))
          make-foo))))
  (procedure?
    (parameterize ([require-nongenerative-clause #t])
      (eval '
        (let ()
          (define-record-type foo (nongenerative))
          make-foo))))
  (procedure?
    (parameterize ([require-nongenerative-clause #t])
      (eval '
        (let ()
          (define-record-type foo (nongenerative #{foo e7akngbfn4x0395fvq3uor-0}))
          make-foo))))
  ((lambda (ls) (not (apply eq? ls)))
   (let ()
     (define f
       (lambda () 
         (define-record-type foo (nongenerative #f))
         (record-type-descriptor foo)))
     (list (f) (f))))
  ((lambda (ls) (apply eq? ls))
   (let ()
     (define f
       (lambda () 
         (define-record-type foo (nongenerative))
         (record-type-descriptor foo)))
     (list (f) (f))))
  )

(mat cp0-record-ref-optimizations
  (eqv?
    (let ()
      (define-record-type foo (fields x))
      (let ([x 17])
        (let ([q (make-foo x)])
          (set! x 43)
          (foo-x q))))
    17)
  (eqv?
    (let ()
      (define-record-type foo (fields x))
      (let ([x 17])
        (let ([q (make-foo x)])
          #;(set! x 43)
          (foo-x q))))
    17)
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type foo (fields x))
           (let ([x 17])
             (let ([q (make-foo x)])
               #;(set! x 43)
               (foo-x q))))))
    17)
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record-type foo (fields x))
           (let ([x 17])
             (let ([q (make-foo x)])
               (set! x 43)
               (foo-x q))))))
    `(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x))
                  'define-record-type)])
       (let ([x 17])
         (let ([q (#3%$record rtd x)])
           (set! x 43)
           (#3%$object-ref 'scheme-object q ,fixnum?)))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (fields x y))
           (let ([q (make-foo a 3)])
             (list (foo-x q) (foo-y q))))))
    '(lambda (a)
       (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x) (immutable y))
         'define-record-type)
       (#2%list a 3)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (fields x y))
           (let ([q (make-foo a 3)])
             (list (foo-x q) (foo-y q))))))
    '(lambda (a) (#3%list a 3)))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (nongenerative) (fields x y))
           (let ([q (make-foo a 3)])
             (list (foo-x q) (foo-y q))))))
    '(lambda (a) (#2%list a 3)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (nongenerative) (fields x y))
           (let ([q (make-foo a 3)])
             (list (foo-x q) (foo-y q))))))
    '(lambda (a) (#3%list a 3)))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (fields x y))
           (let ([q (make-foo (cons a a) (lambda () a))])
             (list (foo-x q) ((foo-y q)))))))
    '(lambda (a)
       (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x) (immutable y))
         'define-record-type)
       (#2%list (#2%cons a a) a)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (fields x y))
           (let ([q (make-foo (cons a a) (lambda () a))])
             (list (foo-x q) ((foo-y q)))))))
    '(lambda (a) (#3%list (#3%cons a a) a)))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (nongenerative) (fields x y))
           (let ([q (make-foo (cons a a) (lambda () a))])
             (list (foo-x q) ((foo-y q)))))))
    '(lambda (a) (#2%list (#2%cons a a) a)))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (a)
           (define-record-type foo (nongenerative) (fields x y))
           (let ([q (make-foo (cons a a) (lambda () a))])
             (list (foo-x q) ((foo-y q)))))))
    '(lambda (a) (#3%list (#3%cons a a) a)))
  ; oscar's example
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record foo ([immutable ptr a] [immutable ptr b]))
           (define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
           (lambda (x)
             (let* ([r (make-foo 37 x)]
                    [r (inc r)]
                    [r (inc r)])
               r)))))
    `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 1 (#2%+ 1 x)))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record foo ([immutable ptr a] [immutable ptr b]))
           (define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
           (lambda (x)
             (let* ([r (make-foo 37 x)]
                    [r (inc r)]
                    [r (inc r)])
               r)))))
    `(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#3%+ 1 x)))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record-type foo (fields a b))
           (define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
           (lambda (x)
             (let* ([r (make-foo 37 x)]
                    [r (inc r)]
                    [r (inc r)])
               r)))))
    '(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)])
       (lambda (x) (#3%$record rtd 37 (#2%+ 1 (#2%+ 1 x))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record-type foo (fields a b))
           (define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
           (lambda (x)
             (let* ([r (make-foo 37 x)]
                    [r (inc r)]
                    [r (inc r)])
               r)))))
    '(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b))
                  'define-record-type)])
       (lambda (x) (#3%$record rtd 37 (#3%+ 1 (#3%+ 1 x))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record-type foo
             (nongenerative)
             (fields a b)
             (protocol
               (let ([ctr 0])
                 (lambda (new)
                   (lambda (q)
                     (let ([x (begin (set! ctr (+ xtr 1)) ctr)])
                       (new q x)))))))
           (make-foo 3))))
    `(let ([ctr 0])
       (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
         (#3%$make-record-constructor-descriptor ',record-type-descriptor?  #f g0 'define-record-type)
         (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr)))))
  (equivalent-expansion?
    (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (import scheme)
           (define-record-type foo
             (nongenerative)
             (fields a b)
             (protocol
               (let ([ctr 0])
                 (lambda (new)
                   (lambda (q)
                     (let ([x (begin (set! ctr (+ xtr 1)) ctr)])
                       (new q x)))))))
           (make-foo 3))))
    `(let ([ctr 0])
       (letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
         (#3%$make-record-constructor-descriptor ',record-type-descriptor?  #f g0 'define-record-type)
         (#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr)))))
  (error? ; invalid uid
    (let ()
      (define useless
        (lambda (name)
          (record-mutator (make-record-type-descriptor
                            name #f 5 #f #f '#((mutable x))) 0)))
      (procedure? (useless 'useless-box-setter))))
  (equal?
    (let ()
      (define-record foo ((immutable double x)))
      (foo-x (make-foo 3.0)))
    3.0)
  (begin
    (define $foo
      (lambda (y)
        (define-record foo ((immutable double x) (immutable int y)))
        (foo-x (make-foo 3.0 y))))
    #t)
  (equal? ($foo 17) 3.0)
 )

(mat cp0-rtd-inspection-optimizations
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd
             (make-record-type-descriptor 'foo #f #f #f #f
               '#((mutable x))))
           (define rtd
             (make-record-type-descriptor 'bar prtd 'pluto #t #f
               '#((mutable y) (immutable z))))
           (define rcd (make-record-constructor-descriptor rtd #f #f))
           (list 
             (record-type-descriptor? rtd)
             (record-constructor-descriptor? rcd)
             (record-type-descriptor? rcd)
             (record-constructor-descriptor? rtd)
             (record-field-mutable? prtd 0)
             (record-field-mutable? rtd 0)
             (record-field-mutable? rtd 1)
             (record-type-field-names prtd)
             (record-type-field-names rtd)
             (list (record-type-generative? prtd) (record-type-generative? rtd))
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#((mutable x)))])
       (let ([rtd (#2%make-record-type-descriptor 'bar prtd 'pluto #t #f '#((mutable y) (immutable z)))])
         (let ([rcd (#3%make-record-constructor-descriptor rtd #f #f)])
           (#2%list
             #t
             #t
             (#2%record-type-descriptor? rcd)
             (#2%record-constructor-descriptor? rtd)
             #t
             #t
             #f
             '#(x)
             '#(y z)
             (#2%list (#2%record-type-generative? prtd) (#2%record-type-generative? rtd))
             (#2%list #f #f)
             (#2%list #f #t))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#())])
       (#2%make-record-type-descriptor 'bar prtd #f #f #f '#())
       (#2%list
         (#2%list #f #f)
         (#2%list #f #f))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #t '#())])
       (#2%make-record-type-descriptor 'bar prtd #f #f #f '#())
       (#2%list
         (#2%list #t #t)
         (#2%list #f #f))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#())])
       (#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
       (#2%list
         (#2%list #f #t)
         (#2%list #f #t))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #t '#())])
       (#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
       (#2%list
         (#2%list #t #t)
         (#2%list #f #t))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (sealed? opaque?)
           (define prtd (make-record-type-descriptor 'foo #f #f sealed? opaque? '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(lambda (sealed? opaque?)
       (let ([prtd (#2%make-record-type-descriptor 'foo #f #f sealed? opaque? '#())])
         (let ([rtd (#2%make-record-type-descriptor 'bar prtd #f #f #f '#())])
           (#2%list
             (#2%list (#2%record-type-opaque? prtd) (#2%record-type-opaque? rtd))
             (#2%list (#2%record-type-sealed? prtd) #f))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (sealed? opaque?)
           (define prtd (make-record-type-descriptor 'foo #f #f sealed? opaque? '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(lambda (sealed? opaque?)
       (let ([prtd (#2%make-record-type-descriptor 'foo #f #f sealed? opaque? '#())])
         (#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
         (#2%list
           (#2%list (#2%record-type-opaque? prtd) #t)
           (#2%list (#2%record-type-sealed? prtd) #t)))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (sealed? opaque?)
           (define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f sealed? opaque? '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(lambda (sealed? opaque?)
       (let ([rtd (#2%make-record-type-descriptor 'bar (#2%make-record-type-descriptor 'foo #f #f #f #f '#()) #f sealed? opaque? '#())])
         (#2%list
           (#2%list #f (#2%record-type-opaque? rtd))
           (#2%list #f (#2%record-type-sealed? rtd))))))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(lambda (sealed? opaque?)
           (define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
           (define rtd (make-record-type-descriptor 'bar prtd #f sealed? opaque? '#()))
           (list 
             (list (record-type-opaque? prtd) (record-type-opaque? rtd))
             (list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
    '(lambda (sealed? opaque?)
       (let ([rtd (#2%make-record-type-descriptor 'bar (#2%make-record-type-descriptor 'foo #f #f #f #t '#()) #f sealed? opaque? '#())])
         (#2%list
           (#2%list #t #t)
           (#2%list #f (#2%record-type-sealed? rtd))))))
 )

(define (cp0x3 cp0 x)
  (cp0 (cp0 (cp0 x))))

(define (member? o l)
  (and (member o l) #t))
 
(mat cp0-kar-kons-optimizations
  ; for now, it's necessary to run cp0 three times to complete the reduction
  (equal?
    (with-output-to-string
      (lambda ()
        (define-record mybox (val))
        (display (mybox-val (begin (display 1) (make-mybox 2))))))
    "12")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record mybox (val))
           (display (mybox-val (begin (display 1) (make-mybox 2)))))))
    '(#2%display
      (begin
        (#2%display 1)
        2)))
  (eq? (let ()
         (define-record kons (kar kdr))
         (kons-kar (make-kons 'a 'b)))
       'a)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record kons (kar kdr))
           (kons-kar (make-kons 'a 'b)))))
    ''a)
  (eq? (let ()
         (define-record kons (kar kdr))
         (kons-kdr (make-kons 'a 'b)))
       'b)
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
           (define-record kons (kar kdr))
           (kons-kdr (make-kons 'a 'b)))))
    ''b)
  (member?
    (with-output-to-string
      (lambda ()
        (define-record kons (kar kdr))
        (display (kons-kar (make-kons (begin (display 1) (display 2) 3)
                                      (begin (display 4) (display 5) 6))))))
    '("45123" "12453"))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
          (define-record kons (kar kdr))
          (display (kons-kar (make-kons (begin (display 1) (display 2) 3)
                                        (begin (display 4) (display 5) 6)))))))
    '(#2%display
      (begin
        (#2%display 4)
        (#2%display 5)
        (#2%display 1)
        (#2%display 2)
        3)))
  (member?
    (with-output-to-string
      (lambda ()
        (define-record kons (kar kdr))
        (display (kons-kdr (make-kons (begin (display 1) (display 2) 3)
                                      (begin (display 4) (display 5) 6))))))
    '("45126" "12456"))
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
          (define-record kons (kar kdr))
          (display (kons-kdr (make-kons (begin (display 1) (display 2) 3)
                                        (begin (display 4) (display 5) 6)))))))
    '(#2%display
      (begin
        (#2%display 4)
        (#2%display 5)
        (#2%display 1)
        (#2%display 2)
        6)))
  (equal?
    (with-output-to-string
      (lambda ()
        (define-record ktail (kar (immutable kdr)))
        (define x (make-ktail 1 2))
        (display 3)
        (display (ktail-kdr (begin (display 4) x)))))
    "342")
  (equivalent-expansion?
    (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
      (expand/optimize
        '(let ()
          (define-record ktail (kar (immutable kdr)))
          (define x (make-ktail 1 2))
          (display 3)
          (display (ktail-kdr (begin (display 4) x))))))
    '(begin
       (#2%display 3)
       (#2%display
        (begin
          (#2%display 4)
          2))))
  (equal?
    (with-output-to-string
      (lambda ()
        (define-record ktail (kar (immutable kdr)))
        (define x (make-ktail 1 2))
        (display 3)
        (display (ktail-kar (begin (display 4) x)))))
    "341")
  (not (equivalent-expansion?
         (parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
           (expand/optimize
             '(let ()
               (define-record ktail (kar (immutable kdr)))
               (define x (make-ktail 1 2))
               (display 3)
               (display (ktail-kar (begin (display 4) x))))))
         '(begin
            (#2%display 3)
            (#2%display
             (begin
               (#2%display 4)
               1)))))
)