* QL WORLD DIY TOOLKIT - GENERAL-PURPOSE CHANNEL EXTENSIONS
* Version 0.9, Copyright 1993 Simon N Goodwin.
*
start       lea      define,a1
            move.w   $110.w,a2      BP.INIT vector
            jmp      (a2)
*              
* result% = ANYOPEN% ( name$ , mode% )
*
anyopen     lea      16(a3),a4
            cmpa.l   a4,a5          Two parameters please
            bne      bad_param
            addq.l   #8,a3          Get integer mode first
            movea.w  $112.w,a2      Vector to get an integer
            jsr      (a2)
            bne.s    bad_exit
            move.l   a1,d7          Save RI pointer for later
            move.w   0(a1,a6.l),d5  Save open mode for later
            subq.l   #8,a3
            subq.l   #8,a5          Recover first parameter
            movea.w  $116.w,a2      Vector to get a string
            jsr      (a2)
            bne.s    bad_exit
*
* Attempt to open a channel using the string on the RI stack
*
            move.w   d5,d3          Restore Open mode
            ext.l    d3             Take nothing for granted
            movea.l  a1,a0          Point A0 at the string
            moveq    #-1,d1         Owner is this task
            moveq    #1,d0          IO.OPEN trap key
            trap     #4             A0 is A6-relative
            trap     #2             Try it!
            tst.l    d0
            bne.s    return_d0
*
* It worked, find space for it in BASIC's channel table
*
            movea.l  $30(a6),a2
            moveq    #40,d1         Table entry size
scan_chans  cmpa.l   $34(a6),a2     Past the end?
            bge.s    make_room            
            tst.b    0(a2,a6.l)     Is it free?
            bmi.s    found_room
            adda.l   d1,a2          Try the next slot
            addq.w   #1,d0          D0 is channel number
            bra.s    scan_chans
*
make_room   move.w   d0,d6          Save BASIC # for later
            movea.w  $11A.w,a2      Fetch base vector
            lea      44(a2),a2      Adjust for channels
            jsr      (a2)
            movea.l  $34(a6),a2     Point at BV.CHP
            lea      40(a2),a3      Move up one entry
            move.l   a3,$34(a6)     Claim the new one
            move.w   d6,d0          Restore BASIC #
*
* Store channel ID and initialise BASIC channel details
*
found_room  move.l   a0,0(a2,a6.l)
            moveq    #7,d1          Count for 32 bytes
clear_table addq.l   #4,a2
            clr.l    0(a2,a6.l)     Initialise turtle etc.
            dbra     d1,clear_table
            move.b   #80,3(a2,a6.l) Fix default WIDTH
*
return_d0   move.l   d7,$58(a6)     Update BV.RIP
            move.w   d0,0(a6,d7.l)  Stack the result
            moveq    #3,d4          Type = 16 bit Integer
            moveq    #0,d0          No run-time error
            rts
*
bad_param   moveq    #-15,d0        BAD PARAMETER error
bad_exit    rts
*
* result$ = INPUT$ ( # channel% , bytes% )
*
* Read and check both parameters: channel number & length
*
inbytes     movea.w  $112.w,a2      Vector to get integers
            jsr      (a2)
            bne.s    bad_exit
            subq.w   #2,d3          Two parameters?
            bne.s    bad_param
            move.w   0(a1,a6.l),d0  Channel number
            bsr.s    get_qdos_id    Convert BASIC # to ID
            move.w   2(a1,a6.l),d5  Bytes to be read   
            ble.s    bad_param
            addq.l   #4,$58(a6)     Unstack two integers
*
* Make room to read the string onto the RI stack
*
            ext.l    d5
            move.l   d5,d1          D1 is space needed
            addq.l   #2,d1          Allow length word
            move.w   $11A.w,a2      Find BV.CHRIX
            jsr      (a2)           Allocate RI space
            movea.l  $58(a6),a1     Get BV.RIP
            suba.l   d5,a1          Move it down
            btst     #0,d5          Is the length odd?
            beq.s    its_even
            subq.l   #1,a1          Ensure a word boundary
*
* Fetch the string from the file to the RI stack
*
its_even    moveq    #-1,d3         Indefinite timeout
            move.l   d5,d2          D2 is length in bytes
            trap     #4             A1 is relative to A6
            moveq    #3,d0          IO.FSTRG key
            trap     #3
            tst.l    d0             Did it work?
            bne.s    bad_exit
            suba.l   d5,a1          Wind back over the text
            subq.l   #2,a1          Allow for a prefix word
            move.w   d1,0(a1,a6.l)  Set string length
            move.l   a1,$58(a6)     Set BV.RIP
            moveq    #1,d4          Indicate string result
            rts
*
* SET_POS # channel , position
*
* Moves to start or EOF if 32 bit position is beyond file end
*
setpos      movea.w  $118.w,a2      Vector gets addresses
            jsr      (a2)
            bne.s    bad_exit
            subq.w   #2,d3          Test for two parameters
            bne.s    bad_param      Reject otherwise
            move.l   0(a1,a6.l),d0
            bsr.s    get_qdos_id
*
* Set FS.POSAB registers and exit via QDOS TRAP handler
*
            moveq    #-1,d3         Wait as long as it takes
            move.l   4(a1,a6.l),d1
            moveq    #$42,d0        Set the trap key
            trap     #3             Call FS.POSAB
            rts                     Return D0 error, if any
*
* Convert channel number in D0 to channel ID in A0
*
get_qdos_id mulu     #40,d0         Scale for table size
            bmi.s    what_chan      Channel numbers start at 0
            add.l    $30(a6),d0     Add table base offset
            cmp.l    $34(a6),d0 
            bge.s    what_chan      Past end of table?
            move.l   0(a6,d0.l),d0  Fetch ID from table
            bmi.s    what_chan      Channel closed if negative
            movea.l  d0,a0
            rts
*
what_chan   addq.l   #4,a7          Return to prior caller
            moveq    #-6,d0         CHANNEL NOT OPEN error
            rts
*
define      dc.w     1              One procedure
            dc.w     setpos-*
            dc.b     7,'SET_POS'    # channel% , position
            dc.w     0
            dc.w     2              Two functions
            dc.w     inbytes-*
            dc.b     6,'INPUT$'     ( # channel% , bytes% ) 
            dc.w     anyopen-*
            dc.b     8,'ANYOPEN%'   ( name$ , mode% ) 
            dc.w     0            
*
            end