* SuperBASIC TRACE routine                       July 1989  J.R.Oakley  QView

        include 'win1_M_INC_assert'
        include 'win1_M_INC_init'

BP.CHNID equ    $144
BP.FNAME equ    $148
BV_LINUM equ    $68
BV_STMNT equ    $6C
BV_UPROC equ    $7C
CA.GTINT equ    $112
ERR.BP  equ     -15
ERR.NJ  equ     -2
IO.CLOSE equ    2
IO.FBYTE equ    1
IO.NEW  equ     2
IO.OPEN equ     1
IO.SBYTE equ    5
JB_RELA6 equ    $16
MT.ALCHP equ    $18
MT.INF  equ     0
MT.RECHP equ    $19
SV_JBBAS equ    $68
UT.MINT equ     $CE

bv..int equ     6       JB_RELA6 flag that tells us if a job is an interpreter

* define the trace block we will be using
        offset  0
trc_jsr ds.w    3       space for jsr <addr>.l
trc_slin ds.w   1       word start line to trace
trc_elin ds.w   1       word end line to trace
trc_chan ds.l   1       long channel ID, or <=0 if lsw is basic channel number
trc_llno ds.w   1       last line number reported
trc_lstm ds.b   1       last statement reported
trc_step ds.b   1       byte set if single-stepping
trc.size ds.b   0

        section trace
        init

 bp TROFF
        cmp.l   a3,a5
        bne.l   err_bp                  we don't want any params on TROFF
        moveq   #-1,d7
 bp SSTEP
        st      d7
 bp TRON
        moveq   #mt.inf,d0              who are we?
        trap    #1
        move.l  sv_jbbas(a0),a0
        lsl.w   #2,d1
        move.l  0(a0,d1.w),a0           get our JB area base
        btst    #bv..int,jb_rela6(a0)   are we Job 0 or a MultiBasic?
        bne.s   jobok                   yes - good
        moveq   #err.nj,d0              can't handle this if compiled!
rts0
        rts

jobok
        moveq   #31,d6
        move.l  bv_uproc(a6),d1         trace vector is this
        tst.l   d7                      TROFF will set N flag
        bclr    d6,d1                   test and clear msb
        move.l  d1,a4                   set base address, maybe
        bmi.l   dotroff                 if TROFF, go see about release
        bne.s   on_set                  we have control block, make it trace 

        moveq   #trc.size,d1            this much space
        moveq   #-1,d2                  for us
        moveq   #mt.alchp,d0
        trap    #1                      get it
        tst.l   d0
        bne.s   rts0                    whoops

        move.l  a0,a4                   set control address
        assert  0,trc_jsr
        move.w  #$4eb9,(a0)+            put JSR in control block
        lea     trentry(pc),a1
        move.l  a1,(a0)+                and where to JSR to!
        assert  trc_jsr+6,trc_slin,trc_elin-2
        move.l  #$00017fff,(a0)         default line range is 1 to 32767

        move.l  a4,d1
        bset    d6,d1                   trace vector is top-bit-set address
        move.l  d1,bv_uproc(a6)         fill it in

on_set
        move.b  d7,trc_step(a4)         set stepping flag
        cmp.l   a3,a5
        beq.s   rts0                    finished if no parameters

* Convert an optional channel number (#n) or device name (\device)

        move.b  1(a6,a3.l),d5           save delimiter
        bmi.s   channum                 if hash prefixed, get channel number
        cmp.b   #$30,d5                 null parameter and backslash?
        bne.s   chanok                  no, no explicit file name

        addq.l  #8,a3                   skip first null parameter
        moveq   #$F0-256,d5
        and.b   1(a6,a3.l),d5           save hash/delimiter, param=null
        bmi.s   bpkill                  don't like hash here!
        move.w  bp.fname,a2             and get a name to RI stack
        jsr     $4000(a2)
        bne.s   killit                  ouch! zap this

        move.l  a1,a0                   it's here
        moveq   #-1,d1                  for me
        moveq   #io.new,d3              new (exclusive) file
        moveq   #io.open,d0
        trap    #4                      A6-relative 
        trap    #2                      open it
        tst.l   d0
        bne.s   killit                  ...oops
        move.l  a0,d7                   get ready to set channel
        bra.s   chanset

channum
        moveq   #-128,d7                set msw $FFFF, lsb $80
        eor.b   d7,d5                   lose the hash flag now
        bsr.s   gtint                   basic channel to lsw, msw is -1

* Put channel result in control block

chanset
        bsr.s   cladhoc                 throw away any existing ad hoc channel
        move.l  d7,trc_chan(a4)         set new channel
        and.b   #$70,d5                 change delim to look like null param
        beq.s   rts1                    if no delimiter, we're done
        subq.l  #8,a3                   back off by one
        cmp.b   #$50,d5                 was it a TO delimiter?
        beq.s   chanok                  yes - treat this as <null> TO ...
* otherwise, we'll accept any other delimiter before a genuine range
        addq.l  #8,a3                   skip to next parameter
        cmp.l   a3,a5                   but there must be one!
        beq.s   bpkill
        move.b  1(a6,a3.l),d5           pick up next delimiter
chanok

* a3=a5-8 <null> <nodelim>              leave alone
* a3=a5-8 <null> TO                     set 1..32767
* a3=a5-8 <val1> TO                     set <val1>..32767
* a3=a5-8 <val1> <nodelim>              set <val1>..<val1>
* a3=a5-16 <null> TO <val2> <nodelim>   set 1..<val2>
* a3=a5-16 <val1> TO <val2> <nodelim>   set <val1>..<val2>

* Now get a range parameter of the form [start][TO [end]] or [start]TO

        move.b  d5,d1
        beq.s   rts1                    if nothing more, we're finished
        lsl.b   #4,d1                   is it a null (or removed) parameter?
        bne.s   first                   no, go get first parameter
        addq.l  #8,a3
        moveq   #1,d7                   first line defaults to 1
        bra.s   tosommat

bpkill
        bsr.s   killit
err_bp
        moveq   #err.bp,d0
rts1
        rts

* Close any ad hoc channel

cladhoc
        move.l  trc_chan(a4),d0         ad hoc channel?
        ble.s   cladhex                 no, that's OK then
        move.l  d0,a0                   yes
        moveq   #io.close,d0            close it
        trap    #2
cladhex
        moveq   #0,d0
        rts

dotroff
        beq.s   rts2                    no control block, TROFF finished
killit
        move.l  d0,-(sp)                save error code
        clr.l   bv_uproc(a6)            always zap vector
        bsr.s   cladhoc                 close any ad hoc channel
        move.l  a4,a0                   point to control block
        moveq   #mt.rechp,d0            release it
        trap    #1
        move.l  (sp)+,d0                reload error code
rts2
        rts

gtint
        move.l  a5,-(sp)                save top
        lea     8(a3),a5                get just one parameter
        move.w  ca.gtint,a2             it's an integer
        jsr     (a2)
        move.l  a5,a3                   remove parameter
        move.l  (sp)+,a5                restore top
        move.l  (sp)+,a2
        bne.s   killit
        move.w  0(a6,a1.l),d7
        bmi.s   bpkill
        jmp     (a2)

first
        bsr.s   gtint                   get integer
        move.w  d7,d1
        swap    d7
        move.w  d1,d7                   put value as both start and end
tosommat
        lsr.b   #4,d5
        beq.s   putrng                  if that's it, it's a single line
        swap    d7
        move.w  #32767,d7               assume default 32767
        subq.b  #5,d5                   must actually be TO ...
        bne.s   bpkill
        cmp.l   a3,a5
        beq.s   putrng
        move.b  1(a6,a3.l),d5
        bsr.s   gtint
        lsr.b   #4,d5                   mustn't have any trailing delimiter
        bne.s   bpkill

* Finally, store range, 0..32767 in either, e.g. TRON TO 0 will suspend trace.
putrng
        move.l  d7,trc_slin(a4)         fill in range in control block
        cmp.l   a3,a5                   must have used up all parameters
        bne.s   bpkill
        rts

* Come here just before each statement is executed etc.

trreg   reg     d0-d3/a0-a3
frame   equ     (4+4)*4
trentry
*        tst.l   4(sp)                   statement entry?
*        bne.s   trnopop                 no, don't deal with the others
*        tst.b   bv_sing(a6)             command line?
*        bne.s   trnopop                 yes, don't trace that

        movem.l trreg,-(sp)             save all affected registers
        move.l  frame(sp),a3            trace control block... plus 6

        move.w  bv_linum(a6),d2         get line number we're at
        assert  trc_jsr+6,trc_slin
        cmp.w   (a3)+,d2                before range start?
        bge.s   tre_may                 yes, go flag leaving range
        addq.l  #trc_llno-trc_slin-2,a3 step to last line number
tre_high
        st      (a3)                    flag to say we've been out of range
tre_done
        movem.l (sp)+,trreg
*trnopop
        addq.l  #8,sp
        rts

tre_may
        assert  trc_slin+2,trc_elin
        cmp.w   (a3)+,d2
        assert  trc_elin+2,trc_chan
        move.l  (a3)+,a0                pick up the channel, while we're here
        assert  trc_chan+4,trc_llno
        bgt.s   tre_high                go set flag if past end of range

        move.l  a0,d1                   channel number?
        bgt.s   tre_chid                no, already ID
        move.w  bp.chnid,a2
        jsr     $4000(a2)
        bne.s   tre_done                unavailable at present, just ignore it
tre_chid
        move.w  ut.mint,a2              how to print numbers

* Print line number and statement number, if they've changed.

        tst.b   (a3)                    have we been out of range?
        bpl.s   tre_lno                 no, go on as usual
        bsr.s   lf                      show we've been away by double spacing
tre_lno
        cmp.w   (a3)+,d2                reporting same line?
        beq.s   tre_stm                 yes - don't bother
        sf      (a3)                    force statement mismatch
        bsr.s   lf                      newline before statement number
        move.w  d2,-(a3)
        move.w  (a3)+,d1
        jsr     (a2)
tre_stm
        move.b  bv_stmnt(a6),d2
        assert  trc_llno+2,trc_lstm
        cmp.b   (a3),d2                 reporting same line and statement?
        beq.s   tre_typ                 yes - don't bother
        move.b  d2,(a3)
        moveq   #';',d1
        bsr.s   sbyte
        move.b  (a3),d1
        jsr     (a2)
tre_typ
        move.w  frame+6(sp),d2
        lsr.w   #1,d2
        move.b  tre_tab(pc,d2.w),d1
        bsr.s   sbyte

        assert  trc_lstm+1,trc_step
        move.w  (a3),d3                 single stepping will wait
        ext.w   d3
        moveq   #io.fbyte,d0            if network flush output
        trap    #3                      don't care about errors!
        bra.s   tre_done

lf
        moveq   #10,d1
sbyte
        moveq   #io.sbyte,d0
        trap    #3
        rts

tre_tab dc.b    '.=f~R' execute, let, mcf, swap, RENUM

        tini