home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / LIB / ARISOURC.ZIP / FPRND.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-03-07  |  7.5 KB  |  162 lines
  1.  
  2. ; *******************************************************
  3. ; *                                                     *
  4. ; *     Turbo Pascal Runtime Library Version 7.0        *
  5. ; *     Real Round/Trunc                                *
  6. ; *                                                     *
  7. ; *     Copyright (C) 1989-1993 Norbert Juffa           *
  8. ; *                                                     *
  9. ; *******************************************************
  10.  
  11.              TITLE   FPRND
  12.  
  13.  
  14. CODE         SEGMENT BYTE PUBLIC
  15.  
  16.              ASSUME  CS:CODE
  17.  
  18. ; Externals
  19.              EXTRN   HaltError:NEAR
  20.  
  21. ; Publics
  22.  
  23.              PUBLIC  RealTrunc,RTrunc,RRound
  24.  
  25. ;-------------------------------------------------------------------------------
  26. ; RealTrunc converts a TURBO-Pascal six byte floatingpoint number to a four
  27. ; byte signed integer. Truncation or rounding can be requested by the caller
  28. ; by setting a flag. If the conversion results in a long integer overflow, the
  29. ; routine returns with the carry flag set. When rounding is selected, the
  30. ; routine complies with the IEEE "round to nearest or even" mode. For example,
  31. ; Round (4.5) = 4, but Round (5.5) = 6. Special care is taken to accomodate
  32. ; correct handling of the smallest LONGINT number 8000000h.
  33. ;
  34. ; INPUT:     DX:BX:AX  floating point number
  35. ;            CH        rounding flag ( 0 = trunc, all others = round)
  36. ;
  37. ; OUTPUT:    DX:AX     converted longint number
  38. ;            CF        set if overflow occured
  39. ;
  40. ; DESTROYS:  AX,BX,CX,DX,Flags
  41. ;-------------------------------------------------------------------------------
  42.  
  43. $long_zero:  XOR     AX, AX            ; load
  44.              CWD                       ;  zero into DX:AX
  45.              RETN                      ; exit
  46. $too_big:    JNZ     $ovrfl_err2       ; abs (number) > 2^32
  47.              CMP     DH, 80h           ; num negative && abs (num) < 2^32-2^24 ?
  48.              JNE     $ovrfl_err2       ; no, overflow
  49.              XOR     AL, AL            ; clear sticky flag
  50.              PUSH    DX                ; save original sign
  51.              OR      DH, 80h           ; set hidden bit
  52.              JMP     $shft_done        ; too big numbers caught by 2nd check
  53. $ovrfl_err2: STC                       ; signal error
  54.              RETN                      ; exit
  55.  
  56.              ALIGN   4
  57.  
  58. RealTrunc    PROC    NEAR
  59.              ADD     AL, 60h           ; number to big ?
  60.              JC      $too_big          ; probably, do detailed check
  61.              CMP     AL, 0E0h          ; number < 0.5 ?
  62.              JB      $long_zero        ; return zero
  63. $size_ok:    PUSH    DX                ; save sign
  64.              OR      DH, 80h           ; set implicit mantissa bit
  65.              MOV     CL, AL            ; counter
  66.              XOR     AL, AL            ; initialize sticky flag
  67.              CMP     CL, -16           ; 16-bit shift possible ?
  68.              JA      $byte_shift       ; no, try 8-bit shift
  69.              OR      AL, AH            ; accumulate
  70.              OR      AL, BL            ;  sticky flag
  71.              MOV     AH, BH            ; shift DX:BX:AH
  72.              MOV     BX, DX            ;  16 bits to
  73.              XOR     DX, DX            ;   the right
  74.              ADD     CL, 16            ; remaining bit shifts
  75.              JZ      $shft_done        ; no shifts left, ->
  76. $byte_shift: CMP     CL, -8            ; 8-bit shift possible ?
  77.              JA      $4bit_shift       ; no, try nibble shift
  78.              OR      AL, AH            ; accumulate sticky flag
  79.              MOV     AH, BL            ; shift
  80.              MOV     BL, BH            ;  DX:BX:AH
  81.              MOV     BH, DL            ;   8 bits
  82.              MOV     DL, DH            ;    to the
  83.              XOR     DH, DH            ;     right
  84.              ADD     CL, 8             ; remaining bit shifts
  85.              JZ      $shft_done        ; no bit shifts left
  86. $4bit_shift: NEG     AL                ; sticky flag <> 0 ?
  87.              SBB     AL, AL            ; set to FFh if not 0
  88.              CMP     CL, -4            ; nibble shift possible ?
  89.              JA      $bit_shift        ; no, try single bit shifts
  90.              SHR     DX, 1             ; shift DX:BX:AH
  91.              RCR     BX, 1             ;  1 bit to
  92.              RCR     AX, 1             ;   the right and accumulate sticky flag
  93.              SHR     DX, 1             ; shift DX:BX:AH
  94.              RCR     BX, 1             ;  1 bit to
  95.              RCR     AX, 1             ;   the right and accumulate sticky flag
  96.              SHR     DX, 1             ; shift DX:BX:AH
  97.              RCR     BX, 1             ;  1 bit to
  98.              RCR     AX, 1             ;   the right and accumulate sticky flag
  99.              SHR     DX, 1             ; shift DX:BX:AH
  100.              RCR     BX, 1             ;  1 bit to
  101.              RCR     AX, 1             ;   the right and accumulate sticky flag
  102.              ADD     CL, 4             ; remaining bit shifts
  103.              JZ      $shft_done        ; no shifts left
  104. $bit_shift:  NEG     AL                ; sticky flag <> 0 ?
  105.              SBB     AL, AL            ; set to FFh if not 0
  106.  
  107.              ALIGN   4
  108.  
  109. $shift_loop: SHR     DX, 1             ; shift DX:BX:AH
  110.              RCR     BX, 1             ;  1 bit to
  111.              RCR     AX, 1             ;   the right and accumulate sticky flag
  112.              INC     CL                ; adjust shift counter
  113.              JNZ     $shift_loop       ; until counter zero
  114. $shft_done:  NEG     CH                ; test if rounding flag set
  115.              SBB     CH, CH            ; CH = FFh if rounding, CH = 0 if trunc
  116.              AND     AH, CH            ; clear fraction part if trunc
  117.              ADD     AX, 8000h         ; round up ? AH = guard, AL = sticky
  118.              JNZ     $round            ; if no tie case (AH = 80, AL = 0)
  119.              ROR     BL, 1             ; move least significant
  120.              ROL     BL, 1             ;  bit into carry
  121. $round:      POP     CX                ; get original sign flag
  122.              ADC     BX, 0             ; round up
  123.              ADC     DX, 0             ;  result if carry set
  124.              XCHG    AX, BX            ; result in DX:AX
  125.              OR      CH, CH            ; original argument negative ?
  126.              JNS     $pos_long         ; no, was positive
  127.              NOT     DX                ; negate
  128.              NEG     AX                ;  longint
  129.              SBB     DX, -1            ;   in DX:AX
  130.              JNC     $rnd_done         ; DX:AX = 0, no need to check for ovrfl.
  131. $pos_long:   XOR     CH, DH            ; XOR sign of argument and sign of result
  132.              ADD     CH, CH            ; CY, if signs differ (= overflow)
  133. $rnd_done:   RET                       ; done
  134. RealTrunc    ENDP
  135.  
  136.              ALIGN   4
  137.  
  138. RTrunc       PROC    FAR
  139.              XOR     CH, CH            ; flag truncation
  140.              CALL    RealTrunc         ; convert real to longint
  141.              JC      RRangeError       ; longint overflowed
  142.              RET                       ; done
  143. RTrunc       ENDP
  144.  
  145.              ALIGN   4
  146.  
  147. RRound       PROC    FAR
  148.              MOV     CH, 1             ; flag rounding
  149.              CALL    RealTrunc         ; convert real to longint
  150.              JC      RRangeError       ; longint overflowed
  151.              RET                       ; done
  152. RRound       ENDP
  153.  
  154. RRangeError: MOV     AX, 0CFh          ; error code 207 (invalid fp operation)
  155.              JMP     HaltError         ; execute error handler
  156.  
  157.              ALIGN   4
  158.  
  159. CODE         ENDS
  160.  
  161.              END
  162.