* QL WORLD DIY TOOLKIT - BASE & KEY QUEUE FUNCTIONS
* Ver. 0.4, Copyright 1989,90 Simon N Goodwin & Phil Spink.
*
initialise lea.l    define,a1
           move.w   $110,a2         BP.INIT vector
           jmp      (a2)
*
* address = CHBASE or CHBASE(#chan) or CHBASE(index,tag)
*
chbase     moveq    #1,d0           Assume channel 1 at first
           cmpa.l   a3,a5           Any parameters?
           beq.s    chan_sel
           move.w   $112,a2         Vector to get integers
           jsr      (a2)            CA.GTINT
           bne.s    bad_exit
           subq.w   #1,d3           Only 1 parameter?
           beq.s    got_one
           subq.w   #1,d3           Only 2 parameters?
           bne.s    bad_param       No, too many, complain
           move.l   0(a1,a6.l),d0   Fetch tag and index 
           addq.l   #4,$58(a6)      Tidy BV.RIP
           swap     d0              Tag is top of a QDOS ID
           bra.s    got_id
got_one    move.w   0(a1,a6.l),d0   Get BASIC channel No.
           addq.l   #2,$58(a6)      Tidy BV.RIP
chan_sel   mulu     #40,d0          Channel table size
           add.l    $30(a6),d0      Add base offset
           cmp.l    $34(a6),d0 
           bge.s    what_chan       Past end of table?
           move.l   0(a6,d0.l),d0
           bmi.s    what_chan       Negative if closed
got_id     move.l   d0,a0           A0 is channel ID
           lea.l    extopper,a2     A2 -> extension code
           moveq    #0,d3           Don't wait around
           moveq    #9,d0           SD.EXTOP key
           trap     #3              Call QDOS IO system
           tst.l    d0
           beq.s    return_fp       OK, result is in D1
           move.l   d0,d1
           bra.s    return_fp       Return error code
*
extopper   move.l   a0,d1           Return channel base
           moveq    #0,d0           OK if we get this far
           rts
*
bad_param  moveq    #-15,d0         BAD PARAMETER error
bad_exit   rts                      Error code is in D0
what_chan  moveq    #-6,d0          CHANNEL NOT OPEN error
           rts
*
* Count = QUEUE%("string")          Count = 0 if successful
*
qstring    move.w   $116,a2         Fetch CA.GTSTR vector
           jsr      (a2)            Get string parameters
           bne.s    bad_exit        Abort if unsuccessful
           subq.w   #1,d3           Check number of parameters
           bne.s    bad_param       Abort unless only one
           move.w   0(a1,a6.l),d5
           beq.s    return_int      0.W stacked, return at once
           lea.l    2(a1),a4        A4 -> text (A6 relative)
           moveq    #1,d0           Find space used for text
           add.w    d5,d0
           bclr     #0,d0           D0 is length, rounded up
           adda.l   d0,a1           A1 -> space for an integer
           move.l   a1,$58(a6)      Set BV.RIP for later
*
* (A6,A4) -> text, (A6,A1) -> space for result, D5= text length
*
           moveq    #0,d0           MT.INF trap key
           trap     #1              Make A0 -> system variables
           move.l   $4C(a0),d0      Get current queue address
           beq.s    qchanged        If none, do nothing
           move.w   $E0,a5          Fetch IO.QIN vector
           move.l   d0,a2           Set up pointer for IO.QIN
qloop      move.b   0(a4,a6.l),d1   Get next character to queue
           cmpa.l   $4C(a0),a2      Has the queue changed?
           bne.s    qchanged        If so, stop now
           jsr      (a5)            Queue the character
           bne.s    qfull           Error - queue must be full
           addq.l   #1,a4           Advance through the text
           subq.w   #1,d5           One less character to do
           bne.s    qloop           Loop till D5 = 0 (+/- !)
qfull      neg.w    d5              If D5>0, make it negative
qchanged   move.w   d5,0(a1,a6.l)   Stack D5 in prepared space
return_int moveq    #3,d4           Indicate integer result
           moveq    #0,d0           Indicate no error
           rts
*
* address = SYSBASE
*
sysbase    moveq    #0,d0           MT.INF key
           trap     #1              Call QDOS manager
           move.l   a0,d1           A0 -> system variables
*
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 six bytes of space for the result
*
normalised moveq    #6,d1           No. of bytes needed
           move.w   $11A,a0         BV.CHRIX vector
           jsr      (a0)
           move.l   $58(a6),a1      Get safe A1 value
           subq.l   #6,a1
           move.l   a1,$58(a6)      Grab 6 more bytes
           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
*
define     dc.w     0,0,3           No procedures, 3 functions
           dc.w     chbase-*
           dc.b     6,'CHBASE'
           dc.w     qstring-*
           dc.b     6,'QUEUE%'
           dc.w     sysbase-*
           dc.b     7,'SYSBASE'
           dc.w     0
           end