* QL WORLD DIY TOOLKIT - utility commands
* Ver. 0.6, Copyright 1988,90 Simon N Goodwin.
*
bv.rip     equ      $58             A6 offset of maths SP
*
start      lea.l    define,a1
           move.w   $110,a2         BP.INIT vector
           jmp      (a2)
*
define     dc.w     1               One procedure
           dc.w     purge-*
           dc.b     5,'PURGE'
           dc.w     0,3             Three functions
           dc.w     pick-*
           dc.b     5,'PICK$'
           dc.w     check_int-*
           dc.b     6,'CHECK%'
           dc.w     check_flt-*
           dc.b     6,'CHECKF'
           dc.w     0
*
purge      moveq    #0,d1           SuperBASIC task ID
           moveq    #0,d2           = task at top of tree
           moveq    #2,d0           MT.JINF
           trap     #1              
           move.l   d1,d0           End of tree?
           beq.s    all_done
           moveq    #0,d3           No error
           moveq    #5,d0           MT.FRJOB
           trap     #1
           bra.s    purge
*
* String select function PICK$
*
pick       cmpa.l   a3,a5
           beq.s    bad_param       No parameters!
           move.l   a5,d5
           lea.l    8(a3),a5        Isolate first parameter
           move.w   $112,a2
           jsr      (a2)            CA.GTINT
           bne.s    all_done        Return error code
           move.w   0(a1,a6.l),d0   D0 is parameter value
           ble.s    bad_param       Parameter must be >=0
           addq.l   #2,a1
           move.l   a1,bv.rip(a6)   Tidy Maths stack
           asl.w    #3,d0           Multiply parameter by 8
           bvs.s    bad_param       Reject if over 4095
           adda.w   d0,a5           A5 -> End of par. entry
           cmpa.l   d5,a5           Past the true end?
           bhi.s    bad_param
           lea.l    -8(a5),a3       Bracket that one alone
           move.w   $116,a2         Fetch it, as a string
           jsr      (a2)            CA.GTSTR
           bne.s    all_done
           moveq    #1,d4           Return string
           moveq    #0,d0           No error
           rts
*
bad_param  moveq    #-15,d0         Set error code
all_done   rts
*
* Coercion check functions CHECK% and CHECKF
*
check_flt  moveq    #0,d5           Flag
           bra.s    check_num
*
check_int  moveq    #1,d5           Flag
check_num  move.l   bv.rip(a6),a4   Get old stack top
           move.w   $116,a0         Get strings
           jsr      (a0)            CA.GTSTR
           bne.s    all_done
           subq.w   #1,d3           Check for one parameter
           bne.s    bad_param
           move.l   a1,a0           Find text start
           adda.w   0(a1,a6.l),a0   Add length
           addq.l   #2,a0           Point to end
           move.l   a0,d7           D7 -> End+1
           lea.l    2(a1),a0        A0 -> Start
*
           tst.w    d5              Sift INTs from FLOATs
           beq.s    get_float
*
get_int    moveq    #2,d1           No. of bytes needed
           suba.l   d1,a4           Space at top of stack
           move.w   $11A,a2         Check for stack space 
           jsr      (a2)            BV.CHRIX
           move.l   bv.rip(a6),a1   Get safe A1 value
           move.w   $102,a2
           jsr      (a2)            CA.DTOI
           beq.s    coerced
*
           move.w   #-32768,0(a4,a6.l)
           bra.s    ret_int
*
coerced    move.w   0(a1,a6.l),0(a4,a6.l)   
ret_int    move.l   a4,bv.rip(a6)   Set new Maths SP
           moveq    #3,d4           Return integer
           moveq    #0,d0
           rts
*
get_float  moveq    #6,d1           No. of bytes needed
           suba.l   d1,a4           Room for result
           move.w   $11A,a3         BV.CHRIX
           jsr      (a3)
           move.l   bv.rip(a6),a1   Get safe A1 value
           move.w   $100,a2
           jsr      (a2)            CA.DTOF
           beq.s    got_float
*
* Coercion error: return floating point value 1e600 
*
           move.w   #4042,0(a4,a6.l)
           move.w   #-18266,2(a4,a6.l)
           move.w   #13416,4(a4,a6.l)
           bra.s    ret_float
*
got_float  move.l   2(a1,a6.l),2(a4,a6.l)
           move.w   0(a1,a6.l),0(a4,a6.l)
*
ret_float  move.l   a4,bv.rip(a6)   Set new Maths SP
           moveq    #2,d4           Float result flag
           moveq    #0,d0
           rts
*
           end