*  File  NMOUSE:PREFIX.ASM

* Mouse bootstrap prefix
* (c) RWT 1988
* Last changed 30/11/88

* The image formed by concatenating the binaries
* of this file and of the (Imp-compiled) loader
* should be loaded into on-board RAM at $1000.

* This file contains the exception vector table,
* etc, code to enter the main loader, and some of
* the basic extracodes (including floating point).

xvt    equ $1000  Exception vector table address
cpu    equ $3f00  CPU type (also Xcode base)
memtop equ $3ffc  set up by ROM bootstrap

  bin
  rorg xvt

* The exception vector table below is limited to
* entries 0:47, as on our boards only autovectors
* are generated.  So the MMUs are the only possible
* source of full 8-bit interrupt vectors, and they
* should not be programmed to do so.

* The initial SP is irrelevant for our purposes,
* as it is immediately changed to point near the
* end of main memory (the size of which is known
* only at run time), but must nevertheless point
* to somewhere valid, as the entry sequence in the
* ROM bootstrap uses it.

* The space occupied by the initialisation code,
* which is adjacent to the vector table, is later
* used for the supervisor's private variables, and
* cleared before jumping into the main loader.

  dc.l cpu     initial SP
  dc.l begin   initial PC
  dc.l e,e     bus/address error
  dc.l not010  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

*--------------------------*
* Initial entry is to here *
*--------------------------*

begin move.l memtop,sp
  lea -1024(sp),a5      A5  -> end of mem -1k
  lea 0(a5),sp          SSP -> end of mem -1k
  lea -1024(a5),a4      A4  -> end of mem -2k

* Point VBR at the vector table, and also test
* whether this is a 68010 or a 68000.

  move.l #68010,cpu
  lea xvt,a0
  movec a0,vbr          this fails on 68000,
  lea x4,a0              (but that's OK)
  move.l a0,$1010       replace II interceptor

* Enter user mode but leave interrupts 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 cpu,sp
  move.w #jmpl,d0
  xc signal,   1
  xc mul,      2
  xc div,      3
  xc muldiv,   4
  xc iexp,     5
  xc fneg,     6
  xc fadd,     7
  xc fsub,     8
  xc fmul,     9
  xc fdiv,     10
  xc fexp,     11
  xc float,    12
  xc round,    13
  xc trunc,    14
  xc fraction, 15
  xc int,      16
  xc intpt,    17
  xc fracpt,   18
  xc sqrt,     19
  moveq #64-19-1,d1
xloop pea absent
  move.w d0,-(sp)
  dbra d1,xloop

* FE02 header offsets

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

* 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).

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

* Compute reset and main entry points.
* Since this lot is all in local memory we can
* assume that none of the offsets is very big.

  move.w reset(a0),d2      word offset
  add.w d2,d2              byte offset
  move.w main(a0),d1       w
  add.w d1,d1              b
  move.w import(a0),d0     probably =0
  add.w export(a0),d0      probably #0
  lea hdrsize(a0,d0.w),a0  start of code area
  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)           call reset routine

* Clear supervisor variables

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

* Enter main loader

  lea loader,a0             pass header address
  rts

* End of bootstrap

* Miscellaneous macros

* 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 *
*--------------------------------*

not010 move.l #68000,cpu
  addq.l #4,2(sp)   skip offending inst
  rte
x4 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 <'Privilege violation'>

* 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 (for II & PV)
  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

* 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         display registers
  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
  bmi.s yesmore
  cmp.l #68010,cpu
  beq.s nomore
yesmore 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>

*-----------------------*
* 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       disable interrupts
  trap #1
  lea crashmess,a0
  jsr rompstr
  bsr space
  move.l a5,d0
  jsr romphex
  bsr space
  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    return PC
  clr.l d2
  move.w -2(a0),d2       XC offset (assume JSR abs)
  signal $70,4,d2,<'Absent 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:
* MUL, DIV, MULDIV, IEXP.

  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

* end of extended arithmetic

 list

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

 ds.w 0
*nolist
* 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

* End of floating point package
 list

loader equ *
  end