.title diskio ; .LIST MEB .macro struct n fab'n': $fab ctx=n,fop=,rfm=var,dnm=, - rat=cr,nam=nam'n',xab=xab'n' rab'n': $rab ctx=n,fab=fab'n',rop= nam'n': $nam rsa=rs'n',rss=nam$c_maxrss, - esa=es'n',ess=nam$c_maxrss rs'n': .blkb nam$c_maxrss es'n': .blkb nam$c_maxrss prmpt'n': .blkb 256 xab'n': $xabpro .save .psect fabt .address fab'n' .psect rabt .address rab'n' .psect namt .address nam'n' .psect prmt .address prmpt'n' .psect xabt .address xab'n' .restore .endm struct .macro setblk units=4 s_sts: .long 0 .blkl units s_len: .long 0 .blkl units s_eofmess: .long 0 .blkl units .save .psect fabt fabtb: .long 0 .psect rabt rabtb: .long 0 .psect namt namtb: .long 0 .psect prmt prmtb: .long 0 .psect xabt xabtb: .long 0 .restore n = 0 .rept units n = n + 1 struct \n .endr ; .endm setblk ; setblk 20 ; ; ; IF(.NOT.D_OPEN(lun,'R' or 'W',filename [,nbuffs]))STOP 'D_OPEN ERROR' ; where lun is the iopack lun (not related to FORTRAN luns at all), ; 'W' must be specified to get write access to the file ; in which case a new file is created, ; filename is the filename in either CHARACTER form or ; null terminated BYTE string, ; and nbuffs is an optional buffer count which specifies ; how many buffers to use in all i/o requests. This has ; a great deal to do with actual speed. 11 is a good choice. ; There is an optional UIC parameter at the end which says ; to set the owner field if its a new file. ; D_OPEN returns .TRUE. iff the open was successful. d_open:: .word ^m movzbl @4(ap),r2 ;get lun clrl s_sts[r2] clrl s_len[r2] ashl #2,r2,r2 ; mul by 2 to get word offset $rab_store rab=@l^rabtb(r2),mbc=#0 ; clear out buffer $fab_store fab=@l^fabtb(r2),deq=#0 ; counts in case of $fab_store fab=@l^fabtb(r2),alq=#0 ; previous use of io lun $xabpro_store xab=@l^xabtb(r2),uic=#0 ; also clear out owner cmpw 0(ap),#5 ;are there 5 args ? beql owner ;yes.set owner cmpw 0(ap),#4 ;are there 4 args ? beql mbc ;YES. They specified a buffer count. cmpw 0(ap),#3 ;are there 3 args ? beql name ;YES. Good, that's only other legal choice jmp badarg ;error owner: tstl 20(ap) ;did they specify an address? beqlu mbc ;no. skip it moval @l^xabtb(r2),r1 ;get xab address into r1 movl @20(ap),xab$l_uic(r1) mbc: ; user-specified buffer count tstl 16(ap) ; did they omit address ? beqlu name ; yes tstl @16(ap) ; did they say 0 ? beqlu name ; Yes. Ignore them $rab_store rab=@l^rabtb(r2),mbc=@16(ap) ; use user value for $fab_store fab=@l^fabtb(r2),deq=@16(ap) ; multi-buffer count $fab_store fab=@l^fabtb(r2),alq=@16(ap) ; file alloc & extend name: moval @12(ap),r0 ; get addr of descriptor jsb filename done: $rab_store rab=@l^rabtb(r2),rop=; select asynch operation moval @8(ap),r0 ; beql read ;default to read cmpb @4(r0),#^a/W/ ;did they say '/W/rite' beql write ;yes cmpb @4(r0),#^a/w/ ;try small w too. beql write ;yes. cmpb @4(r0),#^a/A/ ;did they say append ? beql append ;yes cmpb @4(ap),#^a/a/ ;try lowercase bneq read ;no must be read append: $rab_store rab=@l^rabtb(r2),rop=; select append mode $fab_store fab=@l^fabtb(r2),fac=;so you can do find brb rdapp write: ; open a new file for writing $fab_store fab=@l^fabtb(r2),fac=;so you can do find $create fab=@l^fabtb(r2),err=error,suc=error blbc r0,opnret ; on error, return with error code. brb conn read: ; open an existing file to read $fab_store fab=@l^fabtb(r2),fac= rdapp: $open fab=@l^fabtb(r2),err=error,suc=error blbc r0,opnret ; on error, return with error code. conn: ; in either case connect a record stream to it. $connect rab=@l^rabtb(r2),err=error,suc=error opnret: ret badarg: pushal invarg calls #1,errmes ret invarg: .long mth$_wronumarg filename: ; filename is a simple subroutine to ; store the filename specified in the fab. ; On call, R0 must point to the filename descriptor ; (or address of the BYTE buffer) and R2 must ; serve as a pointer into the FABTB. ; On return the FAB has been set with the appropriate filename. movl r0,r3 cmpb 2(r0),#14 ;is it a character string ? beql char ;yes. Descriptors always have 14 in high word movl r0,r1 ;not CHAR, must be BYTE w/ null at end cloop: tstb (r1)+ ;look for terminating null bneq cloop ;not yet found decl r1 ;found null. point to last good char subl r0,r1 ;get string length $fab_store fab=@l^fabtb(r2),fns=r1,fna=(r3) ; brb done rsb char: movzbl (r3),r1 ;get string length movl 4(r3),r0 ;get string address decl r0 ;r1 is 1 too big chloop: ;get rid of trailing blanks addl2 r1,r0 ;get last char of string cmpb (r0),#^a/ / ;is it a blank ? bneq cdon ;no. stop looking for more blanks subl2 r1,r0 ;fix up address for next time sobgtr r1,chloop ;decrement length cdon: $fab_store fab=@l^fabtb(r2),fns=r1,fna=@4(r3) rsb ; ; ; ; CALL D_CLOS(lun) ,where ; lun is the iopack lun (no relation to FORTRAN luns) ; d_clos:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait ;even though this is a file operation ;you can't do it until record processing ;completes movzbl @4(ap),r0 clrl s_sts[r0] clrl s_len[r0] movzbl #-1,s_eofmess[r0] $close fab=@l^fabtb(r2),err=error,suc=error moval @l^fabtb(r2),r1 bicl2 #fab$m_dlt,fab$l_fop(r1) ; specify no delete on close bicl2 #fab$m_spl,fab$l_fop(r1) ; specify no spool on close bicl2 #fab$m_scf,fab$l_fop(r1) ; specify no submit file on close ret ; ; errlst: .long rms$_acc,rms$_atr,rms$_atw,rms$_cda,rms$_chn,rms$_cre .long rms$_dac,rms$_dnf,rms$_dpe,rms$_ent,rms$_ext,rms$_fnd .long rms$_ifa,rms$_irc,rms$_mkd,rms$_net,rms$_rer,rms$_rmv .long rms$_rpl,rms$_sup,rms$_sys,rms$_wbe,rms$_wer,rms$_wpl endlst: error: .word ^m moval @4(ap),r2 ;happily error is called by an AST movl rab$l_ctx(r2),r3 movl rab$l_sts(r2),s_sts[r3] ashl #2,r3,r0 ;r0 is pointer into longword tables moval @l^namtb(r0),r1 ;r1 points to nam bitl #nam$m_wildcard,nam$l_fnb(r1) ;check for wildcard op. beqlu 10$ ; no special stuff except on wildcards cmpl s_sts[r3],#rms$_nmf ; fake it for nmf beqlu 11$ cmpl s_sts[r3],#rms$_fnf ; same for fnf bnequ 10$ 11$: movl #rms$_normal,s_sts[r3] 10$: movzwl rab$w_rsz(r2),s_len[r3] pushal s_sts[r3] blbs @(sp),okay tstl s_eofmess[r3] beql 12$ cmpl #rms$_eof,@(sp) ;assume that rab$l_sts and fab$l_sts beql okay ;will always coincide. 12$: blbs wrtmes,do_mes cmpl #rms$_rtb,@(sp) beql okay do_mes: calls #1,errmes ;dump error mess. unless EOF. moval errlst,r1 eloop: cmpl rab$l_sts(r2),(r1)+ beql do_stv cmpl r1,#endlst beql okay brb eloop do_stv: pushal rab$l_stv(r2) calls #1,errmes okay: clrl s_eofmess[r3] ret ; ; ; wait: $wait rab=@l^rabtb(r2) rsb ; ; CALL D_LEN(lun) ; where lun is the iopack lun ; returns the number of bytes read in the last ; transfer. d_len:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait movzbl @4(ap),r1 movl s_len[r1],r0 ret ; ; ; ; IF(D_UNIT(lun))30,40,50 ; where 30 is the label for a successful operation ; 40 is the label for EOF, and ; 50 is the label for error return. ; A call to D_UNIT or D_LEN synchronizes the io by waiting ; for it to complete before returning. d_unit:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait movzbl @4(ap),r1 movl s_sts[r1],r0 blbs r0,minus cmpl #rms$_eof,r0 beqlu zero cmpl #rms$_rtb,r0 beqlu minus plus: movf #^f1.0,r0 ret zero: movf #^f0.0,r0 ret minus: movf #^f-1.0,r0 ret ; ; ; ; CALL D_GET(lun,buffer,len) ; reads the next record from disk into BUFFER ; The maximum number of bytes in the transfer will ; be len. Note that D_GET is asynchronous. d_get:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait cmpw 0(ap),#3 ;better have 3 args beql goin jmp badarg goin: ; set up max record size and buffer address $rab_store rab=@l^rabtb(r2),ubf=@8(ap),usz=@12(ap) movzbl @4(ap),r1 movzbl #-1,s_eofmess[r1] $get rab=@l^rabtb(r2),err=error,suc=error moval @l^rabtb(r2),r1 bits_to_clear = rab$m_cco!rab$m_rne!rab$m_cvt!rab$m_pta!rab$m_pmt bicl2 #bits_to_clear,rab$l_rop(r1) ;clear read modifiers ret ; ; map into COMMON/IO_ERR/ ; .save .psect IO_ERR,pic,ovr,rel,gbl,shr,noexe,rd,wrt,long wrtmes: .long 1 .restore ; ; ; ; CALL D_PUT(lun,buffer,len) ; writes out the next record to iopack lun LUN ; using len bytes starting at buffer. Asynchronous. d_put:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait cmpw 0(ap),#3 ;better be 3 args beql goout jmp badarg goout: ; set up buffer address and record length $rab_store rab=@l^rabtb(r2),rbf=@8(ap),rsz=@12(ap) $put rab=@l^rabtb(r2),err=error,suc=error ret ; ; ; ; CALL D_MARK(lun,addr) ; stores the address (RFA) of the current record ; in addr. addr must be able to hold at least 6 bytes ; d_mark:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait moval @l^rabtb(r2),r1 movaw @8(ap),r0 movw rab$w_rfa(r1),(r0)+ movw rab$w_rfa+2(r1),(r0)+ movw rab$w_rfa+4(r1),(r0)+ ret ; ; ; ; CALL D_JUMP(lun,addr) ; moves the file position to the record whose ; address was stored previously in addr by a call ; to D_MARK d_jump:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait $rab_store rab=@l^rabtb(r2),rac= movaw @8(ap),r0 moval @l^rabtb(r2),r1 movw (r0)+,rab$w_rfa(r1) movw (r0)+,rab$w_rfa+2(r1) movw (r0)+,rab$w_rfa+4(r1) $find rab=@l^rabtb(r2),err=error,suc=error $rab_store rab=@l^rabtb(r2),rac= ret ; ; ; ; CALL D_NAME(lun,filename,len) ; ; where filename is a CHARACTER variable ; which will receive the full filespec of the ; currently open file,and LEN is the length ; of the filename d_name:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^namtb(r2),r1 ;r1 points to the NAM block in question movzbl nam$b_rsl(r1),r2 ;r2 holds the size of string moval @nam$l_rsa(r1),r1 ;r1 holds the address of the string moval @8(ap),r0 ;r0 holds descriptor movzwl r2,@12(ap) movc5 r2,(r1),#^a/ /,(r0),@4(r0) ret ; ; ; call D_FID(lun,buff) ; ; where lun is the usual iolun number ; and buff is the address of a 28 byte buffer. The first ; 16 bytes are loaded with the device name, ; the next 6 bytes are the FID, and the last ; 6 are the DID. This routine is primarily ; useful if you want to send a message to ; the symbiont. ; d_fid:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^namtb(r2),r6 ;r1 points to the NAM block in question movc5 #nam$c_dvi,nam$t_dvi(r6),#^a/ /,#16,@8(ap) movc3 #6,nam$w_fid(r6),(r3) movc3 #6,nam$w_did(r6),(r3) ret ; ; CALL D_RNAM(lun1,oldfile,lun2,newfile) ; ; where oldfile & newfile are the old and new ; filespecs for the rename operation. ; Note that both lun1 & lun2 must not be open. ; d_rnam:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @8(ap),r0 jsb filename pushl r2 ; save oldfab for further use later movzbl @12(ap),r2 ashl #2,r2,r2 moval @16(ap),r0 jsb filename movl (sp)+,r3 ; r3 is pointer to oldfab $rename oldfab=@l^fabtb(r3),newfab=@l^fabtb(r2),err=error,suc=error ret ; Return with status code. ; ; ; I = D_ERAS(IOLUN,FILENAME),where ; IOLUN is a currently closed IOLUN, & ; FILENAME is the name of a file to be deleted. ; exceptionally, we do allow wildcards in FILENAME ; d_eras:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @8(ap),r0 jsb filename $parse fab=@l^fabtb(r2),err=error,suc=error blbs r0,edloop jmp eret edloop: $search fab=@l^fabtb(r2),err=error,suc=error cmpl r0,#rms$_nmf ; have we exhausted wild-card processing ? bnequ 10$ jmp edone 10$: blbs r0,20$ jmp eret 20$: moval @l^fabtb(r2),r1 bisl2 #fab$m_nam,fab$l_fop(r1) ; specify NAM block processing $erase fab=@l^fabtb(r2),err=error,suc=error moval @l^fabtb(r2),r1 bicl2 #fab$m_nam,fab$l_fop(r1) ; specify NAM block processing blbc r0,eret moval @l^namtb(r2),r1 ; R1 points to namblock bitl #nam$m_wildcard,nam$l_fnb(r1) beqlu edone jmp edloop edone: movl #rms$_normal,r0 eret: ret d_delt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^fabtb(r2),r1 bisl2 #fab$m_dlt,fab$l_fop(r1) ; specify delete on close ret d_sbmt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^fabtb(r2),r1 bisl2 #fab$m_scf,fab$l_fop(r1) ; specify delete on close ret d_spool:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^fabtb(r2),r1 bisl2 #fab$m_spl,fab$l_fop(r1) ; specify delete on close ret d_cco:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^rabtb(r2),r1 bisl2 #rab$m_cco,rab$l_rop(r1) ; specify cancel ^O on next read ret d_rne:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^rabtb(r2),r1 bisl2 #rab$m_rne,rab$l_rop(r1) ; specify read no echo on next read ret d_cvt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^rabtb(r2),r1 bisl2 #rab$m_cvt,rab$l_rop(r1) ; specify CUPPER on next read ret d_pta:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^rabtb(r2),r1 bisl2 #rab$m_pta,rab$l_rop(r1) ; specify purge type ahead buffer ret d_pmt:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 moval @l^rabtb(r2),r1 bisl2 #rab$m_pmt,rab$l_rop(r1) ; specify prompt on next read moval @8(ap),r0 ; R0 points to descriptor movzbl 0(r0),r3 movb 0(r0),rab$b_psz(r1) ; set prompt string size ; moval @4(r0),rab$l_pbf(r1) ; set prompt string address moval @l^prmtb(r2),rab$l_pbf(r1) ; set prompt string address movc5 r3,@4(r0),#^a/ /,#256,@l^prmtb(r2) ; store prompt ret d_trunc:: .word ^m movzbl @4(ap),r2 ashl #2,r2,r2 jsb wait $truncate rab=@l^rabtb(r2),err=error,suc=error ret .end