; Java Library
;
; Copyright (C) 2020 Kestrel Institute (http://www.kestrel.edu)
;
; License: A 3-clause BSD license. See the LICENSE file distributed with ACL2.
;
; Author: Alessandro Coglio (coglio@kestrel.edu)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package "JAVA")

(include-book "primitive-types")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defxdoc+ primitive-function-macros
  :parents (semantics)
  :short "Macros to formalize more concisely
          ACL2 functions over the Java primitive values."
  :long
  (xdoc::topstring
   (xdoc::p
    "The ACL2 functions that formalize Java primitive operations and conversions
     have the following structure:
     they take one (if unary) or two (if binary) primitive values as arguments;
     they uses primitive value destructors (e.g. @(tsee int-value->int))
     to obtain the ``core'' values to operate upon with existing ACL2 functions;
     they use existing ACL2 functions to generate the ``core'' result;
     they uses primitive value constructors (e.g. @(tsee int-value))
     to return the result primitive value.")
   (xdoc::p
    "The only ``interesting'' part is how the core result
     is calculated from the core arguments via existing ACL2 functions.
     The rest is boilerplate that can be automatically generated,
     which we do via macros.")
   (xdoc::p
    "We introduce two general macros:
     one for unary functions, and one for binary functions.
     These can generate functions over primitive values
     of any combination of operand and result types,
     which are all explicitly specified.
     Since certain combinations of operand and result types
     are shared by certain collections of primitive operations,
     we also introduce more specialized macros for these combinations."))
  :order-subtopics t
  :default-parent t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define primitive-type-predicate ((type primitive-typep))
  :returns (predicate symbolp)
  :short "The recognizer of the fixtype of the values of a primitive type."
  (packn-pos (list (symbol-name (primitive-type-kind type)) '-value-p)
             (pkg-witness "JAVA")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define primitive-type-constructor ((type primitive-typep))
  :returns (constructor symbolp)
  :short "The constructor of the fixtype of the values of a primitive type."
  (packn-pos (list (symbol-name (primitive-type-kind type)) '-value)
             (pkg-witness "JAVA")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define primitive-type-destructor ((type primitive-typep))
  :returns (destructor symbolp)
  :short "The destructor of the fixtype of the values of a primitive type."
  (primitive-type-case type
                       :boolean 'boolean-value->bool
                       :char 'char-value->nat
                       :byte 'byte-value->int
                       :short 'short-value->int
                       :int 'int-value->int
                       :long 'long-value->int
                       :float 'float-value->float
                       :double 'double-value->double))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-primitive-unary
  :short "Macro to formalize a unary ACL2 function over Java primitive values."
  :long
  (xdoc::topstring
   (xdoc::p
    "This macro takes as required arguments
     the name of the function to define,
     the primitive type of the operand,
     the primitive type of the result,
     and an untranslated term that defines the operation on the core value.
     This term must have @('x') as the only free variable,
     which the boilerplate code generated by the macro binds to
     the core value of the operand.")
   (xdoc::p
    "This macro also takes optional arguments for XDOC documentation:
     parents, short string, and long string.
     The latter may be forms, e.g. involving XDOC constructors.")
   (xdoc::@def "def-primitive-unary"))

  (define def-primitive-unary-fn ((name symbolp)
                                  (in-type primitive-typep)
                                  (out-type primitive-typep)
                                  (operation "An untranslated term.")
                                  (parents symbol-listp)
                                  (parents-suppliedp booleanp)
                                  (short "A string or form or @('nil').")
                                  (short-suppliedp booleanp)
                                  (long "A string or form or @('nil').")
                                  (long-suppliedp booleanp))
    :returns (event "A @(tsee acl2::pseudo-event-formp).")
    :parents nil
    (b* ((in-predicate (primitive-type-predicate in-type))
         (in-destructor (primitive-type-destructor in-type))
         (out-predicate (primitive-type-predicate out-type))
         (out-constructor (primitive-type-constructor out-type)))
      `(define ,name ((operand ,in-predicate))
         :returns (result ,out-predicate)
         ,@(and parents-suppliedp (list :parents parents))
         ,@(and short-suppliedp (list :short short))
         ,@(and long-suppliedp (list :long long))
         (b* ((x (,in-destructor operand)))
           (,out-constructor ,operation))
         :hooks (:fix)
         :no-function t)))

  (defmacro def-primitive-unary (name
                                 &key
                                 in-type
                                 out-type
                                 operation
                                 (parents 'nil parents-suppliedp)
                                 (short 'nil short-suppliedp)
                                 (long 'nil long-suppliedp))
    `(make-event
      (def-primitive-unary-fn
        ',name
        ,in-type
        ,out-type
        ',operation
        ',parents ,parents-suppliedp
        ,short ,short-suppliedp
        ,long ,long-suppliedp))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-primitive-binary
  :short "Macro to formalize a binary ACL2 function over Java primitive values."
  :long
  (xdoc::topstring
   (xdoc::p
    "This is similar to @(tsee def-primitive-unary),
     but it takes two input type arguments instead of one
     (the one for the left operand, followed by the one for the right operand).
     The untranslated term that defines the operation on the core values
     must have @('x') and @('y') as its only free variables:
     they are for the (core) left and right operand, respectively.")
   (xdoc::p
    "This macro also takes an optional argument saying whether
     the right operand should be non-zero;
     in this case, the right operand type must be @('int') or @('long').
     If this argument is @('t'),
     the guard of the generated function requires the right operand
     to be different from the zero value of the respective type.
     This is used to define the integer division and reminder operations;
     it is @('nil') by default.")
   (xdoc::@def "def-primitive-binary"))

  (define def-primitive-binary-fn ((name symbolp)
                                   (in-type-left primitive-typep)
                                   (in-type-right primitive-typep)
                                   (out-type primitive-typep)
                                   (operation "An untranslated term.")
                                   (nonzero booleanp)
                                   (parents symbol-listp)
                                   (parents-suppliedp booleanp)
                                   (short "A string or form or @('nil').")
                                   (short-suppliedp booleanp)
                                   (long "A string or form or @('nil').")
                                   (long-suppliedp booleanp))
    :returns (event "A @(tsee acl2::maybe-pseudo-event-formp).")
    :parents nil
    (b* ((in-predicate-left (primitive-type-predicate in-type-left))
         (in-predicate-right (primitive-type-predicate in-type-right))
         (in-destructor-left (primitive-type-destructor in-type-left))
         (in-destructor-right (primitive-type-destructor in-type-right))
         (out-predicate (primitive-type-predicate out-type))
         (out-constructor (primitive-type-constructor out-type))
         ((when (and nonzero
                     (not (primitive-type-case in-type-right :int))
                     (not (primitive-type-case in-type-right :long))))
          (raise "The :NONZERO argument may be T ~
                  only if the right operand type is int or long, ~
                  but it is ~x0 instead."
                 (primitive-type-kind in-type-right)))
         (guard? (and nonzero
                      `(not (equal (,in-destructor-right operand-right) 0)))))
      `(define ,name ((operand-left ,in-predicate-left)
                      (operand-right ,in-predicate-right))
         ,@(and guard? (list :guard guard?))
         :returns (result ,out-predicate)
         ,@(and parents-suppliedp (list :parents parents))
         ,@(and short-suppliedp (list :short short))
         ,@(and long-suppliedp (list :long long))
         (b* ((x (,in-destructor-left operand-left))
              (y (,in-destructor-right operand-right)))
           (,out-constructor ,operation))
         :hooks (:fix)
         :no-function t)))

  (defmacro def-primitive-binary (name
                                  &key
                                  in-type-left
                                  in-type-right
                                  out-type
                                  operation
                                  nonzero
                                  (parents 'nil parents-suppliedp)
                                  (short 'nil short-suppliedp)
                                  (long 'nil long-suppliedp))
    `(make-event
      (def-primitive-binary-fn
        ',name
        ,in-type-left
        ,in-type-right
        ,out-type
        ',operation
        ,nonzero
        ',parents ,parents-suppliedp
        ,short ,short-suppliedp
        ,long ,long-suppliedp))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-boolean-unary
  :short "Specialization of @(tsee def-primitive-unary) to
          the case in which input and output types are @('boolean')."
  :long (xdoc::topstring-@def "def-boolean-unary")

  (defmacro def-boolean-unary (name
                               &key
                               operation
                               (parents 'nil parents-suppliedp)
                               (short 'nil short-suppliedp)
                               (long 'nil long-suppliedp))
    `(def-primitive-unary ,name
       :in-type (primitive-type-boolean)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-int-unary
  :short "Specialization of @(tsee def-primitive-unary) to
          the case in which input and output types are @('int')."
  :long (xdoc::topstring-@def "def-int-unary")

  (defmacro def-int-unary (name
                           &key
                           operation
                           (parents 'nil parents-suppliedp)
                           (short 'nil short-suppliedp)
                           (long 'nil long-suppliedp))
    `(def-primitive-unary ,name
       :in-type (primitive-type-int)
       :out-type (primitive-type-int)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-long-unary
  :short "Specialization of @(tsee def-primitive-unary) to
          the case in which input and output types are @('long')."
  :long (xdoc::topstring-@def "def-long-unary")

  (defmacro def-long-unary (name
                            &key
                            operation
                            (parents 'nil parents-suppliedp)
                            (short 'nil short-suppliedp)
                            (long 'nil long-suppliedp))
    `(def-primitive-unary ,name
       :in-type (primitive-type-long)
       :out-type (primitive-type-long)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-float-unary
  :short "Specialization of @(tsee def-primitive-unary) to
          the case in which input and output types are @('float')."
  :long (xdoc::topstring-@def "def-float-unary")

  (defmacro def-float-unary (name
                             &key
                             operation
                             (parents 'nil parents-suppliedp)
                             (short 'nil short-suppliedp)
                             (long 'nil long-suppliedp))
    `(def-primitive-unary ,name
       :in-type (primitive-type-float)
       :out-type (primitive-type-float)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-double-unary
  :short "Specialization of @(tsee def-primitive-unary) to
          the case in which input and output types are @('double')."
  :long (xdoc::topstring-@def "def-double-unary")

  (defmacro def-double-unary (name
                              &key
                              operation
                              (parents 'nil parents-suppliedp)
                              (short 'nil short-suppliedp)
                              (long 'nil long-suppliedp))
    `(def-primitive-unary ,name
       :in-type (primitive-type-double)
       :out-type (primitive-type-double)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-boolean-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which input and output types are @('boolean')."
  :long (xdoc::topstring-@def "def-boolean-binary")

  (defmacro def-boolean-binary (name
                                &key
                                operation
                                (parents 'nil parents-suppliedp)
                                (short 'nil short-suppliedp)
                                (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-boolean)
       :in-type-right (primitive-type-boolean)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-int-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which input and output types are @('int')."
  :long (xdoc::topstring-@def "def-int-binary")

  (defmacro def-int-binary (name
                            &key
                            operation
                            nonzero
                            (parents 'nil parents-suppliedp)
                            (short 'nil short-suppliedp)
                            (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-int)
       :in-type-right (primitive-type-int)
       :out-type (primitive-type-int)
       :operation ,operation
       :nonzero ,nonzero
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-long-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which input and output types are @('long')."
  :long (xdoc::topstring-@def "def-long-binary")

  (defmacro def-long-binary (name
                             &key
                             operation
                             nonzero
                             (parents 'nil parents-suppliedp)
                             (short 'nil short-suppliedp)
                             (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-long)
       :in-type-right (primitive-type-long)
       :out-type (primitive-type-long)
       :operation ,operation
       :nonzero ,nonzero
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-float-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which input and output types are @('float')."
  :long (xdoc::topstring-@def "def-float-binary")

  (defmacro def-float-binary (name
                              &key
                              operation
                              (parents 'nil parents-suppliedp)
                              (short 'nil short-suppliedp)
                              (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-float)
       :in-type-right (primitive-type-float)
       :out-type (primitive-type-float)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-double-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which input and output types are @('double')."
  :long (xdoc::topstring-@def "def-double-binary")

  (defmacro def-double-binary (name
                               &key
                               operation
                               (parents 'nil parents-suppliedp)
                               (short 'nil short-suppliedp)
                               (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-double)
       :in-type-right (primitive-type-double)
       :out-type (primitive-type-double)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-int=>boolean-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which the input types are @('int')
          and the output type is @('boolean')."
  :long (xdoc::topstring-@def "def-int=>boolean-binary")

  (defmacro def-int=>boolean-binary (name
                                     &key
                                     operation
                                     (parents 'nil parents-suppliedp)
                                     (short 'nil short-suppliedp)
                                     (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-int)
       :in-type-right (primitive-type-int)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-long=>boolean-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which the input types are @('long')
          and the output type is @('boolean')."
  :long (xdoc::topstring-@def "def-long=>boolean-binary")

  (defmacro def-long=>boolean-binary (name
                                      &key
                                      operation
                                      (parents 'nil parents-suppliedp)
                                      (short 'nil short-suppliedp)
                                      (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-long)
       :in-type-right (primitive-type-long)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-float=>boolean-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which the input types are @('float')
          and the output type is @('boolean')."
  :long (xdoc::topstring-@def "def-float=>boolean-binary")

  (defmacro def-float=>boolean-binary (name
                                       &key
                                       operation
                                       (parents 'nil parents-suppliedp)
                                       (short 'nil short-suppliedp)
                                       (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-float)
       :in-type-right (primitive-type-float)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defsection def-double=>boolean-binary
  :short "Specialization of @(tsee def-primitive-binary) to
          the case in which the input types are @('double')
          and the output type is @('boolean')."
  :long (xdoc::topstring-@def "def-double=>boolean-binary")

  (defmacro def-double=>boolean-binary (name
                                        &key
                                        operation
                                        (parents 'nil parents-suppliedp)
                                        (short 'nil short-suppliedp)
                                        (long 'nil long-suppliedp))
    `(def-primitive-binary ,name
       :in-type-left (primitive-type-double)
       :in-type-right (primitive-type-double)
       :out-type (primitive-type-boolean)
       :operation ,operation
       ,@(and parents-suppliedp (list :parents parents))
       ,@(and short-suppliedp (list :short short))
       ,@(and long-suppliedp (list :long long)))))
