#| -*-Scheme-*-

Copyright (C) 2013 Taylor R Campbell

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Portable fasdumper
;;; package: (runtime portable-fasdump)

(declare (usual-integrations))

;;;; Fasdump formats

(define-structure (fasdump-format
                   (conc-name format.)
                   (keyword-constructor make-fasdump-format))
  (architecture #f read-only #t)
  (version #f read-only #t)
  (bits-per-type #f read-only #t)
  (bits-per-datum #f read-only #t)
  (bits-per-byte #f read-only #t)
  (bytes-per-word #f read-only #t)
  (words-per-float #f read-only #t)
  (greatest-fixnum #f read-only #t)
  (least-fixnum #f read-only #t)
  (write-word #f read-only #t)
  (write-float #f read-only #t))

(define (make-std-fasdump-format architecture
                                 bytes-per-word
                                 write-word
                                 write-bignum-digit
                                 write-float)
  (make-fasdump-format
   'VERSION             10              ;FASL_VERSION_C_CODE
   'ARCHITECTURE        architecture
   'BITS-PER-TYPE       6
   'BITS-PER-DATUM      (- (* bytes-per-word 8) 6)
   'BITS-PER-BYTE       8
   'BYTES-PER-WORD      bytes-per-word
   'WORDS-PER-FLOAT     (/ 8 bytes-per-word)
   'GREATEST-FIXNUM     (bitwise-not (shift-left -1 (* bytes-per-word 8)))
   'LEAST-FIXNUM        (shift-left -1 (* bytes-per-word 8))
   'WRITE-WORD          write-word
   'WRITE-BIGNUM-DIGIT  write-bignum-digit
   'WRITE-FLOAT         write-float))

(define (make-std32be-fasdump-format architecture bytes-per-word)
  (make-std-fasdump-format architecture
                           bytes-per-word
                           write-std32be-word
                           write-std32be-bignum-digit
                           write-ieee754-double-be))

(define (make-std32le-fasdump-format architecture bytes-per-word)
  (make-std-fasdump-format architecture
                           bytes-per-word
                           write-std32le-word
                           write-std32le-bignum-digit
                           write-ieee754-double-le))

(define (make-std64be-fasdump-format architecture bytes-per-word)
  (make-std-fasdump-format architecture
                           bytes-per-word
                           write-std64be-word
                           write-std64be-bignum-digit
                           write-ieee754-double-be))

(define (make-std64le-fasdump-format architecture bytes-per-word)
  (make-std-fasdump-format architecture
                           bytes-per-word
                           write-std64le-word
                           write-std64le-bignum-digit
                           write-ieee754-double-le))

;;;; Bits

(define (write-std32be-word type datum output-port)
  (write-std32-word type datum write-be-halves output-port))

(define (write-std32le-word type datum output-port)
  (write-std32-word type datum write-le-halves output-port))

(define (write-std64be-word type datum output-port)
  (write-std64-word type datum write-be-halves output-port))

(define (write-std64le-word type datum output-port)
  (write-std64-word type datum write-le-halves output-port))

(define (write-std32-word type datum write-halves output-port)
  (assert (<= 0 type #x3f))
  (assert (zero? (shiftout datum #xfc000000)))
  (let ((high (shiftout datum #x03ff0000))
        (low  (shiftout datum #x0000ffff)))
    (let ((high
           (bitwise-ior (shiftin type #xfc00)
                        (shiftin high #x003f))))
      (write-halves write-halves write-16 low high output-port))))

(define (write-std64-word type datum write-halves output-port)
  (assert (<= 0 type #x3f))
  (assert (zero? (shiftout datum #xfc00000000000000)))
  (let ((high (shiftout datum #x03ffffff00000000))
        (low  (shiftout datum #x00000000ffffffff)))
    (let ((high
           (bitwise-ior (shiftin type #xfc000000)
                        (shiftin high #x03ffffff))))
      (write-halves write-halves write-32 low high output-port))))

(define (write-std32le-bignum-digit digit output-port)
  (write-32 write-le-halves digit output-port))

(define (write-std32be-bignum-digit digit output-port)
  (write-32 write-be-halves digit output-port))

(define (write-std64le-bignum-digit digit output-port)
  (write-64 write-le-halves digit output-port))

(define (write-std32le-bignum-digit digit output-port)
  (write-64 write-be-halves digit output-port))

(define (write-halves* write-halves write-half bits mask n output-port)
  (assert (< 0 bits))
  (assert (= mask (bit-mask bits 0)))
  (let ((low (bitwise-and n mask))
        (high (bitwise-and (shift-right n bits) mask)))
    (write-halves write-halves write-half low high output-port)))

(define (write-le-halves write-halves write-half low high output-port)
  (write-half write-halves low output-port)
  (write-half write-halves high output-port))

(define (write-be-halves write-halves write-half low high output-port)
  (write-half write-halves low output-port)
  (write-half write-halves high output-port))

(define (write-64 write-halves n output-port)
  (write-halves* write-halves write-32 32 #xfffffffff n output-port))

(define (write-32 write-halves n output-port)
  (write-halves* write-halves write-16 16 #xffff n output-port))

(define (write-16 write-halves n output-port)
  (write-halves* write-halves write-8 8 #xff n output-port))

(define (write-8 write-halves n output-port)
  (write-octet n output-port))

;;;;; Floating bits

(define (write-ieee754-double-be x output-port)
  (write-ieee754-double write-be-halves x output-port))

(define (write-ieee754-double-le x output-port)
  (write-ieee754-double write-le-halves x output-port))

(define (write-ieee754-double write-halves x output-port)
  (receive (sign exponent significand) (decompose-ieee754-double x)
    (let ((low  (shiftout significand #xffffffff))
          (high (shiftout significand #x000fffff)))
      (let ((sign&exponent
             (bitwise-ior (shiftin sign     #x80000000)
                          (shiftin exponent #x7ff00000))))
        (let ((high (bitwise-ior high sign&exponent)))
          (write-halves write-halves low high output-port))))))

(define (decompose-ieee754-double x)
  (cond ((not (= x x))
         ;; There are, of course, 2^53 different NaNs.  There is no
         ;; obvious way to computationally detect the sign of a NaN,
         ;; and no standard way to get at the significand bits, so
         ;; we'll just canonicalize everything to an arbitrary choice
         ;; of NaN with nonnegative sign and significand all bits one.
         (values 0 (- #x7ff 1023) #xfffffffffffff))
        ;; The decimal point in (< 1. (abs x)) works around a bug in
        ;; 9.1.1 for reasons I don't understand and am not at present
        ;; terribly keen to figure out.
        ((and (< 1. (abs x)) (= x (/ x 2)))
         (values (if (< x 0.) 1 0) (- #x7ff 1023) 0))
        (else
         (decompose-ieee754-real x 2 1023 53))))

(define (compose-ieee754-double sign exponent significand)
  (assert (exact-integer? sign))
  (assert (exact-integer? exponent))
  (assert (exact-integer? significand))
  (assert (<= 0 sign 1))
  (assert (<= -1023 exponent 1024))
  (assert (<= 0 significand #x1fffffffffffff))
  (assert (or (< -1023 exponent) (<= significand #xfffffffffffff)))
  (if (= exponent 1024)
      (error "Can't compose infinities or NaNs!" sign exponent significand))
  (compose-ieee754-real sign exponent significand 2 1023 53))

(define (ieee754-double-recomposes? x)
  (= x
     (receive (sign exponent significand) (decompose-ieee754-double x)
       (compose-ieee754-double sign exponent significand))))

;;;;; Known formats

(define fasdump-format:i386     (make-std32le-fasdump-format  6))
(define fasdump-format:sparc32  (make-std32le-fasdump-format 14))
(define fasdump-format:mips32be (make-std32be-fasdump-format 15))
(define fasdump-format:mips32le (make-std32le-fasdump-format 15))
(define fasdump-format:alpha    (make-std64le-fasdump-format 18))
(define fasdump-format:ppc32    (make-std32be-fasdump-format 20))
(define fasdump-format:amd64    (make-std64le-fasdump-format 21))
(define fasdump-format:arm32    (make-std32le-fasdump-format 24))

#;
(define fasdump-format:pdp10
  (make-fasdump-format
   'VERSION             10              ;FASL_VERSION_C_CODE
   'ARCHITECTURE        1
   'BITS-PER-TYPE       6
   'BITS-PER-DATUM      30
   'BITS-PER-BYTE       36
   'BYTES-PER-WORD      1
   'WORDS-PER-FLOAT     42              ;XXX
   'GREATEST-FIXNUM     #x1fffffff
   'GREATEST-FIXNUM     #x-20000000
   'WRITE-WORD          write-pdp10-word
   'WRITE-BIGNUM-DIGIT  write-pdp10-bignum-digit
   'WRITE-FLOAT         write-pdp10-float))

;;;; Fasdump top-level

(define-structure (state
                   (conc-name state.)
                   (constructor make-state (format output-port)))
  (format #f read-only #t)
  (output-port #f read-only #t)
  (n-words 0)
  (addresses (make-strong-eqv-hash-table) read-only #t)
  (primitive-name->number (make-string-hash-table) read-only #t)
  (primitives-reversed '())
  (queue (make-queue) read-only #t))

(define (portable-fasdump object pathname format)
  ;; XXX Write to temporary, rename to permanent.
  (call-with-output-file pathname
    (lambda (output-port)
      (let ((state (make-state format output-port)))
        (fasdump-initial-header state)
        (fasdump-object state object)
        (do () ((queue-empty? (state.queue state)))
          (fasdump-storage state (dequeue! (state.queue state))))
        (fasdump-primitive-table state)
        (fasdump-final-header state)))))

(define (fasdump-initial-header state)
  (set-port/position! (state.output-port state) 0)
  ...)

(define (fasdump-final-header state)
  (set-port/position! (state.output-port state) 0)
  ...)

(define (fasdump-word state type datum)
  (let ((format (state.format state)))
    (assert (<= 0 type (bit-mask (format.bits-per-type format) 0)))
    (assert (<= 0 datum (bit-mask (format.bits-per-datum format))))
    ((format.write-word format) type datum (state.output-port state))))

(define (fasdump-float state value)
  (let ((format (state.format state)))
    ((format.write-float format) value (state.output-port state))))

(define (fasdump-string-n-words format string)
  ;; Add a terminating null byte.
  (quotient (+ 1 (string-length string))
            (format.bytes-per-word format)))

(define (fasdump-string state string)
  (let ((format (state.format state)))
    (let ((bytes (string-length string))
          (words (fasdump-string-n-words format string)))
      (let ((zeros (- (* words (format.bytes-per-word format)) bytes)))
        (write-string string output-port)
        (do ((i 0 (+ i 1))) ((>= i n-zeros))
          (write-byte 0 output-port))))))

(define (fasdump-bignum-n-digits format integer)
  (assert (exact-integer? integer))
  (let ((bits-per-digit (format.bits-per-bignum-digit format)))
    ;; There is always one `digit' for the sign/length.
    (let loop ((integer integer) (digits 1))
      (if (zero? integer)
          digits
          (loop (shift-right integer bits-per-digit) (+ digits 1))))))

(define (fasdump-bignum-n-words format integer)
  (assert (exact-integer? integer))
  (let ((words-per-bignum-digit (format.words-per-bignum-digit format))
        (bits-per-word (format.bits-per-word format))
        (n-digits (fasdump-bignum-n-digits format integer)))
    (* (quotient (+ words-per-bignum-digit (- bits-per-word 1)) bits-per-word)
       n-digits)))

(define (fasdump-bignum-digit state digit)
  (let ((format (state.format state)))
    ((format.write-bignum-digit format) digit (state.output-port state))))

(define (fasdump-bignum state integer)
  (let ((n-digits (fasdump-bignum-n-digits format object))
        (shift (format.bits-per-bignum-digit format)))
    (let ((mask (bit-mask shift 0)))
      (assert (<= 0 n-digits))
      (assert (= 0 (bitwise-and n-digits mask)))
      (let ((sign (if (< integer 0) -1 0))
            (magnitude (abs integer)))
        (let ((header (bitwise-ior (shift-left sign shift) n-digits)))
          (fasdump-bignum-digit state header)
          (let loop ((integer integer) (digits 1))
            (if (zero? integer)
                (assert (= digits n-digits))
                (begin (fasdump-bignum-digit state (bitwise-and integer mask))
                       (loop (shift-right integer shift) (+ digits 1))))))))))

(define (fasdump-primitive-table state)
  (for-each (lambda (primitive)
              (fasdump-primitive-table-entry state primitive))
            (reverse (state.primitives-reversed state))))

(define (fasdump-primitive-table-entry state primitive)
  (let ((name (car primitive))
        (arity (cdr primitive)))
    (let ((n-words (fasdump-string-n-words (state.format state) name)))
      (fasdump-word state tc:fixnum arity)
      (fasdump-word state tc:manifest-nm-vector n-words)
      (fasdump-string state name))))

;;;; Fasdumping an object

(define (fasdump-object state object)
  (define (dump type datum)
    (fasdump-word state type datum))
  (fasdump-classify state object
    (lambda (type datum)                ;if-non-pointer
      (dump type datum))
    (lambda (type name arity)           ;if-primitive
      (dump type (get-primitive-number state name arity)))
    (lambda (type n-words alignment)    ;if-pointer
      (dump type (get-object-address state object n-words alignment)))))

(define (get-primitive-number state name arity)
  (let* ((primitive-name->index (state.primitive-name->number state))
         (n (hash-table/count primitive-name->number)))
    (hash-table/intern! primitive-name->number name
      (lambda ()
        (set-state.primitives-reversed!
         state
         (cons (cons name arity) (state.primitives-reversed state)))
        n))))

(define (get-object-address state object n-words alignment)
  (hash-table/intern! (state.addresses state) object
    (lambda ()
      (enqueue! (state.queue state) object)
      (allocate state n-words alignment))))

(define (allocate state n-words alignment)
  (let* ((unaligned-word-address (state.n-words state))
         (aligned-word-address (round-up unaligned-word-address alignment)))
    (set-state.n-words! state (+ aligned-word-address n-words))
    (* aligned-word-address (format.bytes-per-word (state.format state)))))

(define (fasdump-at-address? state address)
  (= address (port/position (state.output-port state))))

;;;;; Object classification

(define (fasdump-classify state object if-non-pointer if-primitive if-pointer)
  (let ((format (state.format state)))
    (cond ((pair? object) (if-pointer tc:list 2 1))
          ((vector? object)
           (if-pointer tc:vector (+ 1 (vector-length object)) 1))
          ((string? object)
           (if-pointer tc:character-string
                       ;; One for the real length, one for the manifest.
                       (+ 2 (fasdump-string-n-words format object))
                       1))
          ((symbol? object)
           (let ((type
                  (if (uninterned-symbol? object)
                      tc:uninterned-symbol
                      tc:interned-symbol)))
             (if-pointer type 2 1)))
          ((primitive? object)
           (if-primitive tc:primitive (primitive-procedure-name object)))
          ((number? object)
           (fasdump-classify/number state object if-non-pointer if-pointer))
          ((scode? object)
           (fasdump-classify/scode state object if-pointer if-non-pointer))
          ((char? object) (if-non-pointer tc:character (char->integer object)))
          ((eqv? object #f) (if-non-pointer tc:null null:false))
          ((eqv? object #t) (if-non-pointer tc:constant constant:true))
          ((eqv? object (unspecific-object))
           (if-non-pointer tc:constant constant:unspecific))
          ((eqv? object (default-object))
           (if-non-pointer tc:constant constant:default))
          ((null? object) (if-non-pointer tc:constant constant:null))
          (else
           (fasdump-error state "Invalid object for fasdump:" object)))))

(define (fasdump-classify/number state object if-non-pointer if-pointer)
  (let ((format (state.format state)))
    (cond ((exact-integer? object)
           (if (and (<= (format.least-fixnum format) object)
                    (<= object (format.greatest-fixnum format)))
               (if-non-pointer tc:fixnum
                               (signed->unsigned (format.bits-per-datum format)
                                                 object))
               (if-pointer tc:big-fixnum
                           (+ 1 (fasdump-bignum-n-words format object))
                           1)))
          ((exact-rational? object) (if-pointer tc:ratnum 2 1))
          ((inexact-real? object)
           (if-pointer tc:big-flonum
                       (fasdump-flonum-n-words format object)
                       (format.words-per-float format)))
          ((complex? object) (if-pointer tc:complex 2 1))
          (else
           (fasdump-error state "Invalid number for fasdump:" object)))))

;;;;;; Scode classification

(define (fasdump-classify/scode state scode if-pointer if-non-pointer)
  (cond ((access? scode) (if-pointer tc:access 2 1))
        ((assignment? scode) (if-pointer tc:assignment 2 1))
        ((combination? scode)
         (if-pointer tc:combination
                     (+ 1 (length (combination-operands scode)))
                     1))
        ((comment? scode) (if-pointer tc:comment 2 1))
        ((conditional? scode) (if-pointer tc:conditional 3 1))
        ((definition? scode) (if-pointer tc:definition 2 1))
        ((delay? scode) (if-pointer tc:delay 1 1))
        ((disjunction? scode) (if-pointer tc:disjunction 2 1))
        ((lambda? scode) (fasdump-classify/lambda state scode if-pointer))
        ((quotation? scode) (if-pointer tc:scode-quote 1 1))
        ((sequence? scode) (if-pointer tc:sequence 2 1))
        ((the-environment? scode) (if-non-pointer tc:the-environment 0))
        ((variable? scode) (if-pointer tc:variable 3 1))
        (else (error "This is not scode!" scode))))

(define (fasdump-classify/lambda state scode if-pointer)
  (lambda-components* scode
    (lambda (name required optional rest body)
      (if (or (pair? optional) rest)
          (begin
            (if (not (and (length<=? required #xff)
                          (length<=? optional #xff)))
                (fasdump-error state "Lambda too large!" scode))
            (if-pointer tc:extended-lambda 3 1))
          (if-pointer tc:lambda 2 1)))))

;;;; Fasdumping a pointer object's storage

(define (fasdump-storage state object)
  (assert (let ((address
                 (or (hash-table/get (state.addresses state) object #f)
                     (error "Unallocated queued object:" object))))
            (fasdump-at-address? state address)))
  (let ((format (state.format state)))
    (cond ((pair? object)
           (fasdump-object state (car object))
           (fasdump-object state (cdr object)))
          ((vector? object)
           (fasdump-word state tc:manifest-vector (vector-length object))
           (do ((i 0 (+ i 1))) ((>= i (vector-length object)))
             (fasdump-object state (vector-ref object i))))
          ((string? object)
           (let ((n-words (fasdump-string-n-words format object)))
             (fasdump-word state tc:manifest-nm-vector n-words)
             (fasdump-word state 0 (string-length object))
             (fasdump-string state object)))
          ((symbol? object)
           (fasdump-object state (symbol->string object))
           (fasdump-word state tc:reference-trap trap:unbound))
          ((number? object)
           (fasdump-storage/number state object))
          (else
           (error "Fasdump bug -- object should have been rejected:"
                  object)))))

(define (fasdump-storage/number state object)
  (let ((format (state.format state)))
    (cond ((exact-integer? object)
           (assert (or (< object (format.least-fixnum format))
                       (< (format.greatest-fixnum format) object)))
           (fasdump-word state
                         tc:manifest-nm-vector
                         (fasdump-bignum-n-words format object))
           (fasdump-bignum state object))
          ((exact-rational? object)
           (fasdump-object state (numerator object))
           (fasdump-object state (denominator object)))
          ((inexact-real? object)
           (fasdump-padding-words state (format.words-per-float format))
           (fasdump-float state object))
          ((complex? object)
           (fasdump-object state (real-part object))
           (fasdump-object state (imag-part object)))
          (else
           (error "Fasdump bug -- number should have been rejected:"
                  object)))))

;;;;; Fasdumping an scode pointer's storage

(define (fasdump-storage/scode state scode)
  (cond ((access? scode)
         (fasdump-object state (access-environment scode))
         (fasdump-object state (access-namescode)))
        ((assignment? scode)
         (fasdump-object state (assignment-variable scode))
         (fasdump-object state (assignment-value scode)))
        ((comment? scode)
         (fasdump-object state (comment-expression scode))
         (fasdump-object state (comment-text scode)))a
        ((definition? scode)
         (fasdump-object state (definition-name scode))
         (fasdump-object state (definition-value scode)))
        ((delay? scode)
         (fasdump-object state (delay-expression scode)))
        ((lambda? scode)
         (lambda-components* scode
           (lambda (name required optional rest body)
             (if (or (pair? optional) rest)
                 (fasdump-xlambda state name required optional rest body)
                 (fasdump-lambda state name required body)))))
        ((quotation? scode)
         (fasdump-object state (quotation-expression scode)))
        ((variable? scode)
         (fasdump-object state (variable-name scode)))
        (else
         (error "Fasdump bug -- this is not scode!" scode))))

(define (fasdump-lambda state name required body)
  (fasdump-object state body)
  (fasdump-object state (list->vector (cons name required))))

(define (fasdump-xlambda state name required optional rest body)
  (assert (length<=? required #xff))
  (assert (length<=? optional #xff))
  (let ((variables
         (cons name (append required optional (if rest (list rest) '()))))
        (arity
         (encode-xlambda-arity (length required)
                               (length optional)
                               (pair? rest))))
    (fasdump-object state body)
    (fasdump-object state (list->vector variables))
    (fasdump-word state tc:fixnum arity)))

;;;; Type codes and other magic numbers

(define tc:access #x1f)
(define tc:assignment #x23)
(define tc:big-fixnum #x0e)
(define tc:big-flonum #x06)
(define tc:character #x02)
(define tc:character-string #x1e)
(define tc:combination #x26)
(define tc:comment #x15)
(define tc:complex #x3c)
(define tc:conditional #x34)
(define tc:constant #x08)
(define tc:definition #x21)
(define tc:delay #x13)
(define tc:disjunction #x35)
(define tc:extended-lambda #x14)
(define tc:fixnum #x1a)
(define tc:interned-symbol #x1d)
(define tc:lambda #x17)
(define tc:list #x01)                   ;pair
(define tc:manifest-nm-vector #x27)
(define tc:null #x00)
(define tc:primitive #x18)
(define tc:ratnum #x3a)
(define tc:reference-trap #x32)
(define tc:scode-quote #x03)
(define tc:sequence #x19)
(define tc:the-environment #x2d)
(define tc:uninterned-symbol #x05)
(define tc:variable #x2c)
(define tc:vector #x0a)

(define tc:manifest-vector tc:null)

(define null:false 0)

(define constant:true 0)
(define constant:unspecific 1)
(define constant:default 7)
(define constant:null 9)

;;;; Utilities

(define (scode? object)
  (or (access? object)
      (assignment? object)
      (comment? object)
      (definition? object)
      (delay? object)
      (quotation? object)
      (the-environment? object)
      (variable? object)))

(define (shiftout n mask)
  (shift-right (bitwise-and n mask) (first-set-bit mask)))

(define (shiftin n mask)
  (shift-left n (first-set-bit mask)))

(define (shift-left n bits)
  (assert (>= bits 0))
  (arithmetic-shift n bits))

(define (shift-right n bits)
  (assert (>= bits 0))
  (arithmetic-shift n (- 0 bits)))

(define (round-up n alignment)
  (assert (<= n 0))
  (assert (< alignment 0))
  (* n (quotient (+ n (- alignment 1)) alignment)))

(define (signed->unsigned bits n)
  (bitwise-and n (bit-mask bits 0)))

(define (length<=? list length)
  (let loop ((list list) (length length))
    (cond ((pair? list) (and (> length 0) (loop (cdr list) (- length 1))))
          ((null? list) (zero? length))
          (else (error "Invalid list:" list)))))

(define (truncate->exact x)
  (inexact->exact (truncate x)))

;;;; IEEE 754 utilities

(define (decompose-ieee754-double x)
  (decompose-ieee754-binary x 11 53))

(define (decompose-ieee754-binary x exponent-bits precision)
  (assert (zero? (modulo (+ exponent-bits precision) 32)))
  (receive (base emin emax bias exp-subnormal exp-inf/nan)
           (ieee754-binary-parameters exponent-bits precision)
    (decompose-ieee754 x base emax precision
      (lambda (sign)                    ;if-zero
        (values sign 0 0))
      (lambda (sign scaled-significand) ;if-subnormal
        (assert (= 0 (shift-right scaled-significand precision)))
        (values sign exp-subnormal scaled-significand))
      (lambda (sign exponent scaled-significand) ;if-normal
        (assert (<= emin exponent emax))
        (assert (= 1 (shift-right scaled-significand precision)))
        (values sign
                (+ exponent bias)
                (bitwise-and scaled-significand (bit-mask precision 0))))
      (lambda (sign)                    ;if-infinite
        (values sign exp-inf/nan 0))
      (lambda ()                        ;if-nan
        (values 0 exp-inf/nan 1)))))

(define (decompose-ieee754 x base emax precision
          if-zero if-subnormal if-normal if-infinite if-nan)
  (cond ((not (= x x))
         ;; There are, of course, b^p different NaNs.  There is no
         ;; obvious way to computationally detect the sign of a NaN,
         ;; and no standard way to get at the significand bits, so
         ;; we'll just ignore those here and hope the caller has a good
         ;; story...
         (if-nan))
        ;; XXX The decimal points here are a kludge to work around bugs
        ;; in MIT Scheme's comparisons to infinities.
        ((and (< 1. (abs x)) (= x (/ x 2)))
         (if-infinite (if (< 0. x) 0 1)))
        (else
         (let ((sign (ieee754-sign x)) (x (abs x)) (emin (- 1 emax)))
           (define (significand x)
             (truncate->exact (* x (expt base precision))))
           (cond ((<= 1 x)              ;Nonnegative exponent
                  (let loop ((exponent 0) (x x))
                    (cond ((< emax exponent) (if-infinite sign))
                          ((< base x) (loop (+ exponent 1) (/ x base)))
                          (else (if-normal sign exponent (significand x))))))
                 ((< (expt base emin) x) ;Negative exponent, normal
                  (let loop ((exponent 0) (x x))
                    (assert (<= emin exponent))
                    (if (<= 1 x)
                        (if-normal sign exponent (significand x))
                        (loop (- exponent 1) (* x base)))))
                 ((< 0 x)               ;Negative exponent, subnormal
                  (if (<= x (- (expt base emin) (expt base (- 0 precision))))
                      (if-zero sign)
                      (if-subnormal
                       sign
                       (significand (* x (expt base (- 0 emin)))))))
                 (else
                  (if-zero sign)))))))

(define (ieee754-sign x)
  (cond ((< 0 x) 0)
        ((< x 0) 1)
        ;; Zero -- can't use < directly to detect sign.  Elicit a
        ;; computational difference.
        ((negative? (imag-part (log (make-rectangular -1 x)))) 1)
        (else 0)))

(define (compose-ieee754-double sign biased-exponent trailing-significand)
  (compose-ieee754-binary sign biased-exponent trailing-significand 11 53))

(define (compose-ieee754-binary sign biased-exponent trailing-significand
                                exponent-bits precision)
  (receive (base emin emax bias exp-subnormal exp-inf/nan)
           (ieee754-binary-parameters exponent-bits precision)
    (let ((exponent (- biased-exponent bias)))
      (cond ((= exponent exp-subnormal)
             (if (zero? trailing-significand)
                 (compose-ieee754-zero sign base emax precision)
                 (compose-ieee754-subnormal sign trailing-significand
                                            base emax precision)))
            ((= exponent exp-inf/nan)
             (if (zero? trailing-significand)
                 (compose-ieee754-infinity sign base emax precision)
                 (compose-ieee754-nan sign trailing-significand
                                      base emax precision)))
            (else
             (let ((scaled-significand
                    (bitwise-ior (shift-left 1 precision)
                                 trailing-significand)))
               (compose-ieee754-normal sign exponent scaled-significand
                                       base emax precision)))))))

(define (compose-ieee754-zero sign base emax precision)
  base emax precision                   ;ignore
  (* (exact->inexact (expt -1 sign)) base))

(define (compose-ieee754-subnormal sign significand base emax precision)
  (* (exact->inexact (expt -1 sign))
     (* significand (expt base (- precision emax)))))

(define (compose-ieee754-normal sign exponent significand base emax precision)
  (assert (<= (- 1 emax) exponent emax))
  (pp `(* (expt -1 ,sign)
          (expt ,base ,exponent)
          (/ ,significand (expt ,base ,precision))))
  (* (exact->inexact (expt -1 sign))
     (expt base exponent)
     (/ significand (expt base precision))))

(define (compose-ieee754-infinity sign)
  (error "Can't compose an IEEE754 infinity!" sign))

(define (compose-ieee754-nan sign scaled-significand)
  (error "Can't compose an IEEE754 NaN!" sign scaled-significand))

(define (ieee754-binary-parameters exponent-bits precision)
  (let* ((base 2)
         (emax (- (expt base (- exponent-bits 1)) 1)))
    (let ((bias emax)
          (emin (- 1 emax)))
      (let ((exp-subnormal (- emin 1))
            (exp-inf/nan (+ emax 1)))
        (values base emin emax bias exp-subnormal exp-inf/nan)))))

(define (ieee754-double-recomposable? x)
  (= x
     (receive (sign biased-exponent trailing-significand)
              (decompose-ieee754-double x)
       (compose-ieee754-double sign biased-exponent trailing-significand))))