Raymond Toy pushed to branch issue-435-add-core-math-lisp-support at cmucl / cmucl
Commits:
-
e8cec854
by Raymond Toy at 2026-02-25T15:25:23-08:00
-
32530cd0
by Raymond Toy at 2026-02-25T15:27:55-08:00
-
e8f54c41
by Raymond Toy at 2026-02-25T15:49:14-08:00
2 changed files:
Changes:
| ... | ... | @@ -225,21 +225,34 @@ |
| 225 | 225 | (y0 double-float :out)
|
| 226 | 226 | (y1 double-float :out))
|
| 227 | 227 | |
| 228 | -(declaim (inline %%sincos))
|
|
| 228 | +(declaim (inline %%sincos %%sincosf))
|
|
| 229 | 229 | (alien:def-alien-routine ("lisp_sincos" %%sincos)
|
| 230 | 230 | c-call:void
|
| 231 | 231 | (x double-float)
|
| 232 | 232 | (s double-float :out)
|
| 233 | 233 | (c double-float :out))
|
| 234 | 234 | |
| 235 | +(alien:def-alien-routine ("lisp_sincosf" %%sincosf)
|
|
| 236 | + c-call:void
|
|
| 237 | + (x single-float)
|
|
| 238 | + (s single-float :out)
|
|
| 239 | + (c single-float :out))
|
|
| 240 | + |
|
| 235 | 241 | (declaim (inline %sincos))
|
| 236 | 242 | (export '%sincos)
|
| 237 | 243 | (defun %sincos (x)
|
| 238 | - (declare (double-float x))
|
|
| 239 | - (multiple-value-bind (ign s c)
|
|
| 240 | - (%%sincos x)
|
|
| 241 | - (declare (ignore ign))
|
|
| 242 | - (values s c)))
|
|
| 244 | + (declare (float x))
|
|
| 245 | + (etypecase x
|
|
| 246 | + (single-float
|
|
| 247 | + (multiple-value-bind (ign s c)
|
|
| 248 | + (%%sincosf x)
|
|
| 249 | + (declare (ignore ign))
|
|
| 250 | + (values s c)))
|
|
| 251 | + (double-float
|
|
| 252 | + (multiple-value-bind (ign s c)
|
|
| 253 | + (%%sincos x)
|
|
| 254 | + (declare (ignore ign))
|
|
| 255 | + (values s c)))))
|
|
| 243 | 256 | |
| 244 | 257 | |
| 245 | 258 | ;;;; Power functions.
|
| ... | ... | @@ -1005,17 +1018,17 @@ |
| 1005 | 1018 | (if (complexp theta)
|
| 1006 | 1019 | (error (intl:gettext "Argument to CIS is complex: ~S") theta)
|
| 1007 | 1020 | (number-dispatch ((theta real))
|
| 1008 | - ((rational)
|
|
| 1009 | - (let ((arg (coerce theta 'double-float)))
|
|
| 1010 | - (multiple-value-bind (s c)
|
|
| 1011 | - (%sincos arg)
|
|
| 1012 | - (complex (coerce c 'single-float)
|
|
| 1013 | - (coerce s 'single-float)))))
|
|
| 1014 | - (((foreach single-float double-float))
|
|
| 1015 | - (multiple-value-bind (s c)
|
|
| 1016 | - (%sincos (coerce theta 'double-float))
|
|
| 1017 | - (complex (coerce c '(dispatch-type theta))
|
|
| 1018 | - (coerce s '(dispatch-type theta)))))
|
|
| 1021 | + (((foreach rational single-float))
|
|
| 1022 | + (let ((arg (coerce theta 'single-float)))
|
|
| 1023 | + (multiple-value-bind (ign s c)
|
|
| 1024 | + (%%sincosf arg)
|
|
| 1025 | + (declare (ignore ign))
|
|
| 1026 | + (complex c s))))
|
|
| 1027 | + ((double-float)
|
|
| 1028 | + (multiple-value-bind (ign s c)
|
|
| 1029 | + (%%sincos theta)
|
|
| 1030 | + (declare (ignore ign))
|
|
| 1031 | + (complex c s)))
|
|
| 1019 | 1032 | #+double-double
|
| 1020 | 1033 | ((double-double-float)
|
| 1021 | 1034 | (multiple-value-bind (s c)
|
| ... | ... | @@ -683,25 +683,44 @@ |
| 683 | 683 | (asinh %asinh *)
|
| 684 | 684 | (acosh %acosh float)
|
| 685 | 685 | (atanh %atanh float)))
|
| 686 | + (destructuring-bind (name prim rtype)
|
|
| 687 | + stuff
|
|
| 688 | + (let ((primf (intern (string (symbolicate prim "F"))
|
|
| 689 | + "KERNEL")))
|
|
| 690 | + (deftransform name ((x) '(single-float) rtype :eval-name t)
|
|
| 691 | + #-core-math
|
|
| 692 | + `(coerce (,prim (coerce x 'double-float)) 'single-float)
|
|
| 693 | + #+core-math
|
|
| 694 | + `(,primf x))
|
|
| 695 | + (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
|
|
| 696 | + `(,prim x)))))
|
|
| 697 | + |
|
| 698 | +#-core-math
|
|
| 699 | +(dolist (stuff '((sqrt %sqrt float)))
|
|
| 686 | 700 | (destructuring-bind (name prim rtype) stuff
|
| 687 | 701 | (deftransform name ((x) '(single-float) rtype :eval-name t)
|
| 688 | 702 | `(coerce (,prim (coerce x 'double-float)) 'single-float))
|
| 689 | 703 | (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
|
| 690 | - `(,prim x))))
|
|
| 704 | + `(,prim x))))
|
|
| 691 | 705 | |
| 692 | -(defknown (%sincos)
|
|
| 693 | - (double-float) (values double-float double-float)
|
|
| 706 | +(defknown (kernel::%%sincos)
|
|
| 707 | + (double-float) (values null double-float double-float)
|
|
| 708 | + (movable foldable flushable))
|
|
| 709 | + |
|
| 710 | +(defknown (kernel::%%sincosf)
|
|
| 711 | + (single-float) (values null single-float single-float)
|
|
| 694 | 712 | (movable foldable flushable))
|
| 695 | 713 | |
| 696 | 714 | (deftransform cis ((x) (single-float) * :when :both)
|
| 697 | - `(multiple-value-bind (s c)
|
|
| 698 | - (%sincos (coerce x 'double-float))
|
|
| 699 | - (complex (coerce c 'single-float)
|
|
| 700 | - (coerce s 'single-float))))
|
|
| 715 | + `(multiple-value-bind (ign s c)
|
|
| 716 | + (kernel::%%sincosf x)
|
|
| 717 | + (declare (ignore ign))
|
|
| 718 | + (complex c s)))
|
|
| 701 | 719 | |
| 702 | 720 | (deftransform cis ((x) (double-float) * :when :both)
|
| 703 | - `(multiple-value-bind (s c)
|
|
| 704 | - (%sincos x)
|
|
| 721 | + `(multiple-value-bind (ign s c)
|
|
| 722 | + (kernel::%%sincos x)
|
|
| 723 | + (declare (ignore ign))
|
|
| 705 | 724 | (complex c s)))
|
| 706 | 725 | |
| 707 | 726 | ;;; The argument range is limited on the x86 FP trig. functions. A
|