mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
43 lines
2.3 KiB
Common Lisp
43 lines
2.3 KiB
Common Lisp
(in-package "SB-POSIX")
|
|
|
|
(defun strtod (string)
|
|
"Parse the string INPUT and return a double-precision float,
|
|
and a secondary value, the number of characters consumed."
|
|
(flet ((strtod/base-string (chars offset)
|
|
(declare (simple-base-string chars))
|
|
;; On x86, dx arrays are quicker to make than aliens.
|
|
(sb-int:dx-let ((end (make-array 1 :element-type 'sb-ext:word)))
|
|
(sb-sys:with-pinned-objects (chars #-c-stack-is-control-stack end)
|
|
(let* ((base (sb-sys:sap+ (sb-sys:vector-sap chars) offset))
|
|
(answer
|
|
(handler-case
|
|
(alien-funcall
|
|
(extern-alien "strtod" (function double
|
|
system-area-pointer
|
|
system-area-pointer))
|
|
base
|
|
(sb-sys:vector-sap end))
|
|
(floating-point-overflow () nil))))
|
|
(values answer
|
|
(if answer
|
|
(the sb-int:index
|
|
(- (aref end 0) (sb-sys:sap-int base))))))))))
|
|
(when (typep string 'simple-base-string)
|
|
(return-from strtod (strtod/base-string string 0)))
|
|
;; Non-simple base-string with a null terminator in the right place.
|
|
(when (typep string 'base-string)
|
|
(sb-kernel:with-array-data ((data string) (start) (end) :check-fill-pointer t)
|
|
(when (eql (locally
|
|
(declare (optimize (sb-c:insert-array-bounds-checks 0)))
|
|
(schar data (1+ end))) #\Nul)
|
|
(return-from strtod (strtod/base-string data start)))))
|
|
;; Short simple non-base string, or base-string w/o a null in the right place
|
|
(when (typep string '(or (simple-array character (*)) base-string))
|
|
(let ((length (length string)))
|
|
(when (< length 256) ; arbitrary limit to keep stack usage minimal
|
|
(string-dispatch ((simple-array character (*)) base-string) string
|
|
(sb-int:dx-let ((copy (make-array length :element-type 'base-char)))
|
|
(loop for i below length do (setf (schar copy i) (char string i)))
|
|
(return-from strtod (strtod/base-string copy 0)))))))
|
|
(strtod/base-string (coerce string 'simple-base-string) 0))) ; Anything else
|