.title k11rms rms i/o for KERMIT-11 .ident /8.0.02/ ; Brian Nelson 30-Nov-83 09:53:49 ; ; Copyright (C) 1983 Change Software, Inc. ; ; Edited by: ; RBD01 - Bob Denny 03-Mar-84 See K11CMD for edit trails ; ; ; ******************************************************* ; * NOTES REGARDING DECnet (DAP) REMOTE FILE SUPPORT) * ; ******************************************************* ; ; The code here contains some magic for DECnet (DAP) remote file ; access. I have not been able to find documentation on the DAP ; support that is present in RMS-11 (V2). My current understanding ; of this, through experimentation, is as follows: ; ; 1. $PARSE fails with RMS status ER$UIN when given a file ; specification containing a node name, but seems to ; merge the input string and defaults into the expanded ; string buffer anyway. It also sets the file specification ; mask. I have assumed that the ER$UIN error is encountered ; in $PARSE after the merging of the default and input ; filespec information, and reflects the "fact" that RMS-11 ; (V2) DOES NOT SUPPORT WILDCARDING ON REMOTE FILE ACCESS. ; ; 2. Therefore, lookup() has been modified to return the ; expanded string if its second calling parameter (index) ; is zero (1st call) and there is either a node name or a ; quoted literal in the spec, no wildcards and the error ; is ER$UIN. ; ; 3. fparse() has been modified to accept if the error is ER$UIN, ; and if there are no wildcards and there is a node name present. ; The FB$FID bit is cleared, however, so that the original ; file spec string and the defaults will be used by $OPEN. ; ; 4. The "SY:" defaulting is not necessary, and in fact causes ; remote accesses to fail on VMS systems, where "SY:" has ; no conventional meaning. ; ; 5. The other routines which use $parse have been similarly ; modified to use the expanded string once only. ; ; 6. Finally, the NAMCVT routine in K11M41 was changed to handle ; quoted sections in strings and node names. This was the ; hardest part of the DAP adaptation. ; ; I have to believe that $parse and friends act this way because remote ; wildcarding got "left out" at the last minute because of scheduling ; problems in the RMS group. The code I have added here should permit ; remote wildcarding when it is turned on by the RMS folks. ; ; Bob Denny 03-Mar-84 ; ; ; ; Please note that RSTS rms11 requires a real default device. I thus ; have to put my origional default for SY: back in for RSTS only. We ; will determine this at tkb time by defining a global called FU$DEF ; to be <> 0 in K11E80.MAC and = 0 in K11M41.MAC. ; ; ; Brian Nelson 16-Mar-84 17:34:19 ; define macros and things we want for KERMIT-11 .include /IN:K11MAC.MAC/ .iif ndf, k11inc, .error ; INCLUDE for IN:K11MAC.MAC failed ; This is K11RMS.MAC, the RMS11 version 2 i/o interface for ; Kermit on RSTS version 8, RSX11M+ v2.1 and RSX11M v4.1. It ; is, without a doubt, the worst part of Kermit due RMS11, ; but it's strong points are future uses and the RSX / RSTS ; transportability. An example of "future uses" is DECnet ; remote file access (DAP) support now present. ; ; ; open ( %loc filename, %val channel_number ,%val type ) ; create( %loc filename, %val channel_number ,%val type ) ; getrec( %loc buffer , %val channel_number ) { returns RSZ in R1} ; putrec( %loc buffer , %val record_size ,%val channel_number ) ; close ( %val channel_number ) ; putc ( %val char , %val channel_number ) ; getc ( %val channel_number ) cr = 15 lf = 12 ff = 14 soh = 1 maxsiz = 160. ; ; This isn't defined globally. (??) ; nb$nod = 400 ; Node in file or default string (FNB in NAM) .enabl gbl .psect $code ,ro,i,lcl,rel,con .psect rmssup ,rw,d,lcl,rel,con .mcall fabof$ .mcall rabof$ .mcall xabof$ fabof$ RMS$L rabof$ RMS$L xabof$ RMS$L .mcall fab$b ,fab$e ,rab$b ,rab$e .mcall xab$b ,xab$e .mcall nam$b ,nam$e .mcall $initif ,org$ .mcall pool$b ,pool$e ,p$bdb ,p$fab .mcall p$rabx ,p$idx ,p$buf .mcall $compar ,$fetch ,$store ,$rewin .mcall $close ,$creat ,$erase ,$open .mcall $connec ,$delet ,$discon,$find .mcall $get ,$put ,$updat ,$flush .mcall $set ,$off ,$testbits .mcall $read ,$write org$ SEQ, .if ne ,0 ; Decide whether or not to use .ift ; dynamic space allocation by ; task extension or to use rmsbuf: pool$b ; static pools p$rab 5 ; plenty of record streams p$bdb 5 ; same goes for block buffers p$fab 4 ; up to 3 fabs (needed for search) p$buf 2048. ; for 2 files and directory i/o pool$e ; end of static pool .iff ; use task extension for space ; routine modifed from GSA example .mcall gsa$ ; from RMS v2.0 distribution. gsa$ gsa ; set our GSA address .globl gsa ; it may be global .endc ; to decide on pool allocation .sbttl rms file access blocks facc = fb$get ! fb$put fab1: fab$b f$alq 0 ; initial allocation of 10 blocks f$fac facc ; allowed i/o operations f$fna nam1 ; name of the file f$fns 0 ; length of the filename f$fop fb$sup ; supercede old versions f$lch lun1 ; channel number to use f$mrs maxsiz ; maximum recordsize f$org fb$seq ; seq f$rat fb$cr ; implied carriage control f$rfm fb$var ; variable length records fab$e fab1en: fab2: fab$b f$alq 0 ; initial allocation of 10 blocks f$fac facc ; allowed i/o operations f$fna nam2 ; name of the file f$fns 0 ; length of the filename f$fop fb$sup ; supercede old versions f$lch lun2 ; channel number to use f$mrs maxsiz ; maximum recordsize f$org fb$seq ; seq f$rat fb$cr ; implied carriage control f$rfm fb$var ; variable length records fab$e fab2en: fab3: fab$b f$alq 0 ; initial allocation of 10 blocks f$fac facc ; allowed i/o operations f$fna nam3 ; name of the file f$fns 0 ; length of the filename f$fop fb$sup ; supercede old versions f$lch lun3 ; channel number to use f$mrs maxsiz ; maximum recordsize f$org fb$seq ; seq f$rat fb$cr ; implied carriage control f$rfm fb$var ; variable length records fab$e fab3en: fab4: fab$b f$alq 0 ; initial allocation of 10 blocks f$fac facc ; allowed i/o operations f$fna nam4 ; name of the file f$fns 0 ; length of the filename f$fop fb$sup ; supercede old versions f$lch lun4 ; channel number to use f$mrs maxsiz ; maximum recordsize f$org fb$seq ; seq f$rat fb$cr ; implied carriage control f$rfm fb$var ; variable length records fab$e sydisk::.ascii /SY:/ sylen == . - sydisk .even sydska == sydisk sydskl == sylen ; ;RBD01-- ; pointers to buffer and fabs ; ; While none of this is really needed since all this info is ; available in the FAB and RAB, I find it cleaner to do it ; this way and thus avoid having to look at the RMS control ; structures. fablst::.word 0 ,fab1 ,fab2 ,fab3 ,fab4 namlst::.word 0 ,nam1 ,nam2 ,nam3 ,nam4 namlen::.word 0 ,0 ,0 ,0 ,0 rablst::.word 0 ,rab1 ,rab2 ,rab3 ,rab4 buflst: .word ttbuf ,buf1 ,buf2 ,buf3 ,buf4 bufdef: .word ttbuf ,buf1 ,buf2 ,buf3 ,buf4 bufsiz: .word ttbsiz ,maxsiz ,maxsiz ,maxsiz ,maxsiz bigbuf: .word bufx ,bufx ,bufx ,bufx ,bufx filtyp: .word terminal,text ,text ,text ,text bufp: .word 0 ,0 ,0 ,0 ,0 bufs: .word 0 ,0 ,0 ,0 ,0 mode: .word 1 ,0 ,0 ,0 ,0 blknum: .word 0 ,0 ,0 ,0 ,0 itsopen:.word 0 ,0 ,0 ,0 ,0 ; this sets the default for creating text files df$rat::.word fb$cr df$rfm::.word fb$var namln1 = namlen+2 namln2 = namlen+4 namln3 = namlen+6 namln4 = namlen+10 nam1: .rept 100 .byte 0 .endr nam2: .rept 100 .byte 0 .endr nam3: .rept 100 .byte 0 .endr nam4: .rept 100 .byte 0 .endr ttbsiz = 40 ttbuf: .blkb ttbsiz+2 buf1: .blkb maxsiz+2 ; record buffer for GETC channel 1 buf2: .blkb maxsiz+2 ; record buffer for GETC channel 2 buf3: .blkb maxsiz+2 ; record buffer for GETC channel 3 buf4: .blkb maxsiz+2 ; record buffer for GETC channel 4 bufx: .blkb 1002 ; one large buffer to share lun1 = 1 lun2 = 2 lun3 = 3 lun4 = 4 maxlun = lun4 .sbttl rms record access blocks rab1: rab$b ; define record access block r$fab fab1 ; associate a fab with this rab r$rac rb$seq ; access by keys r$rbf buf1 ; where to return the data r$ubf buf1 ; where to return the data r$usz maxsiz ; size of myrec (maximum size) rab$e ; end of record access block rab2: rab$b ; define record access block r$fab fab2 ; associate a fab with this rab r$rac rb$seq ; access by keys r$rbf buf2 ; where to return the data r$ubf buf2 ; where to return the data r$usz maxsiz ; size of myrec (maximum size) rab$e ; end of record access block rab3: rab$b ; define record access block r$fab fab3 ; associate a fab with this rab r$rac rb$seq ; access by keys r$rbf buf3 ; where to return the data r$ubf buf3 ; where to return the data r$usz maxsiz ; size of myrec (maximum size) rab$e ; end of record access block rab4: rab$b ; define record access block r$fab fab4 ; associate a fab with this rab r$rac rb$seq ; access by keys r$rbf buf4 ; where to return the data r$ubf buf4 ; where to return the data r$usz maxsiz ; size of myrec (maximum size) rab$e ; end of record access block proxab: xab$b XB$PRO ; file protection xab x$nxt 0 ; no more links x$pro 60. ; normal protection of <60> xab$e ; end of file protection xab .psect .psect $code .sbttl create sequential file .psect $code .even ; F C R E A T E and FOPEN ; ; fcreate( %loc filename; %val channel_number, %val type ,%val mb_count) ; fopen ( %loc filename; %val channel_number, %val type ,%val mb_count) ; ; input: @r5 filename address ; 2(r5) channel number ; 4(r5) val 'binary' or 'text' or 0 ; 6(r5) RMS multiblock count for the stream ; ; output: r0 rms error code ; ; Create a variable length sequential implied carriage control ; disk file. If 'type' is 'binary' then use read/write access ; to write a fixed 512 byte image file. If channel number is ; zero (0), then initialize buffer single character terminal ; output. It is always assumed that channel '0' implies writes ; to the attached console terminal. .enabl lsb open:: calls fopen ,<@r5,2(r5),4(r5),#0> return create::calls fcreate ,<@r5,2(r5),4(r5),#0> return fopen:: save ; save registers clr -(sp) ; flag for open not create br 5$ ; and try to do it fcreat::save ; save registers mov #-1 ,-(sp) ; flag for create 5$: $initif ; initialize rms i/o system if needed mov 2(r5) ,r0 ; get channel number please bne 10$ ; not channel zero, do it normally mov sp ,itsopen+0 ; flag it as having been initted mov sp ,mode+0 ; psuedo writing to the terminal clr bufp+0 ; initialize the terminal's buffer br 120$ ; pointer and exit 10$: asl r0 ; times 2 mov r0 ,r2 ; save it please mov namlst(r2),r1 ; get address of name block calls fparse ,<@r5,r1> ; parse and fill in defaults tst r0 ; did the parse succeed ? bne 120$ ; no, exit with RMS error in r0 strlen r1 ; get the expanded filename length mov r0 ,namlen(r2) ; and save the length mov r2 ,r0 ; get r0 back again please mov fablst(r0),r1 ; get the file access block mov @sp ,r2 ; also pass create/open flag call settyp ; setup the FAB now mov r0 ,r2 ; save the channel number*2 tst @sp ; create or open bne 30$ ; if ne then create $open r1 ; if eq then open existing file mov #-1 ,bufp(r2) ; init for buffer needing a read clr mode(r2) ; no writing please br 40$ ; check RMS status out now 30$: $creat r1 ; try hard to create the file mov sp ,mode(r2) ; open for writing clr bufp(r2) ; clear single character i/o pointer 40$: $fetch r0,sts,r1 ; get status back out please tst r0 ; if status > 0 then status = 0 bmi 120$ ; error if less than zero mov 2(r5) ,r0 ; connect access up now asl r0 ; flag also that we are open mov sp ,itsopen(r0) ; simple asr r0 ; restore r0 now mov 6(r5) ,r1 ; and the multiblock count also call rmscon ; connect record stream up tst r0 ; if error > 0 then error = 0 bmi 120$ ; yep clr r0 ; error = 0 120$: tst (sp)+ ; pop open/create flag unsave ; pop registers we saved return ; and exit .dsabl lsb .sbttl setup things for open/create in the FAB ; S E T T Y P ; ; input: r0 channel number times 2 ; r2 <> 0 implies create ; r5 --> open/create parameter list ; fbrw = fb$rea ! fb$wri settyp::mov fablst(r0),r1 clr blknum(r0) ; in case of read/write mode mov #maxsiz ,bufsiz(r0) ; default for the buffer size mov #text ,filtyp(r0) ; assume ascii text files for now mov bufdef(r0),buflst(r0) ; set a default record buffer also clr bufs(r0) ; clear single character i/o recsiz $store namlen(r0),FNS,r1 $store #fb$seq,ORG,r1 ; insure sequential by default $store df$rat ,RAT,r1 ; implied carriage control $store df$rfm ,RFM,r1 ; and also variable length records $store #fb$get,FAC,r1 ; insure readonly please tst fu$def ; do we require a default device beq 1$ ; no $store #sydisk,DNA,r1 ; yes, stuff the correct def dev in $store #sylen ,DNS,r1 ; and the length of it also please 1$: tst r2 ; but are we creating the file beq 5$ ; no $store #fb$put,FAC,r1 ; yes, say we want seq puts 5$: cmp 4(r5) ,#binary ; is this a binary file ? bne 100$ ; no, just exit mov #1000 ,bufsiz(r0) ; yes, fix it up for that mov bigbuf(r0),buflst(r0) ; setup a large i/o buffer please mov #binary ,filtyp(r0) ; please $store #0 ,RAT,r1 ; no cr/lf implied please $store #fb$fix ,RFM,r1 ; fixed length also $store #fb$rea ,FAC,r1 ; assume read only please tst r2 ; readonly ? beq 6$ ; yes $store #fbrw ,FAC,r1 ; read/write mode needed ? 6$: save ; zero out the big buffer .if le r$$rms-1 ; If on RMS version 1 ... mov rablst(r0),r2 ; Get the RAB for this file mov #1 ,o$bkt+0(r2) ; Set the bucket (VBN) to 1. clr o$bkt+2(r2) ; ... .endc ;r$$rms-1 mov buflst(r0),r2 ; get the buffer address mov #1000 ,r3 ; 1000 (8) bytes please 10$: clrb (r2)+ ; simple sob r3 ,10$ ; next please unsave ; pop registers we just used 100$: $store bufsiz(r0),MRS,r1 ; stuff max recordsize in please return global .sbttl close a file close:: save ; save registers we may have mov @r5 ,r0 ; get the lun asl r0 ; times 2 tst itsopen(r0) ; check for lun being open beq 90$ ; no, skip all this then clr itsopen(r0) ; not anymore please call flush ; dump out any remaining buffer mov @r5 ,r0 ; then disconnect the access stream beq 100$ ; terminal asl r0 ; channel number times 2 tst mode(r0) ; writing to it today? beq 10$ ; no calls atrfin ,<@r5> ; yes, perhaps do attribute things 10$: mov @r5 ,r0 ; then disconnect the access stream call rmsdis ; by doing a $disconnect mov @r5 ,r1 ; get the FAB for the file open on asl r1 ; the passed channel mov fablst(r1),r1 ; $close r1 ; try hard to close the file $fetch r0,sts,r1 ; get status back out please tst r0 ; if status > 0 then status = 0 blt 100$ ; error if less than zero 90$: clr r0 ; make > 0 status eq 0 100$: unsave return rewind::mov @r5 ,r0 beq 100$ asl r0 mov rablst(r0),r0 $rewind r0 100$: clr r0 return .sbttl try to determine if a file needs binary xfer mode ; B I N F I L ; ; input: @r5 address of the filename ; 2(r5) lun ; output: r0 < 0 then RMS error ; r0 > 0 then the file is most likely binary binfil::save ; save registers we may use clr r4 ; nothing is open as of yet calls chkext ,<@r5> ; check file based on filetype tst r0 ; assume a binary file ? bne 100$ ; yep mov 2(r5) ,r2 ; get the lun asl r2 ; times 2 mov fablst(r2),r2 ; get the fab address now $fetch r3,XAB,r2 ; save the xab link address call getuic ; for RSTS, skip the protection XAB swab r0 ; if the user is not privledged cmpb r0 ,#1 ; since RMS uses the UU.LOK directive bne 5$ ; which may be patched to fail. $store #proxab,XAB,r2 ; and stuff our own into it 5$: calls open ,<@r5,2(r5),#binary> tst r0 ; did the open work bmi 90$ ; no mov sp ,r4 ; flag that it's open call getsys ; if this is RSTS then a protection cmpb r0 ,#sy$rsts ; bit of 100 being set indicates an bne 10$ ; executable file mov #proxab ,r1 ; get the xab for the protection code $testbit #100,PRO,r1 ; if set, then it's executable bne 40$ ; assume it's binary 10$: $testbit #,ORG,r2; indexed or relative file ? bne 40$ ; yes, it must be sent as a binary file $compare #fb$stm,RFM,r2 ; stream ascii file ? beq 30$ ; yes, assume not binary then $testbit #fb$cr,RAT,r2 ; implied carriage control ? bne 30$ ; yes, assume not 8 bit then br 40$ ; anything else is binary please 30$: clr -(sp) ; flag as most likely being ascii br 50$ ; bye 40$: mov #1 ,-(sp) ; flag as being binary and exit 50$: tst r4 ; ever opened up ? beq 60$ ; no calls close ,<2(r5)> ; close up 60$: mov (sp)+ ,r0 90$: $store r3,XAB,r2 ; restore old xab links, if any 100$: unsave ; bye return .sbttl getatr return attributes for a file already open .mcall ifaof$ ; access the ifab for the fab ifaof$ rms$l ; get the ifab symbols defined getsiz::mov @r5 ,r1 ; return error in r0, size in r1 asl r1 ; lun times 2 mov fablst(r1),r1 ; fab for this file mov (r1),r1 ; get the size please clr r0 ; no errors return ; exit getatr::save ; save these please mov @r5 ,r1 ; the channel number please asl r1 ; times two please mov fablst(r1),r1 ; simple mov o$ifi(r1),r1 ; and now we are at the ifab mov 2(r5) ,r2 ; where to copy the attributes to movb f$ratt(r1),(r2)+ ; stuff the input record attributes movb f$forg(r1),(r2)+ ; also stuff the input file org in mov f$rsiz(r1),(r2)+ ; and the input record size please mov f$hvbn(r1),(r2)+ ; and the input eof markers mov f$lvbn(r1),(r2)+ ; like hi and low virtual block mov f$heof(r1),(r2)+ ; and the high and low eof block mov f$leof(r1),(r2)+ ; numbers also mov f$ffby(r1),(r2)+ ; and, at last, the first free byte movb f$hdsz(r1),(r2)+ ; VFC header size next movb f$bksz(r1),(r2)+ ; and largest bucket size mov f$mrs(r1) ,(r2)+ ; the maximum record size mov f$deq(r1) ,(r2)+ ; and the default extenstion size mov f$rtde(r1),(r2)+ ; and the run time extentsion size 100$: unsave ; all done clr r0 ; say it worked ok return putatr::save ; save these please mov @r5 ,r1 ; the channel number please asl r1 ; times two please mov fablst(r1),r1 ; simple mov o$ifi(r1),r1 ; and now we are at the ifab mov 2(r5) ,r2 ; where to get the attributes from movb (r2)+ ,f$ratt(r1) ; stuff the input record attributes movb (r2)+ ,f$forg(r1) ; also stuff the input file org in mov (r2)+ ,f$rsiz(r1) ; and the input record size please mov (r2)+ ,f$hvbn(r1) ; and the input eof markers mov (r2)+ ,f$lvbn(r1) ; like hi and low virtual block mov (r2)+ ,f$heof(r1) ; and the high and low eof block mov (r2)+ ,f$leof(r1) ; numbers also mov (r2)+ ,f$ffby(r1) ; and, at last, the first free byte movb (r2)+ ,f$hdsz(r1) ; VFC header size next movb (r2)+ ,f$bksz(r1) ; and largest bucket size mov (r2)+ ,f$mrs(r1) ; the maximum record size mov (r2)+ ,f$deq(r1) ; and the default extenstion size mov (r2)+ ,f$rtde(r1) ; and the run time extentsion size 100$: unsave ; all done clr r0 ; say it worked ok return .sbttl connect record access block to file access block ; C O N N E C T ; ; connect( %val channel_number ) ; ; input: r0 channel number ; r1 multiblock count ; output: r0 rms sts ; ; Connect a record access block to a file access block. ; Called only from OPEN and CREATE rmscon: mov r1 ,-(sp) ; the block count size mov r0 ,r1 ; get address of record access block asl r1 ; channel number times 2 mov rablst(r1),r1 ; address of a rab to use movb (sp)+ ,o$mbc(r1) ; the block buffer count $conne r1 ; try hard to connect access up $fetch r0,sts,r1 ; get status back out please tst r0 ; if status > 0 then status = 0 blt 10$ ; error if less than zero clr r0 ; make > 0 status eq 0 10$: return .sbttl disconnect record access block from file access block ; R M S D I S ; ; input: r0 channel number ; r0 error sts ; rmsdis: mov r0 ,r1 asl r1 mov rablst(r1),r1 $discon r1 ; disconnect access stream from file $fetch r0,sts,r1 ; get status back out please tst r0 ; if status > 0 then status = 0 blt 10$ ; error if less than zero clr r0 ; make > 0 status eq 0 10$: return .sbttl read a record from a sequential file ; G E T R E C ; ; getrec( %loc buffer, %val channel_number ) ; ; input: @r5 address of user buffer, at least 80 bytes ; 2(r5) channel number ; ; output: r0 rms sts ; r1 record size ; ; Read the next record from a disk file. Assumes that the ; user has supplied a buffer of 80 characters to return ; the record to. getrec::mov 2(r5) ,r0 ; get the channel number asl r0 ; times 2 to index into table mov rablst(r0),r1 ; get the record access buffer $store #0 ,RSZ,r1 $store @r5 ,UBF,r1 ; stuff a record buffer in $store bufsiz(r0),USZ,r1 ; and a maximum record size cmp filtyp(r0),#binary ; a binary file today ? bne 10$ ; no, use normal get$ .if gt r$$rms-1 ; If on RMS-11 version 2 ... clr o$bkt+0(r1) ; use sequential mode please clr o$bkt+2(r1) ; both words are to have zero .endc ;r$$rms-1 $read r1 ; get next virtual block please .if gt r$$rms-1 ; If on RMS-11 version 2 ... br 20$ ; Get error code out now .iff ;r$$rms-1 ; If on RMS-11 version 1 ... $fetch r0,STS,r1 ; Get error code out cmp r0,#ER$EOF ; An end-of-file? bne 20$ ; J if not. $fetch r0,RSZ,r1 ; Get record size tst r0 ; Anything transferred? beq 20$ ; J if not - real EOF ash #-11,r0 ; Convert to block number add r0,o$bkt+0(r1) ; Add in to the vbn to read next adc o$bkt+2(r1) ; ... mov #SU$SUC,r0 ; Show (fake) success br 30$ ; And join common code. .endc ;r$$rms-1 ; 10$: $get r1 ; read a record now 20$: $fetch r0,STS,r1 ; get the return STATUS field 30$: tst r0 ; did it work ? blt 100$ ; no clr r0 ; say no errors $fetch r1,RSZ,r1 ; get the record size now 100$: return global .sbttl put a record to an rms sequential file ; P U T R E C ; ; putrec( %loc buffer, %val record_size, %val channel_number ) ; ; input: @r5 address of user buffer ; 2(r5) record size ; 4(r5) channel number ; ; output: r0 rms sts ; ; Write the next record to a disk file. putrec::mov r1 ,-(sp) mov 4(r5) ,r0 ; get the channel number bne 5$ ; if zero then assume TI: print @r5 ,2(r5) ; dump the buffer to ti: then br 100$ ; and exit 5$: asl r0 ; times 2 to index into table mov rablst(r0),r1 ; get the record access buffer $store @r5 ,RBF,r1 ; stuff a record buffer in $store 2(r5),RSZ,r1 ; and a current record size cmp filtyp(r0),#binary ; image mode today ? bne 10$ ; no $store #1000,RSZ,r1 ; yes, insure block write .if gt r$$rms-1 ; If on RMS-11 version 2 ... clr o$bkt+0(r1) ; yes, clear the VBN fields clr o$bkt+2(r1) ; yes, clear the VBN fields .endc ;r$$rms-1 $write r1 ; simple .if le r$$rms-1 ; If on RMS-11 version 1 ... add #1,o$bkt+0(r1) ; Increment the VBN field adc o$bkt+2(r1) ; ... .endc ;r$$rms-1 br 20$ ; get the status and exit 10$: $put r1 ; read a record now 20$: $fetch r0,STS,r1 ; get the return STATUS field tst r0 ; did it work ? blt 100$ ; no clr r0 ; say no errors 100$: mov (sp)+ ,r1 return .sbttl getc get one character from an input file ; G E T C ; ; getc(%val channel_number) ; ; input: @r5 channel_number ; output: r0 rms error status ; r1 the character just read getc:: mov @r5 ,r0 call getcr0 return getcr0::save ; save temps mov r0 ,r2 ; channel number please asl r2 ; times 2 cmp bufp(r2),#-1 ; need to initialize the buffer? bne 10$ ; no calls getrec ,; yes, load it please tst r0 ; did the read work ? bne 100$ ; no, return rms error code clr bufp(r2) ; it worked. clear current pointer mov r1 ,bufs(r2) ; and save the record size br 30$ ; and goto common code 10$: cmp bufp(r2),#-2 ; flag to return ? bne 20$ ; no movb #cr ,r1 ; yes, return it in r1 mov #-3 ,bufp(r2) ; and setup for a nexttime clr r0 ; no error br 100$ ; bye 20$: cmp bufp(r2),#-3 ; flag to return a ? bne 30$ ; no movb #lf ,r1 ; yes, return in r1 mov #-1 ,bufp(r2) ; flag buffer reload next time clr r0 ; no error br 100$ 30$: tst bufs(r2) ; anything left to get in record? bne 40$ ; yes mov #-2 ,bufp(r2) ; no, flag for a next cmp filtyp(r2),#binary ; a binary file today ? bne 35$ ; yes, need data as is please mov #-1 ,bufp(r2) ; yes, flag for a read next 35$: mov r2 ,r0 ; channel number please asr r0 ; NOT times two call getcr0 ; call ourselves to do it br 100$ ; and exit 40$: mov buflst(r2),r3 ; get the address of the buffer add bufp(r2),r3 ; and point to the next character clr r1 ; to be returned in r1 bisb @r3 ,r1 ; simple inc bufp(r2) ; buffer.pointer := succ(buffer.pointer) dec bufs(r2) ; amountleft := pred( amountleft ) clr r0 ; no errors please 100$: unsave return .sbttl putc put a single character to an rms file ; P U T C ; ; input: @r5 the character to put ; 2(r5) the channel number to use ; ; Buffer single character i/o to internal disk buffer. ; Buffer is dumped if internal buffer is full or, for ; FB$VAR records (default for TEXT), a carraige return ; is found. For FB$VAR with FB$CR format, all carraige ; returns and line feeds are flushed as this record ; format will have them put back later. ; The local buffers are allocated in CREATE and OPEN. putc:: save ; simply save r1 and call putcr0 mov 2(r5) ,r1 ; to do it. putcr0 will be somewhat clr r0 ; faster to call directly due to the bisb @r5 ,r0 ; overhead involved in setting up an call putcr0 ; argument list. unsave ; pop saved r1 and exit return ; bye putcr0::save ; save registers we use mov r1 ,r2 ; channel number asl r2 ; times 2 of course cmp filtyp(r2),#binary ; is this a binary file today ? beq 5$ ; yes, don't dump buffer on cmpb r0 ,#cr ; end of line time today ? beq 10$ ; yes, dump the record out 5$: cmp bufp(r2),bufsiz(r2) ; is the buffer full ? blo 20$ ; no, store some more characters in it 10$: movb r0 ,r3 ; yes, save the input character r0 calls putrec , ; yes, dump the buffer please clr bufp(r2) ; pointer := 0 tst r0 ; did it work ? bne 100$ ; no, die mov buflst(r2),r4 ; it worked. zero the buffer now mov bufsiz(r2),r0 ; get the buffer address and size 15$: clrb (r4)+ ; for i := 1 to bufsiz sob r0 ,15$ ; do buffer[i] := chr(0) movb r3 ,r0 ; ok, restore the old character 20$: cmp filtyp(r2),#binary ; once again, is this a binary file ? beq 30$ ; yes, ignore checks for and ^Z. cmp filtyp(r2),#terminal ; terminal file today ? beq 30$ ; yes, we want cr's and lf's cmpb r0 ,#lf ; we simply like to ignore line feeds beq 90$ ; bye cmpb r0 ,#'Z&37 ; control Z ? beq 90$ ; yes, ignore the control Z's please cmpb r0 ,#cr ; carraige return today ? beq 90$ ; yes, ignore it 30$: mov bufp(r2),r1 ; get the current buffer pointer add buflst(r2),r1 ; and point to a new home for the movb r0 ,@r1 ; the input character in r0 inc bufp(r2) ; pointer := succ( pointer ) 90$: clr r0 ; no errors 100$: unsave return .sbttl flush flush: mov @r5 ,r0 ; get the internal channel number asl r0 ; times 2 for indexing tst bufp(r0) ; anything in the buffer beq 100$ ; no tst mode(r0) ; writing today ? beq 100$ ; no calls putrec , ; yes, dump it return 100$: clr r0 return .sbttl lookup do a filename lookup, wildcarding supported .enabl gbl ; L O O K U P ; ; input: @r5 arg count (DEC standard Fortran convention) ; 2(r5) address of input string ; @4(r5) flag word for initializing with a $PARSE ; 6(r5) address of output string ; ; output: r0 RMS error code ; ; ; clr index ;10$: calls lookup ,<#3,#inbuf,#index,#outbuf> ; tst r0 ; bne 100$ ; do something ; br 10$ .if gt r$$rms-1 ; If on RMS version 2 ... .mcall $parse ,$search .endc ;r$$rms-1 .mcall $fetch ,$compare .mcall fab$b ,fab$e ,nam$b ,nam$e .mcall $off $testbits ;RBD01 .psect $idata fab: fab$b ; argument fab f$nam nam ; link to nam ;RBD01-- f$lch 1 ; a dummy channel for the i/o op fab$e nam: nam$b ; nam definition n$esa expstr ; exp str address n$ess 64. ; exp str length n$rsa resstr ; res str address n$rss 64. ; res str length nam$e expstr: .blkb 64. ; context must be preserved here resstr: .blkb 64. ; a temp place for the result .psect ; no more r/w data .sbttl the real work of lookup .psect $pdata ; Make this <> 0 if you can't do CALFIP fu$dir::.word 0 ; style wildcarding on your non-standard ; RSTS system. Could cause side effects ; with remote decnet nodes. .psect $code lookup::save .if le r$$rms-1 ; If on RMS version 1 ... .if gt r$$fcs ; And using FCS wild cards ... sub #80.,sp ; Allocate buffer area on stack. .endc ;r$$fcs-1 .endc ;r$$rms-1 mov #fab ,r1 ; map the target fab ;RBD01-- tst fu$def ; do we really need a default device? beq 1$ ; no $store #sydisk,DNA,r1 ; yes, please stuff the def device name $store #sylen ,DNS,r1 ; and the length of it also please 1$: strlen #defdir ; anything in the Kermit default dir? tst r0 ; if <> then use it beq 10$ ; nothing there to use. Let system do it $store #defdir ,DNA,r1 ; something was there, stuff it in $store r0 ,DNS,r1 ; and the length of the default 10$: mov r1 ,r0 ; save it for later mov #nam ,r3 ; map the target nam tst @4(r5) ; first time thru needs a parse bne 40$ ; not the first time clrb expstr ; clear the expanded name and clrb resstr ; the resultant string mov 2(r5) ,r4 ; point to the filename passed mov r4 ,r1 ; and save the pointer 20$: tstb (r1)+ ; and get the length of the name bne 20$ ; for an .asciz string sub r4 ,r1 ; compute the length of the string dec r1 ; which is off by one $store #lun.sr,lch,r0 ; channel number please $store r1,fns,r0 ; stuff the filename length $store r4,fna,r0 ; and the filename address .if gt r$$rms-1 ; If on RMS version 2 ... $parse r0 ; parse the strings $fetch r4,sts,r0 ; get error codes cmp #ER$UIN,r4 ; Maybe a remote file spec? ;RBD01+ bne 30$ ; (no) $testbits #,fnb,r3 ; Anything wild? bne 90$ ; (wild remote files no good) $testbits #nb$nod,fnb,r3 ; Remote file? beq 90$ ; (ER$UIN with no node???) $off #nb$wch,fnb,r3 ; Make succeeding $search's act nice $fetch r0,esl,r3 ; Pass back expanded string $fetch r2,esa,r3 ; and skip the $search. br 70$ ;RBD01- 30$: tst r4 ; < 0 ? bmi 90$ ; yes, error ; This added edit 2.12 by BDN for those RSTS systems that totally ; disallow directory lookups by modify the executive for non-priv ; users. 40$: tst fu$dir ; in case george w. @ purdue beq 50$ ; needs this due to a hacked up exec $testbits #,fnb,r3 ; Anything wild? bne 50$ ; yes, let the $search go on tst @4(r5) ; if no wildcarding and we have beq 45$ ; already been here then return mov #ER$NMF ,r4 ; no more files and exit br 90$ ; bye 45$: $fetch r0,esl,r3 ; no, skip the $search and get the $fetch r2,esa,r3 ; expanded string from $parse br 70$ ; and copy it over now ; End of option tp skip lookups for non-wildcarded filenames. 50$: $search r0 ; get a matching file $fetch r4,sts,r0 ; get error codes ; ;RBD01+ ; The following shouldn't have been necessary, as I ; banged off the NB$WCH bit above. But ... ; cmp r4,#ER$UIN ; Remote file hacking? bne 60$ ; (no) mov #ER$FNF,r4 ; Yes, no "more" files br 90$ ; and exit 60$: tst r4 ; < 0 ? ;RBD01- bmi 90$ ; yes, error $fetch r0,rsl,r3 ; get the string length $fetch r2,rsa,r3 ; get the string address ; .iff ;r$$rms-1 ; If on RMS version 1 ... .if gt r$$fcs ; If using wild cards with FCS ... mov sp,r2 ; Get the buffer area into r2. calls fndfir ,<#3,#lun.sr,r4,r2> ; Find the first file br 50$ ; And join common code. 40$: mov sp,r2 ; Point to the buffer. calls fndnxt ,<#3,#lun.sr,r4,r2> ; Find the next file 50$: mov r0,r4 ; Take result from fndnxt. bmi 90$ ; J if error of some kind. strlen r2 ; Get length of translated name. .iff ;r$$fcs ; If not using wild cards ... ; ignore the expansion. mov r4,r2 ; File string address in r2 mov r1,r0 ; File string length in r1 br 70$ ; Show good 40$: mov #ER$FNF ,r4 ; Second time through - no more files br 90$ ; And leave .endc ;r$$fcs ; .endc ;r$$rms-1 70$: mov 6(r5) ,r1 ; where to return the string 80$: .if gt r$$rms-1 ; If on RMS version 2 or above ... movb (r2)+ ,(r1)+ ; copy it over .iff ;r$$rms-1 ; If on RMS version 1 ... .if gt r$$fcs ; If using FCS wildcards ... 80$: movb (r2)+,(r1)+ ; Copy it over (already upper case) .iff ;r$$fcs ; If no wild cards ... movb (r2)+,r3 ; Get a character cmpb r3,#'A+40 ; Is it lower case? blo 85$ ; J if not cmpb r3,#'Z+40 ; Well? bhi 85$ ; J if not sub #40,r3 ; Convert to upper case of so 85$: movb r3,(r1)+ ; Dump in the output buffer .endc ;r$$fcs .endc ;r$$rms-1 sob r0 ,80$ ; for however the long it is clrb @r1 ; insure .asciz please clr r0 ; no errors inc @4(r5) ; say we have at least one file br 100$ ; and exit 90$: mov r4 ,r0 ; error, return it please br 100$ ; exit 100$: .if le r$$rms-1 ; If on RMS version 1 ... .if gt r$$fcs ; And doing wild cards ... add #80.,sp ; Free up buffer area. .endc ;r$$fcs .endc ;r$$rms-1 unsave return .sbttl rename ; R E N A M E ; ; input: @r5 old filename address ; 2(r5) new filename address ; 4(r5) flag, lt 0 don't print the results else print a log ; ; output: r0 error code, zero if at least one file found ; r1 number of files renamed .psect rendat ,rw,d,lcl,con,lcl .if gt r$$rms-1 ; If on RMS version 2 ... .mcall $parse ,$search,$rename .endc ;r$$rms-1 .mcall $compare,$fetch ,$set ,$store .mcall fab$b ,nam$b RNFAB1::FAB$B ; Old file name F$NAM RNNAM1 ; Link to RNNAM1 ;RBD01-- F$LCH 1 ; Channel 1 (a dummy, filled in later) FAB$E RNNAM1::NAM$B ; NAM definition NAM$E RNFAB2::FAB$B ; New file name F$NAM RNNAM2 ; Link to RNNAM2 ;RBD01-- F$LCH 1 ; a dummy channel FAB$E RNNAM2::NAM$B ; NAM definition NAM$E .sbttl the real work of rename .psect $code rename::save ; save temps please .if gt r$$rms-1 ; If on RMS versio 2 ... mov #rnfab1 ,r0 ; point to the old name FAB mov #rnfab2 ,r1 ; point to the new name FAB mov #rnnam1 ,r2 ; point to the old name's NAMEBLOCK mov #rnnam2 ,r3 ; point to the new name's NAMEBLOCK tst fu$def ; do we really need a default device? beq 1$ ; no $store #sydisk,DNA,r0 ; yes. Stuff the default system device $store #sylen ,DNS,r0 ; name and length to the source name and $store #sydisk,DNA,r1 ; then do the same for the new name. Put $store #sylen ,DNS,r1 ; the def device address and length in. 1$: mov r0 ,r4 ; save the FAB1 pointer now ;RBD01-- strlen #defdir ; anything in the Kermit default dir? tst r0 ; if <> then use it beq 5$ ; nothing there to use, use SY: $store #defdir ,DNA,r1 ; something was there, stuff it in $store r0 ,DNS,r1 ; and the length of the default $store #defdir ,DNA,r4 ; something was there, stuff it in $store r0 ,DNS,r4 ; and the length of the default 5$: mov r4 ,r0 ; restore FAB1 pointer now $store #lun.sr ,LCH,r0 ; stuff a logical unit number $store #lun.sr ,LCH,r1 ; stuff a logical unit number sub #100 ,sp ; allocate an ESA for old name $store sp ,ESA,r2 ; and stuff the address in $store #100,ESS,r2 ; and the length of it please sub #100 ,sp ; next is the resultant string $store sp ,RSA,r2 ; buffer for the old filename $store #100,RSS,r2 ; and the size of it please sub #100 ,sp ; the new filename buffer $store sp ,ESA,r3 ; stuff address of the buffer $store #100,ESS,r3 ; and the size of it please clr -(sp) ; a count of the files done so far mov #rnfab1 ,r1 ; point to the old name FAB mov #rnfab2 ,r2 ; point to the new name FAB strlen @r5 ; get the .asciz length of old $store @r5 ,FNA,r1 ; store the old filename address $store r0 ,FNS,r1 ; stuff the length of the old name mov #rnfab1 ,r0 ; point to the old name FAB $parse r0 ; parse the old name please $compar #0 ,STS,r0 ; did the parse work out ok ? blt 90$ ; no, exit strlen 2(r5) ; get the length of the new name $store 2(r5),FNA,r2 ; stuff the new name into FNS field $store r0 ,FNS,r2 ; and the size of it please 10$: mov #rnfab1 ,r0 ; point to the old name FAB mov #rnfab2 ,r1 ; point to the new name FAB mov #rnnam1 ,r2 ; point to the old name's NAMEBLOCK mov #rnnam2 ,r3 ; point to the new name's NAMEBLOCK $set #fb$fid,FOP,r0 ; set explicit search please $search r0 ; do a directory lookup please $compar #0 ,STS,r0 ; did the lookup work ? blt 90$ ; oops, it didn't work $fetch r4 ,RSA,r2 ; get the resultant address $store r4 ,DNA,r1 ; set this as default $fetch r4 ,RSL,r2 ; get the resultant length $store r4 ,DNS,r1 ; set the default length $rename r0,,,r1 ; rename input as output $compar #0 ,sts,r0 ; error? blt 90$ ; yes, exit please inc @sp ; no errors, count that file tst 4(r5) ; should we print the results ? bmi 10$ ; no call 200$ ; yes br 10$ ; go back for more please 90$: mov @sp ,r1 ; return # files renamed dec (sp)+ ; did we get any work done ? bge 100$ ; yes $fetch r0 ,STS,r0 ; no, get the error code cmp r0 ,#ER$NMF ; no files, was it NO MORE FILES ? bne 110$ ; no mov #ER$FNF ,r0 ; yes, change it to FILE NOT FOUND br 110$ ; and exit 100$: clr r0 ; success exit, no errors 110$: add #3*100 ,sp ; pop the buffers .iff ;r$$rms-1 ; If on RMS version 1 ... mov #ER$FNF ,r0 ; show FILE NOT FOUND (not right but ; we have to do something) .endc ;r$$rms-1 unsave ; pop registers now return 200$: print #300$ movb o$rsl(r2),r0 print o$rsa(r2),r0 print #310$ movb o$esl(r3),r0 print o$esa(r3),r0 print #320$ return .enabl lc 300$: .asciz /File / 310$: .asciz / renamed to / 320$: .byte cr,lf,0 .even .sbttl delete a file(s) ; input: @r5 address of filename spec ; 2(r5) if eq -1, don't print the results out ; 0, print on terminal ; >0, write to lun in 2(r5) ; ; output: r0 RMS error code ; r1 number of files renamed delfab = rnfab1 ; reuse the rename fab delnam = rnnam1 ; reuse the rename name block ; internal register usage ; ; r0 RMS error STS ; r1 pointer to the FAB for this operation ; r2 pointer to the NAM block for this operation ; r3 number of files deleted ; r5 pointer to the argument list delete::save ; save registers we may overwrite clr r3 ; files_deleted := 0 mov #delfab ,r1 ; point to the fab we use ;RBD01-- tst fu$def ; do we need a default device name? beq 1$ ; no $store #sydisk ,DNA,r1 ; yes, please stuff the correct defs $store #sylen ,DNS,r1 ; simple 1$: strlen #defdir ; anything in the Kermit default dir? tst r0 ; if <> then use it beq 5$ ; nothing there to use, use SY: $store #defdir ,DNA,r1 ; something was there, stuff it in $store r0 ,DNS,r1 ; and the length of the default 5$: $store #lun.sr,LCH,r1 ; a channel number to use for delete $off #fb$fid,FOP,r1 ; we want an implicit $SEARCH mov #delnam ,r2 ; also point to the NAME block sub #200 ,sp ; allocate result name string .if gt r$$rms-1 ; If on RMS version 2 ... $store sp ,RSA,r2 ; set up the pointer to name string $store #200,RSS,r2 ; and set the size of the string .iff ;r$$rms-1 ; If on RMS version 1 ... mov sp,r4 ; Point to buffer from r4 .endc ;r$$rms-1 ; sub #200 ,sp ; allocate result expanded name string $store sp ,ESA,r2 ; set up the pointer to expanded name $store #200,ESS,r2 ; and set the size of the string $store #ER$FNM ,STS,r1 ; preset a bad filename error strlen @r5 ; get the length of the filename tst r0 ; anything left at all ? beq 90$ ; no, fake a bad filename please $store r0 ,FNS,r1 ; stuff the filename size in please $store @r5 ,FNA,r1 ; stuff the filename address into FAB .if gt r$$rms-1 ; If RMS version 2 or above ... $parse r1 ; try to parse the filename now $compar #0 ,STS,r1 ; did the parse of the name work ? blt 90$ ; no, exit and return STS in r0 10$: $erase r1 ; parse worked, try to delete it $compar #0 ,STS,r1 ; did the erase work out ok ? blt 90$ ; no inc r3 ; count the file as being deleted call 200$ ; do any echoing now please br 10$ ; next please .iff ;r$$rms-1 ; If on RMS version 1 ... .if gt r$$fcs ; If on FCS wild cards ... calls fndfir ,<#3,#lun.sr,(r5),r4> ; Find the first file br 20$ ; Join common code. 10$: calls fndnxt ,<#3,#lun.sr,(r5),r4> ; Find the next file. 20$: $store r0,sts,r1 ; Fake the status. tst r0 ; Errors? bmi 90$ ; J if so. $store r4,fna,r1 ; Store the file name address strlen r4 ; Compute string length $store r0,fns,r1 ; Store the file name length .endc ;r$$fcs $erase r1 ; Try to erase the file $compar #0,sts,r1 ; Any errors? blt 90$ ; J if so inc r3 ; Count the file as being deleted call 200$ ; do any echoing now .if gt r$$fcs ; If doing wild cards ... br 10$ ; try the next file. .endc ;r$$fcs .endc ;r$$rms-1 90$: $fetch r0 ,STS,r1 ; get the error code out please mov r3 ,r1 ; return the # of files deleted .if gt r$$rms-1 ; If on RMS version 2 ... cmp r0 ,#ER$NMF ; error is no more files ? bne 95$ ; no mov #ER$FNF ,r0 ; yes, make it into file not found tst r3 ; ever delete any files at all ? beq 100$ ; no, leave the error as FNF clr r0 ; yes, at least one file deleted br 100$ ; bye .iff ;r$$rms-1 ; Otherwise, if on RMS version 1 ... .if gt r$$fcs ; If using FCS wildcards ... cmp r0,#ER$NMF ; Is the error no more files? bne 95$ ; J if not mov #ER$FNF,r0 ; Yes, make it file not found tst r3 ; Ever delete any files at all? beq 100$ ; J if not. clr r0 ; Show success br 100$ ; And leave .endc ;r$$fcs ; .endc ;r$$rms-1 95$: tst r0 ; error code > 0 bmi 100$ ; no clr r0 ; yes, make the error STS zero then 100$: add #200*2 ,sp ; pop local buffers please unsave ; pop temps and exit return .sbttl printing routines for DELETE 180$: tst 2(r5) ; print out an initial header beq 190$ ; yes, but to the terminal bmi 195$ ; not at all, please strlen #300$ ; no, put it out to disk please calls putrec ,<#300$,r0,2(r5)>; dump the record to disk br 195$ ; and exit 190$: print #300$ ; dump the header to the terminal 195$: return ; bye 200$: cmp r3 ,#1 ; deleted anything as of yet ? bne 210$ ; yes call 180$ ; no, dump a header out please 210$: clr r0 ; get set to get the string length .if gt r$$rms-1 ; If on RMS version 2 ... bisb o$rsl(r2),r0 ; get the string length .iff ;r$$rms-1 ; If on RMS version 1 ... bisb o$esl(r2),r0 ; Get the string length .endc ;r$$rms-1 beq 250$ ; nothing was there to print ????? tst 2(r5) ; echo files deleted to terminal ? beq 240$ ; yes, echo to tt: bmi 250$ ; no, don't echo at all .if gt r$$rms-1 ; If on RMS version 2 ... calls putrec ,; echo to a file that's open .iff ;r$$rms-1 ; If on RMS versio 1 ... calls putrec ,; echo to a file that's open .endc ;r$$rms-1 br 250$ .if gt r$$rms-1 ; If on RMS version 2 ... 240$: print o$rsa(r2),r0 ; print the filename out to tt: .iff ;r$$rms-1 ; if on RMS version 1 ... 240$: print o$esa(r2),r0 ; print the filename out to tt: .endc ;r$$rms-1 ; print #310$ 250$: return 300$: .asciz /Files deleted:/ 310$: .byte cr,lf,0 .even .sbttl fparse parse filename and fill in with defaults .if gt r$$rms-1 .mcall $parse .endc ;r$$rms-1 .mcall $compar ,$fetch ,$off ,$store parfab = rnfab1 parnam = rnnam1 ; F P A R S E ; ; input: @r5 input filename, .asciz ; defdir the default directory name string to use ; ; output: 2(r5) expanded filename, .asciz, maximum length 63 bytes ; r0 error codes fparse::save ; save registers we may overwrite mov #parfab ,r1 ; point to the fab we use ;RBD01-- tst fu$def ; do we need a defualt device string? beq 1$ ; no $store #sydisk,DNA,r1 ; yes, please put it where we need it $store #sylen ,DNS,r1 ; also, the length also 1$: strlen #defdir ; get the default directory spec tst r0 ; was anything there ? beq 2$ ; no $store #defdir,DNA,r1 ; yes, stuff that in for the default $store r0 ,DNS,r1 ; name string, and stuff the length. 2$: $store #lun.sr,LCH,r1 ; a channel number to use for $PARSE $off #fb$fid,FOP,r1 ; we want an implicit $SEARCH mov #parnam ,r2 ; also point to the NAME block sub #100 ,sp ; allocate result name string $store sp ,RSA,r2 ; set up the pointer to name string $store #100,RSS,r2 ; and set the size of the string sub #100 ,sp ; allocate result expanded name string $store sp ,ESA,r2 ; set up the pointer to expanded name $store #100,ESS,r2 ; and set the size of the string $store #ER$FNM ,STS,r1 ; preset a bad filename error strlen @r5 ; get the length of the filename tst r0 ; anything left at all ? beq 90$ ; no, fake a bad filename please $store r0 ,FNS,r1 ; stuff the filename size in please $store @r5 ,FNA,r1 ; stuff the filename address into FAB .if gt r$$rms-1 ; If on RMS version 2 ... $parse r1 ; try to parse the filename now $compar #ER$UIN,sts,r1 ; Maybe a remote file spec? ;RBD01+ bne 5$ ; (no) $testb #,fnb,r2 ; Anything wild? bne 90$ ; (wild remote files no good) $testb #nb$nod,fnb,r2 ; Remote file? beq 90$ ; (ER$UIN with no node???) $off #nb$wch,fnb,r2 ; Make succeeding $search's act nice br 7$ ; Go ahead with it ;RBD01- 5$: $compar #0 ,STS,r1 ; did the parse of the name work ? blt 90$ ; no, exit and return STS in r0 .iff ;r$$rms-1 $store #SU$SUC ,STS,r1 ; Simulate success of parse .endc ;r$$rms-1 7$: mov 2(r5) ,r1 ; where we will copy the name to .if gt r$$rms-1 ; If on RMS version 2 ... movb o$esl(r2),r0 ; the length of the new name .iff ;r$$rms-1 tst r0 ; Is it 0? .endc ;r$$rms-1 beq 30$ ; can't happen unless you fubar cmp r0 ,#77 ; truncate names that are too long blos 10$ ; it's ok mov #77 ,r0 ; too long, please set it to 63 (10) 10$: .if gt r$$rms-1 ; If on RMS version 2 ... mov o$esa(r2),r2 ; where the name is coming from .iff ;r$$rms-1 ; mov @r5 ,r2 ; where the name is coming from .endc ;r$$rms-1 20$: movb (r2)+ ,(r1)+ ; copy a byte at a time please sob r0 ,20$ ; next please 30$: clrb @r1 ; insure .asciz please clr r0 ; no errors please br 100$ ; bye 90$: $fetch r0,STS,r1 ; error from parse, return in r0 100$: add #200 ,sp ; pop local nameblock buffers unsave ; pop registers return ; bye global ; F I X W I L D ; ; FIXWILD will replace % with ? for RSTS/E ; ; input: @r5 Address of string to process fixwil::nop ; in case we want to patch to 207 save ; save a register we use here calls getsys ; is this RSTS ? cmpb r0 ,#sy$rsts ; bne 100$ ; no mov @r5 ,r2 ; get the string address 10$: tstb @r2 ; done with the filename yet ? beq 100$ ; yes, exit cmpb @r2 ,#'% ; check for a % character bne 20$ ; no movb #'? ,@r2 ; yes, replace with question mark 20$: inc r2 ; next please br 10$ ; back again 100$: unsave ; pop r2 clr r0 ; no errors return ; bye .sbttl return current task size and return exec .mcall gtsk$s ; T S K S I Z ; ; output: r0 current task size tsksiz::sub #40 ,sp ; use the stack for a buffer mov sp ,r0 ; and point to it please gtsk$s r0 ; simple mov g.tsts(r0),r0 ; return current size add #40 ,sp ; pop buffer and exit return ; bye ; G E T S Y S ; ; output: r0 operating system ; ; sy$11m (1) for rsx11m ; sy$ias (3) for ias ; sy$rsts (4) for rsts ; sy$mpl (6) for m+ ; sy$rt (7) for rt11 ???? getsys::sub #40 ,sp ; use the stack for a buffer mov sp ,r0 ; and point to it please gtsk$s r0 ; simple mov g.tssy(r0),r0 ; return exec add #40 ,sp ; pop buffer and exit return ; bye .sbttl gsa get space for i/o buffers ; Modified from sample GSA from RMS v2 distribution ; by Brian Nelson 05-Jan-84 10:22:06 ; ; ; Interface: ; Request space: ; R0 -> RMS/user Pool list head (maintained by RL/CQB) ; R1 := Amount of space requested (bytes) ; R2 := 0 (differentiates between request and release) ; ; Release space: ; R0 -> RMS Pool list head (maintained by RL/CQB) ; R1 := Amount of space to be released (bytes) ; R2 -> Base address (for release) ; ; ; Returns: ; C-Bit "set" if an error has occurred (failure) ; C-Bit "clear" if no error has occurred (success) ; .Mcall Extk$S .Sbttl Control block definitions .Psect GSA$$D,RW,D ; ; GSA internal data: ; ; GSABAS - Base address for the next memory allocation. ; Initially set to zero, it will be assigned ; the first address outside of the task's ; current address limits. ; GSAMIN - Decimal value reflecting the minimum size ; (in bytes) to extend the task in order to ; provide space to the pool. ; GSAREQ - Requested pool block number. If a request ; for the 'GSAMIN' fails, then the original ; allocation size will be attempted. If that ; fails, then there is no more memory left. ; GSABAS:: ; GSA base address .Word 000000 ; (for next allocation) GSAMIN:: ; Minimum allocation .Word 512./64. ; (in 32-word blocks) GSAREQ:: ; Size of this request .Word 000000 ; (if 'GSAMIN' extends fail) .Sbttl GSA Initialization code .Psect GSA$$I,RO,I .mcall extk$s ,gtsk$s GSAINI: Mov R0,-(SP) ; R0-2 will be used to Mov R1,-(SP) ; communicate with $INIDM Mov R2,-(SP) ; NOTE: $INIDM uses EXTSK. mov r0 ,-(sp) ; save r0 sub #40 ,sp ; check for 512 boundary mov sp ,r0 ; get the current task size and see gtsk$s r0 ; if we are at a boundary. if so, then mov g.tsts(r0),r0 ; extend a little bit to get INIDM to add #40 ,sp ; behave itself bic #^c777 ,r0 ; strip all the high crap cmp r0 ,#776 ; should we extend a little bit? blo 10$ ; no extk$s #1 ; yes, get 64 more bytes please 10$: mov (sp)+ ,r0 ; restore r0 Call $INIDM ; Initialize dynamic memory Mov R1,GSABAS ; Setup the "free" address Mov (SP)+,R2 ; Restore the registers Mov (SP)+,R1 ; Mov (SP)+,R0 ; Return ; And return to GSA .Sbttl GSA Mainline code .Psect GSA$$M,RO,I ; ; GSA Mainline ; ; Entry point is "GSA", with registers 0-2 loaded as ; described above. ; GSA:: gsax: ; ; First, determine if dynamic memory has been initialized. ; GSABAS (initially set to zero) will be non-zero if $INIDM ; has been called and the memory list initialized. On RSX ; based systems it is possible to install tasks with an ; extension (/INCREMENT). $INIDM will detect this and setup ; the first memory entry in the pool list. ; ; A point to note: If the RSX task has been installed with ; the non-checkpointable (/-CP) flag, then EXTKs will not ; return success. If it is necessary to install the task ; non-checkpointable, then the task should be installed with ; and increment value. ; Tst GSABAS ; Dynamic memory initialized? Bne 10$ ; Yes if NE, proceed Call GSAINI ; Otherwise, initialize pool 10$: Tst R1 ; Real memory? Bne 20$ ; Yes if NE, then process it Return ; Otherwise return with success 20$: Tst R2 ; Address specified? (release) Beq 30$ ; No if EQ, then it's a request Jmp $RLCB ; Otherwise it's a release; do it 30$: Mov R0,-(SP) ; save pool list head Mov R1,-(SP) ; save size of request Mov R2,-(SP) ; save entry flag Call $RQCB ; Try the allocation Bcc 70$ ; CC signifies success Mov 2(SP),R1 ; Obtain the request size Add #63.,R1 ; Round the request Asr R1 ; to a 32-word boundary Asr R1 ; Then convert the value Asr R1 ; to the number of Asr R1 ; 32-word blocks. Asr R1 Asr R1 Mov R1,GSAREQ ; Save the real size Cmp R1,GSAMIN ; Smaller than minimum? Bhi 40$ ; No if HI, use it as is Mov GSAMIN,R1 ; Otherwise use GSAMIN 40$: Extk$S R1 ; Extend the task Bcc 60$ ; CC if successful Cmp R1,GSAREQ ; Is this request? Blos 50$ ; Yes if LOS, the end Mov GSAREQ,R1 ; Otherwise try to use Br 40$ ; the actual request 50$: Sec ; Mark failure Br 70$ ; And exit 60$: Mov 4(SP),R0 ; Setup the PLH Asl R1 ; Convert the real Asl R1 ; size to the actual Asl R1 ; 16-bit size that Asl R1 ; was allocated. Asl R1 ; The virtual address Asl R1 ; should be after the Mov GSABAS,R2 ; task (which is now Add R1,GSABAS ; part of the task) Call GSAX ; Call ourself to release Mov (SP)+,R2 ; Restore our registers Mov (SP)+,R1 ; to the initial state Mov (SP)+,R0 ; upon entry, and reenter Br GSAX ; as if it's a new request 70$: Inc (SP)+ ; These won't alter the Bit (SP)+,(SP)+ ; C-bit, so status remains Return ; unchanged upon return .sbttl get mcr/ccl (rsts) command line and remove task name .mcall gmcr$ ,dir$ .psect mcrbuf ,rw,d,lcl,rel,con gmcr: gmcr$ .psect $code ; G M C R ; ; output: @r5 the command line less the task name, .asciz ; r0 the length of whats left getmcr::save ; just for kicks, save these mov @r5 ,r2 ; point to the resultant command clrb @r2 ; insure .asciz dir$ #gmcr ; get the command line movb @#$dsw ,r0 ; get the length of it ble 90$ ; nothing mov #gmcr+g.mcrb,r1 10$: cmpb @r1 ,#40 ; look for the space delimiting beq 20$ ; the task name from the command inc r1 ; line. did not find it, keep looking sob r0 ,10$ ; keep trying br 90$ ; nothing 20$: inc r1 ; found the space, skip past it dec r0 ; whats left of it ble 90$ ; nothing clr -(sp) ; a length counter today 30$: movb (r1)+ ,(r2)+ ; copy it to the buffer passed inc @sp ; length := succ( length ) sob r0 ,30$ ; next byte please mov (sp)+ ,r0 ; return the command length mov @r5 ,r2 ; restore pointer to the returned string calls cvt$$ , ; remove leading spaces, upper case it add r0 ,r2 ; insure .asciz clrb @r2 ; simple br 100$ ; bye 90$: clr r0 ; nothing 100$: unsave ; pop used registers and exit return .end