Raymond Toy pushed to branch master at cmucl / cmucl

Commits:

9 changed files:

Changes:

  • bin/run-ansi-tests.sh
    ... ... @@ -36,7 +36,7 @@ shift $((OPTIND - 1))
    36 36 
     # Use branch cmucl-expected-failures in general since this branch
    37 37 
     # generally has the list of expected failures.  This is the branch to
    38 38 
     # use on cmucl master in general.
    39 
    -BRANCH=cmucl-expected-failures-etypecase.15
    39 
    +BRANCH=cmucl-expected-failures
    40 40
    41 41 
     set -x
    42 42 
     if [ -d ../ansi-test ]; then

  • src/code/exports.lisp
    ... ... @@ -1368,7 +1368,13 @@
    1368 1368 
       (:export "PACKAGE-LOCAL-NICKNAMES"
    1369 1369 
     	   "ADD-PACKAGE-LOCAL-NICKNAME"
    1370 1370 
     	   "REMOVE-PACKAGE-LOCAL-NICKNAME"
    1371 
    -	   "PACKAGE-LOCALLY-NICKNAMED-BY-LIST"))
    1371 
    +	   "PACKAGE-LOCALLY-NICKNAMED-BY-LIST")
    1372 
    +  ;; Printing and parsing of C-style hex floats
    1373 
    +  (:export "FLOAT-TO-HEX-STRING"
    1374 
    +	   "WRITE-HEX-FLOAT"
    1375 
    +	   "FORMAT-HEX-FLOAT"
    1376 
    +	   "HEX-PARSE-ERROR"
    1377 
    +	   "PARSE-HEX-FLOAT"))
    1372 1378
    1373 1379 
     (defpackage "STREAM"
    1374 1380 
       (:import-from "SYSTEM" "LISP-STREAM")

  • src/code/ext-code.lisp
    1 
    +;;; -*- Log: code.log; Package: Extensions -*-
    2 
    +;;;
    3 
    +;;; **********************************************************************
    4 
    +;;; This code was written as part of the CMU Common Lisp project at
    5 
    +;;; Carnegie Mellon University, and has been placed in the public domain.
    6 
    +;;;
    7 
    +(ext:file-comment
    8 
    +  "$Header: src/code/extensions.lisp $")
    9 
    +;;;
    10 
    +;;;
    11 
    +;;; **********************************************************************
    12 
    +;;;
    13 
    +;;; Spice Lisp extensions to the language.
    14 
    +;;;
    15 
    +;;; These extensions are compiled natively instead of byte-compiled
    16 
    +;;; like the code in code/extensions.lisp.
    17 
    +;;;
    18 
    +;;; **********************************************************************
    19 
    +(in-package "EXTENSIONS")
    20 
    +
    21 
    +(intl:textdomain "cmucl")
    22 
    +
    23 
    +
    24 
    +;;;; C-style hex float printer and parser
    25 
    +
    26 
    +;;; FLOAT-TO-HEX-STRING  -- Public
    27 
    +;;;
    28 
    +;;; Return a string representing a single and double-floats in C-style
    29 
    +;;; hex format.
    30 
    +(defun float-to-hex-string (val &optional at-p)
    31 
    +  "Prints a single or double float in bit-perfect C-style hex.
    32 
    +   If AT-P is true, prepends '+' for non-negative finite values."
    33 
    +  (cond ((ext:float-nan-p val)
    34 
    +	 "0x0.0p+nan")
    35 
    +        ((ext:float-infinity-p val)
    36 
    +         (if (plusp val)
    37 
    +	     (if at-p
    38 
    +		 "+0x1.0p+inf" "0x1.0p+inf")
    39 
    +	     "-0x1.0p+inf"))
    40 
    +        (t
    41 
    +         (multiple-value-bind (sign exp-bits mantissa bias precision suffix)
    42 
    +             (typecase val
    43 
    +               (single-float
    44 
    +                (let ((bits (ldb (byte 32 0) (kernel:single-float-bits val))))
    45 
    +                  (values (ldb (byte 1 31) bits)
    46 
    +                          (ldb (byte 8 23) bits)
    47 
    +                          (ash (ldb (byte 23 0) bits) 1) ; Align 23 to 6 hex digits
    48 
    +                          127 6 "f")))
    49 
    +               (double-float
    50 
    +                (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    51 
    +                  (values (ldb (byte 1 31) hi)
    52 
    +                          (ldb (byte 11 20) hi)
    53 
    +                          (logior (ash (ldb (byte 20 0) hi) 32) (ldb (byte 32 0) lo))
    54 
    +                          1023 13 "")))
    55 
    +               (t (error "Unsupported float type: ~S" (type-of val))))
    56 
    +
    57 
    +           (let ((sign-str (cond ((= sign 1) "-")
    58 
    +                                 (at-p "+")
    59 
    +                                 (t ""))))
    60 
    +             (if (and (zerop exp-bits) (zerop mantissa))
    61 
    +                 (format nil "~A0x0.0p+0~A" sign-str suffix)
    62 
    +                 (format nil "~A0x~A.~V,'0Xp~A~A"
    63 
    +                         sign-str
    64 
    +                         (if (zerop exp-bits) "0" "1")
    65 
    +                         precision
    66 
    +                         mantissa
    67 
    +                         (if (zerop exp-bits) (1+ (- bias)) (- exp-bits bias))
    68 
    +                         suffix)))))))
    69 
    +
    70 
    +;;; WRITE-HEX-FLOAT -- Public
    71 
    +;;;
    72 
    +;;; Writes a float number in C-style hex format to the given stream.
    73 
    +(defun write-hex-float (float &optional (stream *standard-output*))
    74 
    +  "Convert FLOAT to C-style hex string and write it to STREAM.
    75 
    +  Infinities are printed as \"-inf\" and \"inf\".  NaN is printed as
    76 
    +  \"nan\"."
    77 
    +  (declare (float float))
    78 
    +  (write-string (float-to-hex-string float)
    79 
    +		stream))
    80 
    +
    81 
    +;;; FORMAT-HEX-FLOAT -- Public
    82 
    +;;;
    83 
    +;;; Function that can be used in a FORMAT ~/
    84 
    +(defun format-hex-float (stream arg colon-p at-sign-p &optional width)
    85 
    +  "Formatter for ~/ext:format-hex-float/.
    86 
    +   Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored."
    87 
    +  (declare (ignore width colon-p))
    88 
    +  (write-string (float-to-hex-string arg at-sign-p)
    89 
    +                stream))
    90 
    +
    91 
    +(define-condition hex-parse-error (parse-error)
    92 
    +  ((text :initarg :text :reader hex-parse-error-text)
    93 
    +   (message :initarg :message :reader hex-parse-error-message))
    94 
    +  (:report (lambda (c s)
    95 
    +             (format s "Hex float parse error in ~S: ~A"
    96 
    +                     (hex-parse-error-text c) (hex-parse-error-message c)))))
    97 
    +
    98 
    +;;; PARSE-HEX-FLOAT-FROM-STREAM -- Public
    99 
    +;;;
    100 
    +;;; Parse a C-style float hex string from a stream.  Invalid formats
    101 
    +;;; signal an error.  A single-float or double-float may be returned.
    102 
    +(defun parse-hex-float-from-stream (stream)
    103 
    +  "Reads a C-style hex float number from STREAM.  A single-float or
    104 
    +  double-float number is returned.  A HEX-PARSE-ERROR is signaled for
    105 
    +  an invalid format."
    106 
    +  (let* ((sign 1.0d0)
    107 
    +         (char (peek-char t stream))) ; Skip whitespace
    108 
    +
    109 
    +    ;; 1. Handle Sign
    110 
    +    (when (member char '(#\+ #\-))
    111 
    +      (when (char= (read-char stream) #\-) (setf sign -1.0d0))
    112 
    +      (setf char (peek-char nil stream)))
    113 
    +
    114 
    +    ;; 2. Verify '0x' Prefix
    115 
    +    (unless (and (char-equal (read-char stream) #\0)
    116 
    +                 (char-equal (read-char stream) #\x))
    117 
    +      (error 'hex-parse-error :text "Stream" :message "Missing '0x' prefix"))
    118 
    +
    119 
    +    ;; 3. Read Significand
    120 
    +    (let ((val 0.0d0)
    121 
    +          (digits-read 0))
    122 
    +      ;; Integer part loop
    123 
    +      (loop for c = (peek-char nil stream nil nil)
    124 
    +            for digit = (and c (digit-char-p c 16))
    125 
    +            while digit
    126 
    +            do (read-char stream)
    127 
    +               (setf val (+ (* val 16.0d0) digit))
    128 
    +               (incf digits-read))
    129 
    +
    130 
    +      ;; Fractional part loop
    131 
    +      (when (eql (peek-char nil stream nil nil) #\.)
    132 
    +        (read-char stream) ; Consume #\.
    133 
    +        (loop with weight = (/ 1.0d0 16.0d0)
    134 
    +              for c = (peek-char nil stream nil nil)
    135 
    +              for digit = (and c (digit-char-p c 16))
    136 
    +              while digit
    137 
    +              do (read-char stream)
    138 
    +                 (setf val (+ val (* digit weight)))
    139 
    +                 (setf weight (/ weight 16.0d0))
    140 
    +                 (incf digits-read)))
    141 
    +
    142 
    +      (unless (plusp digits-read)
    143 
    +        (error 'hex-parse-error :text "Stream" :message "No hex digits in significand"))
    144 
    +
    145 
    +      ;; 4. Handle Exponent 'p'
    146 
    +      (let ((p-char (read-char stream nil)))
    147 
    +        (unless (and p-char (char-equal p-char #\p))
    148 
    +          (error 'hex-parse-error :text "Stream" :message "Missing exponent 'p'"))
    149 
    +
    150 
    +        ;; Size 6 handles sign + 3-4 digits + buffer
    151 
    +        (let ((exp-str (make-array 6 :element-type 'character
    152 
    +                                     :fill-pointer 0
    153 
    +                                     :adjustable t)))
    154 
    +          (loop for c = (peek-char nil stream nil nil)
    155 
    +                while (and c (find c "+-0123456789"))
    156 
    +                do (vector-push-extend (read-char stream) exp-str))
    157 
    +
    158 
    +          (when (zerop (length exp-str))
    159 
    +            (error 'hex-parse-error :text "Stream" :message "Invalid or missing exponent"))
    160 
    +
    161 
    +          (let* ((raw-exp (parse-integer exp-str))
    162 
    +                 (suffix (peek-char nil stream nil #\Space))
    163 
    +                 (is-single (char-equal suffix #\f))
    164 
    +                 ;; Final Construction
    165 
    +                 (result (* sign (scale-float val raw-exp))))
    166 
    +
    167 
    +            (when is-single (read-char stream)) ; Consume 'f'
    168 
    +
    169 
    +            (if is-single
    170 
    +                (float result 1.0f0)
    171 
    +                result)))))))
    172 
    +
    173 
    +;;; PARSE-HEX-FLOAT -- Public
    174 
    +;;;
    175 
    +;;; Parse a C-style hex float number from either a string or a stream.
    176 
    +(defun parse-hex-float (obj)
    177 
    +  "Parse a C-style hex float number from OBJ which is either a string or a stream."
    178 
    +  (declare (type (or string stream) obj))
    179 
    +  (etypecase obj
    180 
    +    (string
    181 
    +     (with-input-from-string (s obj)
    182 
    +       (parse-hex-float-from-stream s)))
    183 
    +    (stream
    184 
    +     (parse-hex-float-from-stream obj))))

  • src/general-info/release-22a.md
    ... ... @@ -57,6 +57,7 @@ public domain.
    57 57 
         * #460: Unit tests were not being recognized as failing on CI.
    58 58 
         * #463: `double-double-float` is missing comparison operations
    59 59 
                 between `double-double-float` and `double-float`
    60 
    +    * #474: Add functions to print and parse C-style hex floats.
    60 61 
       * Other changes:
    61 62 
       * Improvements to the PCL implementation of CLOS:
    62 63 
       * Changes to building procedure:

  • src/i18n/locale/cmucl.pot
    ... ... @@ -6060,6 +6060,38 @@ msgid ""
    6060 6060 
     " afterward."
    6061 6061 
     msgstr ""
    6062 6062
    6063 
    +#: src/code/ext-code.lisp
    6064 
    +msgid ""
    6065 
    +"Prints a single or double float in bit-perfect C-style hex.\n"
    6066 
    +"   If AT-P is true, prepends '+' for non-negative finite values."
    6067 
    +msgstr ""
    6068 
    +
    6069 
    +#: src/code/ext-code.lisp
    6070 
    +msgid ""
    6071 
    +"Convert FLOAT to C-style hex string and write it to STREAM.\n"
    6072 
    +"  Infinities are printed as \"-inf\" and \"inf\".  NaN is printed as\n"
    6073 
    +"  \"nan\"."
    6074 
    +msgstr ""
    6075 
    +
    6076 
    +#: src/code/ext-code.lisp
    6077 
    +msgid ""
    6078 
    +"Formatter for ~/ext:format-hex-float/. \n"
    6079 
    +"   Uses AT-SIGN-P (@) to force the sign. COLON-P (:) is currently ignored."
    6080 
    +msgstr ""
    6081 
    +
    6082 
    +#: src/code/ext-code.lisp
    6083 
    +msgid ""
    6084 
    +"Reads a C-style hex float number from STREAM.  A single-float or\n"
    6085 
    +"  double-float number is returned.  A HEX-PARSE-ERROR is signaled for\n"
    6086 
    +"  an invalid format."
    6087 
    +msgstr ""
    6088 
    +
    6089 
    +#: src/code/ext-code.lisp
    6090 
    +msgid ""
    6091 
    +"Parse a C-style hex float number from OBJ which is either a string or a "
    6092 
    +"stream."
    6093 
    +msgstr ""
    6094 
    +
    6063 6095 
     #: src/code/commandline.lisp
    6064 6096 
     msgid "A list of all the command line arguments after --"
    6065 6097 
     msgstr ""

  • src/tools/worldcom.lisp
    ... ... @@ -221,6 +221,7 @@
    221 221 
     (comf "target:code/misc")
    222 222 
     (comf "target:code/misc-doc")
    223 223 
     (comf "target:code/extensions" :byte-compile t)
    224 
    +(comf "target:code/ext-code")
    224 225 
     (comf "target:code/commandline")
    225 226 
     (comf "target:code/env-access")
    226 227

  • src/tools/worldload.lisp
    ... ... @@ -44,6 +44,7 @@
    44 44
    45 45
    46 46 
     (maybe-byte-load "target:code/extensions")
    47 
    +(maybe-byte-load "target:code/ext-code")
    47 48 
     (maybe-byte-load "target:code/defmacro")
    48 49 
     (maybe-byte-load "target:code/sysmacs")
    49 50

  • tests/extensions.lisp
    1 
    +;; Test extensions
    2 
    +(defpackage :extensions-tests
    3 
    +  (:use :cl :lisp-unit))
    4 
    +
    5 
    +(in-package "EXTENSIONS-TESTS")
    6 
    +
    7 
    +(defun get-double-bits (val)
    8 
    +  (multiple-value-bind (hi lo) (kernel:double-float-bits val)
    9 
    +    (logior (ash (ldb (byte 32 0) hi) 32) (ldb (byte 32 0) lo))))
    10 
    +
    11 
    +(defun get-single-bits (val)
    12 
    +  (ldb (byte 32 0) (kernel:single-float-bits val)))
    13 
    +
    14 
    +(define-test test-hex-syntax
    15 
    +  (:tag :validation)
    16 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "inf"))
    17 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x.p+0"))
    18 
    +  (assert-error 'ext:hex-parse-error (ext:parse-hex-float "0x1.0p")))
    19 
    +
    20 
    +(define-test test-cliff-boundaries
    21 
    +  (:tag :precision)
    22 
    +  ;; Double Precision (-1022 Cliff)
    23 
    +
    24 
    +  (assert-equal #x0010000000000000
    25 
    +		(get-double-bits (ext:parse-hex-float "0x1.0000000000000p-1022")))
    26 
    +  (assert-equal #x000fffffffffffff
    27 
    +		(get-double-bits (ext:parse-hex-float "0x0.fffffffffffffp-1022")))
    28 
    +  (assert-equal #x001f0195cb356b8f
    29 
    +		(get-double-bits (ext:parse-hex-float "0x1.f0195cb356b8fp-1022")))
    30 
    +
    31 
    +  ;; Single Precision (-126 Cliff)
    32 
    +
    33 
    +  (assert-equal #x00800000
    34 
    +		(get-single-bits (ext:parse-hex-float "0x1.000000p-126f")))
    35 
    +  (assert-equal #x00400000
    36 
    +		(get-single-bits (ext:parse-hex-float "0x0.800000p-126f")))
    37 
    +  (assert-equal #x7f7fffff
    38 
    +		(get-single-bits (ext:parse-hex-float "0x1.fffffep+127f"))))
    39 
    +
    40 
    +(define-test test-negative-zero
    41 
    +  (:tag :edge-cases)
    42 
    +  (assert-equal #x8000000000000000
    43 
    +		(get-double-bits (ext:parse-hex-float "-0x0.0p+0")))
    44 
    +  (assert-equal #x80000000
    45 
    +		(get-single-bits (ext:parse-hex-float "-0x0.0p+0f")))
    46 
    +  (assert-true (typep (ext:parse-hex-float "-0x0.0p+0f")
    47 
    +		      'single-float)))
    48 
    +
    49 
    +(define-test test-subnormal-boundaries
    50 
    +  (:tag :edge)
    51 
    +  ;; Test smallest single-float subnormal
    52 
    +  (let* ((val (kernel:make-single-float 1))
    53 
    +         (str (ext:float-to-hex-string val))
    54 
    +         (parsed (ext:parse-hex-float str)))
    55 
    +    (assert-equal (get-single-bits val) (get-single-bits parsed)
    56 
    +		  val str parsed))
    57 
    +  ;; Test smallest double-float subnormal
    58 
    +  (let* ((val (kernel:make-double-float 0 1))
    59 
    +         (str (ext:float-to-hex-string val))
    60 
    +         (parsed (ext:parse-hex-float str)))
    61 
    +    (assert-equal (get-double-bits val) (get-double-bits parsed)
    62 
    +		  val str parsed)))
    63 
    +
    64 
    +(define-test test-double-roundtrip
    65 
    +  (:tag :stress)
    66 
    +  (loop repeat 10000 do
    67 
    +    (let* ((hi-bits (random #x100000000))
    68 
    +           (hi (if (logbitp 31 hi-bits) (- hi-bits #x100000000) hi-bits))
    69 
    +           (lo (random #x100000000))
    70 
    +           (val (kernel:make-double-float hi lo)))
    71 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    72 
    +        (let* ((str (ext:float-to-hex-string val))
    73 
    +               (parsed (ext:parse-hex-float str)))
    74 
    +          (assert-equal (get-double-bits val)
    75 
    +			(get-double-bits parsed)
    76 
    +			val str parsed))))))
    77 
    +
    78 
    +(define-test test-single-roundtrip
    79 
    +  (:tag :stress)
    80 
    +  (loop repeat 10000 do
    81 
    +    (let* ((bits-raw (random #x100000000))
    82 
    +           (bits (if (logbitp 31 bits-raw) (- bits-raw #x100000000) bits-raw))
    83 
    +           (val (kernel:make-single-float bits)))
    84 
    +      (unless (or (ext:float-nan-p val) (ext:float-infinity-p val))
    85 
    +        (let* ((str (concatenate 'string (ext:float-to-hex-string val) "f"))
    86 
    +               (parsed (ext:parse-hex-float str)))
    87 
    +          (assert-equal (get-single-bits val)
    88 
    +			(get-single-bits parsed)
    89 
    +			val str parsed))))))

  • tests/float.lisp
    ... ... @@ -346,20 +346,7 @@
    346 346 
     ;; Rudimentary code to read C %a formatted numbers that look like
    347 347 
     ;; "-0x1.c4dba4ba1ee79p-620".  We assume STRING is exactly in this
    348 348 
     ;; format.  No error-checking is done.
    349 
    -(defun parse-hex-float (string)
    350 
    -  (let* ((sign (if (char= (aref string 0) #\-)
    351 
    -		   -1
    352 
    -		   1))
    353 
    -	 (dot-posn (position #\. string))
    354 
    -	 (p-posn (position #\p string))
    355 
    -	 (lead (parse-integer string :start (1- dot-posn) :end dot-posn))
    356 
    -	 (frac (parse-integer string :start (1+ dot-posn) :end p-posn :radix 16))
    357 
    -	 (exp (parse-integer string :start (1+ p-posn))))
    358 
    -    (* sign
    359 
    -       (scale-float (float (+ (ash lead 52)
    360 
    -			      frac)
    361 
    -			   1d0)
    362 
    -		    (- exp 52)))))
    349 
    +
    363 350
    364 351 
     ;; Relative error in terms of bits of accuracy.  This is the
    365 352 
     ;; definition used by Baudin and Smith.  A result of 53 means the two
    ... ... @@ -507,50 +494,50 @@
    507 494 
       ;; 13
    508 495 
       ;; Iteration 1.  Without this, we would instead return
    509 496 
       ;;
    510 
    -  ;;   (complex (parse-hex-float "0x1.ba8df8075bceep+155")
    511 
    -  ;;            (parse-hex-float "-0x1.a4ad6329485f0p-895"))
    497 
    +  ;;   (complex (ext:parse-hex-float "0x1.ba8df8075bceep+155")
    498 
    +  ;;            (ext:parse-hex-float "-0x1.a4ad6329485f0p-895"))
    512 499 
       ;;
    513 500 
       ;; whose imaginary part is quite a bit off.
    514 501 
       (frob cdiv.mcgehearty-iteration.1
    515 
    -	(complex (parse-hex-float "0x1.73a3dac1d2f1fp+509")
    516 
    -		 (parse-hex-float "-0x1.c4dba4ba1ee79p-620"))
    517 
    -	(complex (parse-hex-float "0x1.adf526c249cf0p+353")
    518 
    -		 (parse-hex-float "0x1.98b3fbc1677bbp-697"))
    519 
    -	(complex (parse-hex-float "0x1.BA8DF8075BCEEp+155")
    520 
    -		 (parse-hex-float "-0x1.A4AD628DA5B74p-895"))
    502 
    +	(complex (ext:parse-hex-float "0x1.73a3dac1d2f1fp+509")
    503 
    +		 (ext:parse-hex-float "-0x1.c4dba4ba1ee79p-620"))
    504 
    +	(complex (ext:parse-hex-float "0x1.adf526c249cf0p+353")
    505 
    +		 (ext:parse-hex-float "0x1.98b3fbc1677bbp-697"))
    506 
    +	(complex (ext:parse-hex-float "0x1.BA8DF8075BCEEp+155")
    507 
    +		 (ext:parse-hex-float "-0x1.A4AD628DA5B74p-895"))
    521 508 
     	53
    522 509 
     	106)
    523 510 
       ;; 14
    524 511 
       ;; Iteration 2.
    525 512 
       (frob cdiv.mcgehearty-iteration.2
    526 
    -	(complex (parse-hex-float "-0x0.000000008e4f8p-1022")
    527 
    -		 (parse-hex-float "0x0.0000060366ba7p-1022"))
    528 
    -	(complex (parse-hex-float "-0x1.605b467369526p-245")
    529 
    -		 (parse-hex-float "0x1.417bd33105808p-256"))
    530 
    -	(complex (parse-hex-float "0x1.cde593daa4ffep-810")
    531 
    -		 (parse-hex-float "-0x1.179b9a63df6d3p-799"))
    513 
    +	(complex (ext:parse-hex-float "-0x0.000000008e4f8p-1022")
    514 
    +		 (ext:parse-hex-float "0x0.0000060366ba7p-1022"))
    515 
    +	(complex (ext:parse-hex-float "-0x1.605b467369526p-245")
    516 
    +		 (ext:parse-hex-float "0x1.417bd33105808p-256"))
    517 
    +	(complex (ext:parse-hex-float "0x1.cde593daa4ffep-810")
    518 
    +		 (ext:parse-hex-float "-0x1.179b9a63df6d3p-799"))
    532 519 
     	52
    533 520 
     	106)
    534 521 
       ;; 15
    535 522 
       ;; Iteration 3
    536 523 
       (frob cdiv.mcgehearty-iteration.3
    537 
    -	(complex (parse-hex-float "0x1.cb27eece7c585p-355 ")
    538 
    -		 (parse-hex-float "0x0.000000223b8a8p-1022"))
    539 
    -	(complex (parse-hex-float "-0x1.74e7ed2b9189fp-22")
    540 
    -		 (parse-hex-float "0x1.3d80439e9a119p-731"))
    541 
    -	(complex (parse-hex-float "-0x1.3b35ed806ae5ap-333")
    542 
    -		 (parse-hex-float "-0x0.05e01bcbfd9f6p-1022"))
    524 
    +	(complex (ext:parse-hex-float "0x1.cb27eece7c585p-355 ")
    525 
    +		 (ext:parse-hex-float "0x0.000000223b8a8p-1022"))
    526 
    +	(complex (ext:parse-hex-float "-0x1.74e7ed2b9189fp-22")
    527 
    +		 (ext:parse-hex-float "0x1.3d80439e9a119p-731"))
    528 
    +	(complex (ext:parse-hex-float "-0x1.3b35ed806ae5ap-333")
    529 
    +		 (ext:parse-hex-float "-0x0.05e01bcbfd9f6p-1022"))
    543 530 
     	53
    544 531 
     	106)
    545 532 
       ;; 16
    546 533 
       ;; Iteration 4
    547 534 
       (frob cdiv.mcgehearty-iteration.4
    548 
    -	(complex (parse-hex-float "-0x1.f5c75c69829f0p-530")
    549 
    -		 (parse-hex-float "-0x1.e73b1fde6b909p+316"))
    550 
    -	(complex (parse-hex-float "-0x1.ff96c3957742bp+1023")
    551 
    -		 (parse-hex-float "0x1.5bd78c9335899p+1021"))
    552 
    -	(complex (parse-hex-float "-0x1.423c6ce00c73bp-710")
    553 
    -		 (parse-hex-float "0x1.d9edcf45bcb0ep-708"))
    535 
    +	(complex (ext:parse-hex-float "-0x1.f5c75c69829f0p-530")
    536 
    +		 (ext:parse-hex-float "-0x1.e73b1fde6b909p+316"))
    537 
    +	(complex (ext:parse-hex-float "-0x1.ff96c3957742bp+1023")
    538 
    +		 (ext:parse-hex-float "0x1.5bd78c9335899p+1021"))
    539 
    +	(complex (ext:parse-hex-float "-0x1.423c6ce00c73bp-710")
    540 
    +		 (ext:parse-hex-float "0x1.d9edcf45bcb0ep-708"))
    554 541 
     	52
    555 542 
     	106))
    556 543
    ... ... @@ -592,26 +579,6 @@
    592 579 
       (assert-equal -2w300
    593 580 
     		(* -2w300 1w0)))
    594 581
    595 
    -
    596 
    -
    597 
    -;; Rudimentary code to read C %a formatted numbers that look like
    598 
    -;; "-0x1.c4dba4ba1ee79p-620".  We assume STRING is exactly in this
    599 
    -;; format.  No error-checking is done.
    600 
    -(defun parse-hex-float (string)
    601 
    -  (let* ((sign (if (char= (aref string 0) #\-)
    602 
    -		   -1
    603 
    -		   1))
    604 
    -	 (dot-posn (position #\. string))
    605 
    -	 (p-posn (position #\p string))
    606 
    -	 (lead (parse-integer string :start (1- dot-posn) :end dot-posn))
    607 
    -	 (frac (parse-integer string :start (1+ dot-posn) :end p-posn :radix 16))
    608 
    -	 (exp (parse-integer string :start (1+ p-posn))))
    609 
    -    (* sign
    610 
    -       (scale-float (float (+ (ash lead 52)
    611 
    -			      frac)
    612 
    -			   1d0)
    613 
    -		    (- exp 52)))))
    614 
    -
    615 582 
     ;; Relative error in terms of bits of accuracy.  This is the
    616 583 
     ;; definition used by Baudin and Smith.  A result of 53 means the two
    617 584 
     ;; numbers have identical bits.  For complex numbers, we use the min
    ... ... @@ -725,47 +692,47 @@
    725 692 
       ;; 13
    726 693 
       ;; Iteration 1.  Without this, we would instead return
    727 694 
       ;;
    728 
    -  ;;   (complex (parse-hex-float "0x1.ba8df8075bceep+155")
    729 
    -  ;;            (parse-hex-float "-0x1.a4ad6329485f0p-895"))
    695 
    +  ;;   (complex (ext:parse-hex-float "0x1.ba8df8075bceep+155")
    696 
    +  ;;            (ext:parse-hex-float "-0x1.a4ad6329485f0p-895"))
    730 697 
       ;;
    731 698 
       ;; whose imaginary part is quite a bit off.
    732 699 
       (frob cdiv.mcgehearty-iteration.1
    733 
    -	(complex (parse-hex-float "0x1.73a3dac1d2f1fp+509")
    734 
    -		 (parse-hex-float "-0x1.c4dba4ba1ee79p-620"))
    735 
    -	(complex (parse-hex-float "0x1.adf526c249cf0p+353")
    736 
    -		 (parse-hex-float "0x1.98b3fbc1677bbp-697"))
    737 
    -	(complex (parse-hex-float "0x1.BA8DF8075BCEEp+155")
    738 
    -		 (parse-hex-float "-0x1.A4AD628DA5B74p-895"))
    700 
    +	(complex (ext:parse-hex-float "0x1.73a3dac1d2f1fp+509")
    701 
    +		 (ext:parse-hex-float "-0x1.c4dba4ba1ee79p-620"))
    702 
    +	(complex (ext:parse-hex-float "0x1.adf526c249cf0p+353")
    703 
    +		 (ext:parse-hex-float "0x1.98b3fbc1677bbp-697"))
    704 
    +	(complex (ext:parse-hex-float "0x1.BA8DF8075BCEEp+155")
    705 
    +		 (ext:parse-hex-float "-0x1.A4AD628DA5B74p-895"))
    739 706 
     	53)
    740 707 
       ;; 14
    741 708 
       ;; Iteration 2.
    742 709 
       (frob cdiv.mcgehearty-iteration.2
    743 
    -	(complex (parse-hex-float "-0x0.000000008e4f8p-1022")
    744 
    -		 (parse-hex-float "0x0.0000060366ba7p-1022"))
    745 
    -	(complex (parse-hex-float "-0x1.605b467369526p-245")
    746 
    -		 (parse-hex-float "0x1.417bd33105808p-256"))
    747 
    -	(complex (parse-hex-float "0x1.cde593daa4ffep-810")
    748 
    -		 (parse-hex-float "-0x1.179b9a63df6d3p-799"))
    710 
    +	(complex (ext:parse-hex-float "-0x0.000000008e4f8p-1022")
    711 
    +		 (ext:parse-hex-float "0x0.0000060366ba7p-1022"))
    712 
    +	(complex (ext:parse-hex-float "-0x1.605b467369526p-245")
    713 
    +		 (ext:parse-hex-float "0x1.417bd33105808p-256"))
    714 
    +	(complex (ext:parse-hex-float "0x1.cde593daa4ffep-810")
    715 
    +		 (ext:parse-hex-float "-0x1.179b9a63df6d3p-799"))
    749 716 
     	52)
    750 717 
       ;; 15
    751 718 
       ;; Iteration 3
    752 719 
       (frob cdiv.mcgehearty-iteration.3
    753 
    -	(complex (parse-hex-float "0x1.cb27eece7c585p-355 ")
    754 
    -		 (parse-hex-float "0x0.000000223b8a8p-1022"))
    755 
    -	(complex (parse-hex-float "-0x1.74e7ed2b9189fp-22")
    756 
    -		 (parse-hex-float "0x1.3d80439e9a119p-731"))
    757 
    -	(complex (parse-hex-float "-0x1.3b35ed806ae5ap-333")
    758 
    -		 (parse-hex-float "-0x0.05e01bcbfd9f6p-1022"))
    720 
    +	(complex (ext:parse-hex-float "0x1.cb27eece7c585p-355 ")
    721 
    +		 (ext:parse-hex-float "0x0.000000223b8a8p-1022"))
    722 
    +	(complex (ext:parse-hex-float "-0x1.74e7ed2b9189fp-22")
    723 
    +		 (ext:parse-hex-float "0x1.3d80439e9a119p-731"))
    724 
    +	(complex (ext:parse-hex-float "-0x1.3b35ed806ae5ap-333")
    725 
    +		 (ext:parse-hex-float "-0x0.05e01bcbfd9f6p-1022"))
    759 726 
     	53)
    760 727 
       ;; 16
    761 728 
       ;; Iteration 4
    762 729 
       (frob cdiv.mcgehearty-iteration.4
    763 
    -	(complex (parse-hex-float "-0x1.f5c75c69829f0p-530")
    764 
    -		 (parse-hex-float "-0x1.e73b1fde6b909p+316"))
    765 
    -	(complex (parse-hex-float "-0x1.ff96c3957742bp+1023")
    766 
    -		 (parse-hex-float "0x1.5bd78c9335899p+1021"))
    767 
    -	(complex (parse-hex-float "-0x1.423c6ce00c73bp-710")
    768 
    -		 (parse-hex-float "0x1.d9edcf45bcb0ep-708"))
    730 
    +	(complex (ext:parse-hex-float "-0x1.f5c75c69829f0p-530")
    731 
    +		 (ext:parse-hex-float "-0x1.e73b1fde6b909p+316"))
    732 
    +	(complex (ext:parse-hex-float "-0x1.ff96c3957742bp+1023")
    733 
    +		 (ext:parse-hex-float "0x1.5bd78c9335899p+1021"))
    734 
    +	(complex (ext:parse-hex-float "-0x1.423c6ce00c73bp-710")
    735 
    +		 (ext:parse-hex-float "0x1.d9edcf45bcb0ep-708"))
    769 736 
     	52))
    770 737
    771 738 
     (define-test complex-division.misc

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/e1f841fbe5641e473bca8a2f50770251bbec4724...1030fd9b886c9d9461f77a76444635d89c3a8a9f at 1772036660