home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Pascal / BPASCAL.700 / LIB / ARISOURC.ZIP / FPFRC.ASM < prev    next >
Encoding:
Assembly Source File  |  1993-03-07  |  3.5 KB  |  86 lines
  1.  
  2. ; *******************************************************
  3. ; *                                                     *
  4. ; *     Turbo Pascal Runtime Library Version 7.0        *
  5. ; *     Real Frac Function                              *
  6. ; *                                                     *
  7. ; *     Copyright (C) 1989-1993 Norbert Juffa           *
  8. ; *                                                     *
  9. ; *******************************************************
  10.  
  11.              TITLE   FPFRC
  12.  
  13.  
  14. CODE         SEGMENT BYTE PUBLIC
  15.  
  16.              ASSUME  CS:CODE
  17.  
  18. ; Publics
  19.  
  20.              PUBLIC  RFrac,RealFrac
  21.  
  22. ;-------------------------------------------------------------------------------
  23. ; RFrac represents the standard function Frac. It computes the fractional part
  24. ; of a TURBO Pascal six byte floating point number. This routine is realized as
  25. ; a selfcontained routine rather than as a combination of the RInt and RealSub
  26. ; routines.
  27. ;
  28. ; INPUT:     DX:BX:AX  floating point number
  29. ;
  30. ; OUTPUT:    DX:BX:AX  fractional part of floating point number
  31. ;
  32. ; DESTROYS:  AX,BX,CX,DX,Flags
  33. ;-------------------------------------------------------------------------------
  34.  
  35. RFrac        PROC    FAR
  36. RealFrac:    CMP     AL, 80h           ; is number < 1 ?
  37.              JBE     $unchanged        ; yes, that is the result
  38.              CMP     AL, 0A8h          ; is number > 2^39 ?
  39.              JA      $frac_zero        ; yes, no fractional part
  40.              MOV     CH, 7Fh           ; generate mask for sign bit
  41.              OR      CH, DH            ; get sign bit
  42.              PUSH    CX                ; save sign mask
  43.              JMP     $shift_start      ; start left shift
  44.              NOP                       ; filler
  45. $frac_shift8:SUB     AL, 8             ; adjust exponent
  46.              MOV     DH, DL            ; shift
  47.              MOV     DL, BH            ;  mantissa
  48.              MOV     BH, BL            ;   8 bits
  49.              MOV     BL, AH            ;    to the
  50.              XOR     AH, AH            ;     left
  51. $shift_start:CMP     AL, 88h           ; another byte shift possible ?
  52.              JA      $frac_shift8      ; yes, do it
  53.  
  54.              ALIGN   4
  55.  
  56. $frac_shift1:DEC     AX                ; adjust exponent
  57.              ADD     AH, AH            ; shift
  58.              ADC     BX, BX            ;  mantissa
  59.              ADC     DX, DX            ;   1 bit to the left
  60.              CMP     AL, 80h           ; another bit shift necessary ?
  61.              JA      $frac_shift1      ; yes, do it
  62.              MOV     CX, DX            ; test if
  63.              OR      CH, AH            ;   resulting
  64.              OR      CX, BX            ;    mantissa is zero
  65.              POP     CX                ; get back sign mask
  66.              JZ      $frac_zero        ; yes, return zero
  67. $frac_norm:  OR      DH, DH            ; mantissa normalized ?
  68.              JS      $frac_exit        ; yes
  69.              ADD     AH, AH            ; shift
  70.              ADC     BX, BX            ;  mantissa
  71.              ADC     DX, DX            ;   1 bit to the left
  72.              DEC     AL                ; adjust exponent
  73.              JNZ     $frac_norm        ; if no underflow, cont. normalization
  74. $frac_zero:  XOR     AX, AX            ; load
  75.              MOV     BX, AX            ;  a
  76.              CWD                       ;   zero
  77. $frac_exit:  AND     DH, CH            ; mask out sign bit if necessary
  78. $unchanged:  RET                       ; done
  79. RFrac        ENDP
  80.  
  81.              ALIGN   4
  82.  
  83. CODE         ENDS
  84.  
  85.              END
  86.