contrib/sb-posix/strtod.lisp

   1 (in-package "SB-POSIX")
   2
   3 (defun strtod (string)
   4   "Parse the string INPUT and return a double-precision float,
   5 and a secondary value, the number of characters consumed."
   6   (flet ((strtod/base-string (chars offset)
   7            (declare (simple-base-string chars))
   8            ;; On x86, dx arrays are quicker to make than aliens.
   9            (sb-int:dx-let ((end (make-array 1 :element-type 'sb-ext:word)))
  10              (sb-sys:with-pinned-objects (chars)
  11                (let* ((base (sb-sys:sap+ (sb-sys:vector-sap chars) offset))
  12                       (answer
  13                        (handler-case
  14                         (alien-funcall
  15                          (extern-alien "strtod" (function double
  16                                                           system-area-pointer
  17                                                           system-area-pointer))
  18                          base
  19                          (sb-sys:vector-sap end))
  20                         (floating-point-overflow () nil))))
  21                  (values answer
  22                          (if answer
  23                              (the sb-int:index
  24                                (- (aref end 0) (sb-sys:sap-int base))))))))))
  25     (when (typep string 'simple-base-string)
  26       (return-from strtod (strtod/base-string string 0)))
  27     ;; Non-simple base-string with a null terminator in the right place.
  28     (when (typep string 'base-string)
  29       (sb-kernel:with-array-data ((data string) (start) (end) :check-fill-pointer t)
  30         (when (eql (locally
  31                     (declare (optimize (sb-c:insert-array-bounds-checks 0)))
  32                     (schar data (1+ end))) #\Nul)
  33           (return-from strtod (strtod/base-string data start)))))
  34     ;; Short simple non-base string, or base-string w/o a null in the right place
  35     (when (typep string '(or (simple-array character (*)) base-string))
  36       (let ((length (length string)))
  37         (when (< length 256) ; arbitrary limit to keep stack usage minimal
  38           (string-dispatch ((simple-array character (*)) base-string) string
  39             (sb-int:dx-let ((copy (make-array length :element-type 'base-char)))
  40               (loop for i below length do (setf (schar copy i) (char string i)))
  41               (return-from strtod (strtod/base-string copy 0)))))))
  42     (strtod/base-string (coerce string 'simple-base-string) 0))) ; Anything else