common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Add ftruncate1.

Browse source
This commit is contained in:
Stas Boukarev 2025-04-02 04:12:17 +03:00
parent b327ce15a3
commit 5b1d6e6b32
5 changed files with 70 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
src/code/numbers.lisp
View file

@ -651,11 +651,15 @@
(foreach single-float double-float #+long-float long-float))
(fround-float (dispatch-type divisor))))))
(macrolet ((def (name mode docstring)
`(defun ,name (number &optional (divisor 1))
,docstring
(macrolet ((def (name mode docstring &optional values)
`(defun ,name (number ,@(if values
`(divisor)
`(&optional (divisor 1))))
(declare (explicit-check))
(macrolet ((ftruncate-float (rtype)
,docstring
,(wrap-if
values '(values)
`(macrolet ((ftruncate-float (rtype)
`(let* ((float-div (coerce divisor ',rtype))
(res (,(case rtype
(double-float 'sb-kernel:round-double)
@ -691,7 +695,7 @@
(ftruncate-float double-float))
(((foreach fixnum bignum ratio)
(foreach single-float double-float))
(ftruncate-float (dispatch-type divisor))))))))
(ftruncate-float (dispatch-type divisor)))))))))
(def ftruncate :truncate
"Same as TRUNCATE, but returns first value as a float.")
@ -701,6 +705,12 @@
(def fceiling :ceiling
"Same as CEILING, but returns first value as a float.")
(def ftruncate1 :truncate nil t)
(def ffloor1 :floor nil t)
(def fceiling1 :ceiling nil t)
#+round-float
(def fround :round
"Same as ROUND, but returns first value as a float.")

3
src/compiler/fndb.lisp
View file

@ -343,6 +343,9 @@
(defknown (sb-kernel::truncate1 sb-kernel::floor1 sb-kernel::ceiling1) (real real) integer
(movable foldable flushable recursive no-verify-arg-count))
(defknown (sb-kernel::ftruncate1 sb-kernel::ffloor1 sb-kernel::fceiling1) (real real) float
(movable foldable flushable recursive no-verify-arg-count))
(defknown unary-truncate (real) (values integer real)
(movable foldable flushable no-verify-arg-count))

14
src/compiler/ir1final.lisp
View file

@ -320,17 +320,15 @@
(mv-bind-unused-p lvar 1))
(let ((single-value-fun (getf '(truncate sb-kernel::truncate1
floor sb-kernel::floor1
ceiling sb-kernel::ceiling1)
ceiling sb-kernel::ceiling1
ftruncate sb-kernel::ftruncate1
ffloor sb-kernel::ffloor1
fceiling sb-kernel::fceiling1)
combination-name)))
(when single-value-fun
(unless (cdr args)
(let* ((leaf (find-constant 1))
(ref (make-ref leaf))
(lvar (make-lvar combination)))
(use-lvar ref lvar)
(push ref (leaf-refs leaf))
(insert-ref-before ref combination-name)
(setf (cdr args) (list lvar))))
(setf (cdr args)
(list (insert-ref-before (find-constant 1) combination))))
(change-full-call combination single-value-fun)
(setf (node-derived-type combination)
(make-single-value-type (single-value-type (node-derived-type combination)))))))))

3
src/compiler/ir1util.lisp
View file

@ -927,13 +927,14 @@
cast))))
(defun insert-ref-before (leaf node)
(with-ir1-environment-from-node node
(let ((ref (make-ref leaf))
(lvar (make-lvar node)))
(insert-node-before node ref)
(push ref (leaf-refs leaf))
(setf (leaf-ever-used leaf) t)
(use-lvar ref lvar)
lvar))
lvar)))
;;;; miscellaneous shorthand functions

5
src/compiler/ltn.lisp
View file

@ -236,6 +236,8 @@
(let ((kind (basic-combination-kind call))
(info (basic-combination-fun-info call)))
(rewrite-full-call call)
(dolist (arg (basic-combination-args call))
(unless (lvar-info arg)
(setf (lvar-info arg)
@ -253,8 +255,7 @@
(when (basic-combination-info call)
(signal-delayed-combination-condition call))
(setf (basic-combination-kind call) :full))
(setf (basic-combination-info call) :full)
(rewrite-full-call call))))
(setf (basic-combination-info call) :full))))
(annotate-fun-lvar (basic-combination-fun call))
(values))