Add type inference for several number functions

src/cl-functions.lisp

@@ -171,3 +171,162 @@
      (maybe-constant-form-value type env :default t))
 
     (_ t)))
+
+(defstruct (numeric-op (:conc-name %numeric-op-))
+  closed-under-fixnum-p
+  closed-under-integers-p
+  closed-under-rationals-p
+  closed-under-float-p
+  result-necessarily-float-p
+  result-necessarily-integer-p
+  result-necessarily-real-p)
+
+(macrolet ((def (slot-name)
+             `(defun ,(symbolicate 'numeric-op '- slot-name) (op)
+                (multiple-value-bind (value existsp)
+                    (gethash op *numeric-op-table*)
+                  (if existsp
+                      (,(symbolicate '%numeric-op- slot-name) value)
+                      nil)))))
+  (def closed-under-fixnum-p)
+  (def closed-under-integers-p)
+  (def closed-under-rationals-p)
+  (def closed-under-float-p)
+  (def result-necessarily-float-p)
+  (def result-necessarily-integer-p)
+  (def result-necessarily-real-p))
+
+(defparameter *numeric-op-table*
+  (alist-hash-table
+   (nconc
+    (list (cons '+ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t   :closed-under-rationals-p t :closed-under-float-p t))
+          (cons '- (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t   :closed-under-rationals-p t :closed-under-float-p t))
+          (cons '* (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t   :closed-under-rationals-p t :closed-under-float-p t))
+          (cons '/ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p t :closed-under-float-p t))
+
+          (cons '1+ (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t))
+          (cons '1- (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t)))
+
+    #+sbcl
+    (list (cons 'max (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t :result-necessarily-real-p t))
+          (cons 'min (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :closed-under-float-p t :result-necessarily-real-p t)))
+
+    ;; Implementations are free to decide whether to apply contagions or not: http://clhs.lisp.se/Body/f_max_m.htm
+    #-sbcl
+    (list (cons 'max (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p nil :closed-under-float-p nil :result-necessarily-real-p t))
+          (cons 'min (make-numeric-op :closed-under-fixnum-p nil :closed-under-integers-p nil :closed-under-rationals-p nil :closed-under-float-p nil :result-necessarily-real-p t)))
+
+    (list (cons 'floor    (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t))
+          (cons 'ceiling  (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t))
+          (cons 'truncate (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t))
+          (cons 'round    (make-numeric-op :closed-under-fixnum-p t :closed-under-integers-p t :closed-under-rationals-p t :result-necessarily-integer-p t))
+
+          (cons 'ffloor    (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t))
+          (cons 'fceiling  (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t))
+          (cons 'ftruncate (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t))
+          (cons 'fround    (make-numeric-op :closed-under-float-p t :result-necessarily-float-p t)))
+
+    #+sbcl
+    (list (cons 'sin (make-numeric-op :result-necessarily-float-p t))
+          (cons 'cos (make-numeric-op :result-necessarily-float-p t))
+          (cons 'tan (make-numeric-op :result-necessarily-float-p t)))
+    #-sbcl
+    (list (cons 'sin (make-numeric-op))
+          (cons 'cos (make-numeric-op))
+          (cons 'tan (make-numeric-op))))))
+
+(defun numeric-result-type (op arg-types env)
+
+  (flet ((some-subtypep (type)
+           (some (lambda (arg-type)
+                   (subtypep arg-type type env))
+                 arg-types))
+         (all-subtypep (type)
+           (every (lambda (arg-type)
+                    (subtypep arg-type type env))
+                  arg-types)))
+
+    (let* ((realp (numeric-op-result-necessarily-real-p op))
+           (complex-possible-p (not realp)))
+
+      (when (numeric-op-closed-under-fixnum-p op)
+        (when (all-subtypep 'fixnum)
+          (return-from numeric-result-type 'fixnum))
+        (when (and complex-possible-p
+                   (all-subtypep '(complex fixnum)))
+          (return-from numeric-result-type '(complex fixnum))))
+
+      (when (numeric-op-closed-under-integers-p op)
+        (when (all-subtypep 'integer)
+          (return-from numeric-result-type 'integer))
+        (when (and complex-possible-p
+                   (all-subtypep '(complex integer)))
+          (return-from numeric-result-type '(complex integer))))
+
+      (when (numeric-op-closed-under-rationals-p op)
+        (when (all-subtypep 'rational)
+          (return-from numeric-result-type 'rational))
+        (when (and complex-possible-p
+                   (all-subtypep '(complex rational)))
+          (return-from numeric-result-type '(complex rational))))
+
+      (when (numeric-op-closed-under-float-p op)
+        (when (all-subtypep 'single-float)
+          (return-from numeric-result-type 'single-float))
+        (when (all-subtypep 'double-float)
+          (return-from numeric-result-type 'double-float))
+
+        (when complex-possible-p
+          (when (all-subtypep '(complex single-float))
+            (return-from numeric-result-type '(complex single-float)))
+          (when (all-subtypep '(complex double-float))
+            (return-from numeric-result-type '(complex double-float)))))
+
+      (when (numeric-op-result-necessarily-integer-p op)
+        (return-from numeric-result-type 'integer))
+
+      (when (numeric-op-result-necessarily-float-p op)
+        (when (some-subtypep 'double-float)
+          (return-from numeric-result-type 'double-float))
+        ;; What happens if all the results are rational?
+        (return-from numeric-result-type 'single-float))
+
+      (return-from numeric-result-type 'number))))
+
+(defun every-eql-type-p (types env)
+  (let (values)
+    (every (lambda (type)
+             (optima:match (peltadot/types-core:typexpand type env)
+               ((list 'eql value)
+                (push value values))
+               (_
+                (return-from every-eql-type-p
+                  (values nil nil)))))
+           types)
+    (values t (nreverse values))))
+
+(defun numeric-op-form-type (op args env)
+  (let ((arg-types (mapcar (lambda (arg)
+                             (introspect-environment:typexpand
+                              (form-type arg env)
+                              env))
+                           args)))
+    (multiple-value-bind (all-eql-p values)
+        (every-eql-type-p arg-types env)
+      (cond (all-eql-p
+             (or (ignore-errors `(eql ,(apply op values)))
+                 `number))
+            (t
+             (numeric-result-type op arg-types env))))))
+
+(macrolet ((def (&rest ops)
+             `(progn
+                ,@(mapcar (lambda (op)
+                            `(defmethod custom-form-type ((op (eql ',op)) args env)
+                               (numeric-op-form-type op args env)))
+                          ops))))
+  (def + - / * 1+ 1- max min
+    floor ceiling truncate round
+    ffloor fceiling fruncate fround
+
+    sin cos tan atan))