* Mouse bootstrap prefix
* (c) RWT 1988
* Last changed 16/08/88

* The image formed by concatenating the binaries
* of this file and of the (Imp-compiled) loader
* is intended to reside in on-board RAM at $1000.

* This file contains the exception vector table,
* etc, the code to enter the loader, and some of
* the basic extracodes.

  bin
xvt equ $1000
  rorg xvt

* Exception vector table, limited to entries 0:47,
* as only the MMUs are able to generate vector
* numbers in the full 0:255 range, and they should
* not be programmed to do so.

  dc.l $3f00    initial SP (not relevant)
  dc.l begin    initial PC (known to be 16_11C0)
  dc.l e        (until replaced by MMU handler) berr
  dc.l x3       aerr
  dc.l x4       illegal inst
  dc.l x5       div by 0
  dc.l x6       CHK
  dc.l x7       TRAPV
  dc.l x8       priv viol
  dc.l x9       TRACE
  dc.l x4,x4    emulation
  dc.l e,e,e,e,e,e      reserved etc
  dc.l e,e,e,e,e,e
  dc.l e,e,e,e,e,e,e,e  autovectors
  dc.l e,e,e,e,e,e,e,e  traps
  dc.l e,e,e,e,e,e,e,tf

* Dummy (obsolete) extracode jump table

  dc.l o,o,o,o,o,o,o,o,o,o,o,o,o,o,o,o
  dc.l o,o,o,o,o,o,o,o,o,o,o,o,o,o,o,o
  dc.l o,o,o,o,o,o,o,o,o,o,o,o,o,o,o,o
  dc.l o,o,o,o,o,o,o,o,o,o,o,o,o,o,o,o

* The space occupied by the immediately following
* initialisation code is later used for supervisor
* variables.

memtop equ $3ffc        set up by ROM bootstrap

begin move.l memtop,sp  SP -> end of main memory

* Set up the VBR to point at the above table, also
* making sure this is a 68010, not a mere 68000

  move.l sp,a5
  pea -1                (SSP at MEMTOP-4)
  lea xvt,a0
  movec a0,vbr          this fails on 68000

* Clear 1k PCB and 1k POA, setting up A5.
* (A5 to be copied into USP later)

  move.w #2048>>2-1,d0
zloop clr.l -(a5)
  dbra d0,zloop

* Enter user mode already, leaving ints disabled

  move #$700,sr

* Fill in 64-slot extracode jump table:
* First fill in SIGNAL, extended integer,
* floating point arithmetic, then add
* dummy entries for the remaining slots.

jmpw equ $4ef8
jmpl equ $4ef9

xc macro
  pea \1
  move.w d0,-(sp)
  endm

  lea $3f00,sp
  move.w #jmpl,d0
  xc signal
  xc mul
  xc div
  xc muldiv
  xc iexp
  xc fneg
  xc fadd
  xc fsub
  xc fmul
  xc fdiv
  xc fexp
  xc float
  xc round
  xc trunc
  xc fraction
  xc int
  xc intpt
  xc fracpt
  xc sqrt
  moveq #64-20,d1
xloop pea absent
  move.w d0,-(sp)
  dbra d1,xloop
  move.l a5,sp    (USP at MEMTOP-2k)

* Prepare to enter the loader:
* Allocate its GLA if any and pre-initialise
* with illegal instructions in case there are
* external references (unsatisfiable just yet).

* FE02 header offsets

export    equ 4
import    equ 6
codesize  equ 8
reset     equ 12
main      equ 14
ownsize   equ 16
hdrsize   equ 32

  lea loader,a0
  move.l ownsize(a0),d0
  beq.s ng
  lsr.l #2,d0
  and.b #-4,d0
gl move.l #$4afc4afc,-(sp)
  dbra d0,gl
ng move.l sp,a4

* Compute reset and main entry points

  move.w reset(a0),d2
  add.w d2,d2
  move.w main(a0),d1
  add.w d1,d1
  move.w import(a0),d0
  add.w export(a0),d0
  lea hdrsize(a0,d0.w),a0  code start addr
  pea giveup               dummy main return addr
  pea 0(a0,d1.w)           main entry point addr
  lea 0,a6
  move.l #$80808080,d7
  clr.l d4
  jsr 0(a0,d2.w)           reset routine

* Just before diving into the loader,
* clear its global variables, and make
* ROMPSYM available as PRINTSYMBOL.

  lea begin,a0
  move.w #(*-begin)>>1,d0
sloop clr.w (a0)+
  dbra d0,sloop

  lea loader,a0             pass header address
  rts                       dive in

* Plant in-line length-prefixed byte string

string macro
\* dc.b end\@-beg\@
beg\@ dc.b \1
end\@ equ *
  ds.w 0
  endm

* Move string \1 to \2 using \3 as temp

movestring macro
\* clr.w \3
  move.b (\1),\3
\@ move.b (\1,\3.w),(\2,\3.w)
  dbra \3,\@
  endm

signal macro
\* move.l \3,d2
  moveq #\2,d1
  moveq #\1,d0
  lea \@,a0
  bra signal
\@ string <\4>
  endm

temp            set *
                org 0
poaevlink       ds.l 1 [next,pc:mask,a4,*]
poadisplay      ds.l 7 [1(a6):7]
poaevent        ds.b 1
poaeventsub     ds.b 1
poaeventline    ds.w 1
poaeventextra   ds.l 1
poaeventmess    ds.b 256-32
poaeventpc      ds.l 1
poaeventdisplay ds.l 7
poaeventregs    ds.l 16
                rorg temp

* Procedure entry points in ROM
* (for error diagnostics only)

romphex  equ $40c
romphex4 equ $410
rompsym  equ $41c
rompstr  equ $420

*--------------------------------*
* Exception handling starts here *
*--------------------------------*

x4 tst.w 6(sp)
  bmi not68010
  move.w #$7004,6(sp)
  bsr ch
  string <'Illegal instruction'>
x5 move.w #$5104,6(sp)
  bsr.s ch
  string <'Division by zero'>
x6 move.w #$5602,6(sp)
  bsr.s ch
  string <'Out of range (CHK)'>
x7 move.w #$5101,6(sp)
  bsr.s ch
  string <'Overflow (TRAPV)'>
x8 move.w #$7008,6(sp)
  bsr.s ch
  string <'Privileged instruction'>

* Common handler for the above

ch or #$700,sr
  move.l d0,-(sp)   save D0
  moveq #1,d0       set DFC to UD
  movec d0,dfc
  moveq #2,d0       set SFC to UP
  movec d0,sfc
  move.l (sp)+,d0   restore D0
  moves.l d0,poaeventregs(a5)    store d0-d2/a0
  moves.l d1,poaeventregs+4(a5)
  moves.l d2,poaeventregs+8(a5)
  moves.l a0,poaeventregs+32(a5)
  move.l 6(sp),a0   PC
  moves.l a0,poaeventpc(a5)
  moves.l (a0),d2   extra (if relevant)
  move.l (sp)+,a0   message
  move.b 7(sp),d1   subevent
  move.b 6(sp),d0   event+flags
ss move.l #specialsignal,2(sp)
  clr.w 6(sp)
  rte

* Address error handler

m3 string <'Unaligned word (address error)'>
x3 or #$700,sr
  move.l d0,-(sp)
  moveq #1,d0
  movec d0,dfc
  move.l (sp)+,d0
  moves.l d0,poaeventregs(a5)
  moves.l d1,poaeventregs+4(a5)
  moves.l d2,poaeventregs+8(a5)
  moves.l a0,poaeventregs+32(a5)
  move.l 2(sp),a0
  moves.l a0,poaeventpc(a5)
  lea m3,a0
  move.l 10(sp),d2    extra
  moveq #3,d1         subevent
  moveq #$70,d0       event+flags
  move.w (sp),50(sp)  copy SR
  lea 50(sp),sp       long -> short frame
  bra ss

* Line trace handler

tf move.l a0,-(sp)
  or #$700,sr
  lea 1,a0
  movec a0,dfc
  add.l a0,a0
  movec a0,sfc
  move.l 6(sp),a0
  moves.w (a0),a0
  moves.w a0,poaeventline(a5)
  move.l (sp)+,a0
  addq.l #2,2(sp)
x9 rte

* Default fatal exception handler

nl equ 10
newline moveq #nl,d0
  jmp rompsym
space moveq #' ',d0
  jmp rompsym

e  movem.l d0-d7/a0-a7,-(sp)  save all regs
  move.l usp,a0
  move.l a0,60(sp)     USP also
  lea crashmess,a0
  jsr rompstr
  move.l sp,a0         show them
  moveq #1,d2
e2 moveq #7,d1
e1 bsr space
  move.l (sp)+,d0
  jsr romphex
  dbra d1,e1
  bsr newline
  dbra d2,e2
  move.l sp,d0         display SSP
  jsr romphex
  bsr space
  move.w (sp),d0       SR
  jsr romphex4
  bsr space
  move.l 2(sp),d0      PC
  jsr romphex
  bsr space
  move.w 6(sp),d0      FV
  jsr romphex4
  tst.w d0
  bpl.s nomore
  bsr space
  move.w 8(sp),d0      SSW?
  jsr romphex4
  bsr space
  move.l 10(sp),d0     FA?
  jsr romphex
nomore bsr newline
  bra *
crashmess string <nl,'*CRASH*',nl>
toobad string <nl,'Please use a 68010'>
not68010 lea toobad,a0
  jsr rompstr
  bra nomore

*-----------------------*
* Extracodes start here *
*-----------------------*

* This is the signal routine's "special" entry point used
* by the exception handlers.  By the time we get here, PC
* and D0-D2/A0 have already been stored in the event record.

specialsignal movem.l d3-d7,poaeventregs+12(a5)
  movem.l a1-a7,poaeventregs+36(a5)
  bra.s commonsignal

* This is the signal routine's "normal" entry point,
* reached through the extracode jump table.

signal move.l (sp)+,poaeventpc(a5)
  movem.l d0-d7/a0-a7,poaeventregs(a5)

* D0.B = event number & 15 + flags (16/32/64)
* D1.B = subevent            if D0& 16       #0
* D2.L = extra               if D0&    32    #0
* A0 -> message              if D0&       64 #0

commonsignal clr.w poaeventline(a5)
  bclr #4,d0
  bne.s sigsub
  clr.b d1
sigsub move.b d1,poaeventsub(a5)
  bclr #5,d0
  bne.s sigextra
  clr.l d2
sigextra move.l d2,poaeventextra(a5)
  bclr #6,d0
  bne.s sigmess
  lea *+2,a0
sigmess lea poaeventmess(a5),a1
  movestring a0,a1,d1
  move.b d0,poaevent(a5)
  move.l a6,poadisplay(a5)
  movem.l poadisplay(a5),d1-d7
  movem.l d1-d7,poaeventdisplay(a5)
  movem.l poaeventregs(a5),d0-d7

* Chase down list of trap blocks

  clr.l d1
  move.b poaevent(a5),d1
  moveq #1,d0
  lsl.w d1,d0              Now D0 = event bit
  move.l poaevlink(a5),-(sp)
unwindloop move.l (sp),poaevlink(a5)
  beq giveup               No more trap blocks
  move.l poaevlink(a5),sp
  move.l 4(sp),a0          Trap PC
  move.w (a0),d1           event mask
  and.w d0,d1
  beq unwindloop           not trapped here ->
  cmp.l poaeventpc(a5),a0
  bhs.s found              PC<=start: OK
  lea -2(a0),a1
  add.w (a1),a1
  cmp.l poaeventpc(a5),a1
  bhs unwindloop           PC<=end: not OK
found move.l 8(sp),a4       Trap GLA
  pea 2(a0)                save entry point
  moveq #6,d0              Now unravel the display
  lea poadisplay(a5),a0
unlinkloop move.l (a0),a1
  cmp #0,a1
  beq.s unlunk             BR=0: OK
  cmp.l sp,a1
  bhi.s unlunk             BR>SP: OK
  move.l (a1),(a0)
  bra unlinkloop
unlunk lea 4(a0),a0
  dbra d0,unlinkloop
  move.l poadisplay(a5),a6
  movem.l poaeventregs(a5),d0-d1
  movem.l poaeventregs+32(a5),a0-a1
  rts

giveup equ *
  move.w #$700,d0
  trap #1
  lea crashmess,a0
  jsr rompstr
  lea poaeventmess(a5),a0
  jsr rompstr
  bsr space
  move.l poaeventextra(a5),d0
  jsr romphex
  bsr newline
  lea 0,a0       wait on the null semaphore
  trap #7

* Dummy routines for missing extracodes

absent move.l (sp),a0
  clr.l d2
  move.w -2(a0),d2
  signal $70,4,d2,<'Undefined extracode'>

obsolete move.l(sp),a0
  clr.l d2
  move.w -2(a0),d2
  signal $70,4,d2,<'Obsolete extracode'>
o equ jmpw<<16+obsolete

* Extended integer arithmetic extracodes
  ds.w 0
  nolist

* Multiply 32-bit D0 by 32-bit D1, returning
* a 32-bit product in D0.  Set V bit on overflow.

mul movem.l d1-d4,-(sp)
  moveq #0,d4
  move.l d0,d2
  bpl.s m1
  neg.l d0
  moveq #1,d4
  move.l d0,d2
m1 swap d2
  move.l d1,d3
  bpl.s m2
  neg.l d1
  eor.w #1,d4
  move.l d1,d3
m2 swap d3
  tst.w d2
  beq.s maz     * A>>16=0 ->
  tst.w d3
  beq.s mbz     * B>>16=0 ->
  mulu d0,d3
  mulu d1,d2
  mulu d1,d0
  add.l d3,d2
  swap d0
  add.w d2,d0
  swap d0
  bra.s mv      * mandatory overflow ->
maz tst.w d3
  beq.s mabz    * A>>16=B>>16=0 ->
  mulu d0,d3
  mulu d1,d0
  swap d0
  add.w d3,d0
  swap d0
  swap d3
  tst.w d3
  bne.s mv      * certain overflow ->
  bra.s mvt     * possible overflow ->
mbz mulu d1,d2
  mulu d1,d0
  swap d0
  add.w d2,d0
  swap d0
  swap d2
  tst.w d2
  bne.s mv
  bra.s mvt
mabz mulu d1,d0
mvt tst.l d0
  bmi.s mv
  btst #0,d4
  beq.s m8
  neg.l d0
m8 tst.l d0
  movem.l (sp)+,d1-d4
  rts
mv btst #0,d4
  beq.s m9
  neg.l d0
m9 tst.l d0
  movem.l (sp)+,d1-d4
  or.b #2,ccr
  rts

* Multiply 32-bit D0 by 32-bit D1, then divide
* the 64-bit product by 32-bit D2.  Return the
* 32-bit quotient in D0 and 32-bit remainder in D1.

muldiv movem.l d0-d5,-(sp)
  move.l d0,d2
  bpl.s mda
  neg.l d0
  neg.l d2
mda swap d2
  move.l d1,d3
  bpl.s mdb
  neg.l d1
  neg.l d3
mdb swap d3
  move.w d3,d4
  mulu d2,d4    * A*B
  mulu d0,d3    * a*B
  mulu d1,d2    * A*b
  mulu d1,d0    * a*b
  move.l d4,d1
  add.l d2,d3
  bcc.s md1
  add.l #$10000,d1
md1 swap d0
  add.w d3,d0
  bcc.s md2
  addq.l #1,d1
md2 swap d0
  clr.w d3
  swap d3
  add.l d3,d1      * D1_D0 = A_a*B_b
  clr.l d2
  move.l 8(sp),d3  * D3_D2 = Cc<<32
  bpl.s md3
  neg.l d3
md3 move.l #$80000000,d4
  clr.l d5         * quotient
  cmp.l d3,d1
  bhs.s mdv        * overflow ->
md4 lsr.l #1,d3
  roxr.l d2
  cmp.l d3,d1
  bhi.s mds
  blo.s mdns
  cmp.l d2,d0
  blo.s mdns
mds sub.l d2,d0
  subx.l d3,d1
  add.l d4,d5
mdns lsr.l #1,d4
  bcc.s md4
  move.l d0,d1  * remainder
  move.l d5,d0  * quotient
  move.w (sp),d2
  eor.w d2,4(sp)
  bpl.s md8     * non-neg rem ->
  neg.l d1
md8 move.w 8(sp),d2
  eor.w d2,4(sp)
  bpl.s md9     * non-neg quot ->
  neg.l d0
md9 addq.l #8,sp
  movem.l (sp)+,d2-d5
  tst.l d0
  rts
mdv movem.l (sp)+,d0-d5
overflow or.b #2,ccr
  trapv
  rts

* Divide 32 bit integer D0 by 32 bit D1,
* quotient to D0, remainder to D1.

div movem.l d2-d4,-(sp)
  clr d4
  move.l d1,d2
  beq.s divzero
  bpl.s divpos1
  neg.l d2
  or #2,d4
divpos1 move.l d0,d1
  bpl.s divpos2
  neg.l d1
  eor.l #3,d4
divpos2 clr.l d0
  move.l #1,d3
  bra.s divsulps
divsulp lsl.l #1,d2
  lsl.l #1,d3
divsulps cmp.l d2,d1
  bhi.s divsulp
divlp cmp.l d2,d1
  bcs.s divnosub
  add.l d3,d0
  sub.l d2,d1
divnosub lsr.l #1,d2
  lsr.l #1,d3
  bne divlp
  lsr #1,d4
  bcc.s nonegrem
  neg.l d1
nonegrem tst d4
  beq.s nonegquo
  neg.l d0
nonegquo tst.l d0
  movem.l (sp)+,d2-d4
  rts
divzero movem.l (sp)+,d2-d4
  divs #0,d0 invoke hardware exception
  rts        never reached

* Raise integer D0 to integer exponent D1.

iexp movem.l d1-d3,-(sp)
  move.l d1,d3
  beq.s iexpzer
  bmi.s iexpneg
  moveq #1,d2
  move.l d0,d1
iexploop btst #0,d3
  beq.s iexpno
  move.l d2,d0
  jsr mul
  trapv
  move.l d0,d2
iexpno lsr.l #1,d3
  beq.s iexpret
  move.l d1,d0
  jsr mul
  trapv
  move.l d0,d1
  bra iexploop
iexpret move.l d2,d0
  movem.l (sp)+,d1-d3
  rts
iexpzer moveq #1,d2
  bra iexpret
iexpneg clr.l d2
  bra iexpret

 list
 ds.w 0
* end of extended arithmetic
* Floating point extracodes start here
 nolist

************************************
*     Floating Point Package       *
* Copyright M. R. King 1982, 1984. *
* All rights reserved.             *
************************************

* Float integer D0 to real D0

float movem.l d1,-(sp)
  move.w #150*128,d1
  tst.l d0
  beq.s floatret
  bpl.s floatpos
  eor.w #$8000,d1
  neg.l d0
floatpos cmp.l #$00800000,d0
  bcc.s floatsr
floatll lsl.l d0
  sub.w #128,d1
  btst.l #23,d0
  beq.s floatll
  bra.s floatex
floatrl lsr.l d0
  add.w #128,d1
floatsr cmp.l #$00FFFFFF,d0
  bcc.s floatrl
floatex swap d0
  and.w #$007F,d0
  or.w d1,d0
  swap d0
floatret movem.l (sp)+,d1
  rts

* Negate real D0

fneg tst.l d0
  beq.s fnegret
  eor.l #$80000000,d0
fnegret rts

* Round real D0 to integer D0

round tst.l d0
  bpl.s int
  eor.l #$80000000,d0
  bsr.s int
  neg.l d0
  rts

* Convert real D0 to integer D0

int move.l d1,-(sp)
  move.l #$3f000000,d1
  bsr fadd
  move.l (sp)+,d1

* Set integer D0 to integer part of real D0

intpt movem.l d1-d2,-(sp)
  swap d0
  move.w d0,d1
  and.w #$7F,d0
  or.w #$80,d0
  swap d0
  move.w d1,d2
  lsr.w #7,d1
  and.w #$FF,d1
  sub.w #150,d1
  bcc.s intptsl
  neg.w d1
  cmp.w #24,d1
  bcc.s intptzer
  tst.w d2
  bpl.s intptpos
  move.l #-1,d2
  lsl.l d1,d2
  not.l d2
  and.l d0,d2
  bne.s intptni
  lsr.l d1,d0
  neg.l d0
  bra.s intptret
intptni lsr.l d1,d0
  not.l d0
  bra.s intptret
intptsl cmp.w #9,d1
  bcc.s intptofl
  tst.w d2
  bpl.s intptlp
  neg.l d0
intptlp asl.l d1,d0
  bvc.s intptret
intptofl movem.l (sp)+,d1-d2
  bra overflow
intptpos lsr.l d1,d0
intptret movem.l (sp)+,d1-d2
  rts
intptzer tst.w d2
  movem.l (sp)+,d1-d2
  bpl.s intptzp
  tst.l d0
  beq.s intptzr
  move.l #-1,d0
  rts
intptzp move.l #0,d0
intptzr rts

* Truncate real D0 to integer D0

trunc movem.l d1-d2,-(sp)
  swap d0
  move.w d0,d1
  and.w #$7F,d0
  or.w #$80,d0
  swap d0
  move.w d1,d2
  lsr.w #7,d1
  and.w #$FF,d1
  sub.w #150,d1
  bcc.s truncsl
  neg.w d1
  cmp.w #24,d1
  bcc.s trunczer
  lsr.l d1,d0
  tst.w d2
  bpl.s truncst
  neg.l d0
  bra.s truncret
truncsl cmp.w #9,d1
  bcc.s truncofl
  tst.w d2
  bpl.s trunclp
  neg.l d0
trunclp asl.l d1,d0
  bvc.s truncret
truncofl movem.l (sp)+,d1-d2
  bra overflow
truncst tst.l d0
truncret movem.l (sp)+,d1-d2
  rts
trunczer clr.l d0
  bra.s truncret

* Divide real D0 by real D1,
* quotient to real D0.

fdiv movem.l d1-d4,-(sp)
  clr.w d4
  tst.l d1
  bgt.s fdiv1pos
  eor.w #$0100,d4
  and.l #$7FFFFFFF,d1
  bne.s fdiv1pos
  movem.l (sp)+,d1-d4
  bra overflow
fdiv1pos tst.l d0
  bgt.s fdiv0pos
  and.l #$7FFFFFFF,d0
  beq.s fdivret
  eor.w #$0100,d4
fdiv0pos bsr fpextrct
  add.w #151,d2
  sub.w d3,d2
  bcs.s fdivzero
  clr.l d3
fdivlp sub.w #1,d2
  bcs.s fdivzero
  lsl.l d3
  cmp.l d1,d0
  bcs.s fdvnosub
  sub.l d1,d0
  add.l #1,d3
fdvnosub lsl.l d0
  btst.l #23,d3
  beq.s fdivlp
  cmp.w #256,d2
  bcs.s fdivnofl
  movem.l (sp)+,d1-d4
  bra overflow
fdivnofl or.w d4,d2
  lsl.w #7,d2
  swap d3
  and.w #$007F,d3
  or.w d2,d3
  swap d3
  move.l d3,d0
fdivret movem.l (sp)+,d1-d4
  rts
fdivzero clr.l d0
  bra.s fdivret

* Multiply real D0 by real D1

fmul movem.l d1-d6,-(sp)
  clr.w d6
  tst.l d0
  bgt.s fmul0pos
  and.l #$7FFFFFFF,d0
  beq fmulret
  eor.w #$0100,d6
fmul0pos tst.l d1
  bgt.s fmul1pos
  and.l #$7FFFFFFF,d1
  beq.s fmulzero
  eor.w #$0100,d6
fmul1pos bsr fpextrct
  add.w d3,d2
  sub.w #126,d2
  bcs.s fmulzero
  move.l d0,d3
  move.l d1,d4
  mulu d0,d1
  swap d0
  swap d4
  mulu d4,d0
  swap d1
  move.w d4,d5
  mulu d3,d5
  add.w d5,d1
  clr.w d5
  swap d5
  addx.l d5,d0
  swap d3
  swap d4
  mulu d4,d3
  add.w d3,d1
  clr.w d3
  swap d3
  addx.l d3,d0
  lsl.l #8,d0
  rol.w #8,d1
  move.b d1,d0
  lsl.w d1
  btst.l #23,d0
  bne.s fmnoshft
  roxl.l d0
  sub.w #1,d2
  bcs.s fmulzero
  lsl.w d1
fmnoshft clr.l d1
  addx.l d1,d0
  btst.l #24,d0
  beq.s fmnocarr
  lsr.l d0
  add.w #1,d2
fmnocarr cmp.w #256,d2
  bcs.s fmulnofl
  movem.l (sp)+,d1-d6
  bra overflow
fmulzero clr.l d0
  bra.s fmulret
fmulnofl swap d0
  and.w #$007F,d0
  or.w d6,d2
  lsl.w #7,d2
  or.w d2,d0
  swap d0
fmulret movem.l (sp)+,d1-d6
  rts

* (internal) extract mantissa and exponent
* from real D0 and D1. Set D2/D3 to exponent
* of D0/D1 and set D0/D1 to mantissa of D0/D1.

fpextrct swap d0
  move.w d0,d2
  and.w #$007F,d0
  or.w #$0080,d0
  swap d0
  lsr.w #7,d2
  swap d1
  move.w d1,d3
  and.w #$007F,d1
  or.w #$0080,d1
  swap d1
  lsr #7,d3
  rts

* Add real D1 to real D0.

fadd movem.l d1-d4,-(sp)
  clr.w d4
  tst.l d0
  bne.s fadd0nz
  move.l d1,d0
  bra fpasret
fadd0nz bpl.s fadd0pos
  and.l #$7FFFFFFF,d0
  exg d0,d1
  bra.s fsub1pos
fadd0pos tst.l d1
  beq fpasret
  bpl.s fadd1pos
  and.l #$7FFFFFFF,d1
  bra.s fsub0pos
fadd1pos cmp.l d1,d0
  bcc.s fadd0big
  exg d0,d1
fadd0big bsr fpextrct
  sub.w d3,d2
  add.w d2,d3
  cmp.w #24,d2
  bcc fasquick
  lsr.l d2,d1
  add.l d1,d0
  btst.l #24,d0
  beq fasquick
  add.l #1,d0
  lsr.l #1,d0
  add.b #1,d3
  bcc.s fasquick
  movem.l (sp)+,d1-d4
  bra overflow

* Subtract real D1 from real D0.

fsub movem.l d1-d4,-(sp)
  clr.w d4
  tst.l d1
  beq.s fpasret
  bpl.s fsub1pos
  and.l #$7FFFFFFF,d1
  exg d0,d1
  bra.s fadd0pos
fsub1pos tst.l d0
  bne.s fsub0nz
  move.l d1,d0
  eor.l #$80000000,d0
  bra.s fpasret
fsub0nz bpl.s fsub0pos
  and.l #$7FFFFFFF,d0
  eor.w #$0100,d4
  bra.s fadd1pos
fsub0pos cmp.l d1,d0
  bcc.s fsub0big
  exg d0,d1
  eor.w #$0100,d4
fsub0big bsr fpextrct
  sub.w d3,d2
  add.w d2,d3
  cmp.w #24,d2
  bcc.s fasquick
  lsr.l d2,d1
  sub.l d1,d0
  beq.s fpasret
  bhi.s fsubsrch
  neg.l d0
  eor.w #$0100,d4
  bra fsubsrch
fsbsrchl sub.b #1,d3
  bcs.s fsubzero
  lsl.l d0
fsubsrch btst.l #23,d0
  beq.s fsbsrchl
fasquick or.w d3,d4
  lsl.w #7,d4
  swap d0
  and.w #$007F,d0
  or.w d4,d0
  swap d0
fpasret tst.l d0
  bpl.s fpasretp
  and.l #$7FFFFFFF,d0
  beq.s fpasretp
  eor.l #$80000000,d0
fpasretp movem.l (sp)+,d1-d4
  rts
fsubzero clr.l d0
  bra.s fpasretp

* Set real D0 to fractional part of real D0.

fracpt movem.l d1-d2,-(sp)
  swap d0
  move.w d0,d1
  bpl.s fractpen
  and.w #$7F,d0
  or.w #$80,d0
  swap d0
  lsr.w #7,d1
  and.w #$FF,d1
  sub.w #126,d1
  blo.s fracptal
  cmp.w #24,d1
  bcc.s fracptzr
  lsl.l d1,d0
  move.w #126,d1
  neg.l d0
  and.l #$00FFFFFF,d0
  bne.s fracptsc
  bra.s fracptzr
fracptsl sub.w #1,d1
  bcs.s fracptzr
  lsl.l #1,d0
fracptsc btst.l #23,d0
  beq.s fracptsl
  bra.s fracptex
fracptal neg.w d1
  lsr.l d1,d0
  sub.l #$1000000,d0
  beq.s fracptzr
  neg.l d0
  move.w #126,d1
fracptex lsl.w #7,d1
  swap d0
  and.w #$007F,d0
  or.w d1,d0
  swap d0
fracptrt movem.l (sp)+,d1-d2
  rts
fracptzr clr.l d0
  bra.s fracptrt

* Set real D0 to fractional part of D0.

fraction movem.l d1-d2,-(sp)
  swap d0
  move.w d0,d1
fractpen and.w #$7F,d0
  swap d0
  lsr.w #7,d1
  move.w d1,d2
  and.w #$FF,d1
  and.w #$0100,d2
  sub.w #126,d1
  bls.s fractal
  cmp.w #24,d1
  bcc.s fractzr
  lsl.l d1,d0
  move.w #126,d1
  and.l #$00FFFFFF,d0
  bne.s fractsc
  bra.s fractzr
fractsl sub.w #1,d1
  bcs.s fractzr
  lsl.l #1,d0
fractsc btst.l #23,d0
  beq.s fractsl
  bra.s fractex
fractal add.w #126,d1
fractex or.w d2,d1
  lsl.w #7,d1
  swap d0
  and.w #$007F,d0
  or.w d1,d0
  swap d0
fractrt movem.l (sp)+,d1-d2
  rts
fractzr clr.l d0
  bra.s fractrt

* Raise real D0 to integer exponent D1.

fexp movem.l d1-d3,-(sp)
  move.l d1,d3
  beq.s rpzer
  bpl.s rppos
  neg.l d3
  move.l d0,d1
  move.l #$3f800000,d0
  bsr fdiv
rppos move.l #$3f800000,d2
  move.l d0,d1
rploop btst #0,d3
  beq.s rpno
  move.l d2,d0
  bsr fmul
  move.l d0,d2
rpno lsr.l #1,d3
  beq.s rpret
  move.l d1,d0
  bsr fmul
  move.l d0,d1
  bra rploop
rpret move.l d2,d0
  movem.l (sp)+,d1-d3
  rts
rpzer move.l #$3f800000,d2
  bra rpret

* Set real D0 square root of real D0.

sqrt move.w ccr,-(sp)
  and.l #$7FFFFFFF,d0
  beq.s psqrtret
  movem.l d1-d4,-(sp)
  swap d0
  move.w d0,d1
  and.w #$007F,d0
  or.w #$0080,d0
  swap d0
  lsl.l #7,d0
  sub.w #$3F80,d1
  asr.w #1,d1
  add.w #$3F00,d1
  btst.l #6,d1
  beq.s fpsqrtns
  lsl.l #1,d0
fpsqrtns move.l #0,d2
  move.l #0,d3
  move.l #23,d4
fpsqrtlp lsl.l #1,d0
  roxl.l #1,d2
  lsl.l #1,d0
  roxl.l #1,d2
  lsl.l #1,d3
  add.l #1,d3
  sub.l d3,d2
  bcs.s fpsqrtob
  add.l #1,d3
  dbra d4,fpsqrtlp
  bra.s fpsqrtnm
fpsqrtob add.l d3,d2
  sub.l #1,d3
  dbra d4,fpsqrtlp
fpsqrtnm add.w #$0080,d1
  add.l #1,d3
  lsr.l #1,d3
  btst.l #24,d3
  bne.s fpsqrtnm
  and.w #$7F80,d1
  move.w d1,d0
  swap d3
  and.w #$007F,d3
  or.l d3,d0
  movem.l (sp)+,d1-d4
psqrtret move.w (sp)+,ccr
  swap d0
  rts

 list
* End of floating point package
loader equ *
  end