;;; 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.

#|
todo:
  - consider adding uid form, with warnings if nested ftypes do not
    also have uid forms...need to check ftd generative? flag.
    alternatively, consider implementing textual ftype equality.
    would need some sort of union-find algorithm and a couple of extra
    indirects to reduce the cost of checks.  either way, generalize
    syntaxes that now require ftype names to allow arbitrary ftypes
  - consider passing $fptr-ref-xxx, $fptr-set-xxx! more info to
    produce better error messages
  - consider support for variable-length arrays.  there may be no good
    way to do so.  don't want to make ftds generative, but can't
    avoid doing so if the lengths aren't known until run time since
    each evaluation of an ftype form could result in different sizes.
    as an alternative, perhaps give some way to define array-length
    constants, e.g., (define-ftype-constant x 10).
  - consider moving verify-ftype-pointer checks into $fptr-&ref,
    $fptr-ref, and $fptr-set! to reduce the amount of generated code.
    we'd end up doing more checks that way when pointer indirects are
    followed and new fptrs are generated, but that probably isn't a
    big deal.  would need to pass $fptr-ref a who argument for use in
    following pointers from ftype-&ref and ftype-set!
  - consider trying to fix 32-bit macos x powerpc alignment issues.
    doubles and long-longs are aligned on 8-byte boundaries if they
    are first in a struct; otherwise, they are mostly aligned on
    4-byte boundaries.  haven't entirely penetrated the rules governing
    unions, but it's clear the same union can have a different size
    depending on whether it is stand-alone or embedded in a struct
|#

#|
(define-ftype ftype-name ftype) [syntax]

ftype-name -> identifier

ftype ->
  ftype-name
  (* ftype)
  (struct (field-name ftype) ...)
  (union (field-name ftype) ...)
  (array length ftype)
  (bits (field-name signedness bits) ...)
  (function (arg-type ...) result-type)
  (function conv ... (arg-type ...) result-type)
  (packed ftype)
  (unpacked ftype)
  (endian endianness ftype)

length -> exact nonnegative integer

field-name -> identifier

signedness -> signed | unsigned

bits -> exact positive integer

endianness -> native | big | little

built-in ftype names:
    short | unsigned-short
    int | unsigned | unsigned-int
    long | unsigned-long
    long-long | unsigned-long-long
    char | wchar
    float | double
    void* | iptr | uptr
    fixnum | boolean
    integer-8 | unsigned-8
    integer-16 | unsigned-16
    integer-24 | unsigned-24
    integer-32 | unsigned-32
    integer-40 | unsigned-40
    integer-48 | unsigned-48
    integer-56 | unsigned-56
    integer-64 | unsigned-64
    single-float | double-float
    size_t | ssize_t | ptrdiff_t | wchar_t

notes:
  - underscore ( _ ) can be used as the field name for one or
    more fields of a struct or union.  such fields are included
    in the layout but are considered unnamed and cannot be accessed
    via the ftype operators described below.

  - non-underscore field names are handled symbolically, i.e.,
    they are treated as symbols rather than identifiers.  each
    symbol must be unique (as a symbol) with respect to the other
    field names within a single struct or union, but need not be
    unique with respect to field names in other structs or
    unions, including those nested inside the struct or union.

  - by default, padding is inserted where appropriate to maintain
    proper alignment of multibyte scalar values in an attempt to
    mirror the target machine's (often poorly documented) C struct
    layout conventions.  for packed ftypes (ftypes wrapped in a
    packed form with no closer enclosing unpacked form), this
    padding is not inserted.

  - the overall size of an ftype (including padding) must be a fixnum.

  - the total size n of the fields within an ftype bits form must
    be 8, 16, 24, 32, 40, 48, 56, or 64.  padding must be added manually
    if needed.  (Performance might suffer when the total is not a power
    of two or is 64 on a 32-bit machine.)  For little-endian machines,
    the first field occupies the low-order bits of the container, with
    each subsequent field just above the preceding field, while for
    big-endian machines, the first field occupies the high-order bits,
    with each subsequent field just below the preceding field.

  - ftype pointers are records encapsulating an ftype descriptor
    (ftd) along with the address of the foreign object, except that
    pointers of type void* are just addresses.  the encapsulated
    ftd is used to verify the applicability of an ftype-&ref,
    ftype-ref, or ftype-set! operation.

  - two ftypes are considered equivalent if and only if their uids are
    equivalent.  a fresh uid is created each time an ftype declaration
    is expanded.  thus, textually distinct ftypes are not considered
    equivalent even if they are identical in structure.

  - all signed or unsigned integer fields (including bit fields) can
    be set to an exact integer in the range -2^{k-1}..+2^k-1, where
    k is the size in bits of the integer

  - most run-time checks are disabled at optimize-level 3.

  - the use of packed ftypes or the use of improperly aligned
    addresses can result in unaligned references, which are inefficient
    on some machines and result in invalid-memory reference exceptions
    on others.

ftype operators:

(ftype-sizeof ftype-name) [syntax]

   returns the size in bytes of an object with type ftype-name.

(make-ftype-pointer ftype-name address) [syntax]

  creates an ftype pointer encapsulating an ftype descriptor (ftd)
  for the named ftype along with the address.

(ftype-pointer? expr) [syntax]
(ftype-pointer? ftype-name expr) [syntax]

   in the first form, return #t if the value of expr is an ftype
   pointer, otherwise #f.  in the second form, returns #t if the
   value of expr is an ftype pointer of the named ftype,
   otherwise #f.

(ftype-pointer-address fptr) [procedure]

   returns the address encapsulated within fptr.

(ftype-pointer-null? fptr) [procedure]

   returns #t if the address encapsulated within fptr is 0,
   otherwise #f.

(ftype-pointer=? fptr1 fptr2) [procedure]

   returns #t if the addresses encapsulated within fptr are
   the same, otherwise #f.

(ftype-pointer-ftype fptr) [procedure]

   returns an s-expression representation of fptr's ftype.  the
   s-expression should not be modified.

(ftype-pointer->sexpr fptr) [procedure]

   returns an s-expression representation of the foreign object
   pointed to by fptr.  the s-expression should not be modified.

(ftype-&ref ftype-name (access ...) fptr-expr) [syntax]

   returns an ftype pointer to the named field of the foreign object
   pointed to by the value of fptr-expr, which must be an ftype
   pointer of the named ftype.  each access must be a field name or
   array index expression, as appropriate for the named ftype; it is a
   syntax error if this is not the case.  the values of all array indices
   must be in bounds for the array.  any nonnegative index is considered
   in bounds for an array of size zero.  the return value is a freshly
   allocated ftype pointer, except that if (access ...) is empty, the
   return value might be eq to the value of fptr-expr.

(ftype-ref ftype-name (access ...) fptr-expr) [syntax]

   returns the value of the specified field of the foreign object pointed
   to by the value of fptr-expr, which must be an ftype pointer of the
   named ftype.  The access and fptr-expr requirements stated under
   ftype-&ref apply as well to ftype-ref.  In addition, the field must
   be a scalar field, i.e., one of the base types, an alias for one of
   the base types, or a pointer.  If the result is a pointer value,
   other than one declared as void*, the return value is a freshly
   allocated ftype pointer.

   It (access ...) is empty, the "specified field" is the object pointed
   to by the ftype pointer.  For example, if x is an ftype-pointer pointing
   to a double, (ftype-ref double () x) returns the double.

(ftype-set! ftype-name (access ...) fptr-expr val-expr) [syntax]

   sets the value of the named field of the foreign object pointed to
   by the value of fptr-expr, which must be an ftype pointer of the
   named ftype, to the value of val-expr.  The access and fptr-expr
   requirements stated under ftype-&ref and ftype-ref apply as well
   to ftype-set!.  val-expr must evaluate to a value appropriate for
   the identified field; for pointer fields other than those declared as
   void*, the value must be an ftype pointer with the appropriate ftype.
   Otherwise, the value of val-expr must be of the appropriate type,
   e.g., a character for types char and wchar and an integer of the
   appropriate size for int and unsigned.
|#

(begin
(let ()
  (include "types.ss")
  (define-syntax rtd/fptr
    (let ([rtd ($make-record-type #!base-rtd #f
                 '#{ftype-pointer a9pth58056u34h517jsrqv-0}
                 '((immutable uptr address))
                 #f
                 #f)])
      (lambda (x) #`'#,rtd)))
  (define $fptr? (record-predicate rtd/fptr))
  (define $ftype-pointer-address (record-accessor rtd/fptr 0))
  (define-syntax rtd/ftd
    (let ([rtd ($make-record-type #!base-rtd #!base-rtd
                 '#{rtd/ftd a9pth58056u34h517jsrqv-1}
                 '((immutable ptr stype)
                   (immutable ptr size)
                   (immutable ptr alignment))
                 #f
                 #f)])
      (lambda (x) #`'#,rtd)))
  (define ftd? (record-predicate rtd/ftd))
  (define ftd-stype (record-accessor rtd/ftd 0))
  (define ftd-size (record-accessor rtd/ftd 1))
  (define ftd-alignment (record-accessor rtd/ftd 2))
  (define-syntax define-ftd-record-type
    (lambda (x)
      (define construct-name
        (lambda (template-identifier . args)
          (datum->syntax
            template-identifier
            (string->symbol
              (apply string-append
                     (map (lambda (x)
                            (if (string? x)
                                x
                                (symbol->string (syntax->datum x))))
                          args))))))
      (define ftd-field
        (lambda (field)
          (syntax-case field (mutable)
            [field-name
             (identifier? #'field-name)
             #'field-name]
            [(mutable field-name)
             (identifier? #'field-name)
             #'field-name])))
      (define ftd-accessors
        (lambda (record-name field*)
          (define accessor
            (lambda (field-name ordinal)
              #`(define #,(construct-name field-name "ftd-" record-name "-" field-name)
                  (record-accessor rtd #,ordinal))))
          (define mutator
            (lambda (field-name ordinal)
              #`(define #,(construct-name field-name "ftd-" record-name "-" field-name "-set!")
                  (record-mutator rtd #,ordinal))))
          (let f ([field* field*] [ordinal 0])
            (if (null? field*)
                '()
                (syntax-case (car field*) (mutable)
                  [field-name
                   (identifier? #'field-name)
                   (cons (accessor #'field-name ordinal)
                     (f (cdr field*) (+ ordinal 1)))]
                  [(mutable field-name)
                   (identifier? #'field-name)
                   (cons (mutator #'field-name ordinal)
                     (cons (accessor #'field-name ordinal)
                       (f (cdr field*) (+ ordinal 1))))])))))
      (syntax-case x ()
        [(_ record-name ?uid field ...)
         (with-syntax ([(field-name ...) (map ftd-field #'(field ...))]
                       [constructor-name (construct-name #'record-name "make-ftd-" #'record-name)])
           #`(begin
               (define-syntax rtd
                 (let ([rtd ($make-record-type #!base-rtd rtd/ftd
                              '?uid
                              '(field ...)
                              #t
                              #f)])
                   (lambda (x) #`'#,rtd)))
               (define constructor-name
                 (lambda (parent uid stype size alignment field-name ...)
                   ($make-record-type rtd parent (or uid #,(symbol->string (datum record-name))) '() #f #f stype size alignment field-name ...)))
               (define #,(construct-name #'record-name "ftd-" #'record-name "?")
                 (record-predicate rtd))
               #,@(ftd-accessors #'record-name #'(field ...))))])))

  (define-ftd-record-type base #{rtd/ftd-base a9pth58056u34h517jsrqv-8} swap? type)
  (define-ftd-record-type struct #{rtd/ftd-struct a9pth58056u34h517jsrqv-3} field*)
  (define-ftd-record-type union #{rtd/ftd-union a9pth58056u34h517jsrqv-4} field*)
  (define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd)
  (define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd))
  (define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-9} swap? field*)
  (define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-11} conv* arg-type* result-type)
  (module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds)
    (define alignment
      (lambda (max-alignment size)
        (gcd max-alignment size)))
    (define pointer-size (/ (constant address-bits) 8))
    (define pointer-alignment (gcd (constant max-integer-alignment) pointer-size))
    (define base-types
      '(short unsigned-short int unsigned unsigned-int long
        unsigned-long long-long unsigned-long-long char wchar float
        double void* iptr uptr fixnum boolean integer-8 unsigned-8
        integer-16 unsigned-16 integer-24 unsigned-24 integer-32 unsigned-32
        integer-40 unsigned-40 integer-48 unsigned-48 integer-56 unsigned-56
        integer-64 unsigned-64 single-float double-float wchar_t size_t ssize_t ptrdiff_t))
    (define-who mfb
      (lambda (swap?)
        (lambda (ty)
          (define-syntax make
            (syntax-rules ()
              [(_ type bytes pred)
               (if (and swap? (fx= bytes 1))
                   (find (lambda (ftd) (eq? (ftd-base-type ftd) ty)) native-base-ftds)
                   (make-ftd-base rtd/fptr
                     ; creating static gensym so base ftypes are nongenerative to support
                     ; separate compilation of ftype definitions and uses.  creating unique
                     ; name so this works even when this file is reloaded, e.g., as a patch
                     ; file.  machine-type is included in the unique name so that we get
                     ; a different rtd/ftd with the correct "extras" (including size and
                     ; alignment) when cross compiling between machines with different
                     ; base-type characteristics.
                     (let ([pname (format "~a~:[~;s~]" ty swap?)])
                       (let ([gstring (format "~aa9pth58056u34h517jsrqv-~s-~a" pname (constant machine-type-name) pname)])
                         ($intern3 gstring (string-length pname) (string-length gstring))))
                     (if swap?
                         `(endian ,(constant-case native-endianness
                                     [(big) 'little]
                                     [(little) 'big])
                            ,ty)
                         ty)
                     bytes (alignment (if (memq 'type '(single-float double-float)) (constant max-float-alignment) (constant max-integer-alignment)) bytes) swap? ty))]))
          (record-datatype cases (filter-foreign-type ty) make
            ($oops who "unrecognized type ~s" ty)))))
    (define native-base-ftds (map (mfb #f) base-types))
    (define swap-base-ftds (map (mfb #t) base-types)))
  (define expand-field-names
    (lambda (x*)
      (let f ([x* x*] [seen* '()])
        (if (null? x*)
            '()
            (let ([x (car x*)] [x* (cdr x*)])
              (unless (identifier? x) (syntax-error x "invalid field name"))
              (if (free-identifier=? x #'_)
                  (cons #f (f x* seen*))
                  (let ([s (syntax->datum x)])
                    (if (memq s seen*)
                        (syntax-error x "duplicate field name")
                        (cons s (f x* (cons s seen*)))))))))))
  (define expand-ftype-name
    (case-lambda
      [(r ftype) (expand-ftype-name r ftype #t)]
      [(r ftype error?)
       (cond
         [(r ftype) =>
          (lambda (ftd)
            (if (ftd? ftd)
                ftd
                (and error? (syntax-error ftype "unrecognized ftype name"))))]
         [(find (let ([x (syntax->datum ftype)])
                  (lambda (ftd) (eq? (ftd-base-type ftd) x)))
            native-base-ftds)]
         [else (and error? (syntax-error ftype "unrecognized ftype name"))])]))
  (define expand-ftype
    (case-lambda
      [(r defid ftype) (expand-ftype r '() defid ftype)]
      [(r def-alist defid ftype)
       (define (check-size ftd)
         (unless (ftd-function? ftd)
           (let ([size (ftd-size ftd)])
             (unless (and (>= size 0) (< size (constant most-positive-fixnum)))
               (syntax-error ftype "non-fixnum overall size for ftype"))))
         ftd)
       (check-size
         (let f/flags ([ftype ftype] [defid defid] [stype (syntax->datum ftype)] [packed? #f] [swap? #f] [funok? #t])
           (define (pad n k) (if packed? n (logand (+ n (- k 1)) (- k))))
           (let f ([ftype ftype] [defid defid] [stype stype] [funok? funok?])
             (if (identifier? ftype)
                 (cond
                   [(assp (lambda (x) (bound-identifier=? ftype x)) def-alist) =>
                    (lambda (a)
                      (let ([ftd (cdr a)])
                        (unless (ftd? ftd)
                          (syntax-error ftype "recursive or forward reference outside pointer field"))
                        (unless funok?
                          (when (ftd-function? ftd)
                            (syntax-error ftype "unexpected function ftype name outside pointer field")))
                        ftd))]
                   [(r ftype) =>
                    (lambda (ftd)
                      (unless (ftd? ftd) (syntax-error ftype "unrecognized ftype name"))
                      (unless funok?
                        (when (ftd-function? ftd)
                          (syntax-error ftype "unexpected function ftype name outside pointer field")))
                      ftd)]
                   [(find (let ([x (syntax->datum ftype)])
                            (lambda (ftd) (eq? (ftd-base-type ftd) x)))
                      (if swap? swap-base-ftds native-base-ftds))]
                   [else (syntax-error ftype "unrecognized ftype name")])
                 (syntax-case ftype ()
                   [(struct-kwd (field-name ftype) ...)
                    (eq? (datum struct-kwd) 'struct)
                    (let loop ([id* (expand-field-names #'(field-name ...))]
                               [ftd* (map (lambda (ftype stype) (f ftype #f stype #f))
                                          #'(ftype ...) (datum (ftype ...)))]
                               [offset 0] [alignment 1] [field* '()])
                      (if (null? id*)
                          (let ([field* (reverse field*)])
                            (make-ftd-struct (if (null? field*) rtd/fptr (caddar field*))
                              (and defid (symbol->string (syntax->datum defid)))
                              stype (pad offset alignment) alignment field*))
                          (let ([ftd (car ftd*)])
                            (let ([offset (pad offset (ftd-alignment ftd))])
                              (loop (cdr id*) (cdr ftd*)
                                (+ offset (ftd-size ftd))
                                (max alignment (ftd-alignment ftd))
                                (cons (list (car id*) offset ftd) field*))))))]
                   [(union-kwd (field-name ftype) ...)
                    (eq? (datum union-kwd) 'union)
                    (let ([id* (expand-field-names #'(field-name ...))]
                          [ftd* (map (lambda (ftype stype) (f ftype #f stype #f))
                                     #'(ftype ...) (datum (ftype ...)))])
                      (let ([alignment (apply max 1 (map ftd-alignment ftd*))])
                        (make-ftd-union rtd/fptr
                          (and defid (symbol->string (syntax->datum defid)))
                          stype
                          (pad (apply max 0 (map ftd-size ftd*)) alignment)
                          alignment
                          (map cons id* ftd*))))]
                   [(array-kwd ?n ftype)
                    (eq? (datum array-kwd) 'array)
                    (let ([n (datum ?n)])
                      (unless (and (integer? n) (exact? n) (>= n 0))
                        (syntax-error #'?n "invalid array size"))
                      (let ([ftd (f #'ftype #f (datum ftype) #f)])
                        (make-ftd-array ftd
                          (and defid (symbol->string (syntax->datum defid)))
                          stype
                          (* n (ftd-size ftd))
                          (ftd-alignment ftd)
                          n ftd)))]
                   [(bits-kwd (field-name signedness bits) ...)
                    (eq? (datum bits-kwd) 'bits)
                    (let ()
                      (define parse-fields
                        (lambda ()
                          (define signed?
                            (lambda (s)
                              (case (syntax->datum s)
                                [(signed) #t]
                                [(unsigned) #f]
                                [else (syntax-error s "invalid bit-field signedness specifier")])))
                          (let f ([id* (expand-field-names #'(field-name ...))]
                                  [s* #'(signedness ...)]
                                  [bits* #'(bits ...)]
                                  [bit-offset 0])
                            (if (null? id*)
                                (values bit-offset '())
                                (let ([bits (syntax->datum (car bits*))])
                                  (unless (and (fixnum? bits) (fx>= bits 1))
                                    (syntax-error (car bits*) "invalid bit-field bit count"))
                                  (let-values ([(bit-size field*) (f (cdr id*) (cdr s*) (cdr bits*) (+ bit-offset bits))])
                                    (values bit-size
                                      (let ([start (if (eq? (native-endianness) (if swap? 'little 'big))
                                                       (- bit-size bit-offset bits)
                                                       bit-offset)])
                                        (cons (list (car id*) (signed? (car s*)) start (+ start bits))
                                              field*)))))))))
                      (let-values ([(bit-size field*) (parse-fields)])
                        (unless (memq bit-size '(8 16 24 32 40 48 56 64))
                          (syntax-error ftype "bit counts do not add up to 8, 16, 32, or 64"))
                        (let ([offset (fxsrl bit-size 3)])
                          (make-ftd-bits rtd/fptr
                            (and defid (symbol->string (syntax->datum defid)))
                            stype offset (alignment (constant max-integer-alignment) offset)
                            (and swap? (fx> offset 1)) field*))))]
                   [(*-kwd ftype)
                    (eq? (datum *-kwd) '*)
                    (cond
                      [(and (identifier? #'ftype)
                            (assp (lambda (x) (bound-identifier=? #'ftype x)) def-alist)) =>
                       (lambda (a)
                         (if (ftd? (cdr a))
                             (make-ftd-pointer rtd/fptr
                               (and defid (symbol->string (syntax->datum defid)))
                               stype pointer-size pointer-alignment (cdr a))
                             (let ([ftd (make-ftd-pointer rtd/fptr
                                          (and defid (symbol->string (syntax->datum defid)))
                                          stype pointer-size pointer-alignment #f)])
                               (set-cdr! a (cons ftd (cdr a)))
                               ftd)))]
                      [else (make-ftd-pointer rtd/fptr
                              (and defid (symbol->string (syntax->datum defid)))
                              stype pointer-size pointer-alignment (f #'ftype #f (datum ftype) #t))])]
                   [(function-kwd (arg-type ...) result-type)
                    (eq? (datum function-kwd) 'function)
                    (f #'(function-kwd #f (arg-type ...) result-type) #f stype funok?)]
                   [(function-kwd conv ... (arg-type ...) result-type)
                    (eq? (datum function-kwd) 'function)
                    (let ()
                      (define filter-type
                        (lambda (r x result?)
                          (let ([what (if result? 'result 'argument)])
                            (or ($fp-filter-type (expand-fp-ftype 'function-ftype what r x def-alist) result?)
                                (syntax-error x (format "invalid function-ftype ~s type specifier" what))))))
                      (unless funok? (syntax-error ftype "unexpected function ftype outside pointer field"))
                      (make-ftd-function rtd/fptr
                        (and defid (symbol->string (syntax->datum defid)))
                        stype #f #f
                        ($filter-conv 'function-ftype #'(conv ...))
                        (map (lambda (x) (filter-type r x #f)) #'(arg-type ...))
                        (filter-type r #'result-type #t)))]
                   [(packed-kwd ftype)
                    (eq? (datum packed-kwd) 'packed)
                    (f/flags #'ftype #f stype #t swap? funok?)]
                   [(unpacked-kwd ftype)
                    (eq? (datum unpacked-kwd) 'unpacked)
                    (f/flags #'ftype #f stype #f swap? funok?)]
                   [(endian-kwd ?eness ftype)
                    (eq? (datum endian-kwd) 'endian)
                    (let ([eness (datum ?eness)])
                      (unless (memq eness '(big little native))
                        (syntax-error #'?eness "invalid endianness"))
                      (let ([swap? (and (not (eq? eness 'native))
                                        (not (eq? eness (constant native-endianness))))])
                        (f/flags #'ftype #f stype packed? swap? funok?)))]
                   [_ (syntax-error ftype "invalid ftype")])))))]))
  (define expand-fp-ftype
    (lambda (who what r ftype def-alist)
      (syntax-case ftype ()
        [(*/&-kwd ftype-name)
         (and (or (eq? (datum */&-kwd) '*)
                  (eq? (datum */&-kwd) '&))
              (identifier? #'ftype-name))
         (let* ([stype (syntax->datum ftype)]
                [ftd
                 (cond
                  [(assp (lambda (x) (bound-identifier=? #'ftype-name x)) def-alist) =>
                   (lambda (a)
                     (if (ftd? (cdr a))
                         (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment (cdr a))
                         (let ([ftd (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment #f)])
                           (set-cdr! a (cons ftd (cdr a)))
                           ftd)))]
                  [(expand-ftype-name r #'ftype-name #f) =>
                   (lambda (ftd)
                     (make-ftd-pointer rtd/fptr #f stype pointer-size pointer-alignment ftd))]
                  [else (syntax-error #'ftype-name (format "unrecognized ~s ~s ftype name" who what))])])
           ;; Scheme-side argument is a pointer to a value, but foreign side has two variants:
           (if (eq? (datum */&-kwd) '&)
               (cond
                [(ftd-array? (ftd-pointer-ftd ftd))
                 (syntax-error ftype (format "array value invalid as ~a ~s" who what))]
                [else
                 (box ftd)]) ; boxed ftd => pass/receive the value (as opposed to a pointer to the value)
               ftd))]    ; plain ftd => pass/receive a pointer to the value
        [_ (cond
             [(and (identifier? ftype) (expand-ftype-name r ftype #f)) =>
              (lambda (ftd)
                (unless (ftd-base? ftd)
                  (syntax-error ftype (format "invalid (non-base) ~s ~s ftype" who what)))
                (when (ftd-base-swap? ftd)
                  (syntax-error ftype (format "invalid (swapped) ~s ~s ftype" who what)))
                (ftd-base-type ftd))]
             [else (syntax->datum ftype)])])))
  (define-who indirect-ftd-pointer
    (lambda (x)
      (cond
       [(ftd? x)
        (if (ftd-pointer? x)
            (ftd-pointer-ftd x)
            ($oops who "~s is not an ftd-pointer" x))]
       [(box? x)
        (box (indirect-ftd-pointer (unbox x)))]
       [else x])))
  (define-who expand-ftype-defns
    (lambda (r defid* ftype*)
      (define patch-pointer-ftds!
        (lambda (id ftd)
          (lambda (pointer-ftd)
            (ftd-pointer-ftd-set! pointer-ftd ftd))))
      (let ([alist (map list defid*)])
        (for-each
          (lambda (defid ftype a)
            (let ([ftd (expand-ftype r alist defid ftype)])
              (for-each (patch-pointer-ftds! defid ftd) (cdr a))
              (set-cdr! a ftd)))
          defid* ftype* alist)
        (map cdr alist))))
  (define unsigned-type
    (lambda (size)
      (case size
        [(1) 'unsigned-8]
        [(2) 'unsigned-16]
        [(3) 'unsigned-24]
        [(4) 'unsigned-32]
        [(5) 'unsigned-40]
        [(6) 'unsigned-48]
        [(7) 'unsigned-56]
        [(8) 'unsigned-64]
        [else ($oops 'unsigned-type "unexpected size ~s" size)])))
  (define-record-type src-info
    (nongenerative #{src-info sls7d75lyfm0jejerbq3n-0})
    (sealed #f)
    (fields src)
    (protocol
      (lambda (new)
        (lambda (expr)
          (new
            (let ([a (syntax->annotation expr)])
              (and (and a (fxlogtest (annotation-flags a) (constant annotation-debug)))
                   (annotation-source a))))))))
  (define-record-type field-info
    (parent src-info)
    (nongenerative #{field-info sls7d75lyfm0jejerbq3n-1})
    (sealed #t)
    (fields type)
    (protocol
      (lambda (pargs->new)
        (lambda (type expr)
          ((pargs->new expr) type)))))
  (define-record-type ftd-info
    (parent src-info)
    (nongenerative #{ftd-info sls7d75lyfm0jejerbq3n-2})
    (sealed #t)
    (fields who ftd)
    (protocol
      (lambda (pargs->new)
        (lambda (whoid expr ftd)
          ((pargs->new expr) (syntax->datum whoid) ftd)))))
  (define-record-type index-info
    (parent src-info)
    (nongenerative #{index-info sls7d75lyfm0jejerbq3n-3})
    (sealed #t)
    (fields who ftd pointer?)
    (protocol
      (lambda (pargs->new)
        (lambda (whoid expr ftd pointer?)
          ((pargs->new expr) (syntax->datum whoid) ftd pointer?)))))
  (record-writer rtd/ftd
    (lambda (x p wr)
      (fprintf p "#<ftd ~s>" (record-type-name x))))
  (record-writer rtd/fptr
    (lambda (x p wr)
      (fprintf p "#<ftype-pointer ~s ~s>" (record-type-name (record-rtd x)) ($ftype-pointer-address x))))
  (set! $verify-ftype-address
    (lambda (who addr)
      (define address?
        (lambda (x)
          (constant-case address-bits
            [(32) ($integer-32? x)]
            [(64) ($integer-64? x)])))
      (unless (address? addr)
        (if (or (procedure? addr) (string? addr))
            ($oops who "non-function ftype with ~s address" addr)
            ($oops who "invalid address ~s" addr)))))
  (set! $verify-ftype-pointer
    (lambda (info fptr)
      (unless (record? fptr (ftd-info-ftd info))
        ($source-violation (ftd-info-who info) (src-info-src info) #t
          (if ($fptr? fptr)
              "ftype mismatch for ~s"
              "~s is not an ftype pointer")
          fptr))))
  (set! $invalid-ftype-index
    (lambda (info i)
      ($source-violation (index-info-who info) (src-info-src info) #t
        "invalid index ~s for ~:[~;indirection of ~]~s" i (index-info-pointer? info) (index-info-ftd info))))
  (set! $trans-define-ftype
    (lambda (x)
      (lambda (r)
        (syntax-case x ()
          [(_ ftype-name ftype)
           (identifier? #'ftype-name)
           #`(define-syntax ftype-name
               (make-compile-time-value
                 '#,(car (expand-ftype-defns r #'(ftype-name) #'(ftype)))))]
          [(_ [ftype-name ftype] ...)
           (andmap identifier? #'(ftype-name ...))
           (with-syntax ([(ftd ...) (expand-ftype-defns r #'(ftype-name ...) #'(ftype ...))])
             #'(begin
                 (define-syntax ftype-name
                   (make-compile-time-value 'ftd))
                 ...))]))))
  (set! $trans-make-ftype-pointer
    (lambda (x)
      (lambda (r)
        (syntax-case x ()
          [(_ ftype ?addr)
           (identifier? #'ftype)
           (let ([ftd (expand-ftype-name r #'ftype)])
             (with-syntax ([addr-expr
                            (if (ftd-function? ftd)
                                #`(let ([x ?addr])
                                    (cond
                                      ;; we need to make a code object, lock it, set addr to
                                      ;; (foreign-callable-entry-point code-object)
                                      [(procedure? x)
                                       (let ([co #,($make-foreign-callable 'make-ftype-pointer
                                                     (ftd-function-conv* ftd)
                                                     #'x
                                                     (map indirect-ftd-pointer (ftd-function-arg-type* ftd))
                                                     (indirect-ftd-pointer (ftd-function-result-type ftd)))])
                                         (lock-object co)
                                         (foreign-callable-entry-point co))]
                                      ;; otherwise, it is a string, so lookup the foreign-entry
                                      [(string? x) (foreign-entry x)]
                                      ;; otherwise, assume it is an address, let normal check
                                      ;; complain otherwise
                                      [else x]))
                                #'?addr)])
               #`($make-fptr '#,ftd
                   #,(if (or (fx= (optimize-level) 3)
                             (syntax-case #'addr-expr (ftype-pointer-address)
                               [(ftype-pointer-address x) #t]
                               [else #f]))
                         #'addr-expr
                         #'(let ([addr addr-expr])
                             ($verify-ftype-address 'make-ftype addr)
                             addr)))))]))))
  (set! $trans-ftype-pointer?
    (lambda (x)
      (lambda (r)
        (syntax-case x ()
          [(_ x) #`(record? x '#,rtd/fptr)]
          [(_ ftype x) (identifier? #'ftype) #`(record? x '#,(expand-ftype-name r #'ftype))]))))
  (set-who! ftype-pointer-address
    (lambda (fptr)
      (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
      ($ftype-pointer-address fptr)))
  (set-who! ftype-pointer-null?
    (lambda (fptr)
      (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
      (#3%ftype-pointer-null? fptr)))
  (set-who! ftype-pointer=?
    (lambda (fptr1 fptr2)
      (unless ($fptr? fptr1) ($oops who "~s is not an ftype pointer" fptr1))
      (unless ($fptr? fptr2) ($oops who "~s is not an ftype pointer" fptr2))
      (#3%ftype-pointer=? fptr1 fptr2)))
  (set-who! ftype-pointer-ftype
    (lambda (fptr)
      (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
      (ftd-stype (record-rtd fptr))))
  (set-who! ftype-pointer->sexpr
    (lambda (fptr)
      (module (record replay)
        (define ht (make-eqv-hashtable))
        (define-syntax record
          (syntax-rules ()
            [(_ ?fptr expr)
             (let ([fptr ?fptr])
               (let ([addr (ftype-pointer-address fptr)])
                 (cond
                   [(hashtable-ref ht addr #f) => (lambda (x) fptr)]
                   [else
                    (hashtable-set! ht addr #t)
                    (let ([x expr])
                      (hashtable-set! ht addr x)
                      x)])))]))
        (define replay
          (lambda (x)
            (let f ([x x])
              (if ($fptr? x)
                  (hashtable-ref ht (ftype-pointer-address x) #f)
                  (begin
                    (when (pair? x)
                      (set-car! x (f (car x)))
                      (set-cdr! x (f (cdr x))))
                    x)))
            x)))
      (unless ($fptr? fptr) ($oops who "~s is not an ftype pointer" fptr))
      (replay
        (let fptr->sexpr ([fptr fptr])
          (record fptr
            (let f ([fptr fptr] [ftd (record-rtd fptr)] [offset 0])
              (cond
                [(ftd-struct? ftd)
                 `(struct
                    ,@(map (lambda (field)
                             (if (car field)
                                 `(,(car field) ,(f fptr (caddr field) (+ offset (cadr field))))
                                 '(_ _)))
                        (ftd-struct-field* ftd)))]
                [(ftd-union? ftd)
                 `(union
                    ,@(map (lambda (field)
                             (if (car field)
                                 `(,(car field) ,(f fptr (cdr field) offset))
                                 '(_ _)))
                        (ftd-union-field* ftd)))]
                [(ftd-array? ftd)
                 (let ([n (ftd-array-length ftd)]
                       [ftd (ftd-array-ftd ftd)])
                   (if (and (ftd-base? ftd) (memq (ftd-base-type ftd) '(char wchar)))
                       (let g ([i 0])
                         (if (fx= i n)
                             (make-string n)
                             (let ([c (f fptr ftd (+ offset (* i (ftd-size ftd))))])
                               (if (or (eq? c 'invalid) (eqv? c #\nul))
                                   (if (fx= i 0) `(array ,n invalid) (make-string i))
                                   (let ([s (g (fx+ i 1))])
                                     (string-set! s i c)
                                     s)))))
                       `(array ,n
                          ,@(let g ([i 0])
                              (if (fx= i n)
                                  '()
                                  (cons (f fptr ftd (+ offset (* i (ftd-size ftd))))
                                        (g (fx+ i 1))))))))]
                [(ftd-pointer? ftd)
                 (cond
                   [(guard (c [#t #f]) ($fptr-fptr-ref fptr offset (ftd-pointer-ftd ftd))) =>
                    (lambda (fptr)
                      (if (zero? (ftype-pointer-address fptr))
                          'null
                          (let ([ftd (ftd-pointer-ftd ftd)])
                            (if (and (ftd-base? ftd) (memq (ftd-base-type ftd) '(char wchar)))
                                (let g ([i 0])
                                  (let ([c (f fptr ftd (* i (ftd-size ftd)))])
                                    (if (or (eq? c 'invalid) (eqv? c #\nul))
                                        (if (fx= i 0) '(* invalid) (make-string i))
                                        (let ([s (g (fx+ i 1))])
                                          (string-set! s i c)
                                          s))))
                                `(* ,(fptr->sexpr fptr))))))]
                   [else 'invalid])]
                [(ftd-function? ftd)
                 (let ([addr (ftype-pointer-address fptr)])
                   `(function ,(or (foreign-address-name addr) addr)))]
                [(ftd-bits? ftd)
                 (let ([type (unsigned-type (ftd-size ftd))])
                   `(bits
                      ,@(map (lambda (field)
                               (apply
                                 (lambda (id signed? start end)
                                   (if id
                                       `(,id
                                         ,(guard (c [#t 'invalid])
                                            ($fptr-ref-bits type (ftd-bits-swap? ftd) signed?
                                              fptr offset start end)))
                                       '(_ _)))
                                 field))
                          (ftd-bits-field* ftd))))]
                [(ftd-base? ftd)
                 (guard (c [#t 'invalid])
                   ($fptr-ref (filter-foreign-type (ftd-base-type ftd))
                     (ftd-base-swap? ftd) fptr offset))]
                [else ($oops '$fptr->sexpr "unhandled ftd ~s" ftd)])))))))
  (set! $unwrap-ftype-pointer
    (lambda (fptr)
      (let f ([ftd (record-rtd fptr)])
        (cond
          [(ftd-struct? ftd)
           `(struct
              ,@(map (lambda (field)
                       `(,(car field) . ,($fptr-&ref fptr (cadr field) (caddr field))))
                  (ftd-struct-field* ftd)))]
          [(ftd-union? ftd)
           `(union
              ,@(map (lambda (field)
                       `(,(car field) . ,($fptr-&ref fptr 0 (cdr field))))
                  (ftd-union-field* ftd)))]
          [(ftd-array? ftd)
           (let ([n (ftd-array-length ftd)]
                 [ftd (ftd-array-ftd ftd)])
             `(array ,n
                ,(lambda (i)
                   (unless (and (fixnum? i) (if (fx= n 0) (fx>= i 0) ($fxu< i n)))
                     (errorf '$dump-foreign-type "invalid index ~s for array of length ~s" i n))
                   ($fptr-&ref fptr (* i (ftd-size ftd)) ftd))))]
          [(ftd-pointer? ftd)
           (let ([ftd (ftd-pointer-ftd ftd)])
             `(* ,(lambda () ($fptr-fptr-ref fptr 0 ftd))
                 ,(lambda (who v)
                    ($verify-ftype-pointer (make-ftd-info who #f ftd) v)
                    (#3%$fptr-fptr-set! fptr 0 v))))]
          [(ftd-function? ftd)
           (let ([addr (ftype-pointer-address fptr)])
             `(function ,(foreign-address-name addr)))]
          [(ftd-bits? ftd)
           (let ([type (unsigned-type (ftd-size ftd))])
             `(bits
                ,@(map (lambda (field)
                         (apply
                           (lambda (id signed? start end)
                             `(,id ,(lambda ()
                                      (guard (c [#t 'invalid])
                                        ($fptr-ref-bits type (ftd-bits-swap? ftd) signed? fptr 0 start end)))
                                   ,(lambda (v)
                                      (#2%$fptr-set-bits! type (ftd-bits-swap? ftd) fptr 0
                                        start end v))))
                           field))
                    (ftd-bits-field* ftd))))]
          [(ftd-base? ftd)
           (let ([type (filter-foreign-type (ftd-base-type ftd))])
             `(base
                ,type
                ,(lambda () (guard (c [#t 'invalid]) ($fptr-ref type (ftd-base-swap? ftd) fptr 0)))
                ,(lambda (v) (#2%$fptr-set! (ftd-base-type ftd) type (ftd-base-swap? ftd) fptr 0 v))))]
          [else ($oops '$unwrap-ftype-pointer "unhandled ftd ~s" ftd)]))))
  (set! $trans-ftype-sizeof
    (lambda (x)
      (lambda (r)
        (syntax-case x ()
          [(_ ftype)
           (identifier? #'ftype)
           (let ([ftd (expand-ftype-name r #'ftype)])
             (when (ftd-function? ftd)
               ($oops 'ftype-sizeof "function ftypes have unknown size"))
             (ftd-size ftd))]))))
  (set! $ftd?
    (lambda (x)
      (ftd? x)))
  (set! $ftd-as-box? ; represents `(& <ftype>)` from `$expand-fp-ftype`
    (lambda (x)
      (and (box? x) (ftd? (unbox x)))))
  (set! $ftd-size
    (lambda (x)
      (ftd-size x)))
  (set! $ftd-alignment
    (lambda (x)
      (ftd-alignment x)))
  (set! $ftd-compound?
    (lambda (x)
      (or (ftd-struct? x)
          (ftd-union? x)
          (ftd-array? x))))
  (set! $ftd-unsigned?
    (lambda (x)
      (and (ftd-base? x)
           (case (ftd-base-type x)
             [(unsigned-8 unsigned-16 unsigned-32 unsigned-64) #t]
             [else #f]))))
  (set! $ftd->members
    (lambda (x)
      ;; Currently used for x86_64 and arm32 ABI: Returns a list of
      ;;  (list 'integer/'float size offset)
      (let loop ([x x] [offset 0] [accum '()])
        (cond
         [(ftd-base? x)
          (cons (list (case (ftd-base-type x)
                        [(double double-float float single-float)
                         'float]
                        [else 'integer])
                      (ftd-size x)
                      offset)
                accum)]
         [(ftd-struct? x)
          (let struct-loop ([field* (ftd-struct-field* x)] [accum accum])
            (cond
             [(null? field*) accum]
             [else (let* ([fld (car field*)]
                          [sub-ftd (caddr fld)]
                          [sub-offset (cadr fld)])
                     (struct-loop (cdr field*)
                                  (loop sub-ftd (+ offset sub-offset) accum)))]))]
         [(ftd-union? x)
          (let union-loop ([field* (ftd-union-field* x)] [accum accum])
            (cond
             [(null? field*) accum]
             [else (let* ([fld (car field*)]
                          [sub-ftd (cdr fld)])
                     (union-loop (cdr field*)
                                 (loop sub-ftd offset accum)))]))]
         [(ftd-array? x)
          (let ([elem-ftd (ftd-array-ftd x)])
            (let array-loop ([len (ftd-array-length x)] [offset offset] [accum accum])
              (cond
               [(fx= len 0) accum]
               [else (array-loop (fx- len 1)
                                 (+ offset (ftd-size elem-ftd))
                                 (loop elem-ftd offset accum))])))]
         [else (cons (list 'integer (ftd-size x) offset) accum)]))))
  (set! $ftd-atomic-category
    (lambda (x)
      ;; Currently used for PowerPC32 ABI
      (cond
       [(ftd-base? x)
	(case (ftd-base-type x)
	  [(double double-float float single-float)
	   'float]
	  [(unsigned-short unsigned unsigned-int
			   unsigned-long unsigned-long-long
			   unsigned-8 unsigned-16 unsigned-32 unsigned-64)
	   'unsigned]
	  [else 'integer])]
       [else 'integer])))
  (set! $expand-fp-ftype ; for foreign-procedure, foreign-callable
    (lambda (who what r ftype)
      (indirect-ftd-pointer
        (expand-fp-ftype who what r ftype '()))))
  (let ()
    (define-who ftype-access-code
      (lambda (whoid ftd a* fptr-expr offset)
        (let loop ([ftd ftd] [a* a*] [fptr-expr fptr-expr] [offset offset] [idx* '()])
          (if (null? a*)
              (values fptr-expr offset ftd idx* #f)
              (let ([a (car a*)])
                (cond
                  [(ftd-struct? ftd)
                   (let ([s (syntax->datum a)])
                     (cond
                       [(and (symbol? s) (assq s (ftd-struct-field* ftd))) =>
                        (lambda (field)
                          (let ([offset #`(#3%fx+ #,offset #,(cadr field))] [ftd (caddr field)])
                            (loop ftd (cdr a*) fptr-expr offset idx*)))]
                       [else (syntax-error a "unexpected accessor")]))]
                  [(ftd-union? ftd)
                   (let ([s (syntax->datum a)])
                     (cond
                       [(and (symbol? s) (assq s (ftd-union-field* ftd))) =>
                        (lambda (field)
                          (let ([ftd (cdr field)])
                            (loop ftd (cdr a*) fptr-expr offset idx*)))]
                       [else (syntax-error a "unexpected accessor")]))]
                  [(ftd-array? ftd)
                   (let ([elt-ftd (ftd-array-ftd ftd)] [len (ftd-array-length ftd)])
                     (if (memv (syntax->datum a) '(* 0))
                         (loop elt-ftd (cdr a*) fptr-expr offset idx*)
                         (let ([a-id (car (generate-temporaries (list #'i)))])
                           (loop elt-ftd (cdr a*) fptr-expr
                             #`(#3%fx+ #,offset (#3%fx* #,a-id #,(ftd-size elt-ftd)))
                             (cons (list ftd a-id a len) idx*)))))]
                  [(ftd-pointer? ftd)
                   (let ([elt-ftd (ftd-pointer-ftd ftd)])
                     (let ([fptr-expr #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,elt-ftd)])
                        (if (memv (syntax->datum a) '(* 0))
                            (loop elt-ftd (cdr a*) fptr-expr 0 idx*)
                            (let ([a-id (car (generate-temporaries (list #'i)))])
                              (loop elt-ftd (cdr a*) fptr-expr
                                (trans-idx a-id a elt-ftd (make-index-info whoid a ftd #f))
                                (cons (list ftd a-id a #f) idx*))))))]
                  [(ftd-bits? ftd)
                   (let ([s (syntax->datum a)])
                     (cond
                       [(and (symbol? s) (assq s (ftd-bits-field* ftd))) =>
                        (lambda (field)
                          (unless (null? (cdr a*))
                            (syntax-error (cadr a*) "unexpected accessor"))
                          (values fptr-expr offset ftd idx* field))]
                       [else (syntax-error a "unexpected accessor")]))]
                  [(ftd-base? ftd) (syntax-error a "unexpected accessor")]
                  [(ftd-function? ftd) (syntax-error a "unexpected accessor")]
                  [else ($oops who "unhandled ftd ~s" ftd)]))))))
    (define trans-bitfield
      (lambda (ftd signed? offset start end do-base do-bits)
        (define (little-endian?)
          (constant-case native-endianness
            [(little) (not (ftd-bits-swap? ftd))]
            [(big) (ftd-bits-swap? ftd)]))
        (let ([width (fx- end start)])
          (cond
            [(and (fx= width 8) (fx= (mod start 8) 0))
             (do-base (if signed? 'integer-8 'unsigned-8) #f
               #`(fx+ #,offset
                      #,(if (little-endian?)
                            (div start 8)
                            (fx- (ftd-size ftd) (div start 8) 1))))]
            [(and (fx= width 16) (fx= (mod start 16) 0))
             (do-base (if signed? 'integer-16 'unsigned-16) (ftd-bits-swap? ftd)
               #`(fx+ #,offset
                      #,(if (little-endian?)
                            (div start 8)
                            (fx- (ftd-size ftd) (div start 8) 2))))]
            [(and (fx= width 32) (fx= (mod start 32) 0))
             (do-base (if signed? 'integer-32 'unsigned-32) (ftd-bits-swap? ftd)
               #`(fx+ #,offset
                      #,(if (little-endian?)
                            (div start 8)
                            (fx- (ftd-size ftd) (div start 8) 4))))]
            [(and (fx= width 64) (fx= start 0))
             (do-base (if signed? 'integer-64 'unsigned-64) (ftd-bits-swap? ftd) offset)]
            [else
             (or (and (and (fx= (ftd-size ftd) 8) (fx= (constant ptr-bits) 32))
                      (cond
                        [(and (fx>= start 0) (fx<= end 32))
                         (do-bits 4 (if (little-endian?) offset #`(fx+ #,offset 4)) start end)]
                        [(and (fx>= start 32) (fx<= end 64))
                         (do-bits 4 (if (little-endian?) #`(fx+ #,offset 4) offset) (fx- start 32) (fx- end 32))]
                        [else #f]))
                 (do-bits (ftd-size ftd) offset start end))]))))
    (define trans-idx
      (lambda (?idx ?orig-idx ftd info)
        (if (memv (syntax->datum ?idx) '(* 0))
            0
            (if (ftd-function? ftd)
                (syntax-error ?orig-idx "cannot calculate offset for function index")
                (let ([size (ftd-size ftd)])
                  (if (fx= (optimize-level) 3)
                      #`(#3%fx* #,size #,?idx)
                      #`(let ([idx #,?idx])
                          (or (and (fixnum? idx)
                                   (let ([offset (* #,size idx)])
                                     (and (fixnum? offset)
                                          (fixnum? (+ offset #,(fx- size 1)))
                                          offset)))
                              ($invalid-ftype-index '#,info idx)))))))))
    (set! $trans-ftype-&ref
      (lambda (q)
        (define trans
          (lambda (ftype a* fptr-expr ?idx)
           (lambda (r)
             (let ([ftd (expand-ftype-name r ftype)])
               (let ([fptr-expr (if (fx= (optimize-level) 3)
                                    fptr-expr
                                    #`(let ([fptr #,fptr-expr])
                                        ($verify-ftype-pointer '#,(make-ftd-info 'ftype-&ref fptr-expr ftd) fptr)
                                        fptr))])
                 (if (and (null? a*) (memv (syntax->datum ?idx) '(* 0)))
                     fptr-expr
                     #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-&ref ?idx ftd #t))])
                         #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                         (ftype-access-code #'ftype-&ref ftd a* fptr-expr #'offset)])
                             (when bitfield (syntax-error q "cannot take address of bit field"))
                             (with-syntax ([((containing-ftd a-id a len) ...) idx*])
                               (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info 'ftype-&ref a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))])
                                 #`(let ([a-id a] ...)
                                     (unless (or #,(fx= (optimize-level) 3) (not len))
                                       (unless (and (fixnum? a-id) (if (eqv? len 0) (fx>= a-id 0) ($fxu< a-id len)))
                                         ($invalid-ftype-index 'info a-id)))
                                     ...
                                     (#3%$fptr-&ref #,fptr-expr #,offset '#,ftd))))))))))))
        (syntax-case q ()
          [(_ ftype (a ...) fptr-expr)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr 0)]
          [(_ ftype (a ...) fptr-expr ?idx)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
    (set! $trans-ftype-ref
      (lambda (q)
        (define trans
          (lambda (ftype a* fptr-expr ?idx)
            (lambda (r)
              (let ([ftd (expand-ftype-name r ftype)])
                (let ([fptr-expr (if (fx= (optimize-level) 3)
                                     fptr-expr
                                     #`(let ([fptr #,fptr-expr])
                                         ($verify-ftype-pointer '#,(make-ftd-info 'ftype-ref fptr-expr ftd) fptr)
                                         fptr))])
                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-ref ?idx ftd #t))])
                      #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                      (ftype-access-code #'ftype-ref ftd a* fptr-expr #'offset)])
                          (define (do-base type swap? offset)
                            (with-syntax ([$fptr-ref-x (datum->syntax #'kwd
                                                         (string->symbol
                                                           (format "$fptr-ref-~:[~;swap-~]~a"
                                                             swap? type)))])
                              #`(#3%$fptr-ref-x #,fptr-expr #,offset)))
                          (with-syntax ([((containing-ftd a-id a len) ...) idx*])
                            (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info 'ftype-ref a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))])
                              #`(let ([a-id a] ...)
                                  (unless (or #,(fx= (optimize-level) 3) (not len))
                                    (unless (and (fixnum? a-id) (if (eqv? len 0) (fx>= a-id 0) ($fxu< a-id len)))
                                      ($invalid-ftype-index 'info a-id)))
                                  ...
                                  #,(cond
                                      [bitfield
                                        (apply
                                          (lambda (id signed? start end)
                                            (trans-bitfield ftd signed? offset start end do-base
                                              (lambda (size offset start end)
                                                (with-syntax ([$fptr-ref-bits-x (datum->syntax #'*
                                                                                  (string->symbol
                                                                                    (format "$fptr-ref-~:[u~;i~]bits-~:[~;swap-~]~a"
                                                                                      signed?
                                                                                      (ftd-bits-swap? ftd)
                                                                                      (unsigned-type size))))])
                                                  #`(#3%$fptr-ref-bits-x #,fptr-expr #,offset #,start #,end)))))
                                          bitfield)]
                                      [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)]
                                      [(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))]
                                      [(ftd-function? ftd) 
                                       ($make-foreign-procedure 'make-ftype-pointer
                                         (ftd-function-conv* ftd)
                                         #f
                                         #`($fptr-offset-addr #,fptr-expr offset)
                                         (map indirect-ftd-pointer (ftd-function-arg-type* ftd))
                                         (indirect-ftd-pointer (ftd-function-result-type ftd)))]
                                      [else (syntax-error q "non-scalar value cannot be referenced")])))))))))))
        (syntax-case q ()
          [(_ ftype (a ...) fptr-expr)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr 0)]
          [(_ ftype (a ...) fptr-expr ?idx)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
    (set! $trans-ftype-set!
      (lambda (q)
        (define trans
          (lambda (ftype a* fptr-expr ?idx val-expr)
            (lambda (r)
              (let ([ftd (expand-ftype-name r ftype)])
                (let ([fptr-expr (if (fx= (optimize-level) 3)
                                     fptr-expr
                                     #`(let ([fptr #,fptr-expr])
                                         ($verify-ftype-pointer '#,(make-ftd-info 'ftype-set! fptr-expr ftd) fptr)
                                         fptr))])
                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-set! ?idx ftd #t))] [val #,val-expr])
                      #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                      (ftype-access-code #'ftype-set! ftd a* fptr-expr #'offset)])
                          (define (do-base orig-type)
                            (lambda (type swap? offset)
                              (with-syntax ([$fptr-set-x! (datum->syntax #'kwd
                                                            (string->symbol
                                                              (format "$fptr-set-~:[~;swap-~]~a!"
                                                                swap? type)))])
                                #`($fptr-set-x! '#,(make-field-info orig-type val-expr) #,fptr-expr #,offset val))))
                          (with-syntax ([((containing-ftd a-id a len) ...) idx*])
                            (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info 'ftype-set! a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))])
                              #`(let ([a-id a] ...)
                                  (unless (or #,(fx= (optimize-level) 3) (not len))
                                    (unless (and (fixnum? a-id) (if (eqv? len 0) (fx>= a-id 0) ($fxu< a-id len)))
                                      ($invalid-ftype-index 'info a-id)))
                                  ...
                                  #,(cond
                                      [bitfield
                                        (apply
                                          (lambda (id signed? start end)
                                            (trans-bitfield ftd signed? offset start end (do-base 'bit-field)
                                              (lambda (size offset start end)
                                                (with-syntax ([$fptr-set-bits-x! (datum->syntax #'*
                                                                                   (string->symbol
                                                                                     (format "$fptr-set-bits-~:[~;swap-~]~a!"
                                                                                       (ftd-bits-swap? ftd)
                                                                                       (unsigned-type size))))])
                                                  #`($fptr-set-bits-x! #,fptr-expr #,offset #,start #,end val)))))
                                          bitfield)]
                                      [(ftd-base? ftd)
                                       (let ([orig-type (ftd-base-type ftd)])
                                         ((do-base orig-type) (filter-foreign-type orig-type) (ftd-base-swap? ftd) offset))]
                                      [(ftd-pointer? ftd)
                                       #`(begin
                                           (unless #,(fx= (optimize-level) 3)
                                             ($verify-ftype-pointer '#,(make-ftd-info 'ftype-set! val-expr (ftd-pointer-ftd ftd)) val))
                                           (#3%$fptr-fptr-set! #,fptr-expr #,offset val))]
                                      [else (syntax-error q "non-scalar value cannot be assigned")])))))))))))
        (syntax-case q ()
          [(_ ftype (a ...) fptr-expr val-expr)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr 0 #'val-expr)]
          [(_ ftype (a ...) fptr-expr ?idx val-expr)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr #'?idx #'val-expr)])))
    (set-who! $trans-ftype-locked-op!
      (lambda (who q prim)
        (define trans
          (lambda (ftype a* fptr-expr ?idx)
            (lambda (r)
              (let ([ftd (expand-ftype-name r ftype)])
                (let ([fptr-expr (if (fx= (optimize-level) 3)
                                     fptr-expr
                                     #`(let ([fptr #,fptr-expr])
                                         ($verify-ftype-pointer '#,(make-ftd-info who fptr-expr ftd) fptr)
                                         fptr))])
                  #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info who ?idx ftd #t))])
                      #,(let-values ([(fptr-expr offset ftd idx* bitfield)
                                      (ftype-access-code who ftd a* fptr-expr #'offset)])
                          (with-syntax ([((containing-ftd a-id a len) ...) idx*])
                            (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info who a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))])
                              #`(let ([a-id a] ...)
                                  (unless (or #,(fx= (optimize-level) 3) (not len))
                                    (unless (and (fixnum? a-id) (if (eqv? len 0) (fx>= a-id 0) ($fxu< a-id len)))
                                      ($invalid-ftype-index 'info a-id)))
                                  ...
                                  #,(cond
                                      [(ftd-base? ftd)
                                       (let ([type (filter-foreign-type (ftd-base-type ftd))])
                                         (unless (memq type
                                                   (constant-case ptr-bits
                                                     [(64) '(unsigned-64 integer-64)]
                                                     [(32) '(unsigned-32 integer-32)]))
                                           (syntax-error q "locked operation on non-integer or non-word-size field unsupported"))
                                         (when (ftd-base-swap? ftd)
                                           (syntax-error q "locked operation on swapped field unsupported"))
                                         #`(($primitive 3 #,prim) #,fptr-expr #,offset))]
                                      [else (syntax-error q "locked operation on non-base-type field unsupported")])))))))))))
        (syntax-case q ()
          [(_ ftype (a ...) fptr-expr)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr 0)]
          [(_ ftype (a ...) fptr-expr ?idx)
           (identifier? #'ftype)
           (trans #'ftype #'(a ...) #'fptr-expr #'?idx)])))
    (set! $trans-ftype-guardian
      (lambda (q)
        (lambda (r)
          (syntax-case q ()
            [(_ ftype)
             (identifier? #'ftype)
             (let ([ftd (expand-ftype-name r #'ftype)])
               (unless (let lockable? ([ftd ftd])
                         (cond
                           [(ftd-base? ftd)
                            (let ([type (filter-foreign-type (ftd-base-type ftd))])
                              (and (memq type
                                     (constant-case ptr-bits
                                       [(64) '(unsigned-64 integer-64)]
                                       [(32) '(unsigned-32 integer-32)]))
                                   (not (ftd-base-swap? ftd))))]
                           [(ftd-struct? ftd)
                            (let ([ls (ftd-struct-field* ftd)])
                              (if (null? ls)
                                  #f
                                  (lockable? (caddr (car ls)))))]
                           [(ftd-union? ftd) (ormap lockable? (map cdr (ftd-union-field* ftd)))]
                           [(ftd-array? ftd) (lockable? (ftd-array-ftd ftd))]
                           [else #f]))
                 (syntax-error q "first field must be a word-sized integer with native endianness"))
               #`(($primitive #,(if (fx= (optimize-level) 3) 3 2) $make-ftype-guardian) '#,ftd))])))))
 ; procedural entry point for inspector to simplify bootstrapping
  (set! $ftype-pointer? (lambda (x) ($fptr? x)))
  (set! $make-fptr
    (lambda (ftd addr)
      (#2%$make-fptr ftd addr)))
  (set! $fptr-offset-addr
    (lambda (fptr offset)
      (#3%$fptr-offset-addr fptr offset)))
  (set! $fptr-&ref
    (lambda (fptr offset ftd)
      (#3%$fptr-&ref fptr offset ftd)))
  (set! $fptr-fptr-ref
    (lambda (fptr offset ftd)
      (#3%$fptr-fptr-ref fptr offset ftd)))

  (set! $fptr-ref-integer-8
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-8 fptr offset)))
  (set! $fptr-ref-unsigned-8
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-8 fptr offset)))

  (set! $fptr-ref-integer-16
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-16 fptr offset)))
  (set! $fptr-ref-unsigned-16
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-16 fptr offset)))
  (set! $fptr-ref-swap-integer-16
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-16 fptr offset)))
  (set! $fptr-ref-swap-unsigned-16
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-16 fptr offset)))

  (set! $fptr-ref-integer-24
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-24 fptr offset)))
  (set! $fptr-ref-unsigned-24
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-24 fptr offset)))
  (set! $fptr-ref-swap-integer-24
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-24 fptr offset)))
  (set! $fptr-ref-swap-unsigned-24
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-24 fptr offset)))

  (set! $fptr-ref-integer-32
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-32 fptr offset)))
  (set! $fptr-ref-unsigned-32
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-32 fptr offset)))
  (set! $fptr-ref-swap-integer-32
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-32 fptr offset)))
  (set! $fptr-ref-swap-unsigned-32
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-32 fptr offset)))

  (set! $fptr-ref-integer-40
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-40 fptr offset)))
  (set! $fptr-ref-unsigned-40
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-40 fptr offset)))
  (set! $fptr-ref-swap-integer-40
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-40 fptr offset)))
  (set! $fptr-ref-swap-unsigned-40
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-40 fptr offset)))

  (set! $fptr-ref-integer-48
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-48 fptr offset)))
  (set! $fptr-ref-unsigned-48
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-48 fptr offset)))
  (set! $fptr-ref-swap-integer-48
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-48 fptr offset)))
  (set! $fptr-ref-swap-unsigned-48
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-48 fptr offset)))

  (set! $fptr-ref-integer-56
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-56 fptr offset)))
  (set! $fptr-ref-unsigned-56
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-56 fptr offset)))
  (set! $fptr-ref-swap-integer-56
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-56 fptr offset)))
  (set! $fptr-ref-swap-unsigned-56
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-56 fptr offset)))

  (set! $fptr-ref-integer-64
    (lambda (fptr offset)
      (#3%$fptr-ref-integer-64 fptr offset)))
  (set! $fptr-ref-unsigned-64
    (lambda (fptr offset)
      (#3%$fptr-ref-unsigned-64 fptr offset)))
  (set! $fptr-ref-swap-integer-64
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-integer-64 fptr offset)))
  (set! $fptr-ref-swap-unsigned-64
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-unsigned-64 fptr offset)))

  (set! $fptr-ref-double-float
    (lambda (fptr offset)
      (#3%$fptr-ref-double-float fptr offset)))
  (set! $fptr-ref-swap-double-float
    (lambda (fptr offset)
      (constant-case ptr-bits
        [(64) (#3%$fptr-ref-swap-double-float fptr offset)]
        [(32) (let ([bv (make-bytevector 8)])
                (bytevector-u64-set! bv 0
                  (foreign-ref 'unsigned-64 ($ftype-pointer-address fptr) offset)
                  (if (eq? (constant native-endianness) 'big) 'little 'big))
                ($object-ref 'double-float bv (constant bytevector-data-disp)))])))
    
  (set! $fptr-ref-single-float
    (lambda (fptr offset)
      (#3%$fptr-ref-single-float fptr offset)))
  (set! $fptr-ref-swap-single-float
    (lambda (fptr offset)
      (constant-case ptr-bits
        [(64) (#3%$fptr-ref-swap-single-float fptr offset)]
        [(32) (let ([bv (make-bytevector 4)])
                (bytevector-u32-set! bv 0
                  (foreign-ref 'unsigned-32 ($ftype-pointer-address fptr) offset)
                  (if (eq? (constant native-endianness) 'big) 'little 'big))
                ($object-ref 'single-float bv (constant bytevector-data-disp)))])))
    
  (set! $fptr-ref-char
    (lambda (fptr offset)
      (#3%$fptr-ref-char fptr offset)))

  (set! $fptr-ref-wchar
    (lambda (fptr offset)
      (#3%$fptr-ref-wchar fptr offset)))
  (set! $fptr-ref-swap-wchar
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-wchar fptr offset)))

  (set! $fptr-ref-boolean
    (lambda (fptr offset)
      (#3%$fptr-ref-boolean fptr offset)))
  (set! $fptr-ref-swap-boolean
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-boolean fptr offset)))

  (set! $fptr-ref-fixnum
    (lambda (fptr offset)
      (#3%$fptr-ref-fixnum fptr offset)))
  (set! $fptr-ref-swap-fixnum
    (lambda (fptr offset)
      (#3%$fptr-ref-swap-fixnum fptr offset)))

  (set-who! $fptr-ref
    (lambda (ty swap? fptr offset)
      (define-syntax proc
        (lambda (x)
          (syntax-case x (scheme-object)
            [(_ scheme-object bytes pred) #'($oops who "unexpected type ~s" ty)]
            [(_ type bytes pred)
             (if (memq (datum type) '(char integer-8 unsigned-8))
                 (datum->syntax #'*
                   (string->symbol
                     (format "$fptr-ref-~a" (datum type))))
                 #`(if swap?
                       #,(datum->syntax #'*
                           (string->symbol
                             (format "$fptr-ref-swap-~a" (datum type))))
                       #,(datum->syntax #'*
                           (string->symbol
                             (format "$fptr-ref-~a" (datum type))))))])))
        ((record-datatype cases ty proc
           ($oops who "unrecognized type ~s" ty))
         fptr offset)))

  (set-who! $fptr-fptr-set!
    (lambda (fptr offset val)
      (#3%$fptr-fptr-set! fptr offset val)))

  (let ()
    (define invalid-value
      (lambda (info val)
        ($source-violation 'ftype-set! (src-info-src info) #t
          "invalid value ~s for type ~s" val (field-info-type info))))
    (set! $fptr-set-integer-8!
      (lambda (info fptr offset val)
        (unless ($integer-8? val) (invalid-value info val))
        (#3%$fptr-set-integer-8! info fptr offset val)))
    (set! $fptr-set-unsigned-8!
      (lambda (info fptr offset val)
        (unless ($integer-8? val) (invalid-value info val))
        (#3%$fptr-set-unsigned-8! info fptr offset val)))

    (set! $fptr-set-integer-16!
      (lambda (info fptr offset val)
        (unless ($integer-16? val) (invalid-value info val))
        (#3%$fptr-set-integer-16! info fptr offset val)))
    (set! $fptr-set-unsigned-16!
      (lambda (info fptr offset val)
        (unless ($integer-16? val) (invalid-value info val))
        (#3%$fptr-set-unsigned-16! info fptr offset val)))
    (set! $fptr-set-swap-integer-16!
      (lambda (info fptr offset val)
        (unless ($integer-16? val) (invalid-value info val))
        (#3%$fptr-set-swap-integer-16! info fptr offset val)))
    (set! $fptr-set-swap-unsigned-16!
      (lambda (info fptr offset val)
        (unless ($integer-16? val) (invalid-value info val))
        (#3%$fptr-set-swap-unsigned-16! info fptr offset val)))

    (set! $fptr-set-integer-24!
      (lambda (info fptr offset val)
        (unless ($integer-24? val) (invalid-value info val))
        (#3%$fptr-set-integer-24! info fptr offset val)))
    (set! $fptr-set-unsigned-24!
      (lambda (info fptr offset val)
        (unless ($integer-24? val) (invalid-value info val))
        (#3%$fptr-set-unsigned-24! info fptr offset val)))
    (set! $fptr-set-swap-integer-24!
      (lambda (info fptr offset val)
        (unless ($integer-24? val) (invalid-value info val))
        (#3%$fptr-set-swap-integer-24! info fptr offset val)))
    (set! $fptr-set-swap-unsigned-24!
      (lambda (info fptr offset val)
        (unless ($integer-24? val) (invalid-value info val))
        (#3%$fptr-set-swap-unsigned-24! info fptr offset val)))

    (set! $fptr-set-integer-32!
      (lambda (info fptr offset val)
        (unless ($integer-32? val) (invalid-value info val))
        (#3%$fptr-set-integer-32! info fptr offset val)))
    (set! $fptr-set-unsigned-32!
      (lambda (info fptr offset val)
        (unless ($integer-32? val) (invalid-value info val))
        (#3%$fptr-set-unsigned-32! info fptr offset val)))
    (set! $fptr-set-swap-integer-32!
      (lambda (info fptr offset val)
        (unless ($integer-32? val) (invalid-value info val))
        (#3%$fptr-set-swap-integer-32! info fptr offset val)))
    (set! $fptr-set-swap-unsigned-32!
      (lambda (info fptr offset val)
        (unless ($integer-32? val) (invalid-value info val))
        (#3%$fptr-set-swap-unsigned-32! info fptr offset val)))

    (set! $fptr-set-integer-40!
      (lambda (info fptr offset val)
        (unless ($integer-40? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-integer-40! info fptr offset val)]
          [(32) (foreign-set! 'integer-40 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-unsigned-40!
      (lambda (info fptr offset val)
        (unless ($integer-40? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-unsigned-40! info fptr offset val)]
          [(32) (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-swap-integer-40!
      (lambda (info fptr offset val)
        (unless ($integer-40? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-integer-40! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'integer-40 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset
                    (bytevector-u40-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))
    (set! $fptr-set-swap-unsigned-40!
      (lambda (info fptr offset val)
        (unless ($integer-40? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-unsigned-40! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'unsigned-40 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset
                    (bytevector-u40-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))

    (set! $fptr-set-integer-48!
      (lambda (info fptr offset val)
        (unless ($integer-48? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-integer-48! info fptr offset val)]
          [(32) (foreign-set! 'integer-48 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-unsigned-48!
      (lambda (info fptr offset val)
        (unless ($integer-48? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-unsigned-48! info fptr offset val)]
          [(32) (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-swap-integer-48!
      (lambda (info fptr offset val)
        (unless ($integer-48? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-integer-48! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'integer-48 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset
                    (bytevector-u48-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))
    (set! $fptr-set-swap-unsigned-48!
      (lambda (info fptr offset val)
        (unless ($integer-48? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-unsigned-48! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'unsigned-48 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset
                    (bytevector-u48-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))

    (set! $fptr-set-integer-56!
      (lambda (info fptr offset val)
        (unless ($integer-56? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-integer-56! info fptr offset val)]
          [(32) (foreign-set! 'integer-56 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-unsigned-56!
      (lambda (info fptr offset val)
        (unless ($integer-56? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-unsigned-56! info fptr offset val)]
          [(32) (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-swap-integer-56!
      (lambda (info fptr offset val)
        (unless ($integer-56? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-integer-56! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'integer-56 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset
                    (bytevector-u56-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))
    (set! $fptr-set-swap-unsigned-56!
      (lambda (info fptr offset val)
        (unless ($integer-56? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-unsigned-56! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'unsigned-56 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset
                    (bytevector-u56-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))

    (set! $fptr-set-integer-64!
      (lambda (info fptr offset val)
        (unless ($integer-64? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-integer-64! info fptr offset val)]
          [(32) (foreign-set! 'integer-64 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-unsigned-64!
      (lambda (info fptr offset val)
        (unless ($integer-64? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-unsigned-64! info fptr offset val)]
          [(32) (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset val)])))
    (set! $fptr-set-swap-integer-64!
      (lambda (info fptr offset val)
        (unless ($integer-64? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-integer-64! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'integer-64 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset
                    (bytevector-u64-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))
    (set! $fptr-set-swap-unsigned-64!
      (lambda (info fptr offset val)
        (unless ($integer-64? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-unsigned-64! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'unsigned-64 bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset
                    (bytevector-u64-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))

    (set! $fptr-set-double-float!
      (lambda (info fptr offset val)
        (unless (flonum? val) (invalid-value info val))
        (#3%$fptr-set-double-float! info fptr offset val)))
    (set! $fptr-set-swap-double-float!
      (lambda (info fptr offset val)
        (unless (flonum? val) (invalid-value info val))
        (constant-case ptr-bits
          [(64) (#3%$fptr-set-swap-double-float! info fptr offset val)]
          [(32) (let ([bv (make-bytevector 8)])
                  ($object-set! 'double-float bv (constant bytevector-data-disp) val)
                  (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset
                    (bytevector-u64-ref bv 0
                      (if (eq? (constant native-endianness) 'big) 'little 'big))))])))

    (set! $fptr-set-single-float!
      (lambda (info fptr offset val)
        (unless (flonum? val) (invalid-value info val))
        (#3%$fptr-set-single-float! info fptr offset val)))
    (set! $fptr-set-swap-single-float!
      (lambda (info fptr offset val)
        (unless (flonum? val) (invalid-value info val))
        (let ([bv (make-bytevector 4)])
          ($object-set! 'single-float bv (constant bytevector-data-disp) val)
          (foreign-set! 'unsigned-32 ($ftype-pointer-address fptr) offset
            (bytevector-u32-ref bv 0
              (if (eq? (constant native-endianness) 'big) 'little 'big))))))

    (set! $fptr-set-char!
      (lambda (info fptr offset val)
        (unless (char? val) (invalid-value info val))
        (#3%$fptr-set-char! info fptr offset val)))

    (set! $fptr-set-wchar!
      (lambda (info fptr offset val)
        (unless (char? val) (invalid-value info val))
        (#3%$fptr-set-wchar! info fptr offset val)))
    (set! $fptr-set-swap-wchar!
      (lambda (info fptr offset val)
        (unless (char? val) (invalid-value info val))
        (#3%$fptr-set-swap-wchar! info fptr offset val)))

    (set! $fptr-set-boolean!
      (lambda (info fptr offset val)
        (#3%$fptr-set-boolean! info fptr offset val)))
    (set! $fptr-set-swap-boolean!
      (lambda (info fptr offset val)
        (#3%$fptr-set-swap-boolean! info fptr offset val)))

    (set! $fptr-set-fixnum!
      (lambda (info fptr offset val)
        (unless (fixnum? val) (invalid-value info val))
        (#3%$fptr-set-fixnum! info fptr offset val)))
    (set! $fptr-set-swap-fixnum!
      (lambda (info fptr offset val)
        (unless (fixnum? val) (invalid-value info val))
        (#3%$fptr-set-swap-fixnum! info fptr offset val)))
    )

  (set-who! $fptr-set!
    (lambda (orig-type ty swap? fptr offset val)
      (define-syntax proc
        (lambda (x)
          (syntax-case x (scheme-object)
            [(_ scheme-object bytes pred) #'($oops who "unexpected type ~s" ty)]
            [(_ type bytes pred)
             (if (memq (datum type) '(char integer-8 unsigned-8))
                 #`($primitive 2
                     #,(datum->syntax #'*
                         (string->symbol
                           (format "$fptr-set-~a!" (datum type)))))
                 #`(if swap?
                       ($primitive 2
                         #,(datum->syntax #'*
                             (string->symbol
                               (format "$fptr-set-swap-~a!" (datum type)))))
                       ($primitive 2
                         #,(datum->syntax #'*
                             (string->symbol
                               (format "$fptr-set-~a!" (datum type)))))))])))
      ((record-datatype cases ty proc
         ($oops who "unrecognized type ~s" ty))
       orig-type fptr offset val)))

  (let ()
    (define-syntax $fptr-ref-ibits
      (lambda (x)
        (syntax-case x ()
          [(kwd k swap?)
           (with-syntax ([$fptr-ref-x (datum->syntax #'kwd
                                        (string->symbol
                                          (format "$fptr-ref-~:[~;swap-~]unsigned-~a"
                                            (datum swap?)
                                            (datum k))))])
             (if (<= (expt 2 (datum k)) (constant most-positive-fixnum))
                 #'(lambda (fptr offset start end)
                     (let ([radix (fxsll 1 (fx- end start))])
                       (let ([n (fxlogand
                                  (fxsra ($fptr-ref-x fptr offset) start)
                                  (fx- radix 1))])
                         (if (fx>= n (fxsra radix 1)) (fx- n radix) n))))
                 #'(lambda (fptr offset start end)
                     (let ([radix (bitwise-arithmetic-shift-left 1 (fx- end start))])
                       (let ([n (logand
                                  (bitwise-arithmetic-shift-right
                                    ($fptr-ref-x fptr offset)
                                    start)
                                  (- radix 1))])
                         (if (>= n (bitwise-arithmetic-shift-right radix 1))
                             (- n radix)
                             n))))))])))
    (set! $fptr-ref-ibits-unsigned-8 ($fptr-ref-ibits 8 #f))
    (set! $fptr-ref-ibits-swap-unsigned-16 ($fptr-ref-ibits 16 #t))
    (set! $fptr-ref-ibits-unsigned-16 ($fptr-ref-ibits 16 #f))
    (set! $fptr-ref-ibits-swap-unsigned-24 ($fptr-ref-ibits 24 #t))
    (set! $fptr-ref-ibits-unsigned-24 ($fptr-ref-ibits 24 #f))
    (set! $fptr-ref-ibits-swap-unsigned-32 ($fptr-ref-ibits 32 #t))
    (set! $fptr-ref-ibits-unsigned-32 ($fptr-ref-ibits 32 #f))
    (set! $fptr-ref-ibits-swap-unsigned-40 ($fptr-ref-ibits 40 #t))
    (set! $fptr-ref-ibits-unsigned-40 ($fptr-ref-ibits 40 #f))
    (set! $fptr-ref-ibits-swap-unsigned-48 ($fptr-ref-ibits 48 #t))
    (set! $fptr-ref-ibits-unsigned-48 ($fptr-ref-ibits 48 #f))
    (set! $fptr-ref-ibits-swap-unsigned-56 ($fptr-ref-ibits 56 #t))
    (set! $fptr-ref-ibits-unsigned-56 ($fptr-ref-ibits 56 #f))
    (set! $fptr-ref-ibits-swap-unsigned-64 ($fptr-ref-ibits 64 #t))
    (set! $fptr-ref-ibits-unsigned-64 ($fptr-ref-ibits 64 #f)))

  (let ()
    (define-syntax $fptr-ref-ubits
      (lambda (x)
        (syntax-case x ()
          [(kwd k swap?)
           (with-syntax ([$fptr-ref-x (datum->syntax #'kwd
                                        (string->symbol
                                          (format "$fptr-ref-~:[~;swap-~]unsigned-~a"
                                            (datum swap?)
                                            (datum k))))])
             (if (<= (expt 2 (datum k)) (constant most-positive-fixnum))
                 #'(lambda (fptr offset start end)
                     (let ([radix (fxsll 1 (fx- end start))])
                       (fxlogand
                         (fxsrl ($fptr-ref-x fptr offset) start)
                         (fx- radix 1))))
                 #'(lambda (fptr offset start end)
                     (let ([radix (bitwise-arithmetic-shift-left 1 (fx- end start))])
                       (logand
                         (bitwise-arithmetic-shift-right ($fptr-ref-x fptr offset) start)
                         (- radix 1))))))])))
    (set! $fptr-ref-ubits-unsigned-8 ($fptr-ref-ubits 8 #f))
    (set! $fptr-ref-ubits-swap-unsigned-16 ($fptr-ref-ubits 16 #t))
    (set! $fptr-ref-ubits-unsigned-16 ($fptr-ref-ubits 16 #f))
    (set! $fptr-ref-ubits-swap-unsigned-24 ($fptr-ref-ubits 24 #t))
    (set! $fptr-ref-ubits-unsigned-24 ($fptr-ref-ubits 24 #f))
    (set! $fptr-ref-ubits-swap-unsigned-32 ($fptr-ref-ubits 32 #t))
    (set! $fptr-ref-ubits-unsigned-32 ($fptr-ref-ubits 32 #f))
    (set! $fptr-ref-ubits-swap-unsigned-40 ($fptr-ref-ubits 40 #t))
    (set! $fptr-ref-ubits-unsigned-40 ($fptr-ref-ubits 40 #f))
    (set! $fptr-ref-ubits-swap-unsigned-48 ($fptr-ref-ubits 48 #t))
    (set! $fptr-ref-ubits-unsigned-48 ($fptr-ref-ubits 48 #f))
    (set! $fptr-ref-ubits-swap-unsigned-56 ($fptr-ref-ubits 56 #t))
    (set! $fptr-ref-ubits-unsigned-56 ($fptr-ref-ubits 56 #f))
    (set! $fptr-ref-ubits-swap-unsigned-64 ($fptr-ref-ubits 64 #t))
    (set! $fptr-ref-ubits-unsigned-64 ($fptr-ref-ubits 64 #f)))

  (set-who! $fptr-ref-bits
    (lambda (ty swap? signed? fptr offset start end)
      (define-syntax proc
        (lambda (x)
          (syntax-case x ()
            [(_ type)
             (if (memq (datum type) '(char integer-8 unsigned-8))
                 #`(if signed?
                       #,(datum->syntax #'*
                           (string->symbol
                             (format "$fptr-ref-ibits-~a" (datum type))))
                       #,(datum->syntax #'*
                           (string->symbol
                             (format "$fptr-ref-ubits-~a" (datum type)))))
                 #`(if swap?
                       (if signed?
                           #,(datum->syntax #'*
                               (string->symbol
                                 (format "$fptr-ref-ibits-swap-~a" (datum type))))
                           #,(datum->syntax #'*
                               (string->symbol
                                 (format "$fptr-ref-ubits-swap-~a" (datum type)))))
                       (if signed?
                           #,(datum->syntax #'*
                               (string->symbol
                                 (format "$fptr-ref-ibits-~a" (datum type))))
                           #,(datum->syntax #'*
                               (string->symbol
                                 (format "$fptr-ref-ubits-~a" (datum type)))))))])))
        ((case ty
           [(unsigned-8) (proc unsigned-8)]
           [(unsigned-16) (proc unsigned-16)]
           [(unsigned-32) (proc unsigned-32)]
           [(unsigned-64) (proc unsigned-64)]
           [else ($oops who "unexpected type ~s" ty)])
         fptr offset start end)))

  (let ()
    (define-syntax $fptr-set-bits!
      (lambda (x)
        (syntax-case x ()
          [(kwd k swap?)
           (with-syntax ([orig-type (datum->syntax #'kwd
                                      (string->symbol
                                        (format "unsigned-~a" (datum k))))]
                         [$fptr-ref-x (datum->syntax #'kwd
                                        (string->symbol
                                          (format "$fptr-ref-~:[~;swap-~]unsigned-~a"
                                            (datum swap?)
                                            (datum k))))]
                         [$fptr-set-x! (datum->syntax #'kwd
                                         (string->symbol
                                           (format "$fptr-set-~:[~;swap-~]unsigned-~a!"
                                             (datum swap?)
                                             (datum k))))])
             (if (<= (expt 2 (datum k)) (constant most-positive-fixnum))
                 #'(lambda (fptr offset start end val)
                     (let* ([size (fx- end start)]
                            [radix (fxsll 1 size)]
                            [radix/2 (fxsrl radix 1)])
                       (unless (and (integer? val) (exact? val) (>= val (- radix/2)) (< val radix))
                         ($oops 'ftype-set! "invalid value ~s for bit field of size ~s" val size))
                       ($fptr-set-x! 'orig-type fptr offset
                         (fxlogor
                           (fxlogand
                             ($fptr-ref-x fptr offset)
                             (fxlognot (fxsll (- radix 1) start)))
                           (fxsll
                             (if (fx< val 0) (fx+ val radix) val)
                             start)))))
                 #'(lambda (fptr offset start end val)
                     (let* ([size (fx- end start)]
                            [radix (bitwise-arithmetic-shift-left 1 size)]
                            [radix/2 (bitwise-arithmetic-shift-right radix 1)])
                       (unless (and (integer? val) (exact? val) (>= val (- radix/2)) (< val radix))
                         ($oops 'ftype-set! "invalid value ~s for bit field of size ~s" val size))
                       ($fptr-set-x! 'orig-type fptr offset
                         (logor
                           (logand
                             ($fptr-ref-x fptr offset)
                             (lognot (bitwise-arithmetic-shift-left (- radix 1) start)))
                           (bitwise-arithmetic-shift-left
                             (if (< val 0) (+ val radix) val)
                             start)))))))])))
    (set! $fptr-set-bits-unsigned-8! ($fptr-set-bits! 8 #f))
    (set! $fptr-set-bits-swap-unsigned-16! ($fptr-set-bits! 16 #t))
    (set! $fptr-set-bits-unsigned-16! ($fptr-set-bits! 16 #f))
    (set! $fptr-set-bits-swap-unsigned-24! ($fptr-set-bits! 24 #t))
    (set! $fptr-set-bits-unsigned-24! ($fptr-set-bits! 24 #f))
    (set! $fptr-set-bits-swap-unsigned-32! ($fptr-set-bits! 32 #t))
    (set! $fptr-set-bits-unsigned-32! ($fptr-set-bits! 32 #f))
    (set! $fptr-set-bits-swap-unsigned-40! ($fptr-set-bits! 40 #t))
    (set! $fptr-set-bits-unsigned-40! ($fptr-set-bits! 40 #f))
    (set! $fptr-set-bits-swap-unsigned-48! ($fptr-set-bits! 48 #t))
    (set! $fptr-set-bits-unsigned-48! ($fptr-set-bits! 48 #f))
    (set! $fptr-set-bits-swap-unsigned-56! ($fptr-set-bits! 56 #t))
    (set! $fptr-set-bits-unsigned-56! ($fptr-set-bits! 56 #f))
    (set! $fptr-set-bits-swap-unsigned-64! ($fptr-set-bits! 64 #t))
    (set! $fptr-set-bits-unsigned-64! ($fptr-set-bits! 64 #f)))

  (set-who! $fptr-set-bits!
    (lambda (ty swap? fptr offset start end val)
      (define-syntax proc
        (lambda (x)
          (syntax-case x ()
            [(_ type)
             (if (memq (datum type) '(char integer-8 unsigned-8))
                 (datum->syntax #'*
                   (string->symbol
                     (format "$fptr-set-bits-~a!" (datum type))))
                 #`(if swap?
                       ($primitive 2
                         #,(datum->syntax #'*
                             (string->symbol
                               (format "$fptr-set-bits-swap-~a!" (datum type)))))
                       ($primitive 2
                         #,(datum->syntax #'*
                             (string->symbol
                               (format "$fptr-set-bits-~a!" (datum type)))))))])))
        ((case ty
           [(unsigned-8) (proc unsigned-8)]
           [(unsigned-16) (proc unsigned-16)]
           [(unsigned-32) (proc unsigned-32)]
           [(unsigned-64) (proc unsigned-64)]
           [else ($oops who "unexpected type ~s" ty)])
         fptr offset start end val)))

  (set! $fptr-locked-incr!
    (lambda (fptr offset)
      (#3%$fptr-locked-incr! fptr offset)))

  (set! $fptr-locked-decr!
    (lambda (fptr offset)
      (#3%$fptr-locked-decr! fptr offset)))

  (set! $fptr-init-lock!
    (lambda (fptr offset)
      (#3%$fptr-init-lock! fptr offset)))

  (set! $fptr-lock!
    (lambda (fptr offset)
      (#3%$fptr-lock! fptr offset)))

  (set! $fptr-spin-lock!
    (lambda (fptr offset)
      (#3%$fptr-spin-lock! fptr offset)))

  (set! $fptr-unlock!
    (lambda (fptr offset)
      (#3%$fptr-unlock! fptr offset)))
)

(define-syntax define-ftype (lambda (x) ($trans-define-ftype x)))
(define-syntax make-ftype-pointer (lambda (x) ($trans-make-ftype-pointer x)))
(define-syntax ftype-pointer? (lambda (x) ($trans-ftype-pointer? x)))
(define-syntax ftype-sizeof (lambda (x) ($trans-ftype-sizeof x)))
(define-syntax ftype-guardian (lambda (x) ($trans-ftype-guardian x)))
(define-syntax ftype-&ref (lambda (x) ($trans-ftype-&ref x)))
(define-syntax ftype-ref (lambda (x) ($trans-ftype-ref x)))
(define-syntax ftype-locked-incr! (lambda (x) ($trans-ftype-locked-op! #'ftype-locked-incr! x #'$fptr-locked-incr!)))
(define-syntax ftype-locked-decr! (lambda (x) ($trans-ftype-locked-op! #'ftype-locked-decr! x #'$fptr-locked-decr!)))
(define-syntax ftype-init-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-init-lock! x #'$fptr-init-lock!)))
(define-syntax ftype-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-lock! x #'$fptr-lock!)))
(define-syntax ftype-spin-lock! (lambda (x) ($trans-ftype-locked-op! #'ftype-spin-lock! x #'$fptr-spin-lock!)))
(define-syntax ftype-unlock! (lambda (x) ($trans-ftype-locked-op! #'ftype-unlock! x #'$fptr-unlock!)))
(define-syntax ftype-set! (lambda (x) ($trans-ftype-set! x)))
)
