conversions.lisp

;;;; conversions.lisp
;;;;
;;;; Conversions between primitive numerical types

(coalton-library/utils:defstdlib-package #:coalton-library/math/conversions
  (:use
   #:coalton
   #:coalton-library/builtin
   #:coalton-library/classes
   #:coalton-library/functions
   #:coalton-library/math/bounded))

(in-package #:coalton-library/math/conversions)

(named-readtables:in-readtable coalton:coalton)

#+coalton-release
(cl:declaim #.coalton-impl/settings:*coalton-optimize-library*)

(cl:eval-when (:compile-toplevel :load-toplevel)
  (cl:unless (cl:and (cl:subtypep '(cl:signed-byte 32) 'cl:fixnum)
                     (cl:subtypep 'cl:fixnum '(cl:signed-byte 64)))
    (cl:with-simple-restart (define-wrong-instances "Compile Coalton anyway, generating an incompatible set of integer `Into' and `TryInto' instances")
      (cl:error "`IFix' detected to not have a size between `I32' and `I64' on your platform.
This is most likely caused by compiling Coalton on a 32-bit Common Lisp implementation.
Coalton supports only 64-bit Common Lisp implementations.

If you ignore this error by selecting the `define-wrong-instances' restart, the set of integer-conversion
`Into' and `TryInto' instances generated by the standard library will be different than it should be on a
supported 64-bit implementation."))))

(cl:eval-when (:compile-toplevel :load-toplevel)
  (cl:defparameter *integer-types*
    '((U8 . (cl:unsigned-byte 8))
      (I8 . (cl:signed-byte 8))
      (U16 . (cl:unsigned-byte 16))
      (I16 . (cl:signed-byte 16))
      (U32 . (cl:unsigned-byte 32))
      (I32 . (cl:signed-byte 32))
      (U64 . (cl:unsigned-byte 64))
      (I64 . (cl:signed-byte 64))
      (UFix . (cl:and cl:fixnum cl:unsigned-byte))
      (IFix . cl:fixnum)
      (Integer . cl:integer))
    "An alist which pairs the names of Coalton's native integer types with equivalent Common Lisp type specifiers."))

(coalton-toplevel
  (declare unsafe-cast (:any -> :other))
  (define (unsafe-cast x)
    "Both :ANY and :OTHER must be natively represented by a subtype of `cl:integer', and X must be a valid member of :OTHER."
    (lisp :other (x) x))

  (declare unify (:ty -> :ty -> :ty))
  (define (unify _ use)
    "Declare a constraint that two values are of the same type.

Used in `cast-if-inbounds' to force the type inference engine to read minBound and maxBound from the correct
`Bounded' instance."
    use)

  (declare cast-if-inbounds ((Ord :src) (Bounded :target) =>
                             :src -> (Result String :target)))
  (define (cast-if-inbounds x)
    "Cast X, minBound and maxBound to `Integer', and compare them. If X is within the bounds, `unsafe-cast' it to the result type."
    (let max-bound = maxBound)
    (let min-bound = minBound)
    (let int = (the Integer (unsafe-cast x)))
    (if (or (< int (unsafe-cast min-bound))
            (> int (unsafe-cast max-bound)))
        (Err "value out of range")
        (Ok
         ;; type hackery to get the minBound and maxBound from the Bounded instance of :target. if we
         ;; removed the two `unfiy' calls, type inference would compute extra type variables for
         ;; minBound and maxBound, each with the contstraints `Bounded _' and `Into _ Integer', but
         ;; without unifying them with :target.
         (unify max-bound (unify min-bound
                                 (unsafe-cast x)))))))

;; these functions are called at compile-time by `define-integer-conversions', so they must be `eval-when
;; :compile-toplevel'.
(cl:eval-when (:compile-toplevel :load-toplevel)
  (cl:defun define-integer-into-instance (from-type to-type)
    "Define an infallible `Into' instance for converting FROM-TYPE into TO-TYPE.

Emitted by `define-integer-conversions' only if every element of FROM-TYPE can be represented in TO-TYPE."
    `(define-instance (Into ,from-type ,to-type)
       (define into unsafe-cast)))

  (cl:defun define-integer-try-into-instance (from-type to-type)
    "Define a fallible `TryInto' instance for converting FROM-TYPE into TO-TYPE.

Emitted by `define-integer-conversions' when some elements of FROM-TYPE cannot be represented in TO-TYPE,
either because FROM-TYPE is signed and TO-TYPE is unsigned, or because FROM-TYPE is wider than TO-TYPE."
    `(define-instance (TryInto ,from-type ,to-type)
       (define tryInto cast-if-inbounds)))

  (cl:defun definitely-subtype? (sub super)
    "Test if SUB is a subtype of SUPER, i.e. every element of SUB is also an element of SUPER.

Unlike `cl:subtypep', signal an error if the subtyping relationship cannot be determined."
    (cl:multiple-value-bind (subtypep determinedp)
        (cl:subtypep sub super)
      (cl:if determinedp
             subtypep
             (cl:error "Unable to determine subtype relationship between ~s and ~s" sub super)))))

(cl:defmacro define-integer-conversions (from-type)
  "For each element of *INTEGER-TYPES* other than FROM-TYPE, define an `Into' or `TryInto' instance as appropriate.

(Into :small :large) is defined for any pair of integer types where :LARGE can represent every element of
:SMALL, e.g. Into U8 I64 is defined.

(TryInto :from :to) is defined for any other pair of integer types, where there are some elements of :FROM which
cannot be represented in :TO. These fall into a few categories:

- (TryInto :signed :unsigned) is implemented rather than (Into :signed :unsigned) where :SIGNED is one of I8, I16,
  I32, I64, IFix; and :UNSIGNED is one of U8, U16, U32, U64; because negative numbers in the source type
  cannot be represented in the destination type.

- (TryInto :larger :smaller) is implemented rather than (Into :smaller :larger) where :LARGER is wider than
  :SMALLER (e.g. U64 is wider than U32, and I64 is wider than I32) because larger (both more-positive and
  more-negative) values of the source type cannot be represented in the destination type."
  (cl:let* ((from-repr (cl:or (cl:cdr (cl:assoc from-type *integer-types*))
                              (cl:error "Attempt to define integer conversions for unknown type ~s" from-type))))
    (cl:cons 'coalton-toplevel
             (cl:loop :for (into-type . into-repr) :in *integer-types*
                :when (cl:not (cl:eq into-type from-type)) ; don't emit an identity `Into' instance
                  :collect (cl:if (definitely-subtype? from-repr into-repr)
                                  ;; if every element of FROM-REPR can fit in INTO-REPR, generate an infallible `Into' instance
                                  (define-integer-into-instance from-type into-type)
                                  ;; otherwise, generate a fallible `TryInto' instance
                                  (define-integer-try-into-instance from-type into-type))))))

(define-integer-conversions U8)
(define-integer-conversions I8)
(define-integer-conversions U16)
(define-integer-conversions I16)
(define-integer-conversions U32)
(define-integer-conversions I32)
(define-integer-conversions U64)
(define-integer-conversions I64)
(define-integer-conversions UFix)
(define-integer-conversions IFix)
(define-integer-conversions Integer)

(cl:defmacro integer-into-float (integer coalton-float lisp-float)
  `(coalton-toplevel
     (define-instance (Into ,integer ,coalton-float)
       (define (into x)
         (lisp ,coalton-float (x)
           (cl:coerce x ',lisp-float))))))

;; Only exact conversions
;; Single-Float: 24 bit mantissa (not including sign)
(integer-into-float U8 Single-Float cl:single-float)
(integer-into-float I8 Single-Float cl:single-float)
(integer-into-float U16 Single-Float cl:single-float)
(integer-into-float I16 Single-Float cl:single-float)
;; Double-Float: 53 bit mantissa (not including sign)
(integer-into-float U8 Double-Float cl:double-float)
(integer-into-float I8 Double-Float cl:double-float)
(integer-into-float U16 Double-Float cl:double-float)
(integer-into-float I16 Double-Float cl:double-float)
(integer-into-float U32 Double-Float cl:double-float)
(integer-into-float I32 Double-Float cl:double-float)

;; Allow Integer -> {Single,Double}-Float conversions
(coalton-toplevel
  (define-instance (TryInto Integer Single-Float)
    (define (tryInto x)
      (lisp (Result String Single-Float) (x)
        (cl:let ((y (cl:ignore-errors (cl:coerce x 'cl:single-float))))
          (cl:if (cl:null y)
                 (Err "Integer to Single-Float conversion out-of-range")
                 (Ok y))))))

  (define-instance (TryInto Integer Double-Float)
    (define (tryInto x)
      (lisp (Result String Double-Float) (x)
        (cl:let ((y (cl:ignore-errors (cl:coerce x 'cl:double-float))))
          (cl:if (cl:null y)
                 (Err "Integer to Double-Float conversion out-of-range")
                 (Ok y)))))))

(cl:eval-when (:compile-toplevel :load-toplevel)
  (cl:defmacro integer-tryinto-float (integer lisp-float float pow)
    `(define-instance (TryInto ,integer ,float)
       (define (tryInto x)
	 (lisp (Result String ,float) (x)
           (cl:if (cl:< ,(cl:- (cl:expt 2 pow)) x ,(cl:expt 2 pow))
	          (cl:let ((y (cl:ignore-errors (cl:coerce x ',lisp-float))))
	            (cl:if (cl:null y)
		           (coalton-impl/util:unreachable)
		           (Ok y)))
	          (Err ,(cl:format cl:nil "Given integer is not within (-2^~D, 2^~D)." pow pow))))))))

(coalton-toplevel
  ;; Single Float
  (integer-tryinto-float I64 cl:single-float Single-Float 24)

  (integer-tryinto-float U64 cl:single-float Single-Float 24)

  (integer-tryinto-float IFix cl:single-float Single-Float 24)

  (integer-tryinto-float UFix cl:single-float Single-Float 24)

  (integer-tryinto-float U32 cl:single-float Single-Float 24)

  (integer-tryinto-float I32 cl:single-float Single-Float 24)

  ;; Double Float
  (integer-tryinto-float I64 cl:double-float Double-Float 53)

  (integer-tryinto-float U64 cl:double-float Double-Float 53)

  (integer-tryinto-float IFix cl:double-float Double-Float 53)

  (integer-tryinto-float UFix cl:double-float Double-Float 53))


#+sb-package-locks
(sb-ext:lock-package "COALTON-LIBRARY/MATH/CONVERSIONS")