*  File  MOUSE:ASMLIB.ASM

* Run time support library
* RWT September 1987

* This file contains run time support
* procedures for FE02-format object
* files, including extended (32-bit)
* integer arithmetic, a basic set of
* 32-bit floating-point operations,
* basic stream I/O procedures, and
* the implementation of the Imp %event
* (exception) signalling mechanism,
* including the conversion of hardware
* exceptions into the appropriate Imp
* events.
* The procedures are accessed through
* the "extracode" mechanism, i.e. a
* fixed-address jump table at low
* addresses: the entry point for
* extracode number N is at $3F00-6N.

* Mouse Supervisor references

curpro  equ $11e0  ad of current process PCB
uptime  equ $11e4  milliseconds
cputype equ $1200  68000 or 68010
scratch equ $120c  temporary variable
propoa  equ $18    offset within PCB of POA

* Imp process-own area fields

                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
                ds.l 4 [scr1,scr2,xh,??]
poaheapbase     ds.l 1
poastacklim     ds.l 1
poacurin        ds.l 1
poacurout       ds.l 1
poainstream     ds.l 1
poaoutstream    ds.l 1
poain0          ds.l 8
poaout0         ds.l 8
poacliparam     ds.b 256

          org  0
scbp      ds.l 1
scbl      ds.l 1
scbbs     ds.l 1
scbbl     ds.l 1
scbfs     ds.l 1
scbfl     ds.l 1
scbfastpc ds.l 1
scbgla    ds.l 1
scbserpc  ds.l 1
scbmode   ds.l 1
scbnext   ds.l 1
scbprompt ds.l 1
scba      ds.l 1
scbb      ds.l 1
scbc      ds.l 1
scbd      ds.l 1
scbname   ds.b 256

   incl inc:module.asm
   module <Extracode Library>
   code

* Miscellanies

jsrw equ $4eb8
jsrl equ $4eb9
jmpw equ $4ef8
jmpl equ $4ef9

push macro
\* move\0 \1,-(sp)
   endm
pop macro
\* move\0 (sp)+,\1
   endm
pushm macro
\* movem.l \1,-(sp)
   endm
popm macro
\* movem.l (sp)+,\1
   endm

* Plant in-line text string

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

* Move string at (\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

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

* Prepare to signal event \1,\2,\3,\4
* from exception context.

excevent macro
\* push.l \3
   push.w #\2
   move.b #\1,(sp)
   jsr exception
   string <\4>
   endm

* General exception handler.
* Stack contains: message address,
* EVENT.B, EVSUB.B, EVEXTRA.L,
* SR.W, PC.L, FW.W?

exception btst #5,10(sp)
   bne.s nottrapped               not user mode ->
   push.l a5
   move.l curpro,a5
   move.l propoa(a5),a5
   movem.l d0-d7/a0-a7,poaeventregs(a5)
   move.l usp,a0
   move.l a0,poaeventregs+60(a5)  original SP
   pop.l poaeventregs+52(a5)      original A5
   pop.l a1                       message
   pop.w poaevent(a5)             event & subevent
   pop.l poaeventextra(a5)
   lea poaeventmess(a5),a0        copy message
   movestring a1,a0,d0
   move.l 2(sp),poaeventpc(a5)    save PC and
   move.l a6,poadisplay(a5)       register display
   movem.l poadisplay(a5),d1-d7
   movem.l d1-d7,poaeventdisplay(a5)
   lea unwinder,a0
   move.l a0,2(sp)
   movem.l poaeventregs(a5),d0-d7/a0-a1
   rte                            invoke unraveller

nottrapped lea 0,a0         die unceremoniously
   trap #7

* Chase down list until event trap block found.

unwinder clr.w poaeventline(a5)
   clr.l d1
   move.b poaevent(a5),d1
   moveq #1,d0
   lsl.w d1,d0              D0 contains event bit
   push.l poaevlink(a5)
unwindloop move.l (sp),poaevlink(a5)
   move.l poaevlink(a5),sp
   cmp #0,sp
   beq nottrapped           No more trap blocks
   move.l 4(sp),a0          PC component
   move.w (a0),d1           event mask
   and.w d0,d1
   beq unwindloop
   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       GLA component
   pea 2(a0)                save entry point
   moveq #6,d0              Now unravel the display
   lea poadisplay(a5),a0
unlinkloop move.l (a0),a1
   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

* Exception handler entry points

buserror     cmp.l #68010,cputype
             beq.s berr010
             move.l 2(sp),scratch
             move.w (sp),scratch+4
             move.w 6(sp),scratch+6
             lea 8(sp),sp
berr         excevent 0,2,scratch,<'Bus error'>
berr010      move.l 10(sp),scratch
             move.w 8(sp),scratch+4
             move.w $18(sp),scratch+6
             move.w (sp),$30(sp)
             move.l 2(sp),$32(sp)
             clr.w $36(sp)
             lea $30(sp),sp
             bra berr
addresserror cmp.l #68010,cputype
             beq.s aerr010
             move.l 2(sp),scratch
             move.w (sp),scratch+4
             move.w 6(sp),scratch+6
             lea 8(sp),sp
aerr         excevent 0,3,scratch,<'Address error'>
aerr010      move.l 10(sp),scratch
             move.w 8(sp),scratch+4
             move.w $18(sp),scratch+6
             move.w (sp),$30(sp)
             move.l 2(sp),$32(sp)
             clr.w $36(sp)
             lea $30(sp),sp
             bra aerr
illegalinst  equ *
     excevent 0,4,d7,<'Illegal instruction'>
dividebyzero excevent 1,4,d7,<'Division by zero'>
CHKinst      excevent 6,2,d7,<'CHK: Out of bounds'>
TRAPVinst    excevent 1,1,d7,<'TRAPV: Overflow'>
emulator     excevent 0,4,d7,<'Emulator trap'>
reserved     excevent 0,4,d7,<'Reserved exception'>
undeftrap    excevent 0,4,d7,<'Unimplemented TRAP'>
trace        rte

* Privilege violation
* Check for MOVE SR,D0 (emulate)
* Otherwise convert to event.

privilegeviol or #$700,sr
* push.l a0
* move.l 6(sp),a0
* cmp.w #$40e7,(a0)
* beq.s srtosp
* cmp.w #$40c0,(a0)
* pop.l a0
* beq srtod0
  excevent 0,8,d7,<'Privilege violation'>
srtod0 move.w (sp),d0
  addq.l #2,2(sp)
  rte
srtosp move.l usp,a0
  move.w 4(sp),-(a0)
  move.l a0,usp
  pop.l a0
  addq.l #2,2(sp)
  rte

* Imp line number trace

linetrace move.l a0,-(sp)
  move.l 6(sp),a0
  swap d5
  move.w (a0)+,d5
  move.l a0,6(sp)
  move.l (sp)+,a0
  rte
*linetrace addq.l #2,2(sp)
*   rte

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

absmess string <'Undefined extracode'>
absent move.l #xcodebase+6,d2
   sub.l (sp)+,d2
   divu #6,d2
   signalevent $70,4,d2,<'Undefined extracode'>

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

* Signal Imp Event:
* 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

signal movem.l d0-d7/a0-a7,poaeventregs(a5)
   addq.l #4,poaeventregs+60(a5)     adjust SP
   clr.w poaevent(a5)
   bclr #4,d0
   beq.s nosub
   move.b d1,poaeventsub(a5)
nosub bclr #5,d0
   beq.s noextra
   move.l d2,poaeventextra(a5)
noextra bclr #6,d0
   beq.s nomess
   lea poaeventmess(a5),a1
   movestring a0,a1,d1
nomess move.b d0,poaevent(a5)
   move.l (sp),poaeventpc(a5)
   move.l a6,poadisplay(a5)
   movem.l poadisplay(a5),d1-d7
   movem.l d1-d7,poaeventdisplay(a5)
   movem.l poaeventregs(a5),d0-d7/a0-a1
   jmp unwinder

* Extended arithmetic starts here
*  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   zdivoflow
         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
zdivoflow movem.l (sp)+,d2-d4
         divs #0,d0            * invoke trap
         rts                   * never reached

* Raise integer D0 to integer exponent D1.

power    movem.l d1-d3,-(sp)
         move.l d1,d3
         beq.s intpzer
         bmi.s intpneg
         moveq #1,d2
         move.l d0,d1
intploop btst #0,d3
         beq.s intpno
         move.l d2,d0
         jsr mul
         trapv
         move.l d0,d2
intpno   lsr.l #1,d3
         beq.s intpret
         move.l d1,d0
         jsr mul
         trapv
         move.l d0,d1
         bra intploop
intpret  move.l d2,d0
         movem.l (sp)+,d1-d3
         rts
intpzer  moveq #1,d2
         bra intpret
intpneg  clr.l d2
         bra intpret

* end of extended arithmetic

  list
zzz equ *
* 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    fpnegret
         eor.l    #$80000000,d0
fpnegret 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
fpdivlp  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    fpdivlp
         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.

fpow     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

*************************
* Stream IO starts here *
*************************

* NEXTSYMBOL

nextsymbol move.l poacurin(a5),a0
  cmp #0,a0
  ble endoffile
  move.l scbp(a0),a1
  cmp.l scbl(a0),a1
  bhs.s nsrefresh
  moveq #0,d0
  move.b (a1),d0
  rts
nsrefresh push.l a4
  movem.l scbfastpc(a0),a1/a4
  jsr (a1)
  pop.l a4
  bra nextsymbol
endoffile moveq #$69,d0
  move.l poainstream(a5),d2
  lea eoi,a0
  jmp signal
eoi string <'End of input'>

* READSYMBOL

readsymbol move.l poacurin(a5),a0
  cmp #0,a0
  ble endoffile
  move.l scbp(a0),a1
  cmp.l scbl(a0),a1
  bhs.s rsrefresh
  moveq #0,d0
  move.b (a1)+,d0
  move.l a1,scbp(a0)
  rts
rsrefresh push.l a4
  movem.l scbfastpc(a0),a1/a4
  jsr (a1)
  pop.l a4
  bra readsymbol

* PRINTSYMBOL

printsymbol move.l poacurout(a5),a0
  cmp #0,a0
  ble.s psspecial
  move.l scbp(a0),a1
  cmp.l scbl(a0),a1
  bhs.s psflush
  move.b d0,(a1)+
  move.l a1,scbp(a0)
  rts
psflush push.l a4
  movem.l scbfastpc(a0),a1/a4
  jsr (a1)
  pop.l a4
psnull rts
psspecial beq psnull
  jmp (a0)

* PRINTSTRING

printstring clr.w d0
  move.b (a0)+,d0
  beq psnull
  subq.w #1,d0
  lea -6(sp),sp
ps1 move.w d0,(sp)
  moveq #0,d0
  move.b (a0)+,d0
  move.l a0,2(sp)
  bsr printsymbol
  move.w (sp),d0
  move.l 2(sp),a0
  dbra d0,ps1
  lea 6(sp),sp
  rts

* SELECTINPUT

selectinput cmp.l #7,d0
  bgt.s badstream
  tst.l d0
  bmi.s badstream
  move.l d0,poainstream(a5)
  lsl.w #2,d0
  lea poain0(a5),a0
  move.l (a0,d0.w),poacurin(a5)
  rts
badstream equ *
  signalevent $75,0,d0,<'Invalid stream number'>

* SELECTOUTPUT

selectoutput cmp.l #7,d0
  bgt badstream
  tst.l d0
  bmi badstream
  move.l d0,poaoutstream(a5)
  lsl.w #2,d0
  lea poaout0(a5),a0
  move.l (a0,d0.w),poacurout(a5)
  rts

excvec macro
  lea \1,a0
  move.l a0,(a1)+
  endm

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

* Add entries to exception vector table

begin lea $1008,a1
  excvec buserror
  excvec addresserror
  excvec illegalinst
  excvec dividebyzero
  excvec CHKinst
  excvec TRAPVinst
  excvec privilegeviol
  excvec trace
  excvec emulator
  move.l a0,(a1)+
  excvec reserved
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  move.l a0,(a1)+
  lea 92(a1),a1      skip to trap 15
  excvec linetrace

* Intercept undefined TRAPs

  lea undeftrap,a0
  moveq #15,d0
loop1 tst.l -(a1)
  dbmi d0,loop1
  bpl.s loop1done
  move.l a0,(a1)
  dbra d0,loop1
loop1done equ *

nxcodes   equ 64
xcodebase equ $3f00
xcodelim  equ xcodebase-6*nxcodes

* Intercept undefined extracodes

   move.w #nxcodes-1,d0
   lea xcodebase,a0
   lea absent,a1
loop2 lea -6(a0),a0
   cmp.w #$4afc,(a0)
   dbeq d0,loop2
   bne.s loop2done
   move.w #jsrl,(a0)
   move.l a1,2(a0)
   dbra d0,loop2
loop2done equ *

* Add entries to extracode table

xcode macro
  lea \2,a0
  move.l a0,xcodebase-6*\1+2
  move.w #jmpl,xcodebase-6*\1
  endm

* The following is a complete list
* of the "new" extracodes.  The
* commented-out ones are defined
* elsewhere, the rest in this file.

   xcode 1,signal
   xcode 2,mul
   xcode 3,div
   xcode 4,muldiv
   xcode 5,power
   xcode 6,fneg
   xcode 7,fadd
   xcode 8,fsub
   xcode 9,fmul
   xcode 10,fdiv
   xcode 11,fpow
   xcode 12,float
   xcode 13,round
   xcode 14,trunc
   xcode 15,fraction
   xcode 16,int
   xcode 17,intpt
   xcode 18,fracpt
   xcode 19,sqrt
*  xcode 20,heapnew
*  xcode 21,heapdispose
   xcode 22,nextsymbol
   xcode 23,readsymbol
   xcode 24,printsymbol
   xcode 25,printstring
*  xcode 26,openinput
*  xcode 27,openoutput
   xcode 28,selectinput
   xcode 29,selectoutput
*  xcode 30,setinput
*  xcode 31,setoutput
*  xcode 32,closeinput
*  xcode 33,closeoutput
*  xcode 34,prompt

*  35 spare
*  36:57 back-compat (see below)
*  58 spare

* The remaining 6 are supervisor-related
*  59 becomeprocess
*  60 signalsemaphore
*  61 removeinthandler
*  62 addinthandler
*  63 waitforinterrupt
*  64 returnfromint

* Redirect old extracodes to new ones

oxbase equ $10c0

oxcode macro
  move.w #jmpw,oxbase+4*\1
  move.w #xcodebase-6*\2,oxbase+4*\1+2
  endm

* These simply map across

 oxcode  0,24 printsymbol
 oxcode  1,25 printstring
 oxcode  2,23 readsymbol
 oxcode  3,22 nextsymbol
 oxcode  4,34 prompt
 oxcode  6,28 selectinput
 oxcode  7,29 selectoutput
 oxcode 10,32 closeinput
 oxcode 11,33 closeoutput
 oxcode 12,26 openinput
 oxcode 13,27 openoutput
 oxcode 24,2  mul
 oxcode 25,3  div

* These take up spare slots.

 oxcode  5,36  testsymbol
 oxcode  8,37  resetinput
 oxcode  9,38  resetoutput
 oxcode 14,39  etheropen
 oxcode 15,40  etherclose
 oxcode 16,41  etherwrite
 oxcode 17,42  etherread
 oxcode 18,43  fcomm
 oxcode 19,44  fcommw
 oxcode 20,45  fcommr
 oxcode 21,46  signaloldevent
 oxcode 23,47  write
 oxcode 28,48  cputime
 oxcode 32,49  settermmode
 oxcode 47,50  defname
 oxcode 48,51  refname
 oxcode 49,52  transname
 oxcode 51,53  nhex
 oxcode 52,54  bhex
 oxcode 53,55  whex
 oxcode 54,56  lhex
 oxcode 55,57  rhex

* Of the above, the following are
* implemented in this file.

 xcode 37,resetinput
 xcode 38,resetoutput
 xcode 46,oldsignal
 xcode 48,cputime
 xcode 53,nhex
 xcode 54,bhex
 xcode 55,whex
 xcode 56,lhex
 xcode 57,rhex

reset rts

*********************************
* Backwards-compatibility stuff *
* (to be gotten rid of at the   *
* earliest possible opportunity *
* (i.e. probably never))        *
*********************************

cputime move.l uptime,d0
  rts

resetinput clr.l d0
  jmp $3f00-6*30

resetoutput clr.l d0
  jmp $3f00-6*31

oldsignal tst.l d0
  bpl.s olds1
  neg.l d0
olds1 move.l d0,d1
  lsr.l #4,d1
  and.l #15,d0
  or.w #$50,d0
  bra signal

lhex swap d0
  bsr.s whex
  swap d0

whex ror.w #8,d0
  bsr.s bhex
  rol.w #8,d0

bhex ror.b #4,d0
  bsr.s nhex
  rol.b #4,d0

nhex move.l d0,-(sp)
  and.l #15,d0
  cmp #9,d0
  ble.s nhex1
  add #7,d0
nhex1 add #'0',d0
  bsr printsymbol
  move.l (sp)+,d0
  rts

rhex0 bsr readsymbol
rhex bsr nextsymbol
  and.l #127,d0
  cmp #' ',d0
  ble rhex0
  clr.l d1
rhex1 cmp #'0',d0
  blt.s rhex9
  cmp #'9',d0
  ble.s rhex2
  and #95,d0
  cmp #'A',d0
  blt.s rhex9
  cmp #'F',d0
  bgt.s rhex9
  sub #7,d0
rhex2 sub #'0',d0
  lsl.l #4,d1
  add d0,d1
  bsr readsymbol
  bsr nextsymbol
  bra rhex1
rhex9 move.l d1,d0
  rts

   endmodule
   end