;;;; This file contains the the NUMBER-DISPATCH macro

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-KERNEL")

;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
;;; with the type dispatches and bodies. Result is a tree built of
;;; alists representing the dispatching off each arg (in order). The
;;; leaf is the body to be executed in that case.
(defun parse-number-dispatch (vars result types var-types body)
  ;; Shouldn't be necessary, but avoids a warning in certain lisps that
  ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation.
  (named-let parse-number-dispatch ((vars vars) (result result)
                                    (types (subst 'sb-xc:fixnum 'fixnum types))
                                    (var-types var-types) (body body))
    (cond ((null vars)
           (unless (null types) (error "More types than vars."))
           (when (cdr result)
             (error "Duplicate case: ~S." body))
           (setf (cdr result)
                 (sublis var-types body :test #'equal)))
          ((null types)
           (error "More vars than types."))
          (t
           (flet ((frob (var type)
                    (parse-number-dispatch
                     (rest vars)
                     (or (assoc type (cdr result) :test #'equal)
                         (car (setf (cdr result)
                                    (acons type nil (cdr result)))))
                     (rest types)
                     (acons `(dispatch-type ,var) type var-types)
                     body)))
             (let ((type (first types))
                   (var (first vars)))
               (if (and (consp type) (eq (first type) 'foreach))
                   (dolist (type (rest type))
                     (frob var type))
                   (frob var type))))))))

;;; our guess for the preferred order in which to do type tests
;;; (cheaper and/or more probable first.)
(defconstant-eqx +type-test-ordering+
    '((eql 1) sb-xc:fixnum single-float double-float integer #+long-float long-float
      sb-vm:signed-word word bignum
      complex ratio)
  #'equal)

;;; Should TYPE1 be tested before TYPE2?

(defun type-test-order (type1 type2)
  (let ((o1 (position type1 +type-test-ordering+ :test #'equal))
        (o2 (position type2 +type-test-ordering+ :test #'equal)))
    (cond ((not o1) nil)
          ((not o2) t)
          (t
           (< o1 o2)))))

;;; Return an ETYPECASE form that does the type dispatch, ordering the
;;; cases for efficiency.
;;; Check for some simple to detect problematic cases where the caller
;;; used types that are not disjoint and where this may lead to
;;; unexpected behaviour of the generated form, for example making
;;; a clause unreachable, and throw an error if such a case is found.
;;; An example:
;;;   (number-dispatch ((var1 integer) (var2 float))
;;;     ((fixnum single-float) a)
;;;     ((integer float) b))
;;; Even though the types are not reordered here, the generated form,
;;; basically
;;;   (etypecase var1
;;;     (fixnum (etypecase var2
;;;               (single-float a)))
;;;     (integer (etypecase var2
;;;                (float b))))
;;; would fail at runtime if given var1 fixnum and var2 double-float,
;;; even though the second clause matches this signature. To catch
;;; this earlier than runtime we throw an error already here.
(defun generate-number-dispatch (vars error-tags cases)
  ;; Shouldn't be necessary, but avoids a warning in certain lisps that
  ;; seem to like to warn about self-calls in :COMPILE-TOPLEVEL situation.
  (named-let generate-number-dispatch ((vars vars) (error-tags error-tags) (cases cases))
    (if vars
        (let ((var (first vars))
              (cases (sort cases #'type-test-order :key #'car)))
          (flet ((error-if-sub-or-supertype (type1 type2)
                   (when (or (cl:subtypep type1 type2)
                             (cl:subtypep type2 type1))
                     (error "Types not disjoint: ~S ~S." type1 type2)))
                 (error-if-supertype (type1 type2)
                   (when (cl:subtypep type2 type1)
                     (error "Type ~S ordered before subtype ~S."
                            type1 type2)))
                 (test-type-pairs (fun)
                   ;; Apply FUN to all (ordered) pairs of types from the
                   ;; cases.
                   (mapl (lambda (cases)
                           (when (cdr cases)
                             (let ((type1 (caar cases)))
                               (dolist (case (cdr cases))
                                 (funcall fun type1 (car case))))))
                         cases)))
            ;; For the last variable throw an error if a type is followed
            ;; by a subtype, for all other variables additionally if a
            ;; type is followed by a supertype.
            (test-type-pairs (if (cdr vars)
                                 #'error-if-sub-or-supertype
                                 #'error-if-supertype)))
          `((typecase ,(car var)
              ,@(mapcar (lambda (case)
                          `(,(first case)
                            ,@(when (eq (cadr var) 'unsigned-byte)
                                `((when (minusp ,(car var))
                                    (go ,(car error-tags)))))
                            ,@(generate-number-dispatch (rest vars)
                                                        (rest error-tags)
                                                        (cdr case))))
                 cases)
              (t (go ,(first error-tags))))))
        cases)))

;;; This is a vaguely case-like macro that does number cross-product
;;; dispatches. The Vars are the variables we are dispatching off of.
;;; The Type paired with each Var is used in the error message when no
;;; case matches. Each case specifies a Type for each var, and is
;;; executed when that signature holds. A type may be a list
;;; (FOREACH Each-Type*), causing that case to be repeatedly
;;; instantiated for every Each-Type. In the body of each case, any
;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
;;; type of that var in that instance of the case.
;;;
;;; [Though it says "_any_ list", it's still an example of how not to perform
;;; incomplete lexical analysis within a macro imho. Let's say that the body
;;; code passes a lambda that happens name its args DISPATCH-TYPE and X.
;;; What happens?
;;; (macroexpand-1 '(number-dispatch ((x number))
;;;                  ((float) (f x (lambda (dispatch-type x) (wat))))))
;;; -> [stuff elided]
;;;      (TYPECASE X (FLOAT (F X (LAMBDA FLOAT (WAT))))
;;;
;;; So the NUMBER-DISPATCH macro indeed substituted for *any* appearance
;;; just like it says. I wonder if we could define DISPATCH-TYPE as macrolet
;;; that expands to the type for the current branch, so that it _must_
;;; be in a for-evaluation position; but maybe I'm missing something?]
;;;
;;; As an alternate to a case spec, there may be a form whose CAR is a
;;; symbol. In this case, we apply the CAR of the form to the CDR and
;;; treat the result of the call as a list of cases. This process is
;;; not applied recursively.
;;;
;;; Be careful when using non-disjoint types in different cases for the
;;; same variable. Some uses will behave as intended, others not, as the
;;; variables are dispatched off sequentially and clauses are reordered
;;; for efficiency. Some, but not all, problematic cases are detected
;;; and lead to a compile time error; see GENERATE-NUMBER-DISPATCH above
;;; for an example.
(defmacro number-dispatch (var-specs &body cases)
  (let ((res (list nil))
        (vars (mapcar #'car var-specs))
        (block (gensym "NUMBER-DISPATCH")))
    (dolist (case cases)
      (if (symbolp (first case))
          (let ((cases (apply (symbol-function (first case)) (rest case))))
            (dolist (case cases)
              (parse-number-dispatch vars res (first case) nil (rest case))))
          (parse-number-dispatch vars res (first case) nil (rest case))))

    (collect ((errors)
              (error-tags))
      (dolist (spec var-specs)
        (let* ((var (first spec))
               (type (second spec))
               (tag (gensym (symbol-name var))))
          (error-tags tag)
          (errors tag)
          (errors
           #+sb-xc-host
           `(error 'simple-type-error :datum ,var
                   :expected-type ',type
                   :format-control
                   "~@<Argument ~A is not a ~S: ~2I~_~S~:>"
                   :format-arguments
                   (list ',var ',type ,var))
           #-sb-xc-host
           (sb-c::internal-type-error-call var type))))

      `(block ,block
         (tagbody
            (return-from ,block
              ,@(generate-number-dispatch var-specs (error-tags)
                                          (cdr res)))
            ,@(errors))))))

;;;; binary operation dispatching utilities

;;; Return NUMBER-DISPATCH forms for rational X float.
(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
  `(((single-float single-float) (,op ,x ,y))
    (((foreach ,@rat-types)
      (foreach single-float double-float #+long-float long-float))
     (,op (coerce ,x '(dispatch-type ,y)) ,y))
    (((foreach single-float double-float #+long-float long-float)
      (foreach ,@rat-types))
     (,op ,x (coerce ,y '(dispatch-type ,x))))
    #+long-float
    (((foreach single-float double-float long-float) long-float)
     (,op (coerce ,x 'long-float) ,y))
    #+long-float
    ((long-float (foreach single-float double-float))
     (,op ,x (coerce ,y 'long-float)))
    (((foreach single-float double-float) double-float)
     (,op (coerce ,x 'double-float) ,y))
    ((double-float single-float)
     (,op ,x (coerce ,y 'double-float)))))

;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
(defun bignum-cross-fixnum (fix-op big-op)
  (case fix-op
    (+
     `(((fixnum fixnum) (,fix-op x y))
       ((fixnum bignum)
        (add-bignum-fixnum y x))
       ((bignum fixnum)
        (add-bignum-fixnum x y))
       ((bignum bignum)
        (,big-op x y))))
    (-
     `(((fixnum fixnum) (,fix-op x y))
       ((fixnum bignum)
        (subtract-fixnum-bignum x y))
       ((bignum fixnum)
        (subtract-bignum-fixnum x y))
       ((bignum bignum)
        (,big-op x y))))
    (t
     `(((fixnum fixnum) (,fix-op x y))
       ((fixnum bignum)
        (,big-op (make-small-bignum x) y))
       ((bignum fixnum)
        (,big-op x (make-small-bignum y)))
       ((bignum bignum)
        (,big-op x y))))))

(defmacro dispatch-ratio ((ratio numerator denominator) &body body)
  `(let ((,numerator (numerator ,ratio))
         (,denominator (denominator ,ratio)))
     (if (and (fixnump ,numerator)
              (fixnump ,denominator))
         (progn ,@body)
         (progn ,@body))))

(defmacro dispatch-two-ratios ((numerator1-var numerator1)
                               (denominator1-var denominator1)
                               (numerator2-var numerator2)
                               (denominator2-var denominator2)
                               body
                               &optional (fixnum-body body))
  `(let ((,numerator1-var ,numerator1)
         (,denominator1-var ,denominator1)
         (,numerator2-var ,numerator2)
         (,denominator2-var ,denominator2))
     (if (and (fixnump ,numerator1-var)
              (fixnump ,numerator2-var)
              (fixnump ,denominator1-var)
              (fixnump ,denominator2-var))
         ,fixnum-body
         ,body)))

(defmacro cond-dispatch (cond &body body)
  `(if ,cond
       (progn ,@body)
       (progn ,@body)))
