* QL WORLD DIY TOOLKIT - BASIC ACCESS routines
* Ver. 0.6, Copyright 1988,90 Simon N Goodwin.
*
start      lea.l    define,a1
           move.w   $110,a2         BP.INIT vector
           jmp      (a2)
*
define     dc.w     1               One procedure
           dc.w     bv_poke-*
           dc.b     5,'BPOKE'
           dc.w     0,3             Three functions
           dc.w     bv_byte-*
           dc.b     6,'BPEEK%'
           dc.w     bv_word-*
           dc.b     8,'BPEEK_W%'
           dc.w     bv_long-*
           dc.b     7,'BPEEK_L'
           dc.w     0               End of functions
*
find_basic moveq    #0,d1           SuperBASIC task ID
           moveq    #0,d2           = task at top of tree
           moveq    #2,d0           MT.JINF
           trap     #1              A0 -> Base of task 0,0
           rts
*
bv_poke    lea.l    16(a3),a4       Check for 2 parameters
           cmpa.l   a4,a5
           bne.s    bad_param
           move.w   $118,a2         CA.GTLIN
           jsr      (a2)            Get long integers
           bne.s    bad_exit        
           move.l   0(a1,a6.l),d4   Get address offset
           move.l   4(a1,a6.l),d6   Get new value
           trap     #0              Stop SuperBASIC moving
           bsr.s    find_basic
           move.b   d6,0(a0,d4.l)
           bra.s    return_ok
*
bv_long    moveq    #-1,d5
           bra.s    bv_peek
bv_word    moveq    #1,d5
           bra.s    bv_peek
bv_byte    moveq    #0,d5
bv_peek    move.w   $118,a2         CA.GTLIN
           jsr      (a2)            Get a long integer
           bne.s    bad_exit
           move.l   0(a1,a6.l),d4
           addq.l   #2,$58(a6)      Leave room for an integer
           tst.w    d5              Allow access to odd bytes
           beq.s    maybe_odd
           btst     #0,d4
           bne.s    bad_param       Reject odd offsets
maybe_odd  subq.w   #1,d3
           beq.s    good_enuf       Allow just 1 parameter
bad_param  moveq    #-15,d0
bad_exit   rts
*
good_enuf  trap     #0              Can't be in subroutine!
           bsr.s    find_basic
*
get_value  tst.w    d5
           beq.s    get_byte
           bmi.s    get_long
           move.w   0(a0,d4.l),d1
           bra.s    return_int
*
get_byte   moveq    #0,d1           Return values 0-255
           move.b   0(a0,d4.l),d1
*           
return_int move.l   $58(a6),a1      Fetch BV.RIP
           move.w   d1,0(a1,a6.l)   Put result in space
           moveq    #3,d4           Indicate type is INT
return_ok  andi     #$DFFF,sr       Restart multi-tasking
           moveq    #0,d0
           rts                      Return, no error
*
get_long   move.l   0(a0,d4.l),d1
           andi     #$DFFF,sr       Restart multi-tasking
*
* Convert D1.L into a floating point value (see May DIY TK)
*
return_fp  move.w   d1,d4           D4 will be exponent
           move.l   d1,d5           D5 will be mantissa
           beq.s    normalised      Zero is a trivial case
           move.w   #2079,d4        First guess at exponent
           add.l    d1,d1           Already normalised?
           bvs.s    normalised
           subq.w   #1,d4           No, halve exponent weight
           move.l   d1,d5           Double mantissa to match
           moveq    #16,d0          Try a 16 bit shift
*
normalise  move.l   d5,d1           Take copy of mantissa
           asl.l    d0,d1           Shift mantissa D0 places
           bvs.s    too_far         Overflow; must shift less
           sub.w    d0,d4           Correct exponent for shift
           move.l   d1,d5           New mantissa is more normal
too_far    asr.w    #1,d0           Halve shift distance
           bne.s    normalise       Try shift of 8, 4, 2 and 1
*
* Check there's enough space for the result: (6-2) bytes
*
normalised moveq    #4,d1           No. of extra bytes needed
           move.w   $11A,a0         BV.CHRIX vector
           jsr      (a0)
           move.l   $58(a6),a1      Get safe A1 value
           subq.w   #4,a1
           move.l   a1,$58(a6)      Grab 4 more bytes safely
*
           move.l   d5,2(a1,a6.l)   Stack mantissa
           move.w   d4,0(a1,a6.l)   Stack exponent
           moveq    #2,d4           Floating point result
           moveq    #0,d0
           rts
*
           end