* QL WORLD DIY TOOLKIT - BASIC PARAMETER ROUTINES
* Ver. 0.8, Copyright 1988,90 Simon N Goodwin.
*
start      lea.l    define,a1
           move.w   $110,a2         BP.INIT vector
           jmp      (a2)
*
define     dc.w     0,0,5           No PROCs, 5 FNs
           dc.w     unset-*         Check value
           dc.b     5,'UNSET'       
           dc.w     partype-*       Check datatype
           dc.b     7,'PARTYPE'
           dc.w     parhash-*       Check for hash
           dc.b     7,'PARHASH'
           dc.w     parsepa-*       Check separator
           dc.b     7,'PARSEPA'
           dc.w     parname-*
           dc.b     8,'PARNAME$'    Get param name
           dc.w     0               
*
unset      moveq    #0,d7           
           bra.s    check_par
partype    moveq    #1,d7          
           bra.s    check_par
parhash    moveq    #-1,d7
           bra.s    check_par
parsepa    moveq    #-2,d7
check_par  subq.l   #8,a5           Check A5-A3 = 8 ie
           cmpa.l   a3,a5           just 1 parameter
           bne.s    bad_param
           move.w   2(a3,a6.l),d0   D0 is name index
           bmi.s    bad_param       Reject expressions
           lsl.w    #3,d0
           move.l   24(a6),a2       A2 -> Name Table
           adda.w   d0,a2           A2 -> Name entry
           tst.w    d7              Check result type
           bmi.s    get_seps
           beq.s    check_set
           moveq    #15,d7          Strip separators
           and.b    1(a2,a6.l),d7   Extract datatype
           bra.s    return_d7   
check_set  tst.b    4(a2,a6.l)      Is a value set?
           bmi.s    ret_true        No, UNSET=1
           bra.s    return_d7       Return flag, 0
get_seps   addq.w   #1,d7           HASH or SEPA ?
           beq.s    check_hash
           moveq    #127,d7         Lose hash bit
           and.b    1(a2,a6.l),d7   Find separator
           lsr.w    #4,d7           Shed type bits
           bra.s    return_d7
check_hash tst.b    1(a2,a6.l)      <0 means HASH 
           bpl.s    return_d7       Result D7 is 0
ret_true   moveq    #1,d7           Return 1 (true)
return_d7  moveq    #2,d1           Reserve 2 bytes  
           move.w   $11A,a0         BV.CHRIX
           jsr      (a0)            Check for space
           move.l   $58(a6),a1      Get maths SP
           subq.l   #2,a1           Allocate space
           move.l   a1,$58(a6)      Adjust BV.RIP
           move.w   d7,0(a1,a6.l)   Stack result
           moveq    #3,d4           Integer type
           moveq    #0,d0           No errors
           rts
*
bad_param  moveq    #-15,d0         Parameter error
           rts
not_found  moveq    #-7,d0          Not found error
exit       rts
*
parname    move.w   $112,a2         CA.GTINT
           jsr      (a2)            Get parameter
           bne.s    exit            Exit if AWOL
           subq.w   #1,d3           Check param count
           bne.s    bad_param       Only one expected
           move.w   0(a1,a6.l),d0   Fetch value
           subq.w   #1,d0           Count from 0
           bmi.s    bad_param       Reject if <1
           lsl.w    #3,d0           * 8 for NT offset
           move.l   60(a6),a0       A0 -> Return stack
           tst.b    -8(a0,a6.l)     Check call type
           beq.s    not_found       Reject GO SUBs
           move.l   -24(a0,a6.l),a2 A2 -> First param.
           move.l   -20(a0,a6.l),d1 D1 -> First local
           sub.l    a2,d1           D1 = param space
           cmp.w    d1,d0           Check offset
           bcc.s    ret_null        Parameter missing
           adda.w   d0,a2           A2 -> chosen entry
           moveq    #0,d0           Chack for late QLs
           trap     #1              Call MT.INF
           cmpi.l   #'1.03',d2      QDOS 1.03 or less?
           bls.s    no_tweak        Leave "AH" & "JM"
           adda.l   24(a6),a2       A2 := A2 + NT_BASE
no_tweak   move.w   2(a6,a2.l),d0   Get NT pointer
           bmi.s    ret_null        Value parameter!
           lsl.w    #3,d0           Index into NT
           movea.l  24(a6),a0       A0 -> Name Table
           adda.w   d0,a0           A0 -> Name entry
           move.w   2(a6,a0.l),d0   Name list offset
           bmi.s    bad_param       No name set up
           move.l   32(a6),a2       A2 -> Name List
           adda.w   d0,a2           A2 -> Name text
           moveq    #1,d4           
           add.b    0(a2,a6.l),d4   Get name length
           bclr     #0,d4           Make it even
           move.l   d4,d1           D1 = space needed
           move.w   $11A,a0         BV.CHRIX
           jsr      (a0)            Check for space
           move.l   $58(a6),a1      Get new maths SP
           suba.l   d4,a1           Allocate space
           move.l   a1,$58(a6)      Set BV.RIP
           moveq    #0,d1           Clear length MSB 
           move.b   0(a6,a2.l),d1   Get length 0-255
           move.w   d1,0(a1,a6.l)   Stack length
copy_chars move.b   1(a6,a2.l),2(a6,a1.l)
           addq.l   #1,a2           Advance in name
           addq.l   #1,a1           Advance in stack
           subq.w   #1,d1           Count down text
           bne.s    copy_chars
ret_string moveq    #1,d4           Result is a string
           moveq    #0,d0           No error
           rts
ret_null   clr.w    0(a1,a6.l)      Re-use INT space
           bra.s    ret_string
           end