fpc/rtl/m68k/lowmath.inc

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Carl-Eric Codere,
    member of the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
{*************************************************************************}
{  lowmath.inc                                                            }
{  Ported to FPC-Pascal by Carl Eric Codere                               }
{  Terms of use: This source code is freeware.                            }
{*************************************************************************}
{  This inc. implements low-level mathemtical routines  for the motorola  }
{  68000 family of processors.                                            }
{*************************************************************************}
{ single floating point routines taken from GCC 2.5.2 Atari compiler      }
{ library source.                                                         }
{  Original credits:                                                      }
{    written by Kai-Uwe Bloem ([email protected]).                   }
{      Based on a 80x86 floating point packet from comp.os.minix,         }
{        written by P.Housel                                              }
{    Patched by Olaf Flebbe ([email protected])          }
{    Revision by michal 05-93 ([email protected])               }
{*************************************************************************}
{--------------------------------------------------------------------}
{ LEFT TO DO:                                                        }
{ o Add support for FPU if present.                                  }
{ o Verify if single comparison works in all cases.                  }
{ o Add support for  NANs in SINGLE_CMP                              }
{ o Add comp (80-bit) multiplication,addition,substract,division,    }
{    shift.                                                          }
{ o Add stack checking for the routines which use the stack.         }
{    (This will probably have to be done in the code generator).     }
{--------------------------------------------------------------------}



Procedure Single_Norm;[alias : 'FPC_SINGLE_NORM'];Assembler;
{--------------------------------------------}
{ Low-level routine to normalize single  e   }
{  IEEE floating point values. Never called  }
{  directly.                                 }
{ On Exit:                                   }
{      d0 = result.                          }
{  Registers destroyed: d0,d1                }
{--------------------------------------------}
Asm
   tst.l    d4             { rounding and u.mant == 0 ?    }
   bne      @normlab1
   tst.b    d1
   beq      @retzok
@normlab1:
   clr.b    d2             { "sticky byte"                 }
@normlab3:
   move.l   #$ff000000,d5
@normlab4:
   tst.w    d0             { divide (shift)                }
   ble      @normlab2      {  denormalized number          }
   move.l   d4,d3
   and.l    d5,d3          {  or until no bits above 23    }
   beq      @normlab5
@normlab2:
   addq.w   #1,d0          { increment exponent            }
   lsr.l    #1,d4
   or.b     d1,d2          { set "sticky"                  }
   roxr.b   #1,d1          { shift into rounding bits      }
   bra      @normlab4
@normlab5:
   and.b    #1,d2
   or.b     d2,d1          { make least sig bit "sticky"   }
   asr.l    #1,d5          { #0xff800000 -> d5             }
@normlab6:
   move.l   d4,d3          { multiply (shift) until        }
   and.l    d5,d3          { one in "implied" position     }
   bne      @normlab7
   subq.w   #1,d0          { decrement exponent            }
   beq      @normlab7      {  too small. store as denormalized number }
   add.b    d1,d1          { some doubt about this one *              }
   addx.l   d4,d4
   bra      @normlab6
@normlab7:
   tst.b    d1             { check rounding bits          }
   bge      @normlab9      { round down - no action neccessary }
   neg.b    d1
   bvc      @normlab8      { round up                     }
   move.w   d4,d1          { tie case - round to even     }
                           {   dont need rounding bits any more }
   and.w    #1,d1          { check if even                }
   beq      @normlab9      {   mantissa is even - no action necessary  }
                           { fall through                 }
@normlab8:
   clr.w    d1             { zero rounding bits            }
   add.l    #1,d4
   tst.w    d0
   bne      @normlab10     { renormalize if number was denormalized   }
   add.w    #1,d0          { correct exponent for denormalized numbers }
   bra      @normlab3
@normlab10:
   move.l   d4,d3          { check for rounding overflow              }
   asl.l    #1,d5          { #0xff000000 -> d5                        }
   and.l    d5,d3
   bne      @normlab4      { go back and renormalize                  }
@normlab9:
   tst.l    d4             { check if normalization caused an underflow }
   beq      @retz
   tst.w    d0             { check for exponent overflow or underflow  }
   blt      @retz
   cmp.w    #255,d0
   bge      @oflow

   lsl.w    #8,d0          { re-position exponent - one bit too high }
   lsl.w    #1,d2          { get X bit                               }
   roxr.w   #1,d0          { shift it into sign position             }
   swap     d0             { map to upper word                       }
   clr.w    d0
   and.l    #$7fffff,d4    { top mantissa bits                       }
   or.l     d4,d0          { insert exponent and sign                }
   movem.l  (sp)+,d2-d5
   rts

@retz:
   { handling underflow should be done here... }
   { by default simply return 0 as retzok...   }
@retzok:
   moveq.l   #0,d0
   lsl.w     #1,d2
   roxr.l    #1,d0          { sign of 0 is the same as of d2          }
   movem.l   (sp)+,d2-d5
   rts

@oflow:
   move.l    #$7f800000,d0  { +infinity as proposed by IEEE         }

   tst.w     d2             { transfer sign                         }
   bge       @ofl_clear     { (mjr++)                               }
   bset      #31,d0         {                                       }
@ofl_clear:
   or.b      #2,ccr         { set overflow flag.                    }
   movem.l   (sp)+,d2-d5
   rts
end;


Procedure Single_AddSub; Assembler;
{--------------------------------------------}
{ Low-level routine to add/subtract single   }
{  IEEE floating point values. Never called  }
{  directly.                                 }
{ On Exit:                                   }
{      d0 = result -- from normalize routine }
{      Flags : V set if overflow.            }
{              on underflow d0 = 0           }
{  Registers destroyed: d0,d1                }
{--------------------------------------------}
Asm
{--------------------------------------------}
{ On Entry:                                  }
{      d1-d0 = single values to subtract.    }
{--------------------------------------------}
XDEF SINGLE_SUB
   eor.l      #$80000000,d0         {   reverse sign of v }
{--------------------------------------------}
{ On Entry:                                  }
{      d0, d1 = single values to add.        }
{--------------------------------------------}
XDEF SINGLE_ADD
   movem.l d2-d5,-(sp)              { save registers      }
   move.l   d0,d4                   { d4 = d0 = v         }
   move.l   d1,d5                   { d5 = d1 = u         }

   move.l  #$7fffff,d3
   move.l  d5,d0                    { d0 = u.exp          }
   move.l  d5,d2                    { d2.h = u.sign       }
   swap       d0
   move.w  d0,d2                    { d2 = u.sign         }
   and.l   d3,d5                    { remove exponent from u.mantissa }

   move.l  d4,d1                    { d1 = v.exp          }
   and.l   d3,d4                    { remove exponent from v.mantissa }
   swap    d1
   eor.w   d1,d2                    { d2 = u.sign ^ v.sign (in bit 15)}
   clr.b   d2                       { we will use the lowest byte as a flag }
   moveq.l #15,d3
   bclr    d3,d1                    { kill sign bit u.exp             }
   bclr    d3,d0                    { kill sign bit u.exp             }
   btst    d3,d2                    { same sign for u and v?          }
   beq     @slabel1
   cmp.l   d0,d1                    { different signs - maybe x - x ? }
   seq     d2                       { set 'cancellation' flag         }
@slabel1:
   lsr.w   #7,d0                    { keep here exponents only        }
   lsr.w   #7,d1
{--------------------------------------------------------------------}
{          Now perform testing of NaN and infinities                 }
{--------------------------------------------------------------------}
   moveq.l #-1,d3
   cmp.b   d3,d0
   beq     @alabel1
   cmp.b   d3,d1
   bne     @nospec
   bra     @alabel2
{--------------------------------------------------------------------}
{                        u is special.                               }
{--------------------------------------------------------------------}
@alabel1:
   tst.b      d2
   bne        @retnan      { cancellation of specials -> NaN }
   tst.l      d5
   bne        @retnan      { arith with Nan gives always NaN }

   addq.w     #4,a0        { here is an infinity             }
   cmp.b      d3,d1
   bne        @alabel3     { skip check for NaN if v not special }
{--------------------------------------------------------------------}
{                        v is special.                               }
{--------------------------------------------------------------------}
@alabel2:
   tst.l           d4
   bne        @retnan
@alabel3:
   move.l     (a0),d0
   bra        @return
{--------------------------------------------------------------------}
{                     Return a quiet nan                             }
{--------------------------------------------------------------------}
@retnan:
   moveq.l    #-1,d0
   lsr.l      #1,d0                { 0x7fffffff -> d0        }
   bra        @return
{ Ok, no inifinty or NaN involved.. }
@nospec:
   tst.b           d2
   beq        @alabel4
   moveq.l    #0,d0                { x - x hence we always return +0 }
@return:
   movem.l    (sp)+,d2-d5
   rts

@alabel4:
   moveq.l    #23,d3
   bset       d3,d5           { restore implied leading "1"   }
   tst.w      d0              { check for zero exponent - no leading "1" }
   bne        @alabel5
   bclr       d3,d5           { remove it                     }
   addq.w     #1,d0           { "normalize" exponent          }
@alabel5:
   bset       d3,d4           { restore implied leading "1"   }
   tst.w      d1              { check for zero exponent - no leading "1"  }
   bne        @alabel6
   bclr       d3,d4           { remove it                     }
   addq.w  #1,d1              { "normalize" exponent          }
@alabel6:
   moveq.l    #0,d3           { (put initial zero rounding bits in d3) }
   neg.w      d1              { d1 = u.exp - v.exp            }
   add.w      d0,d1
   beq        @alabel8      { exponents are equal - no shifting neccessary }
   bgt        @alabel7      { not equal but no exchange neccessary         }
   exg        d4,d5                { exchange u and v }
   sub.w      d1,d0                { d0 = u.exp - (u.exp - v.exp) = v.exp }
   neg.w      d1
   tst.w      d2              { d2.h = u.sign ^ (u.sign ^ v.sign) = v.sign }
   bpl        @alabel7
   bchg       #31,d2
@alabel7:
   cmp.w      #26,d1       { is u so much bigger that v is not }
   bge        @alabel9      { significant ?                     }
{--------------------------------------------------------------------}
{ shift mantissa left two digits, to allow cancellation of           }
{ most significant digit, while gaining an additional digit for      }
{ rounding.                                                          }
{--------------------------------------------------------------------}
   moveq.l #1,d3
@alabel10:
   add.l           d5,d5
   subq.w  #1,d0              { decrement exponent            }
   subq.w  #1,d1              { done shifting altogether ?    }
   dbeq    d3,@alabel10        { loop if still can shift u.mant more }
   moveq.l    #0,d3

   cmp.w      #16,d1          { see if fast rotate possible    }
   blt        @alabel11
   or.w       d4,d3           { set rounding bits              }
   clr.w      d4
   swap       d4
   subq.w  #8,d1
   subq.w  #8,d1
   bra      @alabel11

@alabel12:
   move.b    d4,d2
   and.b      #1,d2
   or.b       d2,d3
   lsr.l      #1,d4               { shift v.mant right the rest of the way }
@alabel11:
   dbra    d1,@alabel12           { loop                                   }

@alabel8:
   tst.w      d2                  { are the signs equal ?                  }
   bpl        @alabel13           { yes, no negate necessary               }


   tst.w      d3                  { negate rounding bits and v.mant        }
   beq        @alabel14
   addq.l  #1,d4
@alabel14:
   neg.l           d4

@alabel13:
   add.l      d4,d5                { u.mant = u.mant + v.mant              }
   bcs        @alabel9             { needn not negate                      }
   tst.w      d2                   { opposite signs ?                      }
   bpl        @alabel9             { do not need to negate result          }

   neg.l      d5
   not.l      d2                   { switch sign                           }
@alabel9:
   move.l  d5,d4                   { move result for normalization         }
   clr.l      d1
   tst.l      d3
   beq        @alabel15
   moveq.l #-1,d1
@alabel15:
   swap    d2                      { put sign into d2 (exponent is in d0)  }
   jmp     FPC_SINGLE_NORM             { leave registers on stack for norm_sf  }
end;


Procedure Single_Mul;Assembler;
{--------------------------------------------}
{ Low-level routine to multiply two single   }
{  IEEE floating point values. Never called  }
{  directly.                                 }
{ Om Entry:                                  }
{      d0,d1 = values to multiply            }
{ On Exit:                                   }
{      d0 = result.                          }
{  Registers destroyed: d0,d1                }
{ stack space used (and restored): 8 bytes.  }
{--------------------------------------------}
Asm
XDEF SINGLE_MUL
   movem.l  d2-d5,-(sp)
   move.l   d0,d4       { d4 = v                   }
   move.l   d1,d5       { d5 = u                   }

   move.l   #$7fffff,d3
   move.l   d5,d0       { d0 = u.exp               }
   and.l    d3,d5       { remove exponent from u.mantissa }
   swap     d0
   move.w   d0,d2       { d2 = u.sign              }

   move.l   d4,d1       { d1 = v.exp               }
   and.l    d3,d4       { remove exponent from v.mantissa }
   swap     d1
   eor.w    d1,d2       { d2 = u.sign ^ v.sign (in bit 15)}

   moveq.l  #15,d3
   bclr     d3,d0       { kill sign bit                   }
   bclr     d3,d1       { kill sign bit                   }
   tst.l    d0          { test if one of factors is 0     }
   beq      @mlabel1
   tst.l    d1
@mlabel1:
   seq      d2         { 'one of factors is 0' flag in the lowest byte }
   lsr.w    #7,d0      { keep here exponents only         }
   lsr.w    #7,d1

{--------------------------------------------------------------------}
{          Now perform testing of NaN and infinities                 }
{--------------------------------------------------------------------}
   moveq.l  #-1,d3
   cmp.b    d3,d0
   beq      @mlabel2
   cmp.b    d3,d1
   bne      @mnospec
   bra      @mlabel3
{--------------------------------------------------------------------}
{                   first operand is special                         }
{--------------------------------------------------------------------}
@mlabel2:
   tst.l    d5         { is it NaN?                       }
   bne      @mretnan
@mlabel3:
   tst.b    d2         { 0 times special or special times 0 ? }
   bne      @mretnan   { yes -> NaN                       }
   cmp.b    d3,d1      { is the other special ?           }
   beq      @mlabel4   { maybe it is NaN                  }
{--------------------------------------------------------------------}
{                   Return infiny with correct sign                  }
{--------------------------------------------------------------------}
@mretinf:
   move.l   #$ff000000,d0  { we will return #0xff800000 or #0x7f800000 }
   lsl.w    #1,d2
   roxr.l   #1,d0      { shift in high bit as given by d2 }
@mreturn:
   movem.l  (sp)+,d2-d5
   rts

{--------------------------------------------------------------------}
{                        v is special.                               }
{--------------------------------------------------------------------}
@mlabel4:
   tst.l    d4          { is this NaN?                    }
   beq      @mretinf    { we know that the other is not zero }
@mretnan:
   moveq.l  #-1,d0
   lsr.l    #1,d0       { 0x7fffffff -> d0                }
   bra      @mreturn
{--------------------------------------------------------------------}
{                    End of NaN and Inf                              }
{--------------------------------------------------------------------}
@mnospec:
   tst.b    d2          { not needed - but we can waste two instr. }
   bne      @mretzz     { return signed 0 if one of factors is 0   }
   moveq.l  #23,d3
   bset     d3,d5       { restore implied leading "1"              }
   subq.w   #8,sp       { multiplication accumulator               }
   tst.w    d0          { check for zero exponent - no leading "1" }
   bne      @mlabel5
   bclr     d3,d5       { remove it                                }
   addq.w   #1,d0       { "normalize" exponent                     }
@mlabel5:
   tst.l   d5
   beq     @mretz       { multiplying zero                         }

   moveq.l #23,d3
   bset    d3,d4        { restore implied leading "1"              }
   tst.w   d1           { check for zero exponent - no leading "1" }
   bne     @mlabel6
   bclr    d3,d4        { remove it                                }
   addq.w  #1,d1        { "normalize" exponent                     }
@mlabel6:
   tst.l   d4
   beq     @mretz       { multiply by zero                         }

   add.w   d1,d0        { add exponents,                           }
   sub.w   #BIAS4+16-8,d0 { remove excess bias, acnt for repositioning }

   clr.l   (sp)         { initialize 64-bit product to zero        }
   clr.l   4(sp)
{--------------------------------------------------------------------}
{ see Knuth, Seminumerical Algorithms, section 4.3. algorithm M      }
{--------------------------------------------------------------------}
   move.w  d4,d3
   mulu.w  d5,d3        { mulitply with bigit from multiplier      }
   move.l  d3,4(sp)     { store into result                        }

   move.l  d4,d3
   swap    d3
   mulu.w  d5,d3
   add.l   d3,2(sp)     { add to result                            }

   swap    d5           { [TOP 8 BITS SHOULD BE ZERO !]            }

   move.w  d4,d3
   mulu.w  d5,d3        { mulitply with bigit from multiplier      }
   add.l   d3,2(sp)     { store into result (no carry can occur here) }

   move.l  d4,d3
   swap    d3
   mulu.w  d5,d3
   add.l   d3,(sp)      { add to result                            }
            { [TOP 16 BITS SHOULD BE ZERO !] }
   movem.l 2(sp),d4-d5  { get the 48 valid mantissa bits           }
   clr.w   d5           { (pad to 64)                              }

   move.l  #$0000ffff,d3
@mlabel7:
   cmp.l   d3,d4        { multiply (shift) until                  }
   bhi     @mlabel8     {  1 in upper 16 result bits              }
   cmp.w   #9,d0        { give up for denormalized numbers        }
   ble     @mlabel8
   swap    d4         { (we''re getting here only when multiplying }
   swap    d5         {  with a denormalized number; there''s an   }
   move.w  d5,d4      {  eventual loss of 4 bits in the rounding   }
   clr.w   d5         {  byte -- what a pity 8-)                   }
   subq.w  #8,d0      { decrement exponent                         }
   subq.w  #8,d0
   bra     @mlabel7
@mlabel8:
   move.l  d5,d1      { get rounding bits                          }
   rol.l   #8,d1
   move.l  d1,d3      { see if sticky bit should be set            }
   and.l   #$ffffff00,d3
   beq     @mlabel9
   or.b    #1,d1      { set "sticky bit" if any low-order set      }
@mlabel9:
   addq.w  #8,sp      { remove accumulator from stack              }
   jmp     FPC_SINGLE_NORM{ (result in d4)                             }

@mretz:
   addq.w  #8,sp      { release accumulator space                  }
@mretzz:
   moveq.l #0,d0      { save zero as result                        }
   lsl.w   #1,d2      { and set it sign as for d2                  }
   roxr.l  #1,d0
   movem.l (sp)+,d2-d5
   rts                { no normalizing neccessary                  }
end;


Procedure Single_Div;Assembler;
{--------------------------------------------}
{ Low-level routine to dividr two single     }
{  IEEE floating point values. Never called  }
{  directly.                                 }
{ Om Entry:                                  }
{      d1/d0 = u/v = operation to perform.   }
{ On Exit:                                   }
{      d0 = result.                          }
{  Registers destroyed: d0,d1                }
{ stack space used (and restored): 8 bytes.  }
{--------------------------------------------}
ASM
XDEF SINGLE_DIV
   { u = d1 = dividend }
   { v = d0 = divisor  }
   tst.l  d0              { check if divisor is 0                  }
   bne    @dno_exception

   move.l #$7f800000,d0
   btst   #31,d1          { transfer sign of dividend              }
   beq    @dclear
   bset   #31,d0
@dclear:
   rts

@dno_exception:
   move.l  d1,d4          { d4 = u, d5 = v                         }
   move.l  d0,d5
   movem.l d2-d5,-(sp)    { save registers                         }

   move.l  #$7fffff,d3
   move.l  d4,d0          { d0 = u.exp                             }
   and.l   d3,d4          { remove exponent from u.mantissa        }
   swap    d0
   move.w  d0,d2          { d2 = u.sign                            }

   move.l  d5,d1          { d1 = v.exp                             }
   and.l   d3,d5          { remove exponent from v.mantissa        }
   swap    d1
   eor.w   d1,d2          { d2 = u.sign ^ v.sign (in bit 15)       }

   moveq.l #15,d3
   bclr    d3,d0          { kill sign bit                          }
   bclr    d3,d1          { kill sign bit                          }
   lsr.w   #7,d0
   lsr.w   #7,d1

   moveq.l #-1,d3
   cmp.b   d3,d0          { comparison with #0xff                  }
   beq     @dlabel1       { u == NaN ;; u== Inf                    }
   cmp.b   d3,d1
   beq     @dlabel2       { v == NaN ;; v == Inf                   }
   tst.b   d0
   bne     @dlabel4       { u not zero nor denorm                  }
   tst.l   d4
   beq     @dlabel3       { 0/ ?                                   }

@dlabel4:
   tst.w   d1
   bne     @dnospec

   tst.l   d5
   bne     @dnospec
   bra     @dretinf       { x/0 -> +/- Inf                         }

@dlabel1:
   tst.l   d4             { u == NaN ?                             }
   bne     @dretnan       { NaN/ x                                 }
   cmp.b   d3,d1
   beq     @dretnan       { Inf/Inf or Inf/NaN                     }
{  bra     dretinf      ; Inf/x ; x != Inf && x != NaN             }
{--------------------------------------------------------------------}
{                  Return infinity with correct sign.                }
{--------------------------------------------------------------------}
@dretinf:
   move.l  #$ff000000,d0
   lsl.w   #1,d2
   roxr.l  #1,d0          { shift in high bit as given by d2       }
@dreturn:
   movem.l (sp)+,d2-d5
   rts

@dlabel2:
   tst.l   d5
   bne     @dretnan       { x/NaN                                  }
{   bra    dretzero   ; x/Inf -> +/- 0                             }
{--------------------------------------------------------------------}
{                  Return correct signed zero.                       }
{--------------------------------------------------------------------}
@dretzero:
   moveq.l #0,d0          { zero destination                       }
   lsl.w   #1,d2          { set X bit accordingly                  }
   roxr.l  #1,d0
   bra     @dreturn

@dlabel3:
   tst.w   d1
   bne     @dretzero      { 0/x ->+/- 0                            }
   tst.l   d4
   bne     @dretzero      { 0/x                                    }
{   bra    dretnan         0/0                                     }
{--------------------------------------------------------------------}
{                       Return NotANumber                            }
{--------------------------------------------------------------------}
@dretnan:
   move.l  d3,d0          { d3 contains 0xffffffff                 }
   lsr.l   #1,d0
   bra     @dreturn
{--------------------------------------------------------------------}
{                      End of Special Handling                       }
{--------------------------------------------------------------------}
@dnospec:
   moveq.l #23,d3
   bset    d3,d4          { restore implied leading "1"            }
   tst.w   d0             { check for zero exponent - no leading "1" }
   bne     @dlabel5
   bclr    d3,d4          { remove it                              }
   add.w   #1,d0          { "normalize" exponent                   }
@dlabel5:
   tst.l   d4
   beq     @dretzero      { dividing zero                          }

   bset    d3,d5          { restore implied leading "1"            }
   tst.w   d1             { check for zero exponent - no leading "1"}
   bne     @dlabel6
   bclr    d3,d5          { remove it                              }
   add.w   #1,d1          { "normalize" exponent                   }
@dlabel6:

   sub.w   d1,d0          { subtract exponents,                    }
   add.w   #BIAS4-8+1,d0  { add bias back in, account for shift    }
   add.w   #34,d0     { add loop offset, +2 for extra rounding bits}
                      { for denormalized numbers (2 implied by dbra)}
   move.w  #27,d1     { bit number for "implied" pos (+4 for rounding)}
   moveq.l #-1,d3     { zero quotient (for speed a one''s complement) }
   sub.l   d5,d4      { initial subtraction, u = u - v                }
@dlabel7:
   btst    d1,d3      { divide until 1 in implied position            }
   beq     @dlabel9

   add.l   d4,d4
   bcs     @dlabel8   { if carry is set, add, else subtract           }

   addx.l  d3,d3      { shift quotient and set bit zero               }
   sub.l   d5,d4      { subtract, u = u - v                           }
   dbra    d0,@dlabel7      { give up if result is denormalized        }
   bra     @dlabel9
@dlabel8:
   addx.l  d3,d3      { shift quotient and clear bit zero             }
   add.l   d5,d4      { add (restore), u = u + v                      }
   dbra    d0,@dlabel7      { give up if result is denormalized        }
@dlabel9:
   subq.w  #2,d0      { remove rounding offset for denormalized nums  }
   not.l   d3         { invert quotient to get it right               }

   clr.l   d1         { zero rounding bits                            }
   tst.l   d4         { check for exact result                        }
   beq     @dlabel10
   moveq.l #-1,d1     { prevent tie case                              }
@dlabel10:
   move.l  d3,d4      { save quotient mantissa                        }
   jmp     FPC_SINGLE_NORM{ (registers on stack removed by norm_sf)       }
end;


Procedure Single_Cmp; Assembler;
{--------------------------------------------}
{ Low-level routine to compare single two    }
{  single point values..                     }
{  Never called directly.                    }
{ On Entry:                                  }
{      d1 and d0 Values to compare           }
{      d0 = first operand                    }
{ On Exit:                                   }
{      Flags according to result             }
{  Registers destroyed: d0,d1                }
{--------------------------------------------}
Asm
XDEF  SINGLE_CMP
   tst.l     d0               { check sign bit             }
   bpl       @cmplab1
   neg.l     d0               { negate                     }
   bchg      #31,d0           { toggle sign bit            }
@cmplab1:
   tst.l     d1               { check sign bit             }
   bpl       @cmplab2
   neg.l     d1               { negate                     }
   bchg      #31,d1           { toggle sign bit            }
@cmplab2:
   cmp.l     d0,d1            { compare...                 }
   rts
end;



Procedure LongMul;Assembler;
{--------------------------------------------}
{ Low-level routine to multiply two signed   }
{  32-bit values. Never called directly.     }
{ On entry: d1,d0 = 32-bit signed values to  }
{           multiply.                        }
{ On Exit:                                   }
{      d0 = result.                          }
{  Registers destroyed: d0,d1                }
{  stack space used and restored: 10 bytes   }
{--------------------------------------------}
Asm
XDEF LONGMUL
             cmp.b   #2,Test68000    { Are we on a 68020+ cpu                  }
             blt     @Lmulcontinue
             muls.l  d1,d0           { yes, then directly mul...               }
             rts                     { return... result in d0                  }
@Lmulcontinue:
             move.l    d2,a0         { save registers                          }
             move.l    d3,a1

             move.l    d0,-(sp)
             move.l    d1,-(sp)

             movem.w   (sp)+,d0-d3   { u = d0-d1, v = d2-d3                    }

             move.w    d0,-(sp)      { sign flag                               }
             bpl       @LMul1        { is u negative ?                         }
             neg.w     d1            { yes, force it positive                  }
             negx.w    d0
@LMul1:
             tst.w     d2            { is v negative ?                         }
             bpl       @LMul2
             neg.w     d3            { yes, force it positive ...              }
             negx.w    d2
             not.w     (sp)          {  ... and modify flag word               }
@LMul2:
             ext.l     d0            { u.h <> 0 ?                              }
             beq       @LMul3
             mulu.w    d3,d0         { r  = v.l * u.h                          }
@LMul3:
             tst.w     d2            { v.h <> 0 ?                              }
             beq       @LMul4
             mulu.w    d1,d2         { r += v.h * u.l                          }
             add.w     d2,d0
@LMul4:
             swap      d0
             clr.w     d0
             mulu.w    d3,d1        { r += v.l * u.l                           }
             add.l     d1,d0
             move.l    a1,d3
             move.l    a0,d2
             tst.w     (sp)+        { should the result be negated ?           }
             bpl       @LMul5       { no, just return                          }
             neg.l     d0           { else r = -r                              }
@LMul5:
             rts
end;



Procedure Long2Single;Assembler;
{--------------------------------------------}
{ Low-level routine to convert a longint     }
{  to a single floating point value.         }
{ On entry: d0 = longint value to convert.   }
{ On Exit:                                   }
{      d0 = single IEEE value                }
{  Registers destroyed: d0,d1                }
{  stack space used and restored:  8 bytes   }
{--------------------------------------------}
Asm
XDEF LONG2SINGLE
   movem.l  d2-d5,-(sp)  { save registers to make norm_sf happy}

   move.l   d0,d4        { prepare result mantissa          }
   move.w   #BIAS4+32-8,d0   { radix point after 32 bits    }
   move.l   d4,d2        { set sign flag                    }
   bge      @l2slabel1   { nonnegative                      }
   neg.l    d4           { take absolute value              }
@l2slabel1:
   swap     d2           { follow SINGLE_NORM conventions   }
   clr.w    d1           { set rounding = 0                 }
   jmp      FPC_SINGLE_NORM
end;


Procedure LongDiv; [alias : 'FPC_LONGDIV'];Assembler;
{--------------------------------------------}
{ Low-level routine to do signed long        }
{ division.                                  }
{ On entry: d0/d1 operation to perform       }
{ On Exit:                                   }
{      d0 = quotient                         }
{      d1 = remainder                        }
{  Registers destroyed: d0,d1,d6             }
{  stack space used and restored: 10 bytes   }
{--------------------------------------------}
asm
XDEF LONGDIV
   cmp.b       #2,Test68000  { can we use divs ?                  }
   blt         @continue
   tst.l       d1
   beq         @zerodiv2
   move.l      d1,d6
   clr.l       d1           { clr                                 }
   tst.l       d0           { check sign of d0                    }
   bpl         @posdiv
   move.l      #$ffffffff,d1{ sign extend into  d1                }
@posdiv:
   divsl.l     d6,d1:d0
   rts
@continue:

   move.l      d2,a0      { save registers                        }
   move.l      d3,a1
   move.l      d4,-(sp)   { divisor = d1 = d4                     }
   move.l      d5,-(sp)   { divident = d0 = d5                    }

   move.l      d1,d4      { save divisor                          }
   move.l      d0,d5      { save dividend                         }

   clr.w       -(sp)      { sign flag                             }

   clr.l       d0         { prepare result                        }
   move.l      d4,d2      { get divisor                           }
   beq         @zerodiv   { divisor = 0 ?                         }
   bpl         @LDiv1     { divisor < 0 ?                         }
   neg.l       d2         { negate it                             }
   not.w       (sp)       { remember sign                         }
@LDiv1:
   move.l      d5,d1      { get dividend                          }
   bpl         @LDiv2     { dividend < 0 ?                        }
   neg.l       d1         { negate it                             }
   not.w       (sp)       { remember sign                         }
@LDiv2:
{;== case 1) divident < divisor}
   cmp.l       d2,d1      { is divident smaller then divisor ?    }
   bcs         @LDiv7     { yes, return immediately               }
{;== case 2) divisor has <= 16 significant bits}
   move.l      d4,d6      { put divisor in d6 register            }
   lsr.l       #8,d6      { rotate into low word                  }
   lsr.l       #8,d6
   tst.l       d6
   bne         @LDiv3     { divisor has only 16 bits              }
   move.w      d1,d3      { save dividend                         }
   clr.w       d1         { divide dvd.h by dvs                   }
   swap        d1
   beq         @LDiv4     { (no division necessary if dividend zero)}
   divu        d2,d1
@LDiv4:
   move.w      d1,d0      { save quotient.h                       }
   swap        d0
   move.w      d3,d1      { (d0.h = remainder of prev divu)       }
   divu        d2,d1      { divide dvd.l by dvs                   }
   move.w      d1,d0      { save quotient.l                       }
   clr.w       d1         { get remainder                         }
   swap        d1
   bra         @LDiv7     { and return                            }
{;== case 3) divisor > 16 bits (corollary is dividend > 16 bits, see case 1)}
@LDiv3:
   moveq.l     #31,d3     { loop count                            }
@LDiv5:
   add.l       d1,d1      { shift divident ...                    }
   addx.l      d0,d0      {  ... into d0                          }
   cmp.l       d2,d0      { compare with divisor                  }
   bcs         @LDiv6
   sub.l       d2,d0      { big enough, subtract                  }
   addq.w      #1,d1      { and note bit into result              }
@LDiv6:
   dbra        d3,@LDiv5
   exg         d0,d1      { put quotient and remainder in their registers}
@LDiv7:
   tst.l       d5         { must the remainder be corrected ?     }
   bpl         @LDiv8
   neg.l       d1         { yes, apply sign                       }
{ the following line would be correct if modulus is defined as in algebra}
{;   add.l   sp@(6),d1   ; algebraic correction: modulus can only be >= 0}
@LDiv8:
   tst.w       (sp)+      { result should be negative ?          }
   bpl         @LDiv9
   neg.l       d0         { yes, negate it                      }
@LDiv9:
   move.l      a1,d3
   move.l      a0,d2
   move.l      (sp)+,d5
   move.l      (sp)+,d4
   rts                    { en exit : remainder = d1, quotient = d0 }
@zerodiv:
   move.l      a1,d3      { restore stack...                        }
   move.l      a0,d2
   move.w      (sp)+,d1   { remove sign word                        }
   move.l      (sp)+,d5
   move.l      (sp)+,d4
@zerodiv2:
   move.l      #200,d0
   jsr         FPC_HALT_ERROR { RunError(200)                          }
   rts                    { this should never occur...             }
end;


Procedure LongMod;[alias : 'FPC_LONGMOD'];Assembler;
{ see longdiv for info on calling convention }
asm
XDEF LONGMOD
   jsr     FPC_LONGDIV
   move.l  d1,d0      { return the remainder in d0 }
   rts
end;