;;;; 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")

(eval-when (:compile-toplevel :load-toplevel :execute)

;;; 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 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+
      '(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+))
          (o2 (position type2 +type-test-ordering+)))
      (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 (subtypep type1 type2)
                               (subtypep type2 type1))
                       (error "Types not disjoint: ~S ~S." type1 type2)))
                   (error-if-supertype (type1 type2)
                     (when (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)))

  ) ; EVAL-WHEN

;;; 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)))
    (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)))
          (error-tags tag)
          (errors tag)
          (errors
           (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

(eval-when (:compile-toplevel :execute #+sb-devel :load-toplevel)

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

) ; EVAL-WHEN
