Changeset 9476
 Timestamp:
 May 14, 2008, 6:47:41 PM (13 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/ia32/level0/X86/X8632/x8632float.lisp
r8214 r9476 401 401 :operands operands)))))) 402 402 403 (defvar *roundingmodealist* 404 '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) 405 406 (defun getfpumode (&optional (mode nil modep)) 407 (let* ((flags (%getmxcsrcontrol))) 408 (declare (fixnum flags)) 409 (let* ((roundingmode 410 (car (nth (+ (if (logbitp x86::mxcsrrc0bit flags) 1 0) 411 (if (logbitp x86::mxcsrrc1bit flags) 2 0)) 412 *roundingmodealist*))) 413 (overflow (not (logbitp x86::mxcsrombit flags))) 414 (underflow (not (logbitp x86::mxcsrumbit flags))) 415 (divisionbyzero (not (logbitp x86::mxcsrzmbit flags))) 416 (invalid (not (logbitp x86::mxcsrimbit flags))) 417 (inexact (not (logbitp x86::mxcsrpmbit flags)))) 418 (if modep 419 (ecase mode 420 (:roundingmode roundingmode) 421 (:overflow overflow) 422 (:underflow underflow) 423 (:divisionbyzero divisionbyzero) 424 (:invalid invalid) 425 (:inexact inexact)) 426 `(:roundingmode ,roundingmode 427 :overflow ,overflow 428 :underflow ,underflow 429 :divisionbyzero ,divisionbyzero 430 :invalid ,invalid 431 :inexact ,inexact))))) 432 433 ;;; did we document this? 434 (defun setfpumode (&key (roundingmode :nearest roundingp) 435 (overflow t overflowp) 436 (underflow t underflowp) 437 (divisionbyzero t zerop) 438 (invalid t invalidp) 439 (inexact t inexactp)) 440 (let* ((current (%getmxcsrcontrol)) 441 (new current)) 442 (declare (fixnum current new)) 443 (when roundingp 444 (let* ((rcbits (or 445 (cdr (assoc roundingmode *roundingmodealist*)) 446 (error "Unknown rounding mode: ~s" roundingmode)))) 447 (declare (fixnum rcbits)) 448 (if (logbitp 0 rcbits) 449 (bitsetf x86::mxcsrrc0bit new) 450 (bitclrf x86::mxcsrrc0bit new)) 451 (if (logbitp 1 rcbits) 452 (bitsetf x86::mxcsrrc1bit new) 453 (bitclrf x86::mxcsrrc1bit new)))) 454 (when invalidp 455 (if invalid 456 (bitclrf x86::mxcsrimbit new) 457 (bitsetf x86::mxcsrimbit new))) 458 (when overflowp 459 (if overflow 460 (bitclrf x86::mxcsrombit new) 461 (bitsetf x86::mxcsrombit new))) 462 (when underflowp 463 (if underflow 464 (bitclrf x86::mxcsrumbit new) 465 (bitsetf x86::mxcsrumbit new))) 466 (when zerop 467 (if divisionbyzero 468 (bitclrf x86::mxcsrzmbit new) 469 (bitsetf x86::mxcsrzmbit new))) 470 (when inexactp 471 (if inexact 472 (bitclrf x86::mxcsrpmbit new) 473 (bitsetf x86::mxcsrpmbit new))) 474 (unless (= current new) 475 (%setmxcsrcontrol new)) 476 (%getmxcsr))) 477 403 478 ;;; end duplicated code 404 479
Note: See TracChangeset
for help on using the changeset viewer.