#-h- minprim.mar 52021 asc 17-may-82 19:28:01 j (sventek j) #-h- start.mac 3251 asc 25-mar-82 06:55:45 v1.1 (sw-tools v1.1) .title minprm .sbttl start ;+ ; initialization routine for the software tools runtime system ;- ap=%5 blank=40 ; ascii for BLANK .mcall exst$s,alun$s,srda$s,fdof$l,wtse$s,gtsk$s fdof$l .psect $r.rod,con,ro,rel,lcl,d .enabl lc fmttsk: .asciz "%2r" errmsg: .asciz "Cannot open ERROUT." felmsg: .asciz "felled." .even .dsabl lc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb initst:: initr4:: sub #32.,sp ; make room for gtsk buffer on stack mov sp,r0 ; save address gtsk$s r0 ; get task parameters mov g.tsts(r0),r$enda ; save last virtual address mov r0,-(sp) ; set up call to sprint mov #fmttsk,-(sp) ; ... mov #r$tknm,-(sp) ; ... clr -(sp) ; ... mov sp,ap ; ... call sprint ; format task name into r$tknm add #40.,sp ; restore stack mov #r$dbst,r5 ; start of pointer array clr r2 ; lun 0 10$: cmp r5,#r$dbnd ; done? beq 20$ ; YES inc r2 ; next lun value call $fchnl ; get FFDB address in r0 bcs 20$ ; c set => invalid lun add #d.fdb,r0 ; now have FDB address mov (r5)+,r1 ; RFDB address mov r0,r.fdb(r1) ; store away FDB address movb r2,r.lun(r1) ; and lun br 10$ 20$: call r$gefn ; get a free event flag mov r0,r$ioef ; store it for use in qio's call r$gefn ; get a free event flag mov r0,r$spef ; store it for use in spwn calls srda$s #rcdast ; establish receive data AST call makarg ; get arguments call ttyatt ; attach terminal for ^O mov r$erdb,r1 ; ERROUT RFDB address mov #r$erac,-(sp) ; address of ERROUT access mov r$erfl,-(sp) ; address of ERROUT file spec clr -(sp) ; dummy # of arguments mov sp,ap ; place address in arg pointer call r$cref ; open the file bcs baderr ; cannot open ERROUT mov r$indb,r1 ; STDIN RFDB address mov r$infl,2(ap) ; address of STDIN filespec mov #r$inac,4(ap) ; address of STDIN access call r$opnf ; open the file bcs nbderr ; cannot open STDIN mov r$oudb,r1 ; STDOUT RFDB address mov r$oufl,2(ap) ; address of STDOUT filespec mov #r$ouac,4(ap) ; address of STDOUT access call r$cref ; create the file bcs nbderr ; cannot open STDOUT add #6,sp ; restore stack return ; ; ; endst:: endr4:: r$exit:: tstb r$fgpc ; foreground process active? beq 25$ ; NO mov #r$fgpc,r0 ; address of pid call r$kill ; kill the bugger wtse$s r$spef ; wait for it to die 25$: mov #r$dbst,r4 ; start of array of pointers 30$: cmp r4,#r$dbnd ; done? beq 40$ ; YES mov (r4)+,r1 ; get RFDB address into r1 call r$clsf ; close the file if open br 30$ ; go again 40$: mov #ex$suc,r0 ; assume successful exit tst (ap) ; called with any arguments? beq 50$ ; NO, exit cmp @2(ap),#ok ; endst(OK)? beq 50$ ; YES cmp @2(ap),#err ; endst(ERR) beq 45$ ; YES mov #felmsg,r0 ; address of felled message call r$ermo ; output to user's terminal 45$: mov #ex$sev,r0 ; severe error 50$: exst$s r0 ; exit to RSX/IAS ; ; receive data AST address ; rcdast: mov #eof,-(sp) ; endst(EOF) mov sp,r0 ; address of EOF mov r0,-(sp) ; in call block mov #1,-(sp) ; one arg mov sp,ap ; ... jmp r$exit ; exit baderr: mov #errmsg,r0 ; address of error message call r$ermo ; output to user's terminal br 45$ ; exit nbderr: call cant ; cannot open file .page #-h- alun.mac 427 asc 25-mar-82 06:55:47 v1.1 (sw-tools v1.1) .sbttl alun ;+ ; dsw = alun(lun, dev, unit) ;- lun=2 dev=4 unit=6 ap=%5 ; ; .mcall alun$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb alun:: mov dev(ap),r0 ; address of device string movb (r0)+,-(sp) ; copy to stack movb (r0),1(sp) ; copy to stack mov (sp)+,r1 ; place in register bic #<40+<40*256.>>,r1 ; make upper case alun$s @lun(ap),r1,@unit(ap) ; assign lun mov @#$dsw,r0 ; return DSW return .page #-h- bitsub.mac 1858 asc 25-mar-82 06:55:48 v1.1 (sw-tools v1.1) .sbttl bitsub - routines to manage resource bit masks ;+ ; ; this pair of routines manage resource bit masks ; ; allbit - finds first free bit and allocates it, returning its ; index (1 based) in r0 ; ; frebit - deallocates the resource indicated by the index passed ; in r0 ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ; ; allbit ; ; inputs: ; r0 starting index ; r1 limiting index ; r2 address of first resource mask word ; r3 starting mask bit ; ; outputs: ; r0 index allocated, or ; c bit clear if successful ; c bit set if allocation failure ; ; all other registers are preserved across the call ; allbit:: call r$savr ; save all registers 10$: cmp r0,r1 ; limit exceeded? bgt 30$ ; YES bit r3,(r2) ; bit clear? beq 20$ ; YES inc r0 ; increment index clc ; shift mask bit one position left rol r3 ; ... bcc 10$ ; try again if c clear mov #1,r3 ; reset mask bit tst (r2)+ ; bump resource mask pointer br 10$ ; try again 20$: bis r3,(r2) ; allocate resource clc ; c clear => success br 40$ 30$: sec ; c set => failure 40$: mov r0,2(sp) ; return index to user return .page ; ; frebit ; ; inputs: ; r0 index of resource to deallocate ; r1 limiting index ; r2 address of first word of resource mask ; r3 starting mask bit ; ; outputs: ; all registers are preserved ; the bit corresponding to the index in r0 is cleared ; frebit:: call r$savr ; save all registers tst r0 ; see if valid index ble 70$ ; NO, <= 0 cmp r0,r1 ; index <= limit bgt 70$ ; NO 50$: dec r0 ; reduce counter beq 60$ ; if == 0, done clc ; shift mask bit left one position rol r3 ; ... bcc 50$ ; try again if c clear mov #1,r3 ; initialize mask bit tst (r2)+ ; bump resource mask pointer br 50$ ; try again 60$: bic r3,(r2) ; free up resource 70$: return .page #-h- cant.mac 632 asc 25-mar-82 06:55:49 v1.1 (sw-tools v1.1) .sbttl cant ;+ ; subroutine cant(file) ;- ap=%5 buf=2 .psect $r.rod,con,ro,rel,lcl,d .enabl lc cbuf: .asciz " - cannot open."<12> .dsabl lc .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb cant:: mov r$erdb,r1 ; ERROUT RFDB address call r$lput ; output the file spec mov #cbuf,-(sp) ; place address in call block clr -(sp) ; dummy arg count mov sp,ap ; place in arg pointer call r$lput ; output the line cmp (sp)+,(sp)+ ; clean stack mov #err,-(sp) ; endst(ERR) mov sp,r0 ; address of ERR mov r0,-(sp) ; in call block mov #1,-(sp) ; one arg mov sp,ap ; set up arg ptr jmp r$exit ; done .page #-h- close.mac 732 asc 25-mar-82 06:55:50 v1.1 (sw-tools v1.1) .sbttl close ;+ ; call close(int) ; ; closes the file, flushing the last record if opened for output ;- ap=%5 int=2 ; ; .mcall close$ ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb close:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit number r$clsf:: bit #rf.clo,(r1) ; is the file opened? bne 100$ ; NO, nothing to do bit #rf.mod,(r1) ; output mode? bne 10$ ; NO tst r.byte(r1) ; any bytes left to flush? beq 10$ ; NO movb #newlin,r3 ; place NEWLINE character in register call r$cput ; flush the buffer 10$: mov r.fdb(r1),r0 ; FDB address in r0 close$ ; close the file mov #rf.clo,(r1) ; mark the file as closed 100$: return .page #-h- create.mac 485 asc 25-mar-82 06:55:51 v1.1 (sw-tools v1.1) .sbttl create ;+ ; int = create(ext, access) ; ; creates a file specified by ext at access ; if the file exists, open it. otherwise create it ; ; if error occurs, returns ERR ;- ap=%5 ext=2 access=4 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb create:: call r$gffb ; get a free RFDB address in r1 bcs 100$ ; c set => error r$cref:: bic #rf.old,(r1) ; wish to create a file call r$opfl ; general open file routine return 100$: mov #err,r0 ; return ERR return .page #-h- ctoo.mac 230 asc 25-mar-82 06:55:51 v1.1 (sw-tools v1.1) .sbttl ctoo ;+ ; integer function ctoo(buf) ;- ap=%5 buf=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ctoo:: mov buf(ap),r0 ; buffer address call $cotb ; convert to binary mov r1,r0 ; return binary number return .page #-h- efnsub.mac 1300 asc 25-mar-82 06:55:52 v1.1 (sw-tools v1.1) .sbttl efnsub ;+ ; this pair of routines implement the following fortran interfaces ; ; integer function getefn() ; subroutine putefn(event_flag) ; ; they permit the programmer to request free event flags and to ; return them when he is done with them. The domain of these ; routines is the set of local event flags 1. -> 24. ; flags 25. -> 32. are listed as reserved for DEC use. ;- ap=%5 efn=2 err=-3 ; error return if no flags available ; ; global data ; bits set in these masks indicate flags which are in use ; .psect $r.rwd,con,rw,rel,lcl,d low: .word 0 ; flags 1. -> 16. high: .word 0 ; flags 17. -> 24. ; ; efn = getefn() ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getefn:: r$gefn:: call r$savr ; save all registers mov #1,r0 ; starting efn number mov #24.,r1 ; limiting event flag number mov #low,r2 ; address of efn mask mov #1,r3 ; initial mask bit call allbit ; get a free efn bcc 10$ ; c clear => successful mov #err,r0 ; return(ERR) 10$: mov r0,2(sp) ; cause value to be returned return ; ; subroutine putefn(efn) ; putefn:: mov @efn(ap),r0 ; get EFN to return r$pefn:: call r$savr ; save all registers mov #24.,r1 ; limiting EFN number mov #low,r2 ; starting address of mask mov #1,r3 ; initial mask bit call frebit ; free the bit return .page #-h- files.mac 2153 asc 25-mar-82 06:55:53 v1.1 (sw-tools v1.1) .sbttl r$gfbk - get ratfor file descriptor block ;+ ; call r$gfbk ; ; inputs: ; r0 rat4 unit number ; ; outputs: ; r0 unchanged ; r1 address of RFDB ; c bit set if error ; clear is success ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$gfbk:: mov r0,-(sp) ; save r0 mov #r$dbst,r0 ; start of pointer array 10$: cmp r0,#r$dbnd ; done? beq 20$ ; YES mov (r0)+,r1 ; get address of RFDB cmpb (sp),r.lun(r1) ; is this the correct lun? bne 10$ ; NO clc ; c clear => success call valbuf ; assure valid buffer br 30$ ; return 20$: sec ; c set => failure 30$: mov (sp)+,r0 ; restore register return .page .sbttl r$gffb - get a free RFDB for use ;+ ; this routine scans the list of RFDB's for one that is not in use ; if successful, the RFDB address is returned in r1 ; ; outputs: ; r1 RFDB address ; c bit set if none are available ; c bit clear if successful ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$gffb:: mov #r$dbst,r0 ; address of pointer array 10$: cmp r0,#r$dbnd ; at end of list? beq 20$ ; YES, error mov (r0)+,r1 ; get RFDB address bit #rf.clo,(r1) ; file open? beq 10$ ; YES, try next RFDB clc ; clear c bit for success call valbuf ; assure valid buffer br 30$ 20$: sec 30$: return .page .sbttl valbuf - validate buffer, and obtain one if not there ;+ ; routine to extend task to obtain a buffer if one is not ; already allocated ; ; inputs: ; r1 RFDB address ; ; outputs: ; r0 mangled ; r1 the same ; c bit set if error extending task ; c bit clear if successful ;- .mcall extk$s .psect $r.rod,con,ro,rel,lcl,d .enabl lc extmsg: .asciz "error extending task." .dsabl lc .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb valbuf: tst r.buf0(r1) ; buffer allocated yet? bne 10$ ; YES extk$s #10 ; extend task by 512. bytes bcc 5$ ; c clear => success mov #extmsg,r0 ; address of error message call r$ermo ; notify user sec ; c set => error br 10$ 5$: mov r$enda,r.buf0(r1) ; store buffer address mov r.buf0(r1),r.bufp(r1) ; initialize buffer pointer add #1000,r$enda ; update task's last address clc ; clear c bit 10$: return .page #-h- fmtuic.mac 426 asc 25-mar-82 06:55:55 v1.1 (sw-tools v1.1) .sbttl fmtuic ;+ ; call fmtuic(grp, mem, buf) ;- ap=%5 grp=2 mem=4 buf=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb fmtuic:: movb @mem(ap),-(sp) ; build binary UIC on stack movb @grp(ap),1(sp) ; ... mov (sp)+,r3 ; place binary in required reg mov buf(ap),r2 ; buffer to format into mov #1,r4 ; desire leading zeros and separators call .ppasc ; convert to ASCII clrb (r2) ; terminate with EOS return .page #-h- getuid.mac 439 asc 25-mar-82 06:55:55 v1.1 (sw-tools v1.1) .sbttl getuid ;+ ; subroutine getuid(grp, mem) ;- ap=%5 grp=2 mem=4 .mcall gtsk$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getuid:: clr @grp(ap) ; initialize to 0 clr @mem(ap) ; ... sub #32.,sp ; space for GTSK buffer mov sp,r0 ; address of buffer gtsk$s r0 ; get task parameters movb g.tsdu(r0),@mem(ap) ; copy member number movb g.tsdu+1(r0),@grp(ap) ; copy group number add #32.,sp ; restore stack return .page #-h- gmcrst.mac 1888 asc 25-mar-82 06:55:57 v1.1 (sw-tools v1.1) .sbttl gmcrst ; ; this routine is called by the runtime initialization routine ; to get the calling command line. First, an attempt is made to ; retrieve a record from the device SR0:, where the command lines ; from a software tools spawn directive will reside. Failing this, ; a GMCR call is made to retrieve a command line from MCR. ; If this too fails, the user is prompted at the terminal for ; the remainder of the arguments with a prompt of the form ; ; args? ; ; inputs: ; r0 258. byte buffer for GMCR and read ; r1 lun to use in read to SR0: ; ; outputs: ; c clear successfully retrieved command line into buffer ; c set no command line found anywhere ; all registers remain the same ; ; ; ; macro calls ; .mcall alun$s,qiow$s ; ; ; defined symbols ; cr=15 ; carriage return ; ; ; ; .psect $r.rod,con,ro,rel,lcl,d ; .enabl lc ;psta: .ascii "args? " ;pstl=.-psta ; .even ; .dsabl lc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb gmcrst:: call r$savr ; save registers tst (r0)+ ; bump address to data area call r$garg ; get args in the tools way bcc 30$ ; c clear => successful 10$: mov (pc)+,-(r0) ; place emt code in buffer .byte 127.,41. ; codes for GMCR mov r0,-(sp) ; place DPB address on stack emt 377 ; go do it bcs 20$ ; c set => error mov @#$dsw,r$iosb+2 ; place count in local var tst (r0)+ ; point at first character br 30$ ; go finish up 20$: mov #2,r$iosb+2 ; initialize to dummy count tst (r0)+ ; bump to data area movb #'*,(r0)+ ; copy dummy image name movb #' ,(r0)+ ; ... ; alun$s r1,#"TI,#0 ; assign lun to TI: ; bcs 30$ ; c set -> error ; qiow$s #io.rpr,r1,r$ioef,,#r$iosb,, ; bcc 30$ ; c clear => OK ; mov #2,r$iosb+2 ; dummy count 30$: add r$iosb+2,r0 ; point at terminator loc movb #cr,(r0) ; place terminator in buffer clc ; clear c bit for sure 40$: return .page #-h- gtddir.mac 798 asc 25-mar-82 06:55:58 v1.1 (sw-tools v1.1) .sbttl gtddir ;+ ; implements the following fortran subroutine call ; ; call gtddir(buf, type) ; ap=%5 buf=2 type=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb gtddir:: cmp #path,@type(ap) ; PATH? bne 1$ ; NO mov #r$ddir,r0 ; address of def dir br 2$ 1$: mov #r$duic,r0 ; address of def uic string 2$: tstb (r0) ; anything in string? bne 10$ ; YES mov r0,-(sp) ; save buffer address call .rdfui ; read default UIC mov r1,r3 ; need it in r3 for .ppasc mov (sp),r2 ; destination address clr r4 ; separators and no leading zeroes call .ppasc ; format UIC clrb (r2) ; terminate with EOS mov (sp)+,r0 ; restore source address 10$: mov buf(ap),r1 ; destination address 20$: movb (r0)+,(r1)+ ; copy character bne 20$ ; if not EOS, do next char return .page #-h- jcopys.mac 604 asc 25-mar-82 06:55:59 v1.1 (sw-tools v1.1) .sbttl jcopys ;+ ; subroutine jcopys(in, i, c, out) ;- ap=%5 in=2 i=4 c=6 out=10 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb jcopys:: mov in(ap),r0 ; address of in(1) mov i(ap),r2 ; address of i dec (r2) ; decrement i add (r2),r0 ; address of in(i) mov out(ap),r1 ; address of out(1) movb @c(ap),r3 ; terminating character 10$: inc (r2) ; increment i movb (r0),(r1)+ ; copy character beq 20$ ; if == 0, done cmpb (r0)+,r3 ; terminating character? bne 10$ ; NO, do next character clrb (r1) ; terminate with EOS inc (r2) ; bump i past terminating char 20$: return .page #-h- kill.mac 1471 asc 25-mar-82 06:56:00 v1.1 (sw-tools v1.1) .sbttl kill ;+ ; integer function kill(proces) ; ; alternate entry - r$kill ; ; proces address passed in r0 ;- .mcall sdat$s,abrt$s ap=%5 proces=2 .psect $r.rwd,con,rw,rel,lcl,d dots: .ascii "..." pidbuf: .asciz "123456" .even task: .rad50 "123456" .psect $r.roi,con,ro,rel,lcl,i .enabl lsb kill:: mov proces(ap),r0 r$kill:: mov r5,-(sp) ; save r5 mov #pidbuf,r1 ; destination address tstb (r0) ; have a non-null pid? bne 10$ ; YES mov #r$fgpc,r0 ; address of foreground proc tstb (r0) ; is there one active? beq 60$ ; NO, nothing to do 10$: movb (r0)+,(r1)+ ; copy character bne 10$ mov #pidbuf,r0 ; address of pid clr r5 ; initialize counter 20$: mov #task,r1 ; buffer for rad50 call r$rad5 ; convert to rad50 bcs 70$ ; c set => error in conversion tst r5 ; which pass bne 40$ ; use abrt movb pidbuf,r0 ; get first character cmpb r0,#'. ; first character PERIOD? beq 30$ ; YES cmpb r0,#'$ ; DOLLAR? bne 40$ ; NO 30$: cmpb r0,pidbuf+1 ; first 2 chars same? beq 40$ ; YES sdat$s #task,#dots ; send message to tool mov @#$dsw,r1 ; get DSW br 50$ 40$: abrt$s #task ; abort task mov @#$dsw,r1 ; get DSW bgt 50$ ; if >, success inc r5 ; increment try count mov #dots,r0 ; starting address of buffer cmp r5,#2 ; done? blt 20$ ; NO 50$: tst r1 ; test DSW blt 60$ mov #ok,r0 ; return(OK) br 70$ 60$: mov #err,r0 ; return(ERR) 70$: mov (sp)+,r5 ; restore r5 return .page #-h- makarg.mac 2372 asc 25-mar-82 06:56:01 v1.1 (sw-tools v1.1) .sbttl makarg ;+ ; this routine fetches and sets up the command line arguments ; for subsequent retrieval by getarg and masking by delarg ;- cr=15 tab=10 ; ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb makarg:: mov #r$gmcr,r0 ; buffer address for args mov #1,r1 ; LUN to use for tools args call gmcrst ; get command line bcs 150$ ; c set => no command line tst (r0)+ ; point at first character mov #r$argv,r1 ; start of argv clr r$argc ; initialize arg count 110$: clr r3 ; clear quote flag 120$: movb (r0)+,r2 ; get next character cmp r2,#' ; is it a BLANK? beq 120$ ; YES, skip leading blanks cmp r2,#cr ; stop on terminator beq 150$ ; done, build stack frame cmp r2,#'' ; check for quoted strings beq 130$ ; cmp r2,#'" ; both kinds are legal bne 131$ ; 130$: mov r2,r3 ; save quote character cmp r1,#r$arge ; does argument fit? bhis 150$ ; NO mov r0,(r1)+ ; add to argv inc r$argc ; increment arg count br 140$ ; 131$: cmp r2,#'< ; STDIN redirection? bne 132$ ; NO mov r0,r$infl ; save address br 140$ ; collect argument 132$: cmp r2,#'> ; STDOUT redirection? bne 134$ ; NO cmpb r2,(r0) ; APPEND access? bne 133$ ; NO inc r0 ; point past ">>" mov #appe$r,r$ouac ; modify STDOUT access 133$: mov r0,r$oufl ; save address br 140$ ; collect argument 134$: cmp r2,#'? ; ERROUT redirection? bne 138$ ; NO cmpb (r0),#' ; BLANK? beq 138$ ; YES, not ERROUT redirection cmpb (r0),#tab ; TAB? beq 138$ ; YES, not ERROUT redirection cmpb (r0),#cr ; end of args? beq 138$ ; YES, not ERROUT redirection cmpb r2,(r0) ; APPEND access? bne 135$ ; NO inc r0 ; point past "??" mov #appe$r,r$erac ; modify ERROUT access 135$: mov r0,r$erfl ; save address br 140$ ; collect argument 138$: cmp r1,#r$arge ; does argument fit? bhis 150$ ; NO mov r0,(r1) ; add to argv dec (r1)+ ; went one character too far inc r$argc ; increment arg count 140$: movb (r0)+,r2 ; collect the argument cmp r2,#cr ; terminator? beq 145$ ; YES tst r3 ; in quoted string? bne 143$ ; YES cmp r2,#' ; is it a BLANK? beq 145$ ; YES, end of argument cmp r2,#tab ; is it a TAB? beq 145$ ; YES, end of argument br 140$ ; try next character 143$: cmp r2,r3 ; closing quote? bne 140$ ; NO 145$: clrb -1(r0) ; terminate with 0-byte cmp r2,#cr ; are we done? bne 110$ ; NO 150$: return .page #-h- open.mac 444 asc 25-mar-82 06:56:02 v1.1 (sw-tools v1.1) .sbttl open ;+ ; int = open(ext, access) ; ; opens an existing file specified by ext at access ; ; if error occurs, returns ERR ;- ap=%5 ext=2 access=4 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb open:: call r$gffb ; get a free RFDB address in r1 bcs 100$ ; c set => error r$opnf:: bis #rf.old,(r1) ; wish to open an existing file call r$opfl ; general open file routine return 100$: mov #err,r0 ; return ERR return .page #-h- putch.mac 1521 asc 25-mar-82 06:56:03 v1.1 (sw-tools v1.1) .sbttl putch ;+ ; call putch(buf, int) ; ; the character in buf is put to the file specified by unit ;- ap=%5 buf=2 int=4 ; ; .mcall qiow$s,put$ ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb putch:: mov @int(ap),r0 ; ratfor unit number call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; is the file open? bne 100$ ; NO, error bit #rf.raw,(r1) ; rawmode terminal? beq 10$ ; NO mov #1,r0 ; number of characters to write mov buf(ap),r2 ; address of buffer mov @int(ap),r1 ; lun to use r$rput:: tst r0 ; any bytes to write? ble 5$ ; NO qiow$s #io.wal,r1,r$ioef,,,, 5$: return 10$: bit #rf.mod,(r1) ; output mode? beq 20$ ; YES cmpb #rdwr$r,r.acc(r1) ; opened at READWRITE? bne 100$ ; NO, error clr r.byte(r1) ; no bytes buffered yet mov r.buf0(r1),r.bufp(r1) ; reset buffer pointer bic #rf.mod,(r1) ; set to output mode 20$: movb @buf(ap),r3 ; place character in register r$cput:: cmp r.byte(r1),#512. ; buffer full? bge 30$ ; YES, flush it cmpb #newlin,r3 ; NEWLINE character? bne 40$ ; NO 30$: mov r.buf0(r1),r2 ; buffer address mov r.fdb(r1),r0 ; real FDB address in r0 put$ ,r2,r.byte(r1) ; put the record mov r2,r.bufp(r1) ; reset buffer pointer clr r.byte(r1) ; zero character count 40$: cmpb #newlin,r3 ; NEWLINE character? beq 100$ ; YES, do not copy movb r3,@r.bufp(r1) ; store the character inc r.byte(r1) ; update byte count inc r.bufp(r1) ; bump buffer pointer 100$: return .page #-h- putlin.mac 1106 asc 25-mar-82 06:56:04 v1.1 (sw-tools v1.1) .sbttl putlin ;+ ; call putlin(buf, int) ;- ap=%5 buf=2 int=4 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb putlin:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit r$lput:: bit #rf.clo,(r1) ; is the file open? bne 100$ ; NO, error mov buf(ap),r4 ; buffer address in non-volatile reg bit #rf.raw,(r1) ; rawmode terminal? beq 30$ ; NO clr r0 ; initialize count of characters 10$: tstb (r4)+ ; null byte yet? beq 20$ ; YES inc r0 ; increment count br 10$ ; try again 20$: mov buf(ap),r2 ; address of buffer mov @int(ap),r1 ; lun to use call r$rput ; do a raw put of the line return 30$: bit #rf.mod,(r1) ; output mode? beq 40$ ; YES cmpb #rdwr$r,r.acc(r1) ; READWRITE access? bne 100$ ; NO, error clr r.byte(r1) ; no bytes buffered yet mov r.buf0(r1),r.bufp(r1) ; reset buffer pointer bic #rf.mod,(r1) ; set to output mode 40$: movb (r4)+,r3 ; place character in r3 beq 100$ ; if == 0, done call r$cput ; put the character (cooked) br 40$ ; do next character 100$: return .page #-h- rbtoo.mac 984 asc 25-mar-82 06:56:05 v1.1 (sw-tools v1.1) .sbttl r$btoo ;+ ; this routine formats the byte found in r1 into octal with ; no leading zeroes into the buffer pointed at by r0 ; r0 is left pointing at the next free location in the buffer ; all other registers are constant across the call ; ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$btoo:: call r$savr ; save r0-r5 movb r1,r2 ; place value in even register bne 10$ ; something to do movb #'0,(r0)+ ; just unit 0 br 40$ ; finish up 10$: ashc #-6,r2 ; rotate low 6 bits into r3 mov #3,r1 ; counter clr r4 ; no digits written yet 20$: bic #177770,r2 ; mask to 3 bits bne 25$ ; if != 0, something to do tst r4 ; written first digit yet? beq 30$ ; NO 25$: inc r4 ; update number of digits written add #'0,r2 ; make it a character movb r2,(r0)+ ; copy to buffer 30$: ashc #3,r2 ; shift next 3 bits into r2 sob r1,20$ ; do again 40$: clrb (r0) ; terminate with EOS mov r0,2(sp) ; place next address in saved r0 return .page #-h- rdspt.mac 1509 asc 25-mar-82 06:56:07 v1.1 (sw-tools v1.1) .sbttl r$dspt ;+ ; this routine builds a data set descriptor ; ; inputs: ; r0 address of file string ; r1 address of data set descriptor ; ; outputs: ; data set descriptor for file string is built ; all registers remain unchanged ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$dspt:: call r$savr ; save r0-r5 clr (r1) ; zero length fields in dspt clr 4(r1) ; ... clr 10(r1) ; ... mov r0,r3 ; initialize roving pointer mov r3,r2 ; start of string 10$: cmpb (r3),#': ; end of device string? bne 20$ ; NO mov r2,2(r1) ; store starting address mov r3,r0 ; calculate length sub r2,r0 ; ... inc r0 ; ... mov r0,(r1) ; place length in dspt mov r3,r2 ; new start of string inc r2 ; ... br 30$ ; do next field 20$: cmpb (r3),#'] ; end of UIC string? bne 25$ ; NO mov r2,6(r1) ; store starting address mov r3,r0 ; calculate length sub r2,r0 ; ... inc r0 ; ... mov r0,4(r1) ; store length mov r3,r2 ; new start of string inc r2 ; ... br 30$ ; do next field 25$: tstb 1(r3) ; end of file spec? bne 30$ ; NO mov r2,12(r1) ; store address mov r3,r0 ; calculate length sub r2,r0 ; ... inc r0 ; ... mov r0,10(r1) ; store length 30$: .enabl lc movb (r3),r0 ; get character cmp r0,#'a ; lower case? blt 40$ ; NO cmp r0,#'z ; lower case? bgt 40$ ; NO bic #40,r0 ; make upper case .dsabl lc 40$: movb r0,(r3)+ ; copy character back into string tstb (r3) ; end of file spec? bne 10$ ; NO return .page #-h- rermo.mac 890 asc 25-mar-82 06:56:08 v1.1 (sw-tools v1.1) .sbttl r$ermo ;+ ; routine to provide error message output ; ; inputs: ; r0 address of ASCIZ message string ; ; all registers remain the same across the call ;- .psect $$iob1,rw,d,lcl,rel,ovr errorb: .blkb 132. .psect $r.roi,con,ro,rel,lcl,i .enabl lsb .mcall qiow$s,gtsk$s sep: .asciz " *** " .even r$ermo:: call r$savr ; save r0-r5 mov #errorb,r0 ; address of output buffer mov #<15+<256.*12>>,(r0)+ ; copy CRLF into buffer mov #r$tknm,r1 ; address of task name string call copy mov #sep,r1 ; separator string call copy ; copy into error buffer mov 2(sp),r1 ; user's buffer call copy ; copy it movb #15,(r0)+ ; CR at end sub #errorb,r0 ; length of buffer in r0 qiow$s #io.wlb,.molun,r$ioef,,,,<#errorb,r0,#0> 100$: return ; ; ; copy: movb (r1)+,(r0)+ ; copy character bne copy ; if not 0, do again tstb -(r0) ; point at null byte return .page #-h- rgarg.mac 1487 asc 25-mar-82 06:56:09 v1.1 (sw-tools v1.1) .sbttl r$garg .if df SRDRV .mcall alun$s,qiow$s .iff .mcall get$ .psect $r.rod,con,ro,rel,lcl,d seed: .asciz "arg" ; seed for fgenr8 call .even .psect $$iob1,ovr,rw,rel,lcl,d file: .blkb 40. ; space for arg file name .even .endc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$garg:: call r$savr ; save registers .if df SRDRV alun$s r1,#"SR,#0 ; assign lun to SR0: bcs 10$ ; c set => error - return qiow$s #io.rlb,r1,r$ioef,,#r$iosb,, ; read from driver bcs 10$ ; c set => error - try MCR tstb r$iosb ; see if error in driver ble 10$ ; if <=, YES .iff mov #file,-(sp) ; address of file mov #seed,-(sp) ; address of seed mov #r$tknm,-(sp) ; address of pid mov #3,-(sp) ; three args mov sp,ap ; arg pointer for fgenr8 call fgenr8 ; call fgenr8(pid, seed, file) add #8.,sp ; clean up stack mov #r$inac,-(sp) ; READ access mov #file,-(sp) ; file to open clr -(sp) ; dummy count mov sp,ap ; arg pointer mov r$erdb,r1 ; ERROUT RFDB address call r$opnf ; open the file rol r2 ; save c bit add #6.,sp ; clean up stack ror r2 ; restore c bit bcs 10$ ; c set => open error mov 2(sp),r2 ; fetch buffer address clr r$iosb+2 ; assume error get$ r.fdb(r1),r2,#255. ; read the record bcs 5$ ; read error mov f.nrbd(r0),r$iosb+2 ; copy the count of chars read 5$: call .dlfnb ; close and delete the file .endc clc ; c clear => success return 10$: sec ; c set => error return .page #-h- ropfl.mac 4252 asc 17-may-82 19:10:02 j (sventek j) .sbttl r$opfl ;+ ; this routine performs general file opens for the software tools ; runtime system ; ; inputs: ; r1 RFDB address ; ; outputs: ; c set error in opening file ; c clear successful open ;- ap=%5 ext=2 access=4 .mcall nmblk$,ofnb$,fdop$r,fdat$r,fdrc$r .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$opfl:: mov r1,-(sp) ; save RFDB address mov ap,-(sp) ; save argument pointer mov #path,-(sp) ; type for fxlate mov sp,r0 ; save address add #r.name,r1 ; address of out mov r1,-(sp) ; place in call block mov r0,-(sp) ; address of type mov ext(ap),-(sp) ; address of in mov #3,-(sp) ; arg count mov sp,ap ; establish argument pointer call fxlate ; convert to local file spec mov 6(sp),r0 ; address of file spec in r0 add #10.,sp ; pop arg block from stack mov (sp)+,ap ; restore argument pointer mov (sp)+,r2 ; save RFDB in non-volatile reg sub #12.,sp ; build data set desc on stack mov sp,r1 ; dspt address in r1 call r$dspt ; build a data set descriptor mov r2,r1 ; RFDB address in correct place mov r.fdb(r1),r0 ; get FDB address mov sp,f.dspt(r0) ; store away dspt address mov pc,r2 ; get address of branch statement br 50$ ; branch around pure code nmblk$ ,,0,SY,0 ; default name block 50$: tst (r2)+ ; address of dfnb in r2 mov r2,f.dfnb(r0) ; store into FDB call r$pars ; parse the file spec rol r3 ; save c bit in r3 add #12.,sp ; restore stack ror r3 ; restore c bit bcc 51$ ; c clear => success jmp 100$ ; error 51$: movb @access(ap),r.acc(r1) ; store access mode in RFDB bgt 55$ ; if > 0, truncate after put$ fdrc$r ,#fd.ins ; do not truncate on put$ negb r.acc(r1) ; make access positive 55$: fdop$r ,,,,,#fa.enb!fa.dlk ; no lock upon aborted closure mov #fd.cr,r2 ; assume LIST cctrl cmpb #prin$r,r.acc(r1) ; PRINT access? bne 60$ ; NO mov #fd.ftn,r2 ; FORTRAN cctrl 60$: fdat$r ,#r.var,r2 ; variable length records cmpb #read$r,r.acc(r1) ; READ access? beq 90$ ; YES .if df newver ; NEW VERSIONS ON WRITE ACCESS? cmpb #writ$r,r.acc(r1) ; WRITE access? beq 82$ ; YES .endc ; newver cmpb #appe$r,r.acc(r1) ; APPEND access? bne 80$ ; NO ofnb$ ,#fo.apd ; open existing file at append access bcc 85$ ; c clear => success br 81$ ; open a new file 80$: ofnb$ ,#fo.upd ; open existing file for write .if df newver bcc 85$ ; c clear => success .iff bcs 81$ ; c set => error, try new file cmpb #rdwr$r,r.acc(r1) ; READWRITE access? beq 85$ ; YES, don't delete bitb #fd.dir,f.rctl(r0) ; directory device? beq 85$ ; NO bitb #fd.ftn!fd.cr,f.ratt(r0); any implied carriage control? bne 801$ ; YES movb #fd.cr,f.ratt(r0) ; make sure there is 801$: cmpb #prin$r,r.acc(r1) ; PRINT access? bne 802$ ; NO movb #fd.ftn,f.ratt(r0) ; make sure it is 802$: clr f.rsiz(r0) ; longest record is zero bytes clr f.efbk(r0) ; truncate file to zero length mov #1,f.efbk+2(r0) ; ... clr f.ffby(r0) ; ... call updhdr ; update the file header br 85$ .endc ; newver 81$: cmpb #ie.lck,f.err(r0) ; failed because file is locked? beq 100$ ; YES, return(ERR) cmpb #prin$r,r.acc(r1) ; PRINT carriage control? bne 82$ ; NO movb #fd.ftn,f.ratt(r0) ; make sure it is 82$: ofnb$ ,#fo.wrt ; open new file at write access bcs 100$ ; c set => open error br 85$ ; fill in RFDB 90$: ofnb$ ,#fo.rd!fa.shr ; open at read access with sharing bcs 100$ ; c set => open error 85$: clr (r1) ; file is open and flags cleared bitb #fd.tty,f.rctl(r0) ; is it a TTY? beq 86$ ; NO bis #rf.tty,(r1) ; note this in RFDB 86$: bitb #fd.ftn!fd.cr,f.ratt(r0); any implied carriage control? beq 87$ ; NO bis #rf.ctl,(r1) ; note this in RFDB 87$: cmpb #read$r,r.acc(r1) ; READ access? bne 88$ ; NO bis #rf.mod,(r1) ; indicate inputmode 88$: cmpb f.rtyp(r0),#r.var ; variable length records? bne 89$ ; NO bit #rf.ctl,(r1) ; implied carriage control? beq 89$ ; NO bis #rf.chr,(r1) ; indicate character file 89$: mov r.buf0(r1),r.bufp(r1) ; initialize buffer pointer clr r.byte(r1) ; clear number of bytes movb r.lun(r1),r0 ; return lun for success clc ; clear c bit for success return 100$: mov #err,r0 ; return ERR sec ; c set for sure return .page #-h- rpars.mac 2002 asc 25-mar-82 06:56:13 v1.1 (sw-tools v1.1) .sbttl r$pars ; ; this routine parses the file spec into the fdb and name block ; it takes care of named directories ; ; inputs: ; r0 address of FDB ; ; outputs: ; c bit set => error in parse ; c bit clear => success ; ; all registers are saved across the call ; ; upon return, the FDB in r0 is ready for an OFNB$[X] macro call to ; open the file ; .mcall nmblk$ ; ; .psect $r.rod,con,ro,rel,lcl,d dfnb: nmblk$ ,DIR,0 ; default name block for "name.dir" duic: .ascii "[0,377]" ; uic in which "name.dir" is found duicl=.-duic .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$pars:: call r$savr ; save r0-r5 mov r0,r1 ; generate FNB address add #f.fnb,r1 ; ... mov f.dspt(r0),r2 ; data-set descriptor address mov f.dfnb(r0),r3 ; default file name block call .prsdv ; parse device info bcs 30$ ; device error call .prsdi ; parse directory info bcc 20$ ; of form [g,m] sub #12.,sp ; space for dspt on stack mov sp,r3 ; address of dspt clr (r3) ; no device info for named directory clr 2(r3) ; ... mov 4(r2),10(r3) ; copy directory info into file info mov 6(r2),12(r3) ; ... sub #2,10(r3) ; length - brackets inc 12(r3) ; start after [ mov r3,r2 ; dspt mov #duicl,4(r2) ; length of [0,377] string mov #duic,6(r2) ; address in data-set descriptor mov #dfnb,r3 ; default FNB address call .prsdi ; parse directory info bcs 4$ call .prsfn ; parse file info bcs 4$ call .find ; find the file in [0,377] bcs 4$ mov n.fid(r1),n.did(r1) ; copy the file id into the dir id mov n.fid+2(r1),n.did+2(r1) ; ... mov n.fid+4(r1),n.did+4(r1) ; ... mov r1,r2 ; now clear out fields mov #16.,r3 ; filled in by parse of 10$: ; directory file spec clrb (r2)+ sob r3,10$ bic #7,n.stat(r1) 4$: rol r3 ; save c bit in r3 add #12.,sp ; pop dspt from stack ror r3 ; restore c bit bcs 30$ ; c set => named dir not found mov f.dspt(r0),r2 ; restore file's DSD mov f.dfnb(r0),r3 ; restore file's DFNB 20$: call .prsfn ; parse file info 30$: return .page #-h- rrad5.mac 882 asc 25-mar-82 06:56:14 v1.1 (sw-tools v1.1) .sbttl r$rad5 ;+ ; this routine converts the pid passed in r0 into rad50 in the buffer ; passed in r1 ;- .psect $r.rwd,con,rw,rel,lcl,d pidb: .blkb 10 ; buffer for upper-cased pid .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$rad5:: call r$savr ; save all registers clr (r1) ; zero taskname buffer clr 2(r1) ; ... mov r0,r2 ; source address mov #pidb,r3 ; destination address 10$: movb (r2)+,r4 ; get next character .enabl lc cmpb r4,#'a ; lower case? blt 20$ ; NO cmpb r4,#'z bgt 20$ .dsabl lc bic #40,r4 ; make upper case 20$: movb r4,(r3)+ ; copy character bne 10$ mov r1,r3 ; move buffer address mov #pidb,r0 ; address of ascii buffer mov #1,r1 ; do not stop on periods call $cat5b ; convert to rad50 bcs 30$ ; c set => error mov r1,(r3)+ ; copy into buffer mov #1,r1 call $cat5b bcs 30$ mov r1,(r3) 30$: return .page #-h- rsavr.mac 1190 asc 25-mar-82 06:56:15 v1.1 (sw-tools v1.1) .sbttl r$savr - save and restore register routines ;+ ; this routine saves and restores registers r0-r5 - it is the ; equivalent of $saval in syslib ; ; upon return from r$savr, the following is the structure of the ; stack ; ; +-------------------+ ; | return address | ; | saved r5 | 14(sp) ; | saved r4 | 12(sp) ; | saved r3 | 10(sp) ; | saved r2 | 6(sp) ; | saved r1 | 4(sp) ; | saved r0 | 2(sp) ; | address of r$retn | (sp) ; +-------------------+ ; ; upon execution of " rts pc", r$retn is entered, which ; restores the registers and returns to the caller's caller ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$savr:: sub #16,sp ; make room on stack mov 16(sp),(sp) ; move our return address down mov r5,16(sp) ; save r0-r5 mov r4,14(sp) ; ... mov r3,12(sp) ; ... mov r2,10(sp) ; ... mov r1,6(sp) ; ... mov r0,4(sp) ; ... mov #r$retn,2(sp) ; address of routine to restore registers rts pc ; return to caller ; ; ; r$retn: mov (sp)+,r0 ; restore registers r0-r5 mov (sp)+,r1 ; ... mov (sp)+,r2 ; ... mov (sp)+,r3 ; ... mov (sp)+,r4 ; ... mov (sp)+,r5 ; ... rts pc ; return to caller's caller .page #-h- sprint.mac 9024 asc 25-mar-82 06:56:18 v1.1 (sw-tools v1.1) .sbttl sprint ;+ ; subroutine sprint(out, fmt, in1, in2, ...) ; ; character out(ARB), fmt(ARB) ; ; fortran callable sprintf from C library ; ; format string consists of three types of characters ; ; 1. non-special characters which are copied directly to 'out' ; ; 2. escape characters of the form '@c'. If 'c' is special, its ; equivalent is placed in 'out', else 'c' is placed in 'out'. ; ; 3. format directives of the form '%c', where is an ; optional field width and 'c' is one of the following: ; c: character input ; d: integer input, formatted in signed decimal ; o: integer input, formatted in octal ; r: integer input in rad50, convert to ascii ; here, the width indicates how many contiguous integers ; to convert ; s: string input ; x: integer input, formatted in hexadecimal ;- ap=%5 out=2 fmt=4 in1=6 ; ; pure data ; .psect $r.rod,con,ro,rel,lcl,d .enabl lc escchr: .ascii "b"<10> ; @b => backspace ^H .ascii "f"<14> ; @f => formfeed ^L .ascii "l"<12> ; @l => linefeed ^J .ascii "n"<12> ; @n => newline ^J .ascii "r"<15> ; @r => return ^M .ascii "t"<11> ; @t => tab ^I .byte 0 ; end of list fmtchr: .asciz "cdorsx" ; valid format characters .even .dsabl lc fmtrtn: .word cfmt,dfmt,ofmt,rfmt,sfmt,xfmt ; formatting routines .psect $r.rwd,con,rw,rel,lcl,d width: .word 0 ; width of format field sign: .word 0 ; holds sign for decimal format fmtbuf: .blkb 10. ; buffer for formatting filchr: .blkb 1 ; fill character for putstr .even ; ; code for sprint ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb sprint:: call r$savr ; save r0-r5, in case called from macro mov out(ap),r0 ; output string address mov fmt(ap),r1 ; format string address add #in1,ap ; point to address of first argument 10$: movb (r1)+,r2 ; next character from format string beq 30$ ; if == 0, done cmpb #'@,r2 ; escaped character? bne 20$ ; NO movb (r1)+,r2 ; get character after '@' beq 30$ ; if == 0, done mov #escchr,r4 ; address of correspondence array 11$: cmpb r2,(r4)+ ; character match? bne 12$ ; NO movb (r4),r2 ; get equivalence character br 30$ ; copy it to out 12$: inc r4 ; bump past equivalence character tstb (r4) ; done? bne 11$ ; NO br 30$ ; just copy character 20$: cmpb #'%,r2 ; format specifier? bne 30$ ; NO jsr pc,getwid ; get optional width value movb #' ,filchr ; initialize fill character to BLANK movb (r1),r2 ; get format character bisb #40,r2 ; make it lower case clr r4 ; base address 21$: cmpb r2,fmtchr(r4) ; format character match? beq 22$ ; YES inc r4 ; update base address tstb fmtchr(r4) ; done? bne 21$ ; NO br 30$ ; just copy '%' 22$: asl r4 ; multiply base address by 2 jsr pc,@fmtrtn(r4) ; call appropriate subroutine inc r1 ; bump past format character br 10$ ; continue 30$: movb r2,(r0)+ ; copy character into out bne 10$ ; if != 0, do again rts pc ; return to caller .page ; ; formatting routines ; ; register inputs: ; ; r0 next available output address ; r1 address of format character (width has been processed) ; r2-r4 free for use ; ap pointer to address of input argument ; ; ; cfmt - place character in buffer ; .enabl lsb cfmt: mov (ap)+,r2 ; address of character movb (r2),fmtbuf ; place character in temp buf clrb fmtbuf+1 ; one character string mov #fmtbuf,r2 ; string to copy jsr pc,putstr ; copy to user buffer rts pc ; done ; ; sfmt - format string ; sfmt: mov (ap)+,r2 ; address of string jsr pc,putstr ; copy to user's buffer rts pc ; done .page ; ; ofmt - format integer*2 in octal with/without leading zeroes ; if format character is capital o(O), leading zeros ; else leading blanks ; .enabl lsb ofmt: mov r0,-(sp) ; save user buffer address mov r1,-(sp) ; need r1 for scratch mov #fmtbuf,r0 ; format into temporary buffer mov (ap)+,r2 ; address of integer to format mov (r2),r3 ; value of integer bne 4$ ; if non-zero, continue movb #'0,(r0)+ ; just put a zero br 5$ ; go put in user's buffer 4$: clr r2 ; make r2-r3 into 32-bit integer mov #6,r4 ; initialize counter clr r1 ; non-zero character not seen ashc #1,r2 ; shift r2-r3 one bit left 1$: bic #177770,r2 ; mask off to low three bits bne 2$ ; if non-zero, format it tst r1 ; have we seen non-zero yet? beq 3$ ; NO, try next character 2$: inc r1 ; seen non-zero add #'0,r2 ; make it a character movb r2,(r0)+ ; copy into out 3$: ashc #3,r2 ; shift next three bits into r2 sob r4,1$ ; do next character 5$: clrb (r0) ; terminate with EOS mov (sp)+,r1 ; restore r1 mov #fmtbuf,r2 ; address of buffer to copy mov (sp)+,r0 ; restore user's buffer address cmpb (r1),#'O ; upper case o? bne 6$ ; NO movb #'0,filchr ; fill with leading zeroes 6$: jsr pc,putstr ; copy to user's buffer rts pc ; done .page ; ; xfmt - format in hexadecimal ; .psect $r.rod,con,ro,rel,lcl,d .enabl lc xarray: .ascii "0123456789abcdef" .even .dsabl lc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb xfmt: mov r0,-(sp) ; save registers mov r1,-(sp) ; ... mov #fmtbuf,r0 ; format into temporary buffer mov (ap)+,r2 ; address of integer to format mov (r2),r3 ; value of integer bne 31$ ; if non-zero, go ahead movb #'0,(r0)+ ; just put a 0 br 32$ ; copy to user 31$: clr r2 ; make r2-r3 into 32-bit integer mov #4,r4 ; initialize counter clr r1 ; non-zero not seen yet 3$: ashc #4,r2 ; shift next four bits into r2 bic #177760,r2 ; mask to four bits bne 33$ ; non-zero character tst r1 ; seen a non-zero yet? beq 34$ ; NO 33$: inc r1 ; seen a non-zero movb xarray(r2),(r0)+; copy character 34$: sob r4,3$ ; do next character 32$: clrb (r0) ; terminate with EOS mov (sp)+,r1 ; restore registers mov #fmtbuf,r2 ; buffer to copy mov (sp)+,r0 ; user buffer cmpb (r1),#'X ; uppercase x? bne 6$ ; NO movb #'0,filchr ; fill with leading zeroes 6$: jsr pc,putstr ; copy to user buffer rts pc ; done .page ; ; dfmt - format in signed decimal ; .enabl lsb dfmt: mov #fmtbuf+9.,r4 ; end of buffer clrb (r4) ; EOS mov (ap)+,r2 ; address of value clr sign ; assume >= 0 mov (r2),r3 ; value to format bne 5$ ; if non-zero, continue movb #'0,-(r4) ; just output a 0 br 9$ ; copy to user buffer 5$: bgt 6$ ; if > 0, no minus sign inc sign ; indicate negative number neg r3 ; format positive number 6$: clr r2 ; 32-bit number for div 7$: div #10.,r2 ; divide by 10 add #'0,r3 ; make remainder into a character movb r3,-(r4) ; ferret away in buffer mov r2,r3 ; must now divide quotient beq 8$ ; if 0, done clr r2 ; 32-bit number br 7$ ; go again 8$: tst sign ; negative number beq 9$ ; NO movb #'-,-(r4) ; place minus sign in buffer 9$: mov r4,r2 ; buffer to copy jsr pc,putstr ; copy to user buffer rts pc .page ; ; rfmt - format rad50 to ascii ; .psect $r.rod,con,ro,rel,lcl,d .enabl lc t: .ascii " abcdefghijklmnopqrstuvwxyz$.?0123456789" .dsabl lc .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb rfmt: mov r1,-(sp) ; save register mov (ap)+,r1 ; address of integer array mov width,r4 ; number of integers to format bne 10$ ; if != 0, user specified it mov #1,r4 ; count of 1 10$: mov (r1)+,r3 ; value to convert clr r2 ; make it 32-bit for divide div #3100,r2 ; get first character movb t(r2),(r0)+ ; copy first character clr r2 ; remainder is new divisor div #50,r2 ; get second character movb t(r2),(r0)+ ; copy second character movb t(r3),(r0)+ ; and third character sob r4,10$ ; do more, if necessary mov (sp)+,r1 ; restore register rts pc ; done .page ;+ ; support routines for formatting routines ; ; getwid - get user-supplied field width ; ; inputs: ; r0 address of user buffer ; r1 address of first character after '%' ; r2 '%' ; r3,r4 mangled ; .enabl lsb getwid: clr r3 ; default width value 5$: jsr pc,isdig ; is this character a digit? bcs 6$ ; c set => NO movb (r1)+,r2 ; fetch the digit sub #'0,r2 ; make it an integer mul #10.,r3 ; w = 10 * w + d add r2,r3 ; ... br 5$ ; again 6$: mov r3,width ; save width value rts pc ; done ; ; isdig - determine if character pointed to by r1 is a digit ; ; c set => NO ; c clr => YES ; all registers remain unchanged ; isdig: cmpb (r1),#'0 ; < 0 blt 7$ ; YES cmpb (r1),#'9 ; > 9 bgt 7$ ; YES clc ; c clear => is a digit rts pc 7$: sec ; c set => not a digit rts pc ; ; putstr - put formatted string into user buffer ; ; inputs ; r0 next available address in user buffer ; r1 points at character after '%' ; r2 address of buffer to copy to user buffer ; r3-r4 mangled ; putstr: mov width,r4 ; width of field mov r2,r3 ; address of input buffer 8$: dec r4 ; decrement number of blanks to output tstb (r3)+ ; end of string? bne 8$ ; NO inc r4 ; went one too far ble 10$ ; if <= 0, no blanks to output 9$: movb filchr,(r0)+ ; output leading character sob r4,9$ ; do again, if necessary 10$: movb (r2)+,(r0)+ ; copy character to user buffer bne 10$ ; do again, if necessary tstb -(r0) ; went one too far rts pc ; done .page #-h- trndev.mac 1087 asc 25-mar-82 06:56:21 v1.1 (sw-tools v1.1) .sbttl trndev ;+ ; subroutine trndev(dev, unit, buf) ; ; this routine translates the pseudo-device specified by dev and unit ; into its equivalent character string in buf ;- ap=%5 dev=2 unit=4 buf=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb .mcall alun$s,glun$s trndev:: clrb @buf(ap) ; assume error mov dev(ap),r0 ; address of device string movb (r0)+,-(sp) ; place first character on stack movb (r0),1(sp) ; second character mov (sp)+,r1 ; have device string in r1 bic #<40+<40*256.>>,r1 ; make upper case alun$s r$endl,r1,@unit(ap) ; assign lun to DDn: bcs 100$ ; c set => bad error sub #12.,sp ; buffer for GLUN mov sp,r1 ; address of buffer glun$s r$endl,r1 ; GLUN bcs 90$ ; c set => almost as bad error mov buf(ap),r0 ; address of output buffer movb g.luna(r1),(r0)+ ; copy first byte of device name movb g.luna+1(r1),(r0)+ ; second byte of device name movb g.lunu(r1),r1 ; unit number call r$btoo ; format byte to octal movb #':,(r0)+ ; copy COLON clrb (r0) ; terminate with EOS 90$: add #12.,sp ; restore stack 100$: return .page #-h- ttysub.mac 344 asc 25-mar-82 06:56:22 v1.1 (sw-tools v1.1) .sbttl ttysub - tty subroutines ;+ ; subroutine ttyatt ; ; subroutine ttydet ;- .mcall qiow$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ttyatt:: mov #io.att,r0 ; function code for terminal attach br 10$ ttydet:: mov #io.det,r0 ; function code for terminal detach 10$: qiow$s r0,.molun,r$ioef ; perform correct function return .page #-h- updhdr.mac 1019 asc 17-may-82 19:10:08 j (sventek j) .sbttl updhdr - update record i/o portion of file header ;+ ; ; this routine is called by r$opfl to truncate files to 0 length ; upon open at WRITE access as well as to reset the carriage control ; attributes of files with no implied carriage control to LIST ; ; inputs r0 FDB address of file ; ; all registers remain the same across the call ;- .if ndf newver ; assemble only if NOT new versions .mcall qiow$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb updhdr: call r$savr ; save all registers mov r0,r4 ; generate FID address add #f.fnb,r4 ; ... clr -(sp) ; build attr ctrl list on stack mov r0,-(sp) ; address of record i/o area mov (pc)+,-(sp) ; rewrite first 7 words of rio .byte 4,16 mov sp,r3 ; address saved in register movb f.lun(r0),r2 ; lun to use qiow$s #io.wat,r2,r$ioef,,#r$iosb,, ; write attibutes bcs 10$ ; c set => error tstb r$iosb ; successful bgt 20$ ; YES 10$: sec ; c set for sure 20$: add #6,sp ; restore stack return .endc ; newver .page #-h- rdata.mac 2892 asc 25-mar-82 06:56:24 v1.1 (sw-tools v1.1) .sbttl r$data - RFDB database .asect .=0 r.flag:: .blkw 1 ; flags word in RFDB r.buf0:: .blkw 1 ; address of record buffer r.bufp:: .blkw 1 ; current buffer pointer r.byte:: .blkw 1 ; bytes in buffer currently r.fdb:: .blkw 1 ; associated FDB address r.lun:: .blkb 1 ; associated lun r.acc:: .blkb 1 ; access file is opened at r.name:: .blkb 40. ; space for file name r.lgth==. .psect ; ; definitions for bits in r.flag ; rf.clo==1 ; set if file is closed rf.tty==2 ; set if file is associated with terminal rf.old==4 ; set if opening existing file is desired rf.ctl==10 ; set if LIST or Fortran carriage control rf.dir==20 ; set if allocated to a directory rf.raw==40 ; set if unit is raw terminal rf.mod==100 ; set if unit is in inputmode rf.chr==200 ; set if character file ; ; ; general global symbol definitions ; ; eof==-1 err==-3 newlin==12 read$r==1 writ$r==2 rdwr$r==3 appe$r==4 prin$r==5 stdin==1 stdout==2 errout==3 yes==1 no==0 ok==0 path==5 d.fdb==12. ; this offset represents the offset into the FFDB ; for the FDB. it may have to be changed if the RMS ; OTS library is in use for F4P v.3.0 ; ; ; ; .psect $r.rwd,con,rw,rel,lcl,d r$dbst:: r$indb:: .word rfdb1 r$oudb:: .word rfdb2 r$erdb:: .word rfdb3 .word rfdb4,rfdb5,rfdb6,rfdb7 r$dbnd:: r$infl:: .word ti r$inac:: .word read$r r$oufl:: .word ti r$ouac:: .word writ$r r$erfl:: .word ti r$erac:: .word writ$r ti: .asciz "ti:" .even ; ; space for command line argument globals ; r$gmcr:: .blkb 258. ; buffer for command line r$argc:: .word 0 ; holds number of arguments r$argv:: ; start of array of pointers to args .rept 25. ; 25 pointers max .word null ; initially, each points to null arg .endr r$arge:: ; end of list r$ioef:: .word 0 ; event flag number for use in I/O r$spef:: .word 0 ; event flag number for spwn use r$iosb:: .word 0,0 ; io status block r$ddir:: .word 0,0,0,0,0,0 ; buffer for default directory r$duic:: .word 0,0,0,0,0 ; buffer for default uic string r$fgpc:: .byte 0,0,0,0,0,0,0 ; name of active foreground proc r$tknm:: .byte 0,0,0,0,0,0,0 ; our task name null: .asciz "" ; null string .even ; ; pointer to last address in task ; filled in during startup ; r$enda:: .word 0 r$endl:: .word 8. ; scratch lun r$lunm:: .byte 377,0,0,0,0,0,0,0 ; 64 luns max, first 8 dedicated ; ; RFDB's ; rfdb1: .word rf.clo .word 0 ; no buffer initially .blkb rfdb2: .word rf.clo .word 0 ; no buffer initially .blkb rfdb3: .word rf.clo .word errbuf ; only unit with initial buffer .blkb rfdb4: .word rf.clo .word 0 ; no buffer initially .blkb rfdb5: .word rf.clo .word 0 ; no buffer initially .blkb rfdb6: .word rf.clo .word 0 ; no buffer initially .blkb rfdb7: .word rf.clo .word 0 ; no buffer initially .blkb errbuf: .blkb 512. ; record buffer for ERROUT .end #-h- minlib.mar 6074 asc 17-may-82 23:14:57 j (sventek j) #-h- chcopy.mac 524 asc 25-mar-82 06:57:54 v1.1 (sw-tools v1.1) .title minlib .sbttl chcopy ; ; this routine implements the following fortran interface ; ; call chcopy(c, out, j) ; ; after the copy, j is incremented and an EOS is placed in out(j) ; ap=%5 c=2 out=4 j=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb chcopy:: mov out(ap),r0 ; address of out(1) in r0 mov @j(ap),r1 ; value of j in r1 dec r1 ; j-1 in r1 add r1,r0 ; address of out(j) in r0 movb @c(ap),(r0)+ ; copy character clrb (r0) ; write EOS(0) in next location inc @j(ap) ; increment j return .page #-h- equal.mac 659 asc 25-mar-82 06:57:55 v1.1 (sw-tools v1.1) .sbttl equal ; ; this routine implements the following fortran interface ; ; status = equal(a, b) ; ; where a and b are EOS-terminated strings. If they are equal, ; status is returnes as YES(1), otherwise NO(0) ; ap=%5 a=2 b=4 yes=1 no=0 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb equal:: mov a(ap),r1 ; address of a(1) in r1 mov b(ap),r2 ; address of b(1) in r2 mov #no,r0 ; initialize return value to NO 10$: cmpb (r1)+,(r2) ; compare the next character bne 20$ ; if !=, then return tstb (r2)+ ; see if this character is EOS(0) bne 10$ ; not EOS, try next character mov #yes,r0 ; all characters equal, return YES 20$: return .page #-h- fold.mac 721 asc 25-mar-82 06:57:55 v1.1 (sw-tools v1.1) .sbttl fold ; ; this routine implements the following fortran interface ; ; call fold(buf) ; ; where buf is an EOS-terminated string ; ; fold crunches all characters in the range A-Z into lower case ; ap=%5 buf=2 BIGA=101 BIGZ=132 LETA=141 LETZ=172 DIF=LETA-BIGA MASK=177 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb fold:: mov buf(ap),r1 ; address of buf(1) in r1 10$: movb (r1),r0 ; next character into r0 beq 20$ ; if == 0, then done cmpb r0,#BIGA&MASK ; see if >= A blt 30$ ; if <, then copy character back cmpb r0,#BIGZ&MASK ; see if <= Z bgt 30$ ; if >, then copy character back add #DIF,r0 ; add 40(8) to character 30$: movb r0,(r1)+ ; copy byte back into string br 10$ 20$: return .page #-h- gtftok.mac 756 asc 25-mar-82 06:57:56 v1.1 (sw-tools v1.1) .sbttl gtftok ;+ ; integer function gtftok(buf, i, token) ;- ap=%5 buf=2 i=4 token=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb gtftok:: mov buf(ap),r1 ; address of buf(1) mov i(ap),r3 ; address of i dec (r3) ; i = i - 1 add (r3),r1 ; address of buf(i) mov token(ap),r2 ; destination address clr r0 ; initialize return count inc (r3) ; i = i + 1 cmpb (r1),#'/ ; buf(i) == SLASH? bne 10$ ; NO inc (r3) ; i = i + 1 inc r1 ; address of buf(i) 10$: movb (r1)+,(r2) ; copy character beq 30$ ; if == 0, done cmpb (r2),#'/ ; SLASH? beq 20$ ; YES inc r0 ; increment count inc (r3) ; i = i + 1 cmpb (r2)+,#'\ ; BACKSLASH? bne 10$ ; NO, do next character 20$: clrb (r2) ; terminate with EOS 30$: return .page #-h- index.mac 738 asc 17-may-82 23:12:57 j (sventek j) .sbttl index ; ; this routine provides the following fortran interface ; ; i = index(buf, char) ; ; where buf is an EOS terminated string and the value of the function ; is its position in the string if found, and 0 if not ; ap=%5 buf=2 char=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb index:: indexc:: mov buf(ap),r1 ; buffer address in r1 movb @char(ap),r2 ; character to find in r2 clr r0 ; initialize character position 10$: inc r0 ; increment to current char position tstb (r1) ; see if at EOS(0) beq 20$ ; if == 0, return value of 0 cmpb (r1)+,r2 ; see if current byte matches beq 30$ ; if so, r0 contains position br 10$ ; try next byte 20$: clr r0 ; return 0 since char not found 30$: return .page #-h- length.mac 500 asc 25-mar-82 06:57:58 v1.1 (sw-tools v1.1) .sbttl length ; ; ; this routine implements the following fortran interface ; ; n = length(buf) ; ; where buf is a byte array and the string is terminated by a ; 0-byte. The length returned does not include the 0-byte. ; ap=%5 buf=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb length:: mov buf(ap),r1 ; address of buf in r1 clr r0 ; initialize length to 0 10$: tstb (r1)+ ; see if this byte is 0(EOS) beq 20$ ; if so, return inc r0 ; increment length by 1 br 10$ 20$: return .page #-h- stcopy.mac 705 asc 25-mar-82 06:57:59 v1.1 (sw-tools v1.1) .sbttl stcopy ; ; this routine provides the following fortran interface ; ; call stcopy(in, i, out, j) ; ; where in is an EOS-terminated string; j is incremented, also ; ap=%5 in=2 i=4 out=6 j=10 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb stcopy:: mov in(ap),r0 ; address of in(1) in r0 mov @i(ap),r1 ; value of i in r1 dec r1 ; now value of i-1 add r1,r0 ; r0 now has address of in(i) mov out(ap),r1 ; address of out(1) in r1 mov j(ap),r2 ; address of j in r2 dec (r2) ; j has been decremented add (r2),r1 ; r1 now has address of out(j) 10$: inc (r2) ; j now points to location copied to movb (r0)+,(r1)+ ; copy next byte bne 10$ ; if != 0, then do next byte return .page #-h- strcpy.mac 300 asc 25-mar-82 06:58:00 v1.1 (sw-tools v1.1) .sbttl strcpy ;+ ; call strcpy(in, out) ;- ap=%5 in=2 out=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb strcpy:: mov in(ap),r0 ; starting address of source mov out(ap),r1 ; starting address of destination 10$: movb (r0)+,(r1)+ ; copy character bne 10$ ; if not EOS, do again return .page #-h- type.mac 521 asc 25-mar-82 06:58:00 v1.1 (sw-tools v1.1) .sbttl type ;+ ; integer function type(c) ;- ap=%5 c=2 letter=1 digit=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb type:: movb @c(ap),r0 ; fetch character cmp r0,#'0 ; digit? blt 20$ ; NO, too small cmp r0,#'9 ; digit? bgt 10$ ; NO, too large mov #digit,r0 ; return(DIGIT) br 30$ 10$: bic #40,r0 ; make upper case cmp #'A,r0 ; see if letter bgt 20$ ; NO cmp #'Z,r0 ; other bound blt 20$ ; NO mov #letter,r0 ; return(LETTER) br 30$ 20$: movb @c(ap),r0 ; return(c) 30$: return .end #-h- prim.m 45538 asc 25-mar-82 07:04:30 v1.1 (sw-tools v1.1) #-h- appred.mac 540 asc 25-mar-82 06:59:01 v1.1 (sw-tools v1.1) .title appred ;+ ; subroutine appred(int, c, file, buf) ;- ap=%5 int=2 c=4 file=6 buf=10 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb appred:: mov buf(ap),r1 ; address of buffer 10$: tstb (r1)+ ; find end of string bne 10$ ; ... tstb -(r1) ; went one too far movb #' ,(r1)+ ; copy a blank movb @c(ap),(r1)+ ; copy c movb @c(ap),(r1)+ ; copy c mov file(ap),r0 ; address of file spec 20$: movb (r0)+,(r1)+ ; copy characters of file spec bne 20$ ; until EOS has been copied call close ; close the file return .end #-h- assign.mac 608 asc 25-mar-82 06:59:02 v1.1 (sw-tools v1.1) .title assngi ;+ ; int = assngi(ext, access, int) ; ; assigns file ext to rat4 unit int, closing int first if open ; ; returns ERR if any error occurs ;- ap=%5 ext=2 access=4 int=6 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb assngi:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address bcs 100$ ; c set => invalid unit call r$clsf ; close the file if necessary cmp #read$r,@access(ap) ; READ access? bne 10$ ; NO call r$opnf ; open existing file at READ access return 10$: call r$cref ; create file with access return 100$: mov #err,r0 ; return ERR return .end #-h- closdr.mac 202 asc 25-mar-82 06:59:03 v1.1 (sw-tools v1.1) .title closdr ;+ ; subroutine closdr(desc) ;- ap=%5 desc=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb closdr:: mov @desc(ap),r1 ; RFDB address mov #rf.clo,(r1) ; mark RFDB as closed return .end #-h- delarg.mac 616 asc 25-mar-82 06:59:04 v1.1 (sw-tools v1.1) .title delarg ;+ ; subroutine delarg(narg) ;- ap=%5 narg=2 ; ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb delarg:: mov @narg(ap),r1 ; get argument number ble 20$ ; if <= 0, invalid - return cmp r1,r$argc ; see if too large bge 20$ ; if >=, YES dec r$argc ; reduce argument count clc ; multiply n by 2 to get word rol r1 ; offset into argv add #r$argv,r1 ; address of destination mov r1,r0 ; address of source after tst tst (r0)+ ; 11$: cmp r0,#r$arge ; at end of pointers? beq 20$ ; YES mov (r0)+,(r1)+ ; copy pointer over obsolete one br 11$ ; go again 20$: return .end #-h- dfind.mac 809 asc 25-mar-82 06:59:04 v1.1 (sw-tools v1.1) .title dfind ; ; this routine implements the following fortran interface ; ; status = dfind(desc, buf) ; ; where desc is the RFDB address returned by dopen ; buf is an array to hold the file name, type and version ; ; status = OK if another file was found in the directory ; EOF if no more files in the directory ; .mcall fdof$l, nbof$l fdof$l nbof$l ap=%5 desc=2 buf=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb dfind:: mov @desc(ap),r1 ; RFDB address in r1 mov r.fdb(r1),r0 ; FDB address mov r0,r1 ; FDB address in r1 add #f.fnb,r1 ; FNB address in r1 call .find ; find next directory entry bcs 10$ ; if c set, no more files mov buf(ap),r0 ; output buffer address call r$cvtf ; get ascii file name mov #ok,r0 ; return OK return 10$: mov #eof,r0 ; return EOF return .end #-h- dopen.mac 1075 asc 25-mar-82 06:59:05 v1.1 (sw-tools v1.1) .title dopen ;+ ; integer function dopen(ext, desc) ;- ap=%5 ext=2 desc=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb dopen:: call r$gffb ; get free RFDB address in r1 bcs 100$ ; c set => ERROR mov r1,-(sp) ; save RFDB address add #r.name,r1 ; now have address of filename mov r1,-(sp) ; save for later mov ext(ap),r0 ; source address 10$: movb (r0)+,(r1)+ ; copy character bne 10$ ; until EOS mov (sp)+,r0 ; address of filespec mov (sp)+,r2 ; RFDB address sub #12.,sp ; build dspt on stack mov sp,r1 ; address of dspt call r$dspt ; fill it in mov r2,r1 ; RFDB address in correct place mov r.fdb(r1),r0 ; FDB address mov sp,f.dspt(r0) ; pointer to dspt clr f.dfnb(r0) ; no default name block call r$pars ; parse the directory spec rol r3 ; save c bit add #12.,sp ; restore stack ror r3 ; restore c bit bcs 100$ ; c set => invalid directory spec bic #rf.clo,(r1) ; RFDB in use bis #rf.dir,(r1) ; opened by opendr mov r1,@desc(ap) ; return RFDB address as desc mov #ok,r0 return 100$: mov #err,r0 return .end #-h- f11sub.mac 2319 asc 25-mar-82 06:59:07 v1.1 (sw-tools v1.1) .title f11sub ;+ ; this set of routines permit ACP qios to be performed to retrieve ; information on the file pointed to by the RFDB address passed ; in `desc'. `buf' is the address of the buffer to place the ; information into. It is assumed that the buffer is large enough ; for the requested information. ; ; all routines are integer functions of the form ; ; integer function f11xxx(desc, buf) ; ; where desc is the descriptor returned by an opendr call. ; the value returned is OK/ERR ; ; entry size(bytes) description ; ; f11uic 2 owning UIC ; f11pro 2 protection word ; f11cha 1 user-controlled characteristics ; f11rio 32 record i/o area ; f11nam 10 name, type and version ; f11exd 7 expiration date ; f11stb 10 statistics block ; f11hdr 512 whole header block ;- .psect $r.rod,con,ro,rel,lcl,d uiccod: .byte -1,2 ; codes to ACP to fetch appropriate info procod: .byte -2,2 ; ... chacod: .byte -3,1 ; ... riocod: .byte -4,40 ; ... namcod: .byte -5,12 ; ... exdcod: .byte -10,7 ; ... stbcod: .byte -11,12 ; ... hdrcod: .byte -12,0 ; ... ; .mcall qiow$s ap=%5 desc=2 buf=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb f11uic:: mov uiccod,r0 ; ACP code for UIC br common ; do common code f11pro:: mov procod,r0 ; ACP code for protection br common f11cha:: mov chacod,r0 ; ACP code for characteristics br common f11rio:: mov riocod,r0 ; ACP code for record I/O area br common f11nam:: mov namcod,r0 ; ACP code for file name, type and version br common f11exd:: mov exdcod,r0 ; ACP code for expiration date br common f11stb:: mov stbcod,r0 ; ACP code for statistics block br common f11hdr:: mov hdrcod,r0 ; ACP code for entire header block ; ; common processing starts here ; common: mov @desc(ap),r1 ; RFDB address mov r.fdb(r1),r1 ; FDB address clr -(sp) ; build ACP control block on stack mov buf(ap),-(sp) ; buffer address for information mov r0,-(sp) ; function code for ACP mov sp,r3 ; address of control block movb f.lun(r1),r2 ; lun to use for QIOW add #f.fnb+n.fid,r1 ; address of FID area qiow$s #io.rat,r2,r$ioef,,#r$iosb,, bcs 10$ ; c set => error tstb r$iosb ; successful? ble 10$ ; NO mov #ok,r0 ; return(OK) br 20$ 10$: mov #err,r0 ; return(ERR) 20$: add #6,sp ; restore stack return .end #-h- fdel.mac 348 asc 25-mar-82 06:59:08 v1.1 (sw-tools v1.1) .title fdel ;+ ; integer function fdel(int) ;- ap=%5 int=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb fdel:: mov @int(ap),r0 ; rat4 unit call r$gfbk ; get RFDB address in r1 mov r.fdb(r1),r0 ; FDB address call .dlfnb ; delete file mov #ok,r0 ; assume OK bcc 10$ ; c clear => success mov #err,r0 ; return ERR 10$: return .end #-h- filnfo.mac 649 asc 25-mar-82 06:59:09 v1.1 (sw-tools v1.1) .title filnfo ;+ ; integer function filnfo(int, file, access) ;- ap=%5 int=2 file=4 access=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb filnfo:: mov #err,-(sp) ; assume error mov @int(ap),r0 ; rat4 unit number call r$gfbk ; retrieve RFDB bcs 100$ ; c set => error bit #rf.clo,(r1) ; file open on unit? bne 100$ ; NO movb r.acc(r1),r0 ; fetch access mov r0,@access(ap) ; return to user add #r.name,r1 ; now have address of file name mov file(ap),r0 ; destination buffer 10$: movb (r1)+,(r0)+ ; copy character bne 10$ ; if not EOS, do again mov #ok,(sp) ; return(OK) 100$: mov (sp)+,r0 ; return(status) return .end #-h- filpro.mac 512 asc 25-mar-82 06:59:10 v1.1 (sw-tools v1.1) .title filpro ;+ ; routines for manipulating the default file protection word ; in $$FSR2 ; ; subroutine getpro(prot) ; ; subroutine setpro(prot) ; ; the protection words have meaning as per the I/O operations ; manual description of .rdffp and .wdffp ;- ap=%5 prot=2 ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getpro:: call .rdffp ; read default prot word mov r1,@prot(ap) ; return to the user return ; setpro:: mov @prot(ap),r1 ; fetch user value call .wdffp ; write default prot word return .end #-h- frmdat.mac 857 asc 25-mar-82 06:59:10 v1.1 (sw-tools v1.1) .title frmdat ;+ ; subroutine frmdat(in, out) ;- ap=%5 in=2 out=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb frmdat:: mov in(ap),r0 ; source address mov out(ap),r1 ; destination address call twocpy ; copy two characters movb #'-,(r1)+ ; copy separator mov #3,r2 ; number of characters to copy call ncopy ; copy them movb #'-,(r1)+ ; copy separator movb #'1,(r1)+ ; copy 19 movb #'9,(r1)+ ; ... call twocpy ; copy two characters movb #' ,(r1)+ ; copy separator call twocpy ; copy two characters movb #':,(r1)+ ; copy separator call twocpy ; copy two characters movb #':,(r1)+ ; copy separator call twocpy ; copy two characters clrb (r1) ; terminate with EOS return ; ; twocpy: mov #2,r2 ; copy two characters ncopy: movb (r0)+,(r1)+ ; copy next character sob r2,ncopy ; go again if more left return .end #-h- fmtpro.mac 839 asc 25-mar-82 06:59:11 v1.1 (sw-tools v1.1) .title fmtpro ;+ ; subroutine fmtpro(protec, buf) ;- ap=%5 protec=2 buf=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb .enabl lc chars: .ascii "dewr" .dsabl lc .even fmtpro:: mov @protec(ap),r1 ; protection word mov #20,r0 ; initialize mask word mov buf(ap),r2 ; address of buffer mov #3,r3 ; initialize offset into chars br 20$ ; no pipe on first pass 10$: movb #'|,(r2)+ ; copy separator 20$: bit r0,r1 ; see if bit is set beq 30$ ; NO movb #'-,(r2)+ ; copy dash for no access br 40$ 30$: movb chars(r3),(r2)+ ; copy access character 40$: clc ; shift mask bit left one bit rol r0 ; ... bcs 50$ ; c set => all done dec r3 ; decrement offset into chars bge 20$ ; if >= 0, continue mov #3,r3 ; initialize offset br 10$ ; copy separator 50$: clrb (r2) ; terminate with EOS return .end #-h- getarg.mac 951 asc 25-mar-82 06:59:12 v1.1 (sw-tools v1.1) .title getarg ;+ ; integer function getarg(narg, buf, size) ;- ap=%5 narg=2 buf=4 size=6 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getarg:: mov #eof,r0 ; assume invalid number clrb @buf(ap) ; initialize user buffer to null str mov @narg(ap),r1 ; get argument number blt 10$ ; return(EOF) if < 0 cmp r1,r$argc ; see if too large bge 10$ ; YES, return (EOF) clc ; multiply by 2 for word offset rol r1 ; into argv mov r$argv(r1),r1 ; address of nth arg string mov buf(ap),r2 ; address of destination buffer mov @size(ap),r0 ; size of target buffer beq 10$ ; if size is 0, done 1$: movb (r1)+,(r2)+ ; copy next character beq 2$ ; just copied EOS - done sob r0,1$ ; decrement bytes left and try again clrb -(r2) ; write EOS into last position inc r0 ; one less than max 2$: mov r0,r1 ; subtrahend in r1 mov @size(ap),r0 ; minuend in r0 sub r1,r0 ; number of characters in arg 10$: return .end #-h- getch.mac 2580 asc 25-mar-82 06:59:14 v1.1 (sw-tools v1.1) .title getch ;+ ; c = getch(c, int) ; ; gets the next character on ratfor unit int ; ; returns it in variable c and as value of the function ; ; if error occurs or EOF on the file, the value EOF is returned ;- ap=%5 c=2 int=4 ; ; .mcall qiow$s,get$ ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getch:: mov @int(ap),r0 ; get ratfor unit number == lun call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit number bit #rf.clo,(r1) ; is the file open? bne 100$ ; NO bit #rf.raw,(r1) ; rawmode terminal? beq 10$ ; NO mov #1,r0 ; number of chars to read mov @int(ap),r1 ; lun to use mov c(ap),r2 ; address of buffer call r$rget ; fetch the raw character movb @c(ap),r0 ; return character bic #177600,r0 ; mask to 7 bits movb r0,@c(ap) ; return in variable return 10$: bit #rf.mod,(r1) ; inputmode? bne 20$ ; YES cmpb #rdwr$r,r.acc(r1) ; READWRITE unit? bne 100$ ; NO, error clr r.byte(r1) ; no bytes left in record bis #rf.mod,(r1) ; set to inputmode 20$: call r$cget ; get next character in r0 bcc 110$ ; c clear => success 100$: mov #eof,r0 ; return(EOF) 110$: movb r0,@c(ap) ; return character to user return .page .sbttl r$cget - get next cooked character into r0 ;+ ; this routine is called by getch and getlin ; ; inputs: ; r1 RFDB address ; ; outputs: ; r0 next character ; c bit set if error or end-of-file ; c bit clear if OK ; r2 is mangled ;- r$cget:: tst r.byte(r1) ; any bytes left in record? bgt 30$ ; YES mov r.buf0(r1),r2 ; buffer address in r2 mov r.fdb(r1),r0 ; address of FDB in r0 get$ ,r2,#511. ; get next record bcs 40$ ; c set => error or end-of-file mov r2,r.bufp(r1) ; save address in RFDB mov f.nrbd(r0),r0 ; number of bytes read bit #rf.ctl,(r1) ; LIST or FORT carriage control? beq 25$ ; NO add r0,r2 ; address of first free byte in buffer movb #newlin,(r2) ; place NEWLINE at end of buffer inc r0 ; increase count 25$: mov r0,r.byte(r1) ; number of bytes in record 30$: movb @r.bufp(r1),r0 ; character to return dec r.byte(r1) ; decrement no of bytes left inc r.bufp(r1) ; bump pointer clc ; c clear => OK 40$: return .page .sbttl r$rget - fetch raw character[s] ;+ ; this routine is called by getch and readf ; ; inputs: ; r0 number of characters to read ; r1 lun to use ; r2 buffer to read into ; ; outputs: ; a read-pass-all with no-echo is performed on the terminal ; the read completes when the buffer is full ; there are no error returns ;- r$rget:: qiow$s #io.rne!tf.ral,r1,r$ioef,,,, return .end #-h- getdir.mac 1494 asc 25-mar-82 06:59:15 v1.1 (sw-tools v1.1) .title getdir ;+ ; subroutine getdir(key, type, buf) ;- ; ; local data ; .psect $r.rod,con,ro,rel,lcl,d devptr: .word st0,st0,st1,st1,st1,st0,st0,st0,st0 uicptr: .word bin,usr,tmp,lpr,msg,man,src,inc,lib ndirs=<.-uicptr>/2 ; number of valid keys st0: .asciz "ST0" st1: .asciz "ST1" bin: .asciz "105,1" usr: .asciz "105,2" tmp: .asciz "105,3" lpr: .asciz "105,4" msg: .asciz "105,5" man: .asciz "105,6" src: .asciz "105,7" inc: .asciz "105,10" lib: .asciz "105,11" .even ; ; ap=%5 key=2 type=4 buf=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getdir:: mov buf(ap),r0 ; destination address mov @key(ap),r3 ; get value of key ble 100$ ; if key <= 0, invalid cmp r3,#ndirs ; too large? bgt 100$ ; YES dec r3 ; key - 1 clc ; rol r3 ; 2 * (key - 1) mov devptr(r3),r1 ; address of device name cmp @type(ap),#path ; desire pathname format? bne 10$ ; NO movb #'/,(r0)+ ; initial slash call copy ; copy device name movb #'/,(r0)+ ; dividing slash mov uicptr(r3),r1 ; address of uic string call copy ; copy uic string movb #'/,(r0)+ ; trailing slash br 100$ ; finish up 10$: call copy ; copy device name movb #':,(r0)+ ; ":[" movb #'[,(r0)+ ; ... mov uicptr(r3),r1 ; address of uic string call copy ; copy uic string movb #'],(r0)+ ; trailing ']' 100$: clrb (r0) ; terminate with EOS return ; ; ; copy subroutine ; ; copy: movb (r1)+,(r0)+ ; copy character bne copy ; if not 0, go again tstb -(r0) ; point at EOS return .end #-h- getlin.mac 1746 asc 25-mar-82 06:59:16 v1.1 (sw-tools v1.1) .title getlin ;+ ; n = getlin(buf, int) ; ; gets the next line from int into buf (characters up to and ; including a NEWLINE character) ; ; if a read error or end-of-file occurs, EOF is returned ;- ap=%5 buf=2 int=4 ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getlin:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; is the file open? bne 100$ ; NO, error bit #rf.raw,(r1) ; rawmode terminal? bne 100$ ; YES, getlin error on raw tty bit #rf.mod,(r1) ; input mode? bne 5$ ; YES cmpb #rdwr$r,r.acc(r1) ; opened at READWRITE? bne 100$ ; NO, error clr r.byte(r1) ; no bytes left in record bis #rf.mod,(r1) ; set to input mode 5$: mov buf(ap),r3 ; address of user buffer clr r4 ; initialize counter 10$: call r$cget ; get next character into r0 bcs 100$ ; c set => error or EOF movb r0,(r3)+ ; move character into user buf inc r4 ; increment counter cmpb r0,#newlin ; NEWLINE character? beq 20$ ; YES, done cmp r4,#511. ; buffer full? blt 10$ ; NO, get next character 20$: cmp r4,#1 ; only one character? beq 30$ ; YES cmpb -2(r3),#'@ ; escaped NEWLINE? bne 30$ ; NO cmp (ap),#3 ; called from prompt? bne 30$ ; NO sub #2,r3 ; point at '@' dec r4 ; decrease character count movb #' ,(r3)+ ; @n => BLANK mov #4,r0 ; number of characters to put mov 6(ap),r2 ; address of string mov r1,-(sp) ; save RFDB address mov @int(ap),r1 ; lun to use call r$rput ; put secondary prompt mov (sp)+,r1 ; restore RFDB address br 10$ ; get some more characters 30$: clrb (r3) ; terminate with EOS mov r4,r0 ; return count in r0 return 100$: mov #eof,r0 ; return EOF return .end #-h- getnow.mac 624 asc 25-mar-82 06:59:17 v1.1 (sw-tools v1.1) .title getnow ;+ ; subroutine getnow(now) ; ; integer now(7) ;- ap=%5 now=2 .mcall gtim$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getnow:: sub #16.,sp ; room for 8 words on stack mov sp,r0 ; address of buffer gtim$s r0 ; get current time parameters mov now(ap),r0 ; address of user's buffer mov (sp)+,r1 ; year since 1900 add #1900.,r1 ; complete it mov r1,(r0)+ ; give to user mov (sp)+,(r0)+ ; month mov (sp)+,(r0)+ ; day mov (sp)+,(r0)+ ; hour mov (sp)+,(r0)+ ; minute mov (sp)+,(r0)+ ; second cmp (sp)+,(sp)+ ; pop last two words off stack clr (r0) ; no milli-seconds return .end #-h- getpnm.mac 261 asc 25-mar-82 06:59:18 v1.1 (sw-tools v1.1) .title getpnm ;+ ; subroutine getpnm(buf) ;- ap=%5 buf=2 .mcall gtsk$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getpnm:: mov #r$tknm,r0 ; source address mov buf(ap),r1 ; dest address 10$: movb (r0)+,(r1)+ ; copy string bne 10$ ; ... return .end #-h- getpri.mac 330 asc 25-mar-82 06:59:19 v1.1 (sw-tools v1.1) .title getpri ;+ ; subroutine getpri(prio) ;- .mcall gtsk$s ap=%5 prio=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getpri:: sub #32.,sp ; block for GTSK parameters mov sp,r0 ; address in register gtsk$s r0 ; get task parameters mov g.tspr(r0),@prio(ap) ; return priority add #32.,sp ; restore stack return .end #-h- gettyp.mac 534 asc 25-mar-82 06:59:20 v1.1 (sw-tools v1.1) .title gettyp ;+ ; integer function gettyp(int, type) ;- ap=%5 int=2 type=4 ascii=12. binary=60. .psect $r.roi,con,ro,rel,lcl,i .enabl lsb gettyp:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address in r1 mov #err,r0 ; assume error bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; file open? bne 100$ ; NO mov #ascii,r0 ; assume character file bit #rf.chr,(r1) ; character file? bne 100$ ; YES mov #binary,r0 ; binary file 100$: mov r0,@type(ap) ; return in variable also return .end #-h- getuic.mac 196 asc 25-mar-82 06:59:20 v1.1 (sw-tools v1.1) .title getuic ; ; subroutine getuic(uic) ; ap=%5 uic=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getuic:: call .rdfui ; get default file uic mov r1,@uic(ap) ; return to user return .end #-h- glocnm.mac 1152 asc 25-mar-82 06:59:21 v1.1 (sw-tools v1.1) .title glocnm - generate local name from name block ;+ ; subroutine glocnm(int, buf) ;- .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ap=%5 int=2 buf=4 glocnm:: clrb @buf(ap) ; assume error mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address bcs 100$ ; c set => invalid unit call r$clsf ; close the file mov r.fdb(r1),r3 ; FDB address mov r3,r4 ; generate name block address add #f.fnb,r4 ; ... mov buf(ap),r0 ; output buffer address movb n.dvnm(r4),(r0)+ ; copy device name movb n.dvnm+1(r4),(r0)+ ; ... movb n.unit(r4),r1 ; unit number call r$btoo ; format in octal movb #':,(r0)+ ; separator mov r0,-(sp) ; save buffer address mov r3,r1 ; FDB address in r1 call r$guic ; ask ACP for UIC mov r0,r3 ; place UIC in reg mov (sp)+,r0 ; restore buffer address bcs 50$ ; c set => error in ACP qio mov r0,r2 ; buffer address mov r4,-(sp) ; save FNB address clr r4 ; no leading zeroes in UIC call .ppasc ; format uic mov r2,r0 ; put buffer address back mov (sp)+,r1 ; need name block in r1 call r$cvtf ; fetch file name 50$: clrb (r0) ; terminate with EOS 100$: return .end #-h- gtmode.mac 461 asc 25-mar-82 06:59:22 v1.1 (sw-tools v1.1) .title gtmode ;+ ; integer function gtmode(int) ;- ap=%5 int=2 cooked=0 raw=1 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb gtmode:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address mov #err,r0 ; assume ERROR bcs 100$ ; c set => invalid rat4 unit bit #rf.clo,(r1) ; file open? bne 100$ ; NO, ERROR mov #cooked,r0 ; assume COOKED bit #rf.raw,(r1) ; is it RAW? beq 100$ ; NO mov #raw,r0 ; return(RAW) 100$: return .end #-h- isatty.mac 435 asc 25-mar-82 06:59:23 v1.1 (sw-tools v1.1) .title isatty ;+ ; stat = isatty(int) ; ; status returns are YES/NO ;- ap=%5 int=2 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb isatty:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address mov #no,r0 ; assume not bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; is file open on unit? bne 100$ ; NO bit #rf.tty,(r1) ; is it a terminal? beq 100$ ; NO mov #yes,r0 ; return YES 100$: return .end #-h- lunsub.mac 1191 asc 25-mar-82 06:59:24 v1.1 (sw-tools v1.1) .title lunsub ;+ ; this pair of routines implement the following fortran interfaces ; ; integer function getlun() ; subroutine putlun(logical_unit) ; ; they permit the programmer to request free luns and to ; return them when he is done with them. The domain of these ; routines is the set of luns in the range [ 9 , .NLUNS ] ; where .NLUNS is the value given to TKB as UNITS=nnn ;- ap=%5 lun=2 err=-3 ; error return if no luns available ; ; lun = getlun() ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getlun:: r$glun:: call r$savr ; save all registers mov #9.,r0 ; starting lun number mov .nluns,r1 ; limiting event flag number mov #r$lunm,r2 ; address of lun mask mov #400,r3 ; initial mask bit call allbit ; get a free lun bcc 10$ ; c clear => successful mov #err,r0 ; return(ERR) 10$: mov r0,2(sp) ; cause value to be returned return ; ; subroutine putlun(lun) ; putlun:: mov @lun(ap),r0 ; get LUN to return r$plun:: call r$savr ; save all registers cmp r0,#9. ; can user free this lun? blt 20$ ; NO mov .nluns,r1 ; limiting LUN number mov #r$lunm,r2 ; starting address of mask mov #1,r3 ; initial mask bit call frebit ; free the bit 20$: return .end #-h- otoc.mac 1054 asc 25-mar-82 06:59:25 v1.1 (sw-tools v1.1) .title otoc ; ; this routine implements the following fortran interface ; ; length = otoc(n, buf, size) ; ; where n is the number to convert to octal characters ; buf is the array to hold the characters ; size is the size of the buffer ; ; the value of otoc is the length of the string ; ; this conversion is performed with the $cbomg entry ; point in syslib on IAS and RSX ; ap=%5 num=2 buf=4 siz=6 ; ; .psect $r.rwd,con,rw,rel,lcl,d locbuf: .blkb 8. ; local buffer to format into ; ; .psect $r.roi,con,ro,rel,lcl,i .enabl lsb otoc:: mov #locbuf,r0 ; buffer address in r0 mov @num(ap),r1 ; number to format clr r2 ; leading zeroes not wanted call $cbomg ; format number clrb (r0) ; terminate with EOS clr r0 ; initialize count mov #locbuf,r1 ; input buf in r1 mov buf(ap),r2 ; output buf in r2 mov @siz(ap),r3 ; size of string in r3 10$: movb (r1)+,(r2)+ ; copy character beq 20$ ; EOS => done inc r0 ; increment char count sob r3,10$ ; if room, do another 20$: clrb -(r2) ; backup and place EOS return .end #-h- prompt.mac 1870 asc 25-mar-82 06:59:26 v1.1 (sw-tools v1.1) .title prompt ;+ ; integer function prompt(pstr, buf, int) ;- ap=%5 pstr=2 buf=4 int=6 .psect $r.rwd,con,rw,rel,lcl,d secpmt: .ascii <15><12>" _" ; secondary prompt string .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb prompt:: mov ap,-(sp) ; save argument pointer sub #6,sp ; build Fortran call block on stack mov #2,(sp) ; number of arguments to getlin mov int(ap),4(sp) ; address of int mov @int(ap),r0 ; rat4 unit call r$gfbk ; get RFDB address in r1 mov #eof,r0 ; assume error bcs 100$ ; invalid rat4 unit bit #rf.tty,(r1) ; is this a terminal unit? beq 90$ ; NO, just do a getlin inc (sp) ; 3 args to getlin for continuation mov @int(ap),r1 ; lun to use tstb @pstr(ap) ; null prompt string? beq 90$ ; YES, just do a getlin mov pstr(ap),r3 ; initialize starting address of prompt mov sp,ap ; set up arg ptr for r$rput 10$: mov #secpmt,r2 ; CR-LF address mov #2,r0 ; 2 characters to write call r$rput ; write them to tty clr r0 ; initialize count mov r3,r2 ; starting address of prompt 20$: cmpb #newlin,(r3) ; NEWLINE character? beq 30$ ; YES, write buffer tstb (r3) ; at end of prompt? beq 30$ ; YES, write buffer inc r0 ; increment character count inc r3 ; address of next character br 20$ ; do again 30$: tst r0 ; any characters to write? beq 35$ ; NO call r$rput ; write them to tty 35$: tstb (r3) ; end of prompt string? beq 40$ ; YES, do getlin inc r3 ; bump past NEWLINE br 10$ ; try again 40$: mov 6(sp),ap ; restore arg pointer 90$: cmp #3,(sp) ; three args? bne 95$ ; NO movb @pstr(ap),secpmt+2 ; copy first character of prompt mov #secpmt,6(sp) ; address of prompt string 95$: mov buf(ap),2(sp) ; buffer for getlin mov sp,ap ; arg pointer for getlin call getlin ; get the next line 100$: add #10,sp ; restore stack return .end #-h- ptrcpy.mac 334 asc 25-mar-82 06:59:28 v1.1 (sw-tools v1.1) .title ptrcpy ;+ ; subroutine ptrcpy(in, out) ;- ap=%5 in=2 out=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ptrcpy:: mov in(ap),r0 ; address of in linepointer mov out(ap),r1 ; address of out linepointer mov (r0)+,(r1)+ ; copy first word beq 10$ ; if == 0, NULLPOINTER mov (r0),(r1) ; copy second word 10$: return .end #-h- ptreq.mac 430 asc 25-mar-82 06:59:28 v1.1 (sw-tools v1.1) .title ptreq ;+ ; integer function ptreq(ptr1, ptr2) ;- ap=%5 ptr1=2 ptr2=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ptreq:: mov ptr1(ap),r1 ; address of linepointer mov ptr2(ap),r2 ; ... mov #no,r0 ; assume unequal cmp (r1),(r2)+ ; first word equal? bne 20$ ; NO tst (r1)+ ; NULLPOINTER? beq 10$ ; YES cmp (r1),(r2) ; second word equal? bne 20$ ; NO 10$: mov #yes,r0 ; return YES 20$: return .end #-h- rcvdat.mac 845 asc 25-mar-82 06:59:29 v1.1 (sw-tools v1.1) .title rcvdat ; ; this routine performs a receive data or stop; if the task is stopped ; and then unstopped, it performs a receive data to fetch the message ; which caused it to be unstopped ; call with the following interface ; ; subroutine rcvdat([task], buffer) ; .mcall rcst$s,rcvd$s ap=%5 tsk=2 buf=4 .psect $r.rod,con,ro,rel,lcl,d dumtsk: .word 0,0 ; dummy task name to use if user omits it .psect $r.roi,con,ro,rel,lcl,i .enabl lsb rcvdat:: mov tsk(ap),r1 ; move address of task field into r0 cmp #-1,r1 ; see if user left it blank bne 10$ ; if !=, then user supplied task name mov #dumtsk,r1 ; place null task name address into r0 10$: rcst$s r1,buf(ap) ; receive data or stop cmp $dsw,#is.suc ; received data? beq 20$ ; YES rcvd$s r1,buf(ap) ; get data which unstopped us 20$: mov $dsw,r0 ; return dsw return .end #-h- rcvtf.mac 1165 asc 25-mar-82 06:59:30 v1.1 (sw-tools v1.1) .title r$cvtf ;+ ; this routine converts the file spec found in the FNB pointed ; to by r1 into the buffer pointed to by r0. r0 is left pointing ; at the next free location in the buffer. All blanks are squeezed ; out of the name ; ; all other registers remain constant across the call ;- ap=%5 .psect $r.rod,con,ro,rel,lcl,d .enabl lc fmtfil: .asciz "%3r.%r;%o" .even .dsabl lc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$cvtf:: call r$savr ; save r0-r5 mov r1,r2 ; address of version number add #n.fver,r2 mov r2,-(sp) mov r1,r2 ; address of file type add #n.ftyp,r2 mov r2,-(sp) mov r1,r2 ; address of file name add #n.fnam,r2 mov r2,-(sp) mov #fmtfil,-(sp) ; address of format string mov r0,-(sp) ; address of user buffer clr -(sp) ; dummy arg count mov sp,ap ; set up arg pointer call sprint ; format name add #12.,sp ; clean up stack mov r0,r1 ; starting address - squeeze blanks 10$: movb (r1)+,r2 ; get next char beq 20$ ; done cmpb r2,#' ; BLANK? beq 10$ ; YES movb r2,(r0)+ ; copy into lower portion of buffer br 10$ ; do again 20$: clrb (r0) ; EOS mov r0,2(sp) ; saved r0 return .end #-h- readf.mac 1004 asc 25-mar-82 06:59:31 v1.1 (sw-tools v1.1) .title readf ;+ ; integer function readf(buf, n, int) ; ; character buf(n) ; integer n, int ; ; this routine reads the next n bytes, or the number of bytes in the ; next record. It returns as its value the number of bytes ; actually read ; ; If an error occurs or an EOF is sensed, EOF is returned. ; ap=%5 buf=2 n=4 int=6 .mcall get$ .psect $r.roi,con,ro,rel,lcl,i .enabl lsb readf:: mov @int(ap),r0 ; ratfor unit number call r$gfbk ; get RFDB address into r1 bcs 10$ ; c set => invalid unit bit #rf.clo,(r1) ; is the file open? bne 10$ ; NO bit #rf.raw,(r1) ; raw terminal? beq 5$ ; NO mov @n(ap),r0 ; number of characters to read mov @int(ap),r1 ; lun to use mov buf(ap),r2 ; address of buffer call r$rget ; perform raw read of terminal return ; number of characters in r0 5$: get$ r.fdb(r1),buf(ap),@n(ap) ; read the next record bcs 10$ ; c set => error mov f.nrbd(r0),r0 ; return number of bytes read return 10$: mov #eof,r0 ; return(EOF) return .end #-h- remark.mac 592 asc 25-mar-82 06:59:32 v1.1 (sw-tools v1.1) .title remark ;+ ; subroutine remark(buf) ; ; alternate entry point ; subroutine putlnl(buf, int) ; ;- ap=%5 buf=2 int=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb remark:: mov r$erdb,r1 ; ERROUT RFDB address br r$rmrk ; putlnl:: mov @int(ap),r0 ; rat4 unit call r$gfbk ; get RFDB address in r1 bcs 20$ ; c set => invalid unit r$rmrk:: call r$lput ; put the line tstb @buf(ap) ; was the buffer empty? beq 10$ ; YES tst r.byte(r1) ; any bytes left in buffer? beq 20$ ; NO 10$: mov #newlin,r3 ; NEWLINE to flush buffer call r$cput ; flush it 20$: return .end #-h- rguic.mac 1005 asc 25-mar-82 06:59:33 v1.1 (sw-tools v1.1) .title r$guic - get uic associated with open file ;+ ; jsr pc,r$guic ; ; inputs: ; r1 FDB address of open file ; ; outputs: ; r0 binary UIC value ; c bit set if error ; c bit clear is success ; all other registers are maintained across the call ;- .mcall qiow$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb r$guic:: jsr r5,.savr1 ; save all regs but r0 clr -(sp) ; make space for UIC mov sp,r4 ; save address clr -(sp) ; end of attribute list mov r4,-(sp) ; address of buffer to receive UIC mov (pc)+,-(sp) ; read UIC .byte -1,2 mov sp,r3 ; address of control block movb f.lun(r1),r2 ; lun add #f.fnb+n.did,r1 ; address of DID qiow$s #io.rat,r2,r$ioef,,#r$iosb,, ; read UIC bcs 30$ ; c set => error tstb r$iosb ; check for error blt 30$ ; YES mov (r4),r0 ; place UIC value in r0 clc ; c clear => success br 40$ 30$: sec ; c bit set => failure 40$: rol r1 ; save c bit in r1 add #10,sp ; restore stack ror r1 ; restore c bit return .end #-h- rxtra.mac 1336 asc 25-mar-82 06:59:34 v1.1 (sw-tools v1.1) .title r$xtra ;+ ; these routines provide additional entry points ; for opening and closing files ;- ap=%5 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ; ; integer function openf(buf, access, fdb) ; buf=2 access=4 fdb=6 openf:: cmp #read$r,@access(ap) ; READ access? bne 5$ ; NO call open ; open the file br 6$ 5$: call create ; create the file 6$: cmp r0,#err ; error? beq 10$ ; YES call r$gfbk ; get RFDB address in r1 mov r1,@fdb(ap) ; return RFDB address 10$: return ; ; subroutine closef(fdb) ; fdb=2 closef:: mov @fdb(ap),r1 ; RFDB address in r1 call r$clsf ; close the file return ; ; integer function gets(fdb, buf, siz) ; fdb=2 buf=4 siz=6 .mcall get$ gets:: mov @fdb(ap),r1 ; RFDB address get$ r.fdb(r1),buf(ap),@siz(ap) ; get next record bcs 20$ ; c set => error or EOF mov f.nrbd(r0),r0 ; return bytes read br 30$ 20$: mov #eof,r0 ; return EOF 30$: return ; ; integer function getfdb(int) ; int=2 getfdb:: mov @int(ap),r0 ; ratfor unit number == lun call r$gfbk ; get rfdb address in r1 mov #err,r0 ; assume error bcs 40$ ; c set => YES mov r1,r0 ; return RFDB address 40$: return ; ; subroutine puts(fdb, buf, cnt) ; fdb=2 buf=4 cnt=6 .mcall put$ puts:: mov @fdb(ap),r1 ; RFDB address put$ r.fdb(r1),buf(ap),@cnt(ap) ; put the record return .end #-h- sdat.mac 199 asc 25-mar-82 06:59:35 v1.1 (sw-tools v1.1) .title sdat ;+ ; integer function sdat(proces, buf) ;- ap=%5 proces=2 buf=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb .mcall sdat$s sdat:: sdat$s proces(ap),buf(ap) mov @#$dsw,r0 return .end #-h- seek.mac 511 asc 25-mar-82 06:59:36 v1.1 (sw-tools v1.1) .title seek ;+ ; subroutine seek(addres, int) ;- ap=%5 addres=2 int=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb seek:: mov @int(ap),r0 ; rat4 unit call r$gfbk ; get RFDB address in r1 bcs 100$ ; c set => invalid unit number bit #rf.clo,(r1) ; file open? bne 100$ ; NO mov r.fdb(r1),r0 ; FDB address mov addres(ap),r1 ; address of user RFA mov (r1)+,r2 ; store RFA in regs for .point mov (r1),r3 ; ... clr r1 ; no high block address call .point ; position file 100$: return .end #-h- sleep.mac 584 asc 25-mar-82 06:59:37 v1.1 (sw-tools v1.1) .title sleep ;+ ; subroutine sleep(seconds) ; ; this routine gets a free event flag from the pool, sets up a mark ; time for that many seconds, and stops until the event flag becomes ; set ;- ap=%5 sec=2 .mcall mrkt$s,stse$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb sleep:: mov @sec(ap),r1 ; number of seconds to wait ble 20$ ; if <= 0, return call r$gefn ; get a free event flag mrkt$s r0,r1,#2 ; set up mark time bcs 10$ ; c set => ugly error stse$s r0 ; wait for event flag 10$: call r$pefn ; return event flag 20$: mov #ok,r0 ; return(OK) return .end #-h- sndarg.mac 2049 asc 25-mar-82 06:59:38 v1.1 (sw-tools v1.1) .title sndarg ;+ ; integer function sndarg(buf, pid) ;- .if ndf SRDRV .psect $r.rod,con,ro,rel,lcl,d accs: .word writ$r ; access for CREATE seed: .asciz "arg" ; seed for fgenr8 call .even .psect $$iob1,ovr,rw,rel,lcl,d prot: .blkw 1 ; hold the current default file prot file: .blkb 40. ; space for arg file name .even .endc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ap=%5 buf=2 pid=4 sndarg:: .if df SRDRV .mcall qiow$s,alun$s mov pid(ap),r0 ; address of pid sub #4,sp ; space for rad50 taskname mov sp,r1 ; address in r1 call r$rad5 ; convert taskname to rad50 mov #err,r0 ; assume error mov (sp)+,r2 ; low half in r2 mov (sp)+,r3 ; high half in r3 bcs 100$ ; c set => error in conversion alun$s r$endl,#"SR,#0 ; assign lun to sr: bcs 90$ ; c set => error mov buf(ap),r1 ; address of buffer clr r0 ; initialize count 10$: tstb (r1)+ ; EOS yet? beq 20$ ; YES inc r0 ; increment count br 10$ 20$: qiow$s #io.wlb,r$endl,r$spef,,#r$iosb,, bcs 90$ ; c set => error movb r$iosb,r0 ; copy return status br 100$ 90$: mov @#$dsw,r0 ; return DSW 100$: .iff mov ap,-(sp) ; save arg pointer mov #file,-(sp) ; address of filename buffer mov #seed,-(sp) ; address of seed mov pid(ap),-(sp) ; address of pid mov #3,-(sp) ; arg count mov sp,ap ; arg pointer for fgenr8 call fgenr8 ; call fgenr8(pid, seed, file) add #8.,sp ; clean stack call .rdffp ; get def file prot mov r1,prot ; save it for later clr r1 ; [RWED,RWED,RWED,RWED] call .wdffp ; ... mov #accs,-(sp) ; access mov #file,-(sp) ; file clr -(sp) ; dummy arg count mov sp,ap ; arg pointer for create call create ; int = create(file, accs) add #6,sp ; clean stack mov (sp)+,ap ; restore arg pointer cmp r0,#err ; ERROR? beq 50$ ; YES call r$lput ; lput(buf) call r$clsf ; close the file mov #is.suc,r0 ; successful br 60$ 50$: mov #ie.eof,r0 ; error 60$: mov prot,r1 ; restore def file prot call .wdffp ; ... .endc return .end #-h- spwsub.mac 538 asc 25-mar-82 06:59:39 v1.1 (sw-tools v1.1) .title spwsub ;+ ; these routines set and clear the name of the foreground process ; in r$fgpc ;- .mcall dsar$s,enar$s .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ; ; subroutine setfgd(buf) ; ap=%5 buf=2 setfgd:: dsar$s ; disable AST recognition mov buf(ap),r0 ; source string mov #r$fgpc,r1 ; destination address 10$: movb (r0)+,(r1)+ ; copy character bne 10$ ; if not EOS, do again enar$s ; enable AST recognition return ; ; subroutine clrfgd() ; clrfgd:: clrb r$fgpc ; no foreground process active return .end #-h- srda.mac 1126 asc 25-mar-82 06:59:40 v1.1 (sw-tools v1.1) .title srda .mcall gtsk$s, srda$s, ustp$s, astx$s ap=%5 ; argument pointer new=2 ; offset from ap for new ast address old=4 ; same for old .psect $r.rwd,con,rw,rel,lcl,d task: .word 0,0 ; storage for task name curast: .word 0 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb srda:: tst task ; have we done GTSK yet? bne 10$ ; yes we have sub #32.,sp ; space for GTSK mov sp,r0 ; address of buffer gtsk$s r0 ; get current task name in buf mov (r0)+,task ; copy taskname into local storage mov (r0),task+2 ; ... add #32.,sp ; restore stack 10$: mov @new(ap),r0 ; get new ast address bne 20$ ; if != 0, user specified address mov #cntast,r0 ; user wishes unstop ast 20$: mov curast,@old(ap) ; return old ast address mov r0,curast ; save curent ast address srda$s r0 ; establish new ast return crda:: mov @new(ap),r0 ; get new ast address mov r0,curast ; update current ast address beq 30$ ; if == 0, turn off ast's srda$s r0 ; re-establish old ast address br 40$ 30$: srda$s ; turn off ast's 40$: return cntast: ustp$s #task ; unstop current task astx$s ; dismiss current ast .end #-h- stddev.mac 715 asc 25-mar-82 06:59:41 v1.1 (sw-tools v1.1) .title stddev ;+ ; subroutine stddev(buf) ;- ap=%5 buf=2 ; .psect $r.rod,con,ro,rel,lcl,d asn: .asciz "asn " eqs: .asciz "=sy:" .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ; ; stddev:: sub #20.,sp ; space for MCR line mov sp,r2 ; address of MCR buffer mov r2,r1 ; destination address mov #asn,r0 ; source call copy ; copy it mov buf(ap),r0 ; source call copy ; copy it mov #eqs,r0 ; source call copy ; copy it mov r2,r1 ; address of MCR line call r$spwn ; spawn it to MCR add #20.,sp ; restore stack return ; ; ; routine to concatenate strings ; ; copy: movb (r0)+,(r1)+ ; copy character bne copy ; if not EOS, go again tstb -(r1) ; back up to EOS return .end #-h- stddir.mac 1221 asc 25-mar-82 06:59:42 v1.1 (sw-tools v1.1) .title stddir ;+ ; subroutine stddir(buf, desc) ;- ap=%5 buf=2 desc=4 .psect $r.rwd,con,rw,rel,lcl,d set: .ascii "set /uic=" uic: .blkb 10. .even .psect $r.roi,con,ro,rel,lcl,i .enabl lsb stddir:: mov #r$ddir,r3 ; address of buffer for storage mov buf(ap),r2 ; source address 10$: movb (r2)+,(r3)+ ; copy character bne 10$ ; if not EOS, do next char movb r$ddir+1,r1 ; first character of directory cmpb r1,#'0 ; see if [g,m] blt 20$ ; NO cmpb r1,#'7 ; ... bgt 20$ ; NO mov buf(ap),r2 ; source address mov #r$duic,r3 ; destination address 15$: movb (r2)+,(r3)+ ; copy character bne 15$ ; while not EOS, do again br 50$ 20$: mov @desc(ap),r1 ; RFDB address mov r.fdb(r1),r1 ; FDB address call r$guic ; ask ACP for UIC mov r0,r3 ; place returned value in r3 bcc 40$ ; c clear => success mov #177400,r3 ; default to [377,0] 40$: mov #r$duic,r2 ; address to receive uic clr r4 ; desire separators, no leading 0's call .ppasc ; format UIC clrb (r2) ; terminate string 50$: mov #r$duic,r0 ; address of uic string mov #uic,r1 ; destination address 60$: movb (r0)+,(r1)+ bne 60$ mov #set,r1 ; address of MCR command call r$spwn ; spawn it return .end #-h- stmode.mac 688 asc 25-mar-82 06:59:43 v1.1 (sw-tools v1.1) .title stmode ;+ ; integer function stmode(int, mode) ;- ap=%5 int=2 mode=4 cooked=0 raw=1 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb stmode:: mov @int(ap),r0 ; rat4 unit number call r$gfbk ; get RFDB address mov #err,r0 ; assume ERROR bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; is unit open? bne 100$ ; NO, error mov #cooked,r0 ; assume COOKED cmp @int(ap),#errout ; is this ERROUT? beq 100$ ; YES, cannot reset ERROUT bic #rf.raw,(r1) ; assume COOKED cmp #raw,@mode(ap) ; is mode == RAW? bne 100$ ; NO bit #rf.tty,(r1) ; is unit to a terminal? beq 100$ ; NO bis #rf.raw,(r1) ; set unit to raw mode mov #raw,r0 ; ... 100$: return .end #-h- stspwn.mac 1225 asc 25-mar-82 06:59:44 v1.1 (sw-tools v1.1) .title stspwn ;+ ; integer function stspwn(buf) ; ; this routine spawns the command line found in buf to MCR... and ; waits for it's completion. Either the DSW or the final status ; of the offspring task is returned ; ; r$spwn ; this routine spawns the command line found in r1 to MCR... and ; waits for it. Either the directive status word or the first ; word of the error status block is returned in r0. ;- .mcall spwn$s,stse$s .psect $r.rod,con,ro,rel,lcl,d mcr: .rad50 /MCR.../ .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ap=%5 buf=2 stspwn:: mov buf(ap),r1 ; place buffer address in r1 r$spwn:: mov r2,-(sp) ; save register used mov r1,-(sp) ; save buffer address mov #-1,r0 ; initialize counter 10$: inc r0 ; increment counter tstb (r1)+ ; at end of string yet? bne 10$ ; NO mov (sp)+,r1 ; restore r1 sub #16.,sp ; space for error status block mov sp,r2 ; address of error status block spwn$s #mcr,,,,,r$spef,,r2,r1,r0,#0 ; spawn task bcs 30$ ; c set => error stse$s r$spef ; stop for event flag mov (r2),r0 ; return status br 40$ 30$: mov @#$dsw,r0 ; return directive status word 40$: add #16.,sp ; remove error block from stack mov (sp)+,r2 ; restore r2 return .end #-h- writef.mac 935 asc 25-mar-82 06:59:45 v1.1 (sw-tools v1.1) .title writef ;+ ; integer function writef(buf, n, int) ; ; character buf(n) ; integer n, int ; ; this routine writes the n bytes from the buffer buf to the file ; int. It returns as its value the number of bytes written, or ; ERR if an error occurs during the write. ;- ap=%5 buf=2 n=4 int=6 .mcall put$ .psect $r.roi,con,ro,rel,lcl,i .enabl lsb writef:: mov @int(ap),r0 ; ratfor unit number call r$gfbk ; get RFDB address into r1 bcs 10$ ; c set => invalid unit bit #rf.clo,(r1) ; is the file open? bne 10$ ; NO bit #rf.tty,(r1) ; is this a terminal unit? beq 5$ ; NO mov @n(ap),r0 ; set regs for rput call mov @int(ap),r1 ; ... mov buf(ap),r2 ; ... call r$rput ; write buffer to tty br 7$ ; finish up 5$: put$ r.fdb(r1),buf(ap),@n(ap) ; write the next record bcs 10$ ; c set => error 7$: mov @n(ap),r0 ; return number of bytes written return 10$: mov #err,r0 ; return(ERR) return .end #-h- system.mac 654 asc 25-mar-82 06:59:46 v1.1 (sw-tools v1.1) .title system ;+ ; integer function system(buf) ; ; this routine spawns the command line found in buf to MCR... ; This task will not wait for the child to complete ; The DSW of the system call is returned ; ;- .mcall spwn$s .psect $r.rod,con,ro,rel,lcl,d mcr: .rad50 /MCR.../ .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ap=%5 buf=2 system:: mov buf(ap),r1 ; place buffer address in r1 mov #-1,r0 ; initialize counter 10$: inc r0 ; increment counter tstb (r1)+ ; at end of string yet? bne 10$ ; NO mov buf(ap),r1 ; address of buffer spwn$s #mcr,,,,,,,,r1,r0,#0 ; spawn task mov @#$dsw,r0 ; return directive status word return .end #-h- note.mac 625 asc 25-mar-82 06:59:47 v1.1 (sw-tools v1.1) .title note ;+ ; integer function note(addres, int) ; ; returns OK/ERR depending upon success/failure ;- ap=%5 addres=2 int=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb note:: mov @int(ap),r0 ; rat4 unit call r$gfbk ; RFDB address in r1 bcs 100$ ; c set => invalid unit bit #rf.clo,(r1) ; file open? bne 100$ ; NO mov r.fdb(r1),r0 ; FDB address call .mark ; retrieve next RFA mov addres(ap),r1 ; user's buffer address mov r2,(r1)+ ; return low block address mov r3,(r1) ; and byte offset mov #ok,r0 ; return(OK) br 110$ ; return to user 100$: mov #err,r0 ; return(ERR) 110$: return .end #-h- lib.m 6606 asc 25-mar-82 07:04:47 v1.1 (sw-tools v1.1) #-h- clower.mac 601 asc 25-mar-82 07:00:48 v1.1 (sw-tools v1.1) .title clower ; ; this routine implements the following fortran interface ; ; c = clower(x) ; ; where c and x are both logical*1 variables ; ; if x is in the range A-Z, the lower case equivalent is returned. If not ; the character is returned ; ap=%5 x=2 BIGA=101 BIGZ=132 LETA=141 LETZ=172 DIF=LETA-BIGA MASK=177 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb clower:: movb @x(ap),r0 ; place character in r0 cmpb r0,#BIGA&MASK ; see if >= A blt 10$ ; if <, then return cmpb r0,#BIGZ&MASK ; see if <= Z bgt 10$ ; if >, then return add #DIF,r0 ; add 40(8) to character 10$: return .end #-h- concat.mac 647 asc 25-mar-82 07:00:49 v1.1 (sw-tools v1.1) .title concat ; ; this routine implements the following fortran interface ; ; call concat(a, b, c) ; ; where a and b are EOS-terminated strings. a and b will be concatenated ; into c. a and c can be the same variables. ; ap=%5 a=2 b=4 c=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb concat:: mov a(ap),r0 ; address of a(1) in r0 mov c(ap),r1 ; address of c(1) in r1 10$: movb (r0)+,(r1)+ ; copy this character bne 10$ ; while != EOS(0), do next one tstb -(r1) ; backup to EOS character in c mov b(ap),r0 ; address of b(1) in r0 20$: movb (r0)+,(r1)+ ; copy this character bne 20$ ; while != EOS(0), do next one return .end #-h- cupper.mac 608 asc 25-mar-82 07:00:49 v1.1 (sw-tools v1.1) .title cupper ; ; this routine implements the following fortran interface ; ; c = cupper(x) ; ; where c and x are both logical*1 variables ; ; if x is in the range a-z, the upper case equivalent is returned. If not ; the character is returned ; ap=%5 x=2 BIGA=101 BIGZ=132 LETA=141 LETZ=172 DIF=LETA-BIGA MASK=177 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb cupper:: movb @x(ap),r0 ; place character in r0 cmpb r0,#LETA&MASK ; see if >= a blt 10$ ; if <, then return cmpb r0,#LETZ&MASK ; see if <= z bgt 10$ ; if >, then return sub #DIF,r0 ; subtract 40(8) from character 10$: return .end #-h- impath.mac 963 asc 25-mar-82 07:00:50 v1.1 (sw-tools v1.1) .title impath ;+ ; subroutine impath(path) ;- .psect $r.rod,con,ro,rel,lcl,d .enabl lc spath: .asciz "~usr/" .asciz "~bin/" .byte 12,0 spathl=.-spath .even .dsabl lc .psect $r.roi,con,ro,rel,lcl,i .enabl lsb ap=%5 path=2 impath:: mov path(ap),r0 ; destination array address clrb (r0)+ ; EOS => search cwd first mov #path,-(sp) ; want home directory in path format mov sp,r1 ; address of variable mov r1,-(sp) ; address of format variable mov r0,-(sp) ; address to place home directory in mov #2,-(sp) ; one argument mov sp,ap ; set up argument pointer jsr pc,homdir ; fetch home directory tst (sp)+ ; remove argument count mov (sp)+,r0 ; address of start of home directory cmp (sp)+,(sp)+ ; pop temporaries off stack 20$: tstb (r0)+ ; at EOS yet? bne 20$ ; NO mov #spath,r1 ; source array address mov #spathl,r2 ; length of array 10$: movb (r1)+,(r0)+ ; copy next character sob r2,10$ ; do again return .end #-h- indexs.mac 1294 asc 25-mar-82 07:00:51 v1.1 (sw-tools v1.1) .title indexs ; ; this routine implements the following fortran interface ; ; i = indexs(lin, sub) ; ; where lin and sub are EOS-terminated strings ; ; if sub is found in lin, the column where it starts is returned as ; i; if not found, 0 is returned ; ap=%5 lin=2 sub=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb indexs:: matchc:: ; alternate entry point clr r0 ; initialize position in lin mov lin(ap),r1 ; address of lin(1) in r1 10$: inc r0 ; update position in lin mov r1,r2 ; place address of this position in r2 tstb (r1)+ ; see if at EOS(0) beq 20$ ; YES, lin is exhausted, return 0 mov sub(ap),r3 ; address of sub(1) in r3 call $match ; see if match bcc 30$ ; c clear => YES br 10$ ; try next position 20$: clr r0 ; no match, return 0 30$: return .page ; ; ; $match - see if match of strings ; ; called from macro routines via call $match ; ; inputs: ; r2 address of line to match ; r3 address of EOS(0)-terminated substring ; ; outputs: ; r2,r3 modified ; c set no match ; c clear match ; $match: tstb (r3) ; see if at EOS beq ccbit ; if so, clear c-bit cmpb (r2)+,(r3)+ ; compare characters beq $match ; if ==, then try next character sec ; set c bit indicating no match return ccbit: clc ; clear c bit indicating match return .end #-h- scopy.mac 617 asc 25-mar-82 07:00:52 v1.1 (sw-tools v1.1) .title scopy ; ; this routine provides the following fortran interface ; ; call scopy(in, i, out, j) ; ; where in is an EOS-terminated string ; ap=%5 in=2 i=4 out=6 j=10 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb scopy:: mov in(ap),r0 ; address of in(1) in r0 mov @i(ap),r1 ; value of i in r1 dec r1 ; now value of i-1 add r1,r0 ; r0 now has address of in(i) mov out(ap),r1 ; address of out(1) in r1 mov @j(ap),r2 ; value of j in r2 dec r2 ; now value of j-1 add r2,r1 ; r1 now has address of out(j) 10$: movb (r0)+,(r1)+ ; copy next byte bne 10$ ; if != 0, then do next byte return .end #-h- strcmp.mac 561 asc 25-mar-82 07:00:53 v1.1 (sw-tools v1.1) .title strcmp ;+ ; integer function strcmp(str1, str2) ;- ap=%5 str1=2 str2=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb strcmp:: mov str1(ap),r1 ; start of str1 mov str2(ap),r2 ; start of str2 clr r0 ; assume strings are equal 10$: cmpb (r1),(r2) ; characters equal? bne 20$ ; NO tstb (r1)+ ; at EOS? beq 100$ ; YES, return inc r2 ; bump to next character br 10$ ; try next character 20$: mov #-1,r0 ; assume str1 < str2 cmpb (r1),(r2) ; compare characters blt 100$ ; str1 < str2 mov #1,r0 ; return(+1) 100$: return .end #-h- upper.mac 731 asc 25-mar-82 07:00:54 v1.1 (sw-tools v1.1) .title upper ; ; this routine implements the following fortran interface ; ; call upper(buf) ; ; where buf is an EOS-terminated string ; ; upper crunches all characters in the range a-z into upper case ; ap=%5 buf=2 BIGA=101 BIGZ=132 LETA=141 LETZ=172 DIF=LETA-BIGA MASK=177 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb upper:: mov buf(ap),r1 ; address of buf(1) in r1 10$: movb (r1),r0 ; next character into r0 beq 20$ ; if == 0, then done cmpb r0,#LETA&MASK ; see if >= a blt 30$ ; if <, then copy character back cmpb r0,#LETZ&MASK ; see if <= z bgt 30$ ; if >, then copy character back sub #DIF,r0 ; subtract 40(8) from character 30$: movb r0,(r1)+ ; copy byte back into string br 10$ 20$: return .end #-h- prim.r 27198 asc 02-apr-82 08:18:16 v1.1 (sw-tools v1.1) #-h- amove 601 asc 25-mar-82 07:01:46 v1.1 (sw-tools v1.1) ## function amove -- rename files integer function amove(name1, name2) character name1(FILENAMESIZE), name2(FILENAMESIZE) integer open, old, new, create, rename, remove string start "Error removing file in amove: " old = open(name1, READ) if (old == ERR) amove = ERR else { new = create(name2, WRITE) if (new == ERR) { call close(old) amove = ERR } else { call fcopy(old, new) call close(old) call close(new) if (remove(name1) == ERR) { call putlin(start, ERROUT) call remark(name1) } amove = OK } } return end #-h- bckspn 793 asc 25-mar-82 07:01:47 v1.1 (sw-tools v1.1) integer function bckspn(image, args, pid) character image(FILENAMESIZE), args(ARGBUFSIZE), pid(PIDSIZE) real bspawn character file(FILENAMESIZE) integer ids, int, i, newast, oldast integer index, create, sdat string seed "bck" % data bspawn/6RBSPAWN/, newast/0/ % call scratf(seed, file) int = create(file, WRITE) if (int != ERR) { call putlnl(image, int) call putlnl(args, int) call trndev("SY", 0, pid) call putlnl(pid, int) call close(int) i = index(file, ']') + 1 call strcpy(file(i), file) call srda(newast, oldast) if (sdat(bspawn, file) != IS_SUC) int = ERR else { call rcvdat(bspawn, file) int = file(5) if (int == OK) call strcpy(file(6), pid) else int = ERR } call crda(oldast) } return(int) end #-h- cpybyt 197 asc 25-mar-82 07:01:48 v1.1 (sw-tools v1.1) subroutine cpybyt(in, out, n, trmn8r) character in(ARB), out(ARB), trmn8r integer n integer i for (i=1; i <= n; i=i+1) out(i) = in(i) if (trmn8r >= 0) out(i) = trmn8r return end #-h- ctoptr 139 asc 25-mar-82 07:01:49 v1.1 (sw-tools v1.1) subroutine ctoptr(buf, i, ptr) character buf(ARB) integer i, ptr(2) integer ctoi ptr(1) = ctoi(buf, i) ptr(2) = ctoi(buf, i) return end #-h- cwdir 435 asc 25-mar-82 07:01:49 v1.1 (sw-tools v1.1) integer function cwdir(strng) character strng(ARB), out(FILENAMESIZE), temp(12) integer i, opendr, desc call fxlate(strng, PATH, out) if (opendr(out, desc) != ERR) # see if directory exists { i = 1 call jcopys(out, i, ':', temp) call stddev(temp) # set default device call jcopys(out, i, ']', temp) call stddir(temp, desc) call closdr(desc) cwdir = OK } else cwdir = ERR return end #-h- decnfo 1699 asc 25-mar-82 07:01:50 v1.1 (sw-tools v1.1) define(IDOF,1) # h.idof + 1 define(RVDT,13) # i.rvdt + 1 define(CRDT,26) # i.crdt + 1 define(DATE_LENGTH,arith(CRDT,-,RVDT)) define(PROJ,10) # h.proj + 1 define(PROG,9) # h.prog + 1 define(FPRO,11) # h.fpro + 1 define(RTYP,15) # h.ufat + f.rtyp + 1 - record type define(RATT,16) # h.ufat + f.ratt + 1 - record attributes define(EFBH,23) # h.ufat + f.efbk + 1 - high order block number define(EFBL,25) # h.ufat + f.efbk + 2 - low order block number define(FFBY,27) # h.ufat + f.ffby + 1 - first free byte define(R_VAR,2) # r.var in f.rtyp field subroutine decnfo(dbuf, date, group, member, protec, bsize, csize, type) integer group, member, protec, bsize(2), csize(2), type, size(4) character date(ARB), dbuf(512) integer revise, idoff, temp call cpybyt(dbuf(IDOF), idoff, 1, 0) revise = 2 * idoff + RVDT call cpybyt(dbuf(revise), date, DATE_LENGTH, EOS) if (date(1) == 0) { revise = revise + DATE_LENGTH # point at creation date call cpybyt(dbuf(revise), date, DATE_LENGTH, EOS) } call cpybyt(dbuf(PROJ), group, 1, 0) call cpybyt(dbuf(PROG), member, 1, 0) call cpybyt(dbuf(FPRO), protec, 2, -1) call cpybyt(dbuf(EFBH), size(1), 1, 0) # high block # call cpybyt(dbuf(arith(EFBL,+,1)), size(2), 1, 0) # middle block # call cpybyt(dbuf(EFBL), size(3), 1, 0) # low block # call cpybyt(dbuf(FFBY), size(4), 2, -1) # free byte call filsiz(size, bsize, csize) # calculate sizes type = BINARY call cpybyt(dbuf(RTYP), temp, 1, 0) # get record type if (temp == R_VAR) # variable length rec { call cpybyt(dbuf(RATT), temp, 1, 0) # get record attr if (mod(temp, 4) != 0) # either CR | FTN type = ASCII } return end #-h- dnoise 298 asc 25-mar-82 07:01:51 v1.1 (sw-tools v1.1) # subroutine to strip out white noise (;1 and .;1) subroutine dnoise(file) character file(ARB) integer i integer index, equal i = index(file, ';') if (equal(file(i), ";1") == YES) { file(i) = EOS i = index(file, '.') if (file(i+1) == EOS) file(i) = EOS } return end #-h- enbint 308 asc 25-mar-82 07:01:52 v1.1 (sw-tools v1.1) subroutine enbint # character name(PIDSIZE) # integer newast, oldast # integer equal # # external ctcast # # string shl ".SH" # # call getpnm(name) # name(4) = EOS # call upper(name) # if (equal(name, shl) == YES) # { # call getadr(newast, ctcast) # call srda(newast, oldast) # } return end #-h- extpnm 953 asc 25-mar-82 07:01:53 v1.1 (sw-tools v1.1) subroutine extpnm(lin, task) character lin(ARB), task(PIDSIZE), term(10) integer j, i integer indexs, equal, length string tskequ "TASK=" string tskeql "task=" string run "RUN" string at "AT." j = indexs(lin, tskequ) if (j == 0) j = indexs(lin, tskeql) if (j > 0) { i = 1 for (j=j+5; lin(j) != EOS & lin(j) != '/' & i < PIDSIZE; j=j+1) call chcopy(lin(j), task, i) } else { for (i=1; i <= 3 & lin(i) != EOS; i=i+1) task(i) = lin(i) task(i) = EOS call upper(task) call trndev("ti", 0, term) j = 2 if (equal(task, run) == YES) { i = 1 j = 1 } else if (task(1) == '@@') { call strcpy(at, task) i = 4 } for ( ; term(j) != ':'; j=j+1) if (i == PIDSIZE) break else call chcopy(term(j), task, i) } for (i=length(task)+1; i < PIDSIZE; i=i+1) task(i) = ' ' task(i) = EOS call upper(task) return end #-h- fxlate 688 asc 25-mar-82 07:01:54 v1.1 (sw-tools v1.1) subroutine fxlate(in, type, out) integer i, j, length, realdv, type character in(ARB), out(ARB), temp(FILENAMESIZE) call restil(in, out) # resolve ~name stuff if (out(1) == '/') { j = 1 if (realdv(out) == YES) { for (i=2; out(i) != '/' & out(i) != EOS; i=i+1) call chcopy(out(i), temp, j) call chcopy(':', temp, j) } else i = 1 if (out(i) == '/') { call chcopy('[', temp, j) for (i=i+1; out(i) != '/' & out(i) != EOS; i=i+1) call chcopy(out(i), temp, j) call chcopy(']', temp, j) if (out(i) == '/') call stcopy(out, i+1, temp, j) } temp(j) = EOS } else call strcpy(out, temp) call resdef(temp, type, out) return end #-h- gdraux 375 asc 25-mar-82 07:01:55 v1.1 (sw-tools v1.1) subroutine gdraux(desc, file, aux, date, fmt) integer desc, i character file(ARB), aux(ARB), date(ARB) integer f11hdr character hbuf(512) if (f11hdr(desc, hbuf) == ERR) { call scopy("Read access violation!", 1, aux, 1) for (i=1; i <= TCOLWIDTH; i=i+1) date(i) = ' ' date(i) = EOS } else call getaux(hbuf, file, aux, date, fmt) return end #-h- gdrprm 233 asc 25-mar-82 07:01:56 v1.1 (sw-tools v1.1) integer function gdrprm(desc, file) character file(ARB) integer desc integer dfind if (dfind(desc, file) == EOF) gdrprm = EOF else { call dnoise(file) # eliminate white noise gdrprm = OK } return end #-h- genpnm 706 asc 25-mar-82 07:01:56 v1.1 (sw-tools v1.1) integer function genpnm(pid) character parent(PIDSIZE), pid(PIDSIZE) integer init, spstat data init/YES/ if (init == YES) { init = NO call getpnm(parent) if ((parent(1) == '$' | parent(1) == '.') & parent(2) != parent(1)) { if (parent(6) >= '9') spstat = ERR else { spstat = OK parent(6) = parent(6) + 1 } } else { call trndev("TI", 0, parent) # get terminal name parent(2) = parent(1) # first char of terminal name parent(1) = '$' # place $ in first character if (parent(4) == ':') { parent(4) = parent(3) parent(3) = '0' } call strcpy(".1", parent(5)) spstat= OK } } call strcpy(parent, pid) return(spstat) end #-h- getaux 2031 asc 25-mar-82 07:01:58 v1.1 (sw-tools v1.1) subroutine getaux(hbuf, file, aux, date, fmt) character hbuf(512), file(ARB), aux(ARB), date(ARB), fmt(ARB) integer group, member, protec, type, bsize(2), csize(2) character prostr(15), idate(14), datstr(21), temp(MAXCHARS), c character clower integer i, j, w, n integer ctoi, ditoc string ascstr "asc" string binstr "bin" call decnfo(hbuf, idate, group, member, protec, bsize, csize, type) call fmtpro(protec, prostr) # format protection mask call frmdat(idate, datstr) # format modification date call srttim(idate, date) # sortable date string call fmtuic(group, member, idate) # determine owner call resuic(idate, hbuf) # ... # # now format the sucker # aux(1) = EOS for ([i=1; j=1]; fmt(i) != EOS; i=i+1) { if (IS_DIGIT(fmt(i))) w = ctoi(fmt, i) else w = 0 if (fmt(i) == EOS) break c = clower(fmt(i)) select (c) { case 'b': # size in blocks { for (n=ditoc(bsize, temp, MAXCHARS); n < w; n=n+1) call chcopy(' ', aux, j) call stcopy(temp, 1, aux, j) } case 'c': # size in characters { for (n=ditoc(csize, temp, MAXCHARS); n < w; n=n+1) call chcopy(' ', aux, j) call stcopy(temp, 1, aux, j) } case 'm': # modification date call stcopy(datstr, 1, aux, j) case 'n': # filename { for (n=1; file(n) != EOS; n=n+1) call chcopy(file(n), aux, j) while (n <= w) { call chcopy(' ', aux, j) n = n + 1 } } case 'o': # owner name { for (n=1; hbuf(n) != EOS; n=n+1) call chcopy(hbuf(n), aux, j) while (n <= w) { call chcopy(' ', aux, j) n = n + 1 } } case 'p': # protection mask call stcopy(prostr, 1, aux, j) case 't': # file type if (type == ASCII) call stcopy(ascstr, 1, aux, j) else call stcopy(binstr, 1, aux, j) default: # copy anything else call chcopy(fmt(i), aux, j) } } call fold(aux) return end #-h- gwdir 230 asc 25-mar-82 07:01:59 v1.1 (sw-tools v1.1) subroutine gwdir(buf, dtype) character buf(ARB) integer dtype, i, length call trndev("SY", 0, buf) i = length(buf) + 1 call gtddir(buf(i), dtype) if (dtype == PATH) call mkpath(buf, buf) call fold(buf) return end #-h- homdir 581 asc 25-mar-82 07:01:59 v1.1 (sw-tools v1.1) subroutine homdir(home, dtype) character home(ARB), temp(15) integer i, grp, mem, dtype, j integer length call trndev("ho", 0, temp) if (temp(1) == EOS) call trndev("sy", 0, temp) call fold(temp) i = length(temp) + 1 call getuid(grp, mem) call fmtuic(grp, mem, temp(i)) if (dtype == LOCAL) call strcpy(temp, home) else { j = 1 call chcopy('/', home, j) for (i=1; temp(i) != ':'; i=i+1) call chcopy(temp(i), home, j) call chcopy('/', home, j) for (i = i + 2; temp(i) != ']'; i=i+1) call chcopy(temp(i), home, j) call chcopy('/', home, j) } return end #-h- intsrv 81 asc 25-mar-82 07:02:00 v1.1 (sw-tools v1.1) subroutine intsrv integer junk integer kill junk = kill(EOS) return end #-h- itocf 254 asc 25-mar-82 07:02:01 v1.1 (sw-tools v1.1) integer function itocf(n, w, fc, buf, size) character buf(ARB), fc, temp(20) integer w, size, m, itoc, i, length, n m = w - itoc(n, temp, 20) for (i=1; i <= m; i=i+1) buf(i) = fc call scopy(temp, 1, buf, i) itocf = length(buf) return end #-h- jcopys 310 asc 25-mar-82 07:02:02 v1.1 (sw-tools v1.1) # subroutine jcopys(strng, i, c, out) # # character strng(ARB), out(ARB), c # integer i, j # # for (j=1; strng(i) != c & strng(i) != EOS; j=j+1) # { # out(j) = strng(i) # i = i + 1 # } # if (strng(i) == c) # { # out(j) = c # j = j + 1 # i = i + 1 # } # out(j) = EOS # # return # end #-h- kill 502 asc 25-mar-82 07:02:02 v1.1 (sw-tools v1.1) # integer function kill(proces) # # character proces(PIDSIZE), buf(26) # integer ids # real task # # string dots "..." # # call scopy(proces, 1, buf, 1) # call upper(buf) # call irad50(6, buf, task) # if (proces(1) == '$') # call send(task, buf,, ids) # else # { # call abort(task, ids) # if (ids < 0) # { # call concat(dots, proces, buf) # call upper(buf) # call irad50(6, buf, task) # call abort(task, ids) # } # } # if (ids < 0) # kill = ERR # else # kill = OK # # return # end #-h- loccom 875 asc 25-mar-82 07:02:03 v1.1 (sw-tools v1.1) ## loccom - find command according to search path integer function loccom(comand, spath, suffix, path) character comand(ARB), spath(ARB), path(ARB), temp(FILENAMESIZE), suffix(ARB) integer i, n, int, j, type integer length, flfind, index #----- NOTE ----- # Do not write into 'path' until processing is completed, thus allowing loccom # to be called with the same array for 'comand' and 'path' args. #---------------- for (i=1; spath(i) != '@n'; i=i+length(spath(i))+1) { call concat(spath(i), comand, temp) n = length(temp) + 1 if (index(comand, '.') > 0) { if (flfind(temp, path, type) != ERR) return(type) } else { for (j=1; suffix(j) != '@n'; j=j+length(suffix(j))+1) { call scopy(suffix, j, temp, n) if (flfind(temp, path, type) != ERR) return(type) } } } call strcpy(comand, path) return(ERR) end #-h- mailid 956 asc 25-mar-82 07:02:04 v1.1 (sw-tools v1.1) subroutine mailid(sender) character sender(ARB), loguic(10), uic(10), buf(100) integer i, grp, mem, fdb, openf, gets, junk, getwrd, equal, found integer j, length string system "system" string blklp " (" call getuid(grp, mem) call fmtuic(grp, mem, loguic) found = NO call adrfil(buf) if (openf(buf, READ, fdb) != ERR) { while (gets(fdb, buf, 100) != EOF) { buf(100) = EOS i = 1 junk = getwrd(buf, i, sender) call skipbl(buf, i) # skip over home directory info for ( ; buf(i) != ' ' & buf(i) != EOS; i=i+1) ; junk = getwrd(buf, i, uic) if (equal(uic, loguic) == YES) { call skipbl(buf, i) j = length(sender) + 1 call stcopy(blklp, 1, sender, j) # " (" for (i=i+1; buf(i) != '"'; i=i+1) call chcopy(buf(i), sender, j) call chcopy(')', sender, j) found = YES break } } call closef(fdb) } if (found == NO) call strcpy(system, sender) return end #-h- main 45 asc 25-mar-82 07:02:05 v1.1 (sw-tools v1.1) call initst call main call endst(OK) end #-h- mklocl 109 asc 25-mar-82 07:02:06 v1.1 (sw-tools v1.1) # subroutine mklocl(in, out) # # character in(ARB), out(ARB) # # call fxlate(in, PATH, out) # # return # end #-h- mkpath 538 asc 25-mar-82 07:02:06 v1.1 (sw-tools v1.1) subroutine mkpath(in, out) character in(ARB), out(ARB), temp(FILENAMESIZE) integer i, j call fxlate(in, PATH, temp) out(1) = EOS if (temp(1) != EOS) { j = 1 call chcopy('/', out, j) for (i=1; temp(i) != ':'; i=i+1) call chcopy(temp(i), out, j) i = i + 1 if (temp(i) == '[') { call chcopy('/', out, j) for (i=i+1; temp(i) != ']'; i=i+1) call chcopy(temp(i), out, j) call chcopy('/', out, j) i = i + 1 if (temp(i) != EOS) call stcopy(temp, i, out, j) } out(j) = EOS } return end #-h- opendr 335 asc 25-mar-82 07:02:07 v1.1 (sw-tools v1.1) integer function opendr(strng, desc) integer desc integer index, length, dopen character strng(ARB), file(FILENAMESIZE) string stars "*.*;*" call fxlate(strng, PATH, file) if (index(file, ']') != length(file)) opendr = ERR else { call concat(file, stars, file) opendr = dopen(file, desc) } return end #-h- ptrtoc 455 asc 25-mar-82 07:02:08 v1.1 (sw-tools v1.1) integer function ptrtoc(ptr, buf, size) integer ptr(2), size, junk, j, i integer itoc, addset, length character buf(size), temp(7) junk = itoc(ptr(1), temp, 7) j = 1 for (i=1; temp(i) != EOS; i=i+1) junk = addset(temp(i), buf, j, size) junk = addset(' ', buf, j, size) junk = itoc(ptr(2), temp, 7) for (i=1; temp(i) != EOS; i=i+1) junk = addset(temp(i), buf, j, size) if (addset(EOS, buf, j, size) == ERR) buf(size) = EOS return(length(buf)) end #-h- realdv 437 asc 25-mar-82 07:02:08 v1.1 (sw-tools v1.1) integer function realdv(buf) character buf(ARB), dv(2) integer unit, i, device integer ctoo, type, alun equivalence (device, dv(1)) realdv = NO if (type(buf(2)) == LETTER) andif (type(buf(3)) == LETTER) { i = type(buf(4)) if (i == '/' | i == DIGIT | i == EOS) { dv(1) = buf(2) dv(2) = buf(3) unit = ctoo(buf(4)) if (alun(FREEUNIT, device, unit) == IS_SUC) realdv = YES } } return end #-h- remove 283 asc 25-mar-82 07:02:09 v1.1 (sw-tools v1.1) ## remove -- removes file named buf integer function remove(buf) character buf(FILENAMESIZE) integer int, open, fdel, status int = open(buf, READ) if (int != ERR) { status = fdel(int) call close(int) } else status = OK # OK if file doesn't exist return(status) end #-h- resdef 613 asc 25-mar-82 07:02:10 v1.1 (sw-tools v1.1) subroutine resdef(in, type, out) character in(ARB), out(ARB) integer index, i, j, length, type i = 1 out(1) = EOS if (in(i) != EOS) { if (index(in, ':') > 0) call jcopys(in, i, ':', out) else call trndev("SY", 0, out) if (in(i) != EOS) { j = length(out) + 1 if (in(i) == '[' & index(in, ']') > 0) call jcopys(in, i, ']', out(j)) else call gtddir(out(j), type) if (in(i) != EOS) { j = length(out) + 1 call strcpy(in(i), out(j)) } } } call fold(out) return end #-h- restil 953 asc 25-mar-82 07:02:11 v1.1 (sw-tools v1.1) # resolve ~name construct in path names subroutine restil(path, out) character path(ARB), out(ARB), token(FILENAMESIZE), tmp(5) integer i, junk, key, j, k integer gtftok, equal string str "bin@1usr@2tmp@3lpr@4msg@5mail@5man@6src@7inc@10lib@11" call strcpy(path, out) # assume not ~name if (path(1) == '~') { i = 2 token(1) = EOS key = HOMEDIRECTORY if (path(2) != '/') { junk = gtftok(path, i, token) call fold(token) key = ERR for (j=1; str(j) != EOS; j=j+1) { for (k=1; str(j) >= ' '; [k=k+1; j=j+1]) tmp(k) = str(j) tmp(k) = EOS if (equal(token, tmp) == YES) { key = str(j) break } } } if (key != ERR) { if (key == HOMEDIRECTORY) call homdir(token, LOCAL) else call getdir(key, LOCAL, token) j = 1 call stcopy(token, 1, out, j) if (path(i) == '/') i = i + 1 call strcpy(path(i), out(j)) } } return end #-h- resuic 827 asc 25-mar-82 07:02:12 v1.1 (sw-tools v1.1) define(MEM_SIZE,2000) # size of dynamic storage memory subroutine resuic(uic, value) character uic(ARB), value(ARB), name(FILENAMESIZE), buf(100), defn(FILENAMESIZE) integer init, i, length, fdb, openf, junk, getwrd, tblook, gets DS_DECL(Mem, MEM_SIZE) data init/YES/ if (init == YES) { call adrfil(name) call tbinit(MEM_SIZE) # initialize instal block if (openf(name, READ, fdb) == ERR) call remark("cannot open user's file") else { while (gets(fdb, buf, 100) != EOF) { buf(100) = EOS i = 1 junk = getwrd(buf, i, defn) junk = getwrd(buf, i, name) junk = getwrd(buf, i, name) call tbinst(name, defn) } call closef(fdb) } init = NO } if (tblook(uic, name) == NO) call strcpy(uic, name) call strcpy(name, value) return end #-h- scratf 355 asc 25-mar-82 07:02:13 v1.1 (sw-tools v1.1) ## scratf - get scratfch file name based on 'seed' # This routine should append the process ID to 'seed' to generate # a file name unique to the running process. subroutine scratf (seed, name) character seed(ARB), name(ARB), temp(PIDSIZE) call getpnm(temp) # get process name call fgenr8(temp, seed, name) # generate the file name return end #-h- spawn 2113 asc 25-mar-82 07:02:14 v1.1 (sw-tools v1.1) integer function spawn(image, args, pid, wait) character image(FILENAMESIZE), args(ARGBUFSIZE), pid(PIDSIZE), wait, mcrlin(80), argbuf(ARGBUFSIZE), outfil(FILENAMESIZE), errfil(FILENAMESIZE), c, spimg(FILENAMESIZE) character clower integer init, status, junk, opnout, opnerr, outmod, prio integer bckspn, equal, sndarg, stspwn, genpnm, indexs, loccom, filfno, gtmode, stmode string local "local" string blkgtr " >" string blkqmk " ?" string spath "@e@n" # only search current directory string fmtstr "ins %s/task=%s/pri=%d./run=rem" data init/YES/ if (init == YES) { init = NO call getpri(prio) } call strcpy(image, spimg) call fold(spimg) if (equal(spimg, local) == NO) if (loccom(image, spath, spath, spimg) != BINARY) return(ERR) if (clower(wait) == BACKGR) return(bckspn(spimg, args, pid)) opnout = ERR opnerr = ERR outmod = ERR if (equal(spimg, local) == YES) call strcpy(args, mcrlin) else { spawn = ERR if (genpnm(pid) == ERR) return call strcpy(args, argbuf) outmod = gtmode(STDOUT) if (indexs(argbuf, blkgtr) == 0) # no redirect, add it { if (filnfo(STDOUT, outfil, junk) == OK) { opnout = STDOUT call appred(STDOUT, '>', outfil, argbuf) } } i = indexs(argbuf, blkqmk) if (i != 0) { c = argbuf(i+2) if (c == ' ' | c == '@t' | c == EOS) i = 0 } if (i == 0) { if (filnfo(ERROUT, errfil, junk) == OK) { opnerr = ERROUT call appred(ERROUT, '?', errfil, argbuf) } } if (sndarg(argbuf, pid) != IS_SUC) { call sreset(opnout, outfil) if (outmod != ERR) junk = stmode(STDOUT, outmod) call sreset(opnerr, errfil) return } call sprint(mcrlin, fmtstr, spimg, pid, prio) } call extpnm(mcrlin, pid) call ttydet # detach from terminal call setfgd(pid) status = stspwn(mcrlin) call clrfgd call ttyatt # attach to terminal call sreset(opnout, outfil) if (outmod != ERR) junk = stmode(STDOUT, outmod) call sreset(opnerr, errfil) if (status != 0 & status != 1) spawn = CHILD_ABORTED else spawn = OK return end #-h- sreset 156 asc 25-mar-82 07:02:15 v1.1 (sw-tools v1.1) subroutine sreset(int, file) character file(ARB) integer int, junk integer assign if (int != ERR) junk = assign(file, int, APPEND) return end #-h- srttim 822 asc 25-mar-82 07:02:16 v1.1 (sw-tools v1.1) subroutine srttim(in, out) character in(ARB), out(ARB) character month(4, 12), buf(4), number(13) integer i, j, equal data month/'j','a','n',EOS,'f','e','b',EOS,'m','a','r',EOS, 'a','p','r',EOS,'m','a','y',EOS,'j','u','n',EOS, 'j','u','l',EOS,'a','u','g',EOS,'s','e','p',EOS, 'o','c','t',EOS,'n','o','v',EOS,'d','e','c',EOS/ data number/'a','b','c','d','e','f', 'g','h','i','j','k','l', 'm'/ j = 1 call xcopy(in(3), 3, buf, j) buf(j) = EOS call fold(buf) j = 1 call xcopy(in(6), 2, out, j) # copy year into out for (i=1; i <= 12; i=i+1) if (equal(buf, month(1, i)) == YES) break call chcopy(number(i), out, j) # have copied sortable month number call xcopy(in(1), 2, out, j) # copied day into out call scopy(in, 8, out, j) # copy hhmmss call fold(out) return end #-h- xcopy 174 asc 25-mar-82 07:02:17 v1.1 (sw-tools v1.1) subroutine xcopy(in, n, out, j) integer n, j character in(ARB), out(ARB) integer i for (i=1; i <= n; i=i+1) { out(j) = in(i) j = j + 1 } return end #-h- fgenr8 550 asc 25-mar-82 07:02:17 v1.1 (sw-tools v1.1) ## fgenr8 - generate a scratch file name from process name and seed subroutine fgenr8 (root, seed, name) character seed(ARB), name(ARB), root(PIDSIZE) integer i, j, ctype, type, length call getdir(TMPDIRECTORY, LOCAL, name) j = length(name) + 1 for (i=1; root(i) != EOS; i=i+1) { ctype = type(root(i)) if (ctype == DIGIT | ctype == LETTER) { name(j) = root(i) j = j + 1 } } name(j) = '.' j = j + 1 for (i=1; seed(i) != EOS & i <= 3; i=i+1) { name(j) = seed(i) j = j + 1 } name(j) = EOS return end #-h- flfind 276 asc 25-mar-82 07:02:18 v1.1 (sw-tools v1.1) integer function flfind(infil, outfil, type) character infil(FILENAMESIZE), outfil(FILENAMESIZE) integer type, int integer open, gettyp int = open(infil, READ) if (int != ERR) { type = gettyp(int, type) call glocnm(int, outfil) call fold(outfil) } return(int) end #-h- gtzone 246 asc 02-apr-82 08:15:53 v1.1 (sw-tools v1.1) subroutine gtzone(buf) character buf(ARB) integer now(7) integer dstime string tzone TIME_ZONE buf(1) = tzone(1) call getnow(now) if (dstime(now) == YES) buf(2) = 'D' else buf(2) = 'S' buf(3) = 'T' buf(4) = EOS call upper(buf) return end #-h- trmlst 81 asc 25-mar-82 07:02:19 v1.1 (sw-tools v1.1) integer function trmlst(user, buf) character user(ARB), buf(ARB) return(0) end #-h- brdcst 78 asc 25-mar-82 07:02:20 v1.1 (sw-tools v1.1) subroutine brdcst(messag, term) character messag(ARB), term(ARB) return end #-h- chmod 86 asc 25-mar-82 07:02:21 v1.1 (sw-tools v1.1) integer function chmod(file, prot) character file(ARB) integer prot return(ERR) end #-h- filsiz 1209 asc 25-mar-82 07:02:21 v1.1 (sw-tools v1.1) # filsiz - calculate size of file in bytes and blocks # input - size from decnfo # size(1) blocks * 2**16 # size(2) blocks * 2**8 # size(3) blocks * 2**0 # size(4) byte offset in last block # returns double integers for size in blocks (rounded up) and characters subroutine filsiz(size, bsize, csize) integer size(4), bsize(2), csize(2), tsize(2), dif(2) initdi(bsize) # block size initially zero while (!(size(1) <= 0 & size(2) <= 0 & size(3) <= 0)) # done when all zero { if (size(3) == 0) # need to carry { if (size(2) == 0) # need to carry { size(1) = size(1) - 1 size(2) = 256 } size(2) = size(2) - 1 size(3) = 256 } incrdi(bsize) # one more block size(3) = size(3) - 1 # subtract one from super integer } decrdi(bsize) # do not count EOF block initdi(csize) # character size initially zero csize(2) = size(4) # start with byte offset tsize(1) = bsize(1) # temporary counter tsize(2) = bsize(2) # ... initdi(dif) # always add 512 for each block dif(2) = 512 # ... while (!(tsize(1) <= 0 & tsize(2) <= 0)) { adddi(dif, csize) decrdi(tsize) } if (size(4) > 0) incrdi(bsize) # really need to count EOF block return end #-h- lib.r 136140 asc 02-may-82 12:33:35 j (sventek j) #-h- arsubs.r 3238 asc 02-may-82 12:27:16 j (sventek j) #-h- adefns 22 asc 25-mar-82 06:46:38 v1.1 (sw-tools v1.1) define(SEP_CHAR, '`') #-h- afetch 284 asc 02-may-82 12:26:59 j (sventek j) integer function afetch(buf, i, out) integer i, j character buf(ARB), out(ARB) for( j = 1 ; buf(i) != EOS ; [i = i + 1 ; j = j + 1] ) if( buf(i) == SEP_CHAR ) break else out(j) = buf(i) if( buf(i) != EOS ) i = i + 1 out(j) = EOS call fold(out) return( j - 1 ) end #-h- agetch 352 asc 25-mar-82 06:46:41 v1.1 (sw-tools v1.1) character function agetch(c, fd, size) character c filedes fd integer size(2) character getch # function(s) if( size(1) <= 0 & size(2) <= 0 ) c = EOF else if( getch( c, fd) == EOF ) { size(1) = 0 size(2) = 0 } else { size(2) = size(2) - 1 if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return(c) end #-h- agethd 561 asc 02-may-82 12:27:00 j (sventek j) integer function agethd(fd, buf, size, fsize) filedes fd character buf(MAXLINE) integer size(2), fsize(2) integer i integer agtlin, index # function(s) string hdr "#-h- " if( agtlin( buf, fd, fsize) == EOF ) return(EOF) for( i = 1 ; hdr(i) != EOS ; i = i + 1 ) if( buf(i) != hdr(i) ) break if( hdr(i) != EOS ) # bad format archive return(ERR) call skipbl( buf, i) # skip to name of module call scopy( buf, i, buf, 1) i = index( buf, ' ') buf(i) = EOS call fold(buf) i = i + 1 call ctodi( buf, i, size) # get size of module return(OK) end #-h- agtlin 376 asc 25-mar-82 06:46:44 v1.1 (sw-tools v1.1) integer function agtlin(buf, fd, size) character buf(MAXLINE) filedes fd integer size(2), n integer getlin # function(s) if( size(1) <= 0 & size(2) <= 0 ) return(EOF) n = getlin( buf, fd) if( n == EOF ) { size(1) = 0 size(2) = 0 } else { size(2) = size(2) - n if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return(n) end #-h- aopen 814 asc 25-mar-82 06:46:46 v1.1 (sw-tools v1.1) filedes function aopen( name, fd, size) character name(FILENAMESIZE), file(FILENAMESIZE), module(FILENAMESIZE), buf(MAXLINE) integer i, fsize(2), size(2) integer afetch, agethd, equal # function(s) filedes fd filedes open # function(s) i = 1 if( afetch( name, i, file) <= 0 ) # bad name return(ERR) fd = open( file, READ) # open the main file if( fd == ERR ) return(ERR) fsize(1) = MAX_INTEGER fsize(2) = 0 if( afetch( name, i, module) <= 0) # flat archive { size(1) = MAX_INTEGER size(2) = 0 return (fd) } while( agethd( fd, buf, size, fsize) == OK ) if( equal( buf, module) == YES ) { if( afetch( name, i, module) <= 0 ) return(fd) fsize(1) = size(1) fsize(2) = size(2) } else call askip( fd, size, fsize) call close(fd) # ERROR if get here return(ERR) end #-h- askip 332 asc 25-mar-82 06:46:47 v1.1 (sw-tools v1.1) subroutine askip( fd, size, fsize) filedes fd integer size(2), fsize(2) character c character agetch # function(s) while( !( size(1) <= 0 & size(2) <= 0 ) ) { if( agetch( c, fd, fsize) == EOF ) break size(2) = size(2) - 1 if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return end #-h- ds.r 11031 asc 25-mar-82 06:52:32 v1.1 (sw-tools v1.1) #-h- dsdef 748 asc 25-mar-82 06:46:54 v1.1 (sw-tools v1.1) # Defines for support library routines # Defines for memory management routines: define(DS_MEMEND,1) # pointer to end of memory define(DS_AVAIL,2) # start of available space list define(DS_CLOSE,8) # threshhold for close-fitting blocks define(DS_LINK,1) # link field of storage block define(DS_SIZE,0) # size field of storage block define(DS_OHEAD,2) # total words of overhead per block # Defines for symbol table routines: define(ST_LINK,0) # offset of link field in symbol table node define(ST_DATA,1) # offset of data field in symbol table node define(ST_HTABSIZE,29) # should be a prime number define(ST_SCANPOSN,arith(ST_HTABSIZE,+,1)) # offset to two word block # for context of table scan #-h- dsinit 509 asc 25-mar-82 06:46:56 v1.1 (sw-tools v1.1) ## DSInit -- initialize dynamic storage space to `w' words. subroutine dsinit(w) integer w DS_DECL( Mem, 1) pointer t if( w < 2 * DS_OHEAD + 2 ) call error( "in dsinit: unreasonably small memory size." ) # set up avail list: t = DS_AVAIL Mem( t + DS_SIZE ) = 0 Mem( t + DS_LINK ) = DS_AVAIL + DS_OHEAD # set up first block of space: t = DS_AVAIL + DS_OHEAD Mem( t + DS_SIZE ) = w - DS_OHEAD - 1 # -1 for MEMEND Mem( t + DS_LINK ) = LAMBDA # record end of memory: Mem( DS_MEMEND ) = w return end #-h- dsfree 801 asc 25-mar-82 06:46:57 v1.1 (sw-tools v1.1) ## DSFree -- return a block of storage to the available space list. subroutine dsfree(block) pointer block DS_DECL( Mem, 1) pointer p0, p, q integer n p0 = block - DS_OHEAD n = Mem( p0 + DS_SIZE ) q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA | p > p0 ) break q = p } if( q + Mem( q + DS_SIZE ) > p0 ) { call remark( "in dsfree: attempt to free unallocated block." ) return # do not attempt to free the block } if( p0 + n == p & p != LAMBDA ) { n = n + Mem( p + DS_SIZE ) Mem( p0 + DS_LINK ) = Mem( p + DS_LINK ) } else Mem( p0 + DS_LINK ) = p if( q + Mem( q + DS_SIZE ) == p0 ) { Mem( q + DS_SIZE ) = Mem( q + DS_SIZE ) + n Mem( q + DS_LINK ) = Mem( p0 + DS_LINK ) } else { Mem( q + DS_LINK ) = p0 Mem( p0 + DS_SIZE ) = n } return end #-h- dsget 516 asc 25-mar-82 06:46:59 v1.1 (sw-tools v1.1) ## DSGet-- Get pointer to block of at least `w' available words. pointer function dsget(w) integer w DS_DECL( Mem, 1) pointer p, q, l integer n, k n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA ) return(p) if( Mem( p + DS_SIZE ) >= n ) break q = p } k = Mem( p + DS_SIZE ) - n if( k >= DS_CLOSE ) { Mem( p + DS_SIZE ) = k l = p + k Mem( l + DS_SIZE ) = n } else { Mem( q + DS_LINK ) = Mem( p + DS_LINK ) l = p } return( l + DS_OHEAD ) end #-h- dsdump 687 asc 25-mar-82 06:47:01 v1.1 (sw-tools v1.1) ## DSDump -- Produce semi-readable dump of storage. subroutine dsdump(form) character form DS_DECL( Mem, 1) pointer p, t, q t = DS_AVAIL call remark( "** DYNAMIC STORAGE DUMP **." ) call putint( 1, 5, ERROUT) call putch( ' ', ERROUT) call putint( DS_OHEAD + 1, 0, ERROUT) call remark( " words in use." ) p = Mem( t + DS_LINK ) while( p != LAMBDA ) { call putint( p, 5, ERROUT) call putch( ' ', ERROUT) call putint( Mem( p + DS_SIZE ), 0, ERROUT) call remark( " words available." ) q = p + Mem( p + DS_SIZE ) while( q != Mem( p + DS_LINK ) & q < Mem( DS_MEMEND ) ) call dsdbiu( q, form) p = Mem( p + DS_LINK ) } call remark( "** END DUMP **." ) return end #-h- dsdbiu 880 asc 25-mar-82 06:47:03 v1.1 (sw-tools v1.1) ## DSDBIU -- Dump contents of block-in-use. subroutine dsdbiu( b, form) pointer b character form DS_DECL( Mem, 1) integer l, s, lmax, t, j string blanks " " call putint( b, 5, ERROUT) call putch( ' ', ERROUT) call putint( Mem( b + DS_SIZE ), 0, ERROUT) call remark( " words in use." ) l = 0 s = b + Mem( b + DS_SIZE ) if( form == DIGIT ) lmax = 5 else lmax = 50 for( b = b + DS_OHEAD ; b < s ; b = b + 1 ) { if( l == 0 ) call putlin( blanks, ERROUT) if( form == DIGIT ) { call putint( Mem(b), 10, ERROUT) l = l + 1 } elif( form == LETTER ) { t = cvt_to_cptr(b) for( j = 1 ; j <= CHAR_PER_INT ; j = j + 1 ) { call putch( cMem(t), ERROUT) t = t + 1 } l = l + CHAR_PER_INT } if( l >= lmax ) { l = 0 call putch( '@n', ERROUT) } } if( l != 0 ) call putch( '@n', ERROUT) return end #-h- mktabl 453 asc 25-mar-82 06:47:04 v1.1 (sw-tools v1.1) ## MkTabl -- Make a new (empty) symbol table. pointer function mktabl(nodsiz) integer nodsiz DS_DECL( Mem, 1) pointer st pointer dsget integer i st = dsget( ST_HTABSIZE + 3 ) # +3 for record of nodsiz # and 2-word block for scan context mktabl = st if( st != LAMBDA ) # allocation succeeded { Mem(st) = nodsiz for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { st = st + 1 Mem(st) = LAMBDA # null link } } return end #-h- rmtabl 405 asc 25-mar-82 06:47:06 v1.1 (sw-tools v1.1) ## RmTabl -- Remove a symbol table, deleting all entries. subroutine rmtabl(st) pointer st DS_DECL( Mem, 1) integer i pointer bucket, node, walker bucket = st for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { bucket = bucket + 1 walker = Mem(bucket) while( walker != LAMBDA ) { node = walker walker = Mem( node + ST_LINK ) call dsfree(node) } } call dsfree(st) return end #-h- sctabl 1247 asc 25-mar-82 06:47:08 v1.1 (sw-tools v1.1) ## ScTabl - Scan symbol table, returning next entry or EOF. integer function sctabl(table, sym, info, posn) pointer posn, table character sym(ARB) integer info(ARB) DS_DECL( Mem, 1) pointer bucket, walker integer nodsiz, i, j if( posn == 0 ) # just starting scan? { posn = table + ST_SCANPOSN # index to 2-word scan context block Mem(posn) = 1 # get index of first bucket Mem( posn + 1 ) = Mem( table + 1 ) # get pointer to first chain } bucket = Mem(posn) # recover previous position walker = Mem( posn + 1 ) nodsiz = Mem(table) repeat # until the next symbol, or none are left { if( walker != LAMBDA ) # symbol available? { i = walker + ST_DATA + nodsiz i = cvt_to_cptr(i) j = 1 while( cMem(i) != EOS ) { sym(j) = cMem(i) i = i + 1 j = j + 1 } sym(j) = EOS j = walker + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(j) j = j + 1 } Mem(posn) = bucket # save position of next symbol Mem( posn + 1 ) = Mem( walker + ST_LINK ) return(1) # not EOF } else { bucket = bucket + 1 if( bucket > ST_HTABSIZE ) break j = table + bucket walker = Mem(j) } } posn = 0 return(EOF) end #-h- stlu 638 asc 25-mar-82 06:47:09 v1.1 (sw-tools v1.1) ## STLu -- Symbol table lookup primitive. integer function stlu( symbol, node, pred, st) character symbol(ARB) pointer node, pred, st DS_DECL( Mem, 1) integer hash, i, j, nodsiz integer equal nodsiz = Mem(st) hash = 0 for( i = 1 ; symbol(i) != EOS ; i = i + 1 ) hash = hash + symbol(i) hash = mod( hash, ST_HTABSIZE ) + 1 pred = st + hash node = Mem(pred) while( node != LAMBDA ) { i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) == cMem(j) ) { if( symbol(i) == EOS ) return(YES) i = i + 1 j = j + 1 } pred = node node = Mem( pred + ST_LINK ) } return(NO) end #-h- delete 306 asc 25-mar-82 06:47:11 v1.1 (sw-tools v1.1) ## Delete -- Remove a symbol from the symbol table. subroutine delete( symbol, st) character symbol(ARB) pointer st DS_DECL( Mem, 1) integer stlu pointer node, pred if( stlu( symbol, node, pred, st) == YES ) { Mem( pred + ST_LINK ) = Mem( node + ST_LINK ) call dsfree(node) } return end #-h- lookup 454 asc 25-mar-82 06:47:13 v1.1 (sw-tools v1.1) ## Lookup -- Find a symbol in the symbol table, return its data. integer function lookup(symbol, info, st) character symbol(ARB) integer info(ARB) pointer st DS_DECL( Mem, 1) integer i, nodsiz, kluge integer stlu pointer node, pred if( stlu( symbol, node, pred, st) == NO ) return(NO) nodsiz = Mem(st) kluge = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(kluge) kluge = kluge + 1 } return(YES) end #-h- enter 807 asc 25-mar-82 06:47:14 v1.1 (sw-tools v1.1) ## Enter -- Place a symbol in the symbol table, updating if already present. integer function enter(symbol, info, st) character symbol(ARB) integer info(ARB) pointer st DS_DECL( Mem, 1) integer i, nodsiz, j integer stlu, length pointer node, pred pointer dsget nodsiz = Mem(st) if( stlu( symbol, node, pred, st) == NO ) { node = dsget( 1 + nodsiz + ( length(symbol) + CHAR_PER_INT ) / CHAR_PER_INT ) if( node == LAMBDA ) return(ERR) Mem( node + ST_LINK ) = LAMBDA Mem( pred + ST_LINK ) = node i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) != EOS ) { cMem(j) = symbol(i) i = i + 1 j = j + 1 } cMem(j) = EOS } j = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { Mem(j) = info(i) j = j + 1 } return(OK) end #-h- sdupl 419 asc 25-mar-82 06:47:16 v1.1 (sw-tools v1.1) ## SDupl -- Duplicate a string in dynamic storage space. pointer function sdupl(str) character str(ARB) DS_DECL( Mem, 1) integer i, k integer length pointer j pointer dsget j = dsget( ( length(str) + CHAR_PER_INT ) / CHAR_PER_INT ) sdupl = j if( j != LAMBDA ) { k = cvt_to_cptr(j) for( i = 1 ; str(i) != EOS ; i = i + 1 ) { cMem(k) = str(i) k = k + 1 } cMem(k) = EOS } return end #-h- entdef 549 asc 25-mar-82 06:47:17 v1.1 (sw-tools v1.1) ## EntDef -- Enter a new symbol definition, discarding any old one. subroutine entdef( name, defn, table) character name(ARB), defn(ARB) pointer table integer lookup, enter pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "in entdef: no room for new definition." ) return end #-h- ludef 444 asc 25-mar-82 06:47:19 v1.1 (sw-tools v1.1) ## LuDef -- Look up a defined identifier, return its definition. integer function ludef( id, defn, table) character id(ARB), defn(ARB) pointer table DS_DECL( Mem, 1) integer i, j integer lookup pointer locn ludef = lookup( id, locn, table) if( ludef == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end #-h- help.r 3249 asc 25-mar-82 06:52:36 v1.1 (sw-tools v1.1) #-h- defns 344 asc 25-mar-82 06:47:28 v1.1 (sw-tools v1.1) # common / chelp / size, name(FILENAMESIZE), buf(MAXLINE) # # integer size # return size of entry from gethdr # character name # return name of entry from gethdr # character buf # buffer for reading help archive file define(INCL_CHELP,common/chelp/size,name(FILENAMESIZE),buf(MAXLINE) integer size; character name,buf) define(gethdr,phelp0) #-h- gethdr 451 asc 25-mar-82 06:47:30 v1.1 (sw-tools v1.1) ## GetHdr -- Get next archive header from file. integer function gethdr( fd, buf, name, size) character buf(MAXLINE), c, name(FILENAMESIZE) integer ctoi, equal, getlin, getwrd # function(s) integer fd, i, len, size string hdr "#-h-" if( getlin( buf, fd) == EOF ) return(EOF) i = 1 len = getwrd( buf, i, name) if( equal( name, hdr) == NO ) return(ERR) len = getwrd( buf, i, name) size = ctoi( buf, i) call fold(name) return(YES) end #-h- inihlp 586 asc 25-mar-82 06:47:32 v1.1 (sw-tools v1.1) ## IniHlp -- Initialize help system. integer function inihlp( file, ptrara, ptrsiz, fd) filedes fd integer i, ptrsiz, junk linepointer ptrara(ptrsiz) character file(FILENAMESIZE) integer gethdr, open, note # function(s) INCL_CHELP call close(fd) # close it if previously opened fd = open( file, READ) if( fd != ERR ) { for( i = 1 ; i < ptrsiz ; i = i + 1 ) { junk = note ( ptrara(i), fd ) if( gethdr( fd, buf, name, size) != YES ) break call fskip( fd, size) } call ptrcpy( NULLPOINTER, ptrara(i) ) return(OK) } else return(ERR) end #-h- mrkhlp 770 asc 25-mar-82 06:47:33 v1.1 (sw-tools v1.1) ## MrkHlp -- Mark all header lines in help archive. integer function mrkhlp( fd, ptrara, key, outara) filedes fd integer j, i, junk, doall integer equal, gethdr, ptreq # function(s) linepointer ptrara(ARB), outara(ARB) character key(ARB) INCL_CHELP string summar "%" string all "?" if( equal( key, summar) == YES | equal( key, all) == YES ) doall = YES else doall = NO j = 1 for( i = 1 ; ptreq( ptrara(i), NULLPOINTER) == NO ; i = i + 1 ) { call seek( ptrara(i), fd) junk = gethdr( fd, buf, name, size) if( doall == YES | equal( name, key) == YES ) { call ptrcpy( ptrara(i), outara(j) ) j = j + 1 } if( j > 1 & doall == NO ) break } call ptrcpy( NULLPOINTER, outara(j) ) if( j > 1 ) return(OK) else return(ERR) end #-h- puthlp 733 asc 25-mar-82 06:47:35 v1.1 (sw-tools v1.1) ## PutHlp -- Output help message. subroutine puthlp( fd, outara, key, out, putout) character key(ARB) filedes fd integer dosumm, i, junk, out integer equal, gethdr, getlin, ptreq # function(s) linepointer outara(ARB) external putout INCL_CHELP string summar "%" dosumm = equal( key, summar) for( i = 1 ; ptreq( outara(i), NULLPOINTER) == NO ; i = i + 1 ) { call seek( outara(i), fd) junk = gethdr( fd, buf, name, size) if( dosumm == YES ) { junk = getlin( buf, fd) call putout( buf, out) } else { size = size - getlin( buf, fd) for( junk = getlin( buf, fd) ; size > 0 ; junk = getlin( buf, fd) ) { call putout( buf, out) size = size - junk } } } return end #-h- hispmt.r 18950 asc 06-apr-82 15:09:03 j (sventek j) #-h- defns 3203 asc 06-apr-82 14:53:56 j (sventek j) ### Defns Symbol definitions for `logpmt'. define(GLOBAL,'g') define(CURLINE,'.') define(PREVLINE,'-') define(NEXTLINE,'+') define(LASTLINE,'$') define(SCAN,'/') define(BACKSCAN,'\') define(LINE0,1) define(PREV,0) define(NEXT,1) define(MAX_ED_LINES,25) # Maximum number of lines. define(BUFENT,5) # Words in buffer needed/line. # Now calculate size of buffer array = BUFENT * (MAX_ED_LINES + 2). # The 2 is to account for dummy lines before and after real lines. define(MAXBUF,arith(BUFENT,*,arith(MAX_ED_LINES,+,2))) define(SEEKADR,3) define(LINEID,4) define(SCREENSIZE,22) define(FORWARD,'+') define(BACKWARD,'-') define(LINE_NUMBER,0) define(LEFT_HAND_SIDE,1) # /clog00/ common block - formerly known as cbuf in the editor # put on a file called 'clog00' # Used only by logpmt # common /clog00/ buf(MAXBUF), lastbf # integer buf # Data structures describing each line. # integer lastbf # Last entry in buf used. define(I_CLOG00,common/clog00/buf(MAXBUF),lastbf integer buf,lastbf) # formerly known as clines # /clog01/ - common block for logpmt; holds line flags # put on a file called 'clog01' # Used only by logpmt # common /clog01/ line1, line2, nlines, curln, frstln, lastln, # number # integer line1 # first line number # integer line2 # second line number # integer nlines # number of line numbers specified # integer curln # current line: value of dot # integer frstln # first line of history # integer lastln # last line: value of $ # integer number # next available line number define(I_CLOG01,common/clog01/line1,line2,nlines,curln,frstln,lastln,number integer line1,line2,nlines,curln,frstln,lastln,number) # formerly known as cpat # /clog02/ - common block for logpmt # put on a file named 'clog02' # Used only by the logpmt # common /clog02/ pat(MAXPAT) # character pat # pattern define(I_CLOG02,common/clog02/pat(MAXPAT) character pat) # formerly known as cscrat # /clog03/ - common block for logpmt; holds scratch file info # put on a file called 'clog03' # Used only by the logpmt # common /clog03/ scr, scrend(2) , scrfil(FILENAMESIZE) # integer scr # scratch file id # integer scrend # end of info on scratch file # character scrfil # name of scratch file define(I_CLOG03,common/clog03/scr,scrend(2),scrfil(FILENAMESIZE) integer scr,scrend character scrfil) # formerly known as ctxt # /clog04/ - common block for logpmt # put on a file called 'clog04' # Used only by the logpmt # common /clog04/ txt(MAXLINE) # character txt # text line for matching and output define(I_CLOG04,common/clog04/txt(MAXLINE) character txt) # These definitions are used to avoid name collisions in `rlib'. define(pmtfcn,plog00) define(archiv,plog01) define(dohist,plog03) define(dolist,plog04) #define(edline,plog05) define(getb,plog06) define(getind,plog07) define(getlst,plog08) define(getnum,plog09) define(getone,plog10) define(getrhs,plog11) define(gettxt,plog12) define(gtfndx,plog13) define(inject,plog14) #define(logend,plog02) define(nextln,plog15) define(optpat,plog16) define(prevln,plog17) define(ptscan,plog18) define(relink,plog19) define(setb,plog20) define(setbuf,plog21) define(subst,plog22) #-h- logpmt 211 asc 06-apr-82 14:53:58 j (sventek j) ### LogPmt prompt function with history integer function logpmt(pstr, buf, fd) character pstr(ARB), buf(ARB) filedes fd integer pmtfcn # function(s) external prompt return (pmtfcn (pstr, buf, fd, prompt)) end #-h- ledpmt 234 asc 06-apr-82 14:53:58 j (sventek j) ### LedPmt prompt function with history and intra-line editing integer function ledpmt(pstr, buf, fd) character pstr(ARB), buf(ARB) filedes fd integer pmtfcn # function(s) external lnedit return (pmtfcn (pstr, buf, fd, lnedit)) end #-h- pmtfcn 1721 asc 06-apr-82 14:54:00 j (sventek j) ### PmtFcn Prompt function with history mechanism. ### pmtrtn is the function to be called to prompt for input ### status = pmtrtn(pstr, buf, fd) integer function pmtfcn( pstr, lin, int, pmtrtn) character c, lin(ARB), pstr(ARB) character clower # function(s) integer access, i, int, junk, k, nofile integer dohist, edline, equal, index, pmtrtn # function(s) external pmtrtn I_CLOG01 string null "" string whites " @t@n" data nofile / YES / if( nofile == YES ) { nofile = NO call setbuf } repeat { k = pmtrtn( pstr, lin, int) if( k == EOF ) call strcpy( null, lin) else if( lin(1) == '!' ) { c = clower( lin(2) ) if( c == 'h' | c == 'b' ) { for( i = 3 ; IS_LETTER( lin(i) ) ; i = i + 1 ) ; junk = dohist( lastln, lin, i) k = ERR } else if( c == 'w' ) { for( i = 3 ; lin(i) != EOS ; i = i + 1 ) if( index( whites, lin(i) ) > 0 ) break call skipbl( lin, i) access = WRITE if( lin(i) == '>' ) { i = i + 1 if( lin(i) == '>' ) { i = i + 1 access = APPEND } } call scopy( lin, i, lin, 1) i = index( lin, '@n') if( i > 0 ) lin(i) = EOS k = EOF } else if( c == 'q' ) { call strcpy( null, lin) k = EOF } else { k = edline(lin) call putlin( pstr, ERROUT) call putlin( lin, ERROUT) } } else if( lin(1) == ESCAPE & lin(2) == '!' ) { call scopy( lin, 2, lin, 1) k = k - 1 } } until( k != ERR ) if( k != EOF ) call archiv(lin) else { call logend( lin, access) nofile = YES # (dpm 13-Jun-81) } return(k) end #-h- archiv 209 asc 06-apr-82 14:54:01 j (sventek j) ### LP_Archiv Archive lines. (LogPmt) subroutine archiv(lin) character lin(ARB) integer junk integer inject # function(s) if( lin(1) != '@n' ) # Don't log blank lins. junk = inject(lin) return end #-h- dohist 567 asc 06-apr-82 14:54:02 j (sventek j) ### LP_DoHist Perform history display. (LogPmt) integer function dohist( line, lin, i) character direc, lin(ARB) integer curscr, i, lin1, lin2, line, screen integer ctoi, dolist # function(s) I_CLOG01 data screen, curscr / SCREENSIZE, SCREENSIZE / call skipbl( lin, i) if( lin(i) == '@n' ) screen = curscr else { screen = ctoi( lin, i) - 1 if( screen <= 0 ) screen = curscr else curscr = screen } lin1 = line - screen lin2 = line lin1 = max( frstln + 1, lin1) lin2 = min( lin2, lastln) dohist = dolist( lin1, lin2, lin(i) ) return end #-h- dolist 729 asc 06-apr-82 14:54:03 j (sventek j) ### LP_DoList Print lines `from' through `to'. (LogPmt) integer function dolist( from, to, ch) integer gettxt # function(s) integer from, i, j, to, k, num, xpand character c, ch I_CLOG01 I_CLOG04 xpand = NO if( ch == 'l' | ch == 'L' ) xpand = YES for( i = from ; i <= to ; i = i + 1 ) { j = gettxt(i) call getb( j, LINEID, num) call putint( num, 3, STDOUT) # output line number call putch( ' ', STDOUT) for( k = 1 ; txt(k) != EOS ; k = k + 1 ) if( txt(k) >= ' ' | txt(k) == '@n' ) call putch( txt(k), STDOUT) else if( xpand == NO ) call putch( txt(k), STDOUT) else { call putch( '^', STDOUT) c = txt(k) + '@@' call putch( c, STDOUT) } } curln = to dolist = OK return end #-h- edline 969 asc 06-apr-82 14:54:04 j (sventek j) ### LP_EdLine Perform line-editor command. (LogPmt) integer function edline(lin) character lin(ARB), sub(MAXPAT) integer final, gflag, i, junk, linsts, status integer getlst, getrhs, gettxt, length, optpat, subst # function(s) I_CLOG04 I_CLOG01 string badlin "# invalid lin number@n" string badpat "# invalid substitution@n" i = 2 status = OK if( getlst( lin, i, linsts) == OK ) if( line2 == frstln ) linsts = ERR else if( lin(i) == 's' | lin(i) == 'S' ) { status = ERR i = i + 1 if( optpat( lin, i, LEFT_HAND_SIDE ) == OK ) andif( getrhs( lin, i, sub, gflag) == OK ) { junk = gettxt(line2) # Fetch line. status = subst( txt, lin, sub, gflag) # Modify line. } } else { junk = gettxt(line2) call strcpy( txt, lin) } if( linsts == ERR ) { final = ERR call strcpy( badlin, lin) } else if( status == ERR ) { final = ERR call strcpy( badpat, lin) } else final = length(lin) curln = lastln return(final) end #-h- getb 407 asc 06-apr-82 14:54:06 j (sventek j) ### LP_GetB Get `value' of `type' in `buf(index)' (LogPmt) subroutine getb( index, type, value) integer index, type integer value(2) I_CLOG00 if( type == PREV ) value(1) = buf(index) else if( type == NEXT ) value(1) = buf( index + 1 ) else if( type == SEEKADR ) { value(1) = buf( index + 2 ) value(2) = buf( index + 3 ) } else if( type == LINEID ) value(1) = buf( index + 4 ) return end #-h- getind 213 asc 06-apr-82 14:54:06 j (sventek j) ### LP_GetInd Locate line index in buffer (LogPmt version) integer function getind(lin) integer lin, k, j I_CLOG01 k = LINE0 for( j = frstln ; j < lin ; j = j + 1 ) call getb( k, NEXT, k) return(k) end #-h- getlst 584 asc 06-apr-82 14:54:07 j (sventek j) ### LP_GetLst Collect line numbers at `lin(i)'; increment `i'. (LogPmt) integer function getlst( lin, i, status) character lin(MAXLINE) integer getone # function(s) integer i, num, status I_CLOG01 line2 = 0 for( nlines = 0 ; getone( lin, i, num, status) == OK ; ) { line1 = line2 line2 = num nlines = nlines + 1 if( lin(i) != ',' & lin(i) != ';' ) break if( lin(i) == ';' ) curln = num i = i + 1 } nlines = min( nlines, 2) if( nlines == 0 ) line2 = curln if( nlines <= 1 ) line1 = line2 if( status != ERR ) status = OK getlst = status return end #-h- getnum 952 asc 06-apr-82 14:54:08 j (sventek j) ### LP_GetNum Convert one term to line number. (LogPmt) integer function getnum( lin, i, pnum, status) character lin(MAXLINE) integer ctoi, index, nextln, optpat, prevln, ptscan # function(s) integer i, pnum, status I_CLOG01 I_CLOG02 string digits "0123456789" getnum = OK if( index( digits, lin(i) ) > 0 ) { pnum = ctoi( lin, i) i = i - 1 # move back; to be advanced at the end } else if( lin(i) == CURLINE ) pnum = curln else if( lin(i) == LASTLINE ) pnum = lastln else if( lin(i) == PREVLINE ) pnum = prevln(curln) else if( lin(i) == NEXTLINE ) pnum = nextln(curln) else if( lin(i) == SCAN | lin(i) == BACKSCAN ) { if( optpat( lin, i, LINE_NUMBER ) == ERR ) # build the pattern getnum = ERR else if( lin(i) == SCAN ) getnum = ptscan( FORWARD, pnum) else getnum = ptscan( BACKWARD, pnum) } else getnum = EOF if( getnum == OK ) i = i + 1 # point at next character to be examined status = getnum return end #-h- getone 875 asc 06-apr-82 14:54:10 j (sventek j) ### LP_GetOne Evaluate one line number expression. (LogPmt) integer function getone( lin, i, num, status) character lin(MAXLINE) integer getnum # function(s) integer i, istart, mul, num, pnum, status I_CLOG01 istart = i num = frstln call skipbl( lin, i) if( getnum( lin, i, num, status) == OK ) # first term repeat # + or - terms { call skipbl( lin, i) if( lin(i) != '+' & lin(i) != '-' ) { status = EOF break } if( lin(i) == '+' ) mul = +1 else mul = -1 i = i + 1 call skipbl( lin, i) if( getnum( lin, i, pnum, status) == OK ) num = num + mul * pnum if( status == EOF ) status = ERR } until( status != OK ) if( num < frstln | num > lastln ) status = ERR if( status == ERR ) getone = ERR else if( i <= istart ) getone = EOF else getone = OK status = getone return end #-h- getrhs 675 asc 06-apr-82 14:54:11 j (sventek j) ### LP_GetRhs Get substitution string for `s' command. (LogPmt) integer function getrhs( lin, i, sub, gflag) character lin(MAXLINE), sub(MAXPAT) integer index, length, maksub # function(s) integer gflag, i, j character clower # function(s) getrhs = ERR if( lin(i) == EOS ) return if( lin( i + 1 ) == EOS ) return if( index( lin( i + 1 ), lin(i) ) == 0 ) # insert missing delimiter { j = length(lin) call chcopy( lin(i), lin, j) call chcopy( '@n', lin, j) # add trailing '@n' } i = maksub( lin, i + 1, lin(i), sub) if( i == ERR ) return i = i + 1 if( clower( lin(i) ) == GLOBAL ) { i = i + 1 gflag = YES } else gflag = NO getrhs = OK return end #-h- gettxt 442 asc 06-apr-82 14:54:12 j (sventek j) ### LP_GetTxt Locate text for line, copy to `txt'. (LogPmt) integer function gettxt(lin) integer getind, getlin # function(s) integer lin, len, j, k, junk integer loc(2) I_CLOG00 I_CLOG03 I_CLOG04 I_CLOG01 string null "" if( lin > frstln & lin <= lastln ) { k = getind(lin) call getb( k, SEEKADR, loc) call seek( loc, scr) junk = getlin( txt, scr) } else { k = LINE0 call strcpy( null, txt) } gettxt = k return end #-h- gtfndx 222 asc 06-apr-82 14:54:13 j (sventek j) ### LP_GtFNdx Get index for next line. (LogPmt) integer function gtfndx(newind) I_CLOG00 if( lastbf + BUFENT < MAXBUF ) { newind = lastbf lastbf = lastbf + BUFENT } else newind = ERR gtfndx = newind return end #-h- inject 790 asc 06-apr-82 14:54:14 j (sventek j) ### LP_Inject Insert `lin' after `curln'; write scratch. (LogPmt) integer function inject(lin) character lin(MAXLINE) integer gtfndx, note # function(s) integer k1, newind, junk I_CLOG01 I_CLOG03 if( gtfndx(newind) == ERR ) { call getb( LINE0, NEXT, newind) # Get index of frstln. call getb( newind, NEXT, k1) # Get index of second line. call relink( LINE0, k1, LINE0, k1) # Unlink frstln. frstln = frstln + 1 } call setb( newind, SEEKADR, scrend) call seek( scrend, scr) call putlin( lin, scr) junk = note ( scrend, scr) call setb( newind, LINEID, number) number = number + 1 call getb( LINE0, PREV, k1) # Get index of lastln. call relink( k1, newind, newind, LINE0) call relink( newind, LINE0, k1, newind) lastln = lastln + 1 curln = lastln inject = OK return end #-h- nextln 171 asc 06-apr-82 14:54:15 j (sventek j) ### LP_NextLn Get line after `lin'. (LogPmt) integer function nextln(lin) integer lin I_CLOG01 nextln = lin + 1 if( nextln > lastln ) nextln = frstln return end #-h- optpat 734 asc 06-apr-82 14:54:16 j (sventek j) ### LP_OptPat Make pattern if specified at `lin(i)'. (LogPmt) integer function optpat( lin, i, type) character lin(MAXLINE) integer index, length, makpat # function(s) integer i, j, type I_CLOG02 if( lin(i) == EOS ) i = ERR else if( lin( i + 1 ) == EOS ) i = ERR else { if( type == LINE_NUMBER ) andif( index( lin( i + 1 ), lin(i) ) == 0 ) # Add missing delimiter. { j = length(lin) # Location of '@n'. call chcopy( lin(i), lin, j) # Add delimiter. call chcopy( '@n', lin, j) } if( lin( i + 1 ) == lin(i) ) i = i + 1 else i = makpat( lin, i + 1, lin(i), pat) } if( pat(1) == EOS ) i = ERR if( i == ERR ) { pat(1) = EOS optpat = ERR } else optpat = OK return end #-h- prevln 172 asc 06-apr-82 14:54:17 j (sventek j) ### LP_PrevLn Get line before `lin'. (LogPmt) integer function prevln(lin) integer lin I_CLOG01 prevln = lin - 1 if( prevln < frstln ) prevln = lastln return end #-h- ptscan 405 asc 06-apr-82 14:54:18 j (sventek j) ### LP_PtScan Scan for next occurrence of pattern. (LogPmt) integer function ptscan( way, num) integer k, num, way integer gettxt, match, nextln, prevln # function(s) I_CLOG01 I_CLOG02 I_CLOG04 num = curln repeat { if( way == FORWARD ) num = nextln(num) else num = prevln(num) k = gettxt(num) if( match( txt, pat) == YES ) return(OK) } until( num == curln ) return(ERR) end #-h- relink 164 asc 06-apr-82 14:54:19 j (sventek j) ### LP_Relink Rewrite two half line links. (LogPmt) subroutine relink( a, x, y, b) integer a, b, x, y call setb( x, PREV, a) call setb( y, NEXT, b) return end #-h- setb 408 asc 06-apr-82 14:54:20 j (sventek j) ### LP_SetB Set `type' in `buf(index)' to `value'. (Logpmt) subroutine setb( index, type, value) integer index, type integer value(2) I_CLOG00 if( type == PREV ) buf(index) = value(1) else if( type == NEXT ) buf( index + 1 ) = value(1) else if( type == SEEKADR ) { buf( index + 2 ) = value(1) buf( index + 3 ) = value(2) } else if( type == LINEID ) buf( index + 4 ) = value(1) return end #-h- setbuf 607 asc 06-apr-82 14:54:21 j (sventek j) ### LP_SetBuf Create scratch file, set up line 0. (LogPmt) subroutine setbuf filedes create # function(s) integer gtfndx, note # function(s) integer junk, k I_CLOG00 I_CLOG01 I_CLOG03 string fil "log" call scratf( fil, scrfil) # Get unique name for scratch file. scr = create( scrfil, READWRITE) if( scr == ERR ) call cant(scrfil) junk = note ( scrend, scr) lastbf = LINE0 junk = gtfndx(k) # Get index of line 0. call relink( k, k, k, k) # Establish initial linked list. frstln = 0 # Initialize first line. curln = 0 lastln = 0 number = 1 # Next available line number. return end #-h- subst 836 asc 06-apr-82 14:54:22 j (sventek j) ### LP_Subst Substitute `sub' for occurrences of pattern. (LogPmt) integer function subst( old, new, sub, gflag) character new(MAXLINE), old(MAXLINE), sub(MAXPAT) integer addset, amatch # function(s) integer gflag, j, junk, k, lastm, m, subbed I_CLOG01 I_CLOG02 j = 1 subbed = NO lastm = 0 for( k = 1 ; old(k) != EOS ; ) { if( gflag == YES | subbed == NO ) m = amatch( old, k, pat) else m = 0 if( m > 0 & lastm != m ) # replace matched text { subbed = YES call catsub( old, k, m, sub, new, j, MAXLINE) lastm = m } if( m == 0 | m == k ) # no match or null match { junk = addset( old(k), new, j, MAXLINE) k = k + 1 } else # skip matched text k = m } if( addset( EOS, new, j, MAXLINE) == NO ) subst = ERR else if( subbed == NO ) subst = ERR else subst = OK return end #-h- logend 734 asc 06-apr-82 14:54:23 j (sventek j) ### LP_ClrBuf CLear buffer and gun scratch file. (LogPmt) subroutine logend( fil, access) character c, fil(FILENAMESIZE) character getch # function(s) filedes create, open # function(s) integer access, out, junk integer remove # function(s) I_CLOG03 call close(scr) if( fil(1) != EOS ) # User wants file saved. { scr = open( scrfil, READ) # Reopen scrfil at beginning. if( scr != ERR ) # Better not be any errors. { out = create( fil, access) # Open user's file at desired access. if( out != ERR ) # Hope there's no error. { while( getch( c, scr) != EOF ) # Copy the log file. call putch( c, out) call close(out) } call close(scr) } } junk = remove(scrfil) return end #-h- imsort.r 4309 asc 25-mar-82 06:52:48 v1.1 (sw-tools v1.1) #-h- imsym 295 asc 25-mar-82 06:48:36 v1.1 (sw-tools v1.1) define(LAST_PUT,0) # offset into Mem for last put pointer define(LAST_GET,1) # " " " " " get " define(LAST_PTR,2) # offset into Mem for last pointer define(START_DATA,3) # offset into Mem for start of pointer array define(LOGPTR,20) # log base 2 of number of entries to sort #-h- iminit 494 asc 25-mar-82 06:48:37 v1.1 (sw-tools v1.1) ## IMInit -- Initialize in-memory sorting array. pointer function iminit( memsiz, avetok) integer memsiz, avetok DS_DECL( Mem, 1) integer ptrsiz pointer table pointer dsget call dsinit(memsiz) ptrsiz = START_DATA + ( memsiz / ( 1 + avetok / CHAR_PER_INT ) ) table = dsget(ptrsiz) if( table != LAMBDA ) { Mem( table + LAST_PUT ) = table + START_DATA - 1 Mem( table + LAST_GET ) = table + START_DATA - 1 Mem( table + LAST_PTR ) = table + ptrsiz - 1 } return(table) end #-h- imget 360 asc 25-mar-82 06:48:39 v1.1 (sw-tools v1.1) ## IMGet -- Get next token from in-memory sort area integer function imget( table, buf) pointer table character buf(ARB) DS_DECL( Mem, 1) integer i if( Mem( table + LAST_GET ) < Mem( table + LAST_PUT ) ) { i = Mem( table + LAST_GET ) + 1 Mem( table + LAST_GET ) = i call scopy( cMem, Mem(i), buf, 1) return(OK) } else return(EOF) end #-h- imsort 1027 asc 25-mar-82 06:48:41 v1.1 (sw-tools v1.1) ## IMSort -- Quicksort for character lines. subroutine imsort(table) pointer table DS_DECL( Mem, 1) integer imcomp integer i, j, lv(LOGPTR), p, pivlin, uv(LOGPTR) lv(1) = table + START_DATA uv(1) = Mem( table + LAST_PUT ) p = 1 while( p > 0 ) if( lv(p) >= uv(p) ) # only one element in this subset p = p - 1 # pop stack else { i = lv(p) - 1 j = uv(p) pivlin = Mem(j) # pivot line while( i < j ) { for( i = i + 1 ; imcomp( Mem(i), pivlin, cMem) < 0 ; i = i + 1 ) ; for( j = j - 1 ; j > i ; j = j - 1 ) if( imcomp( Mem(j), pivlin, cMem) <= 0 ) break if( i < j ) # out of order pair call imexch( Mem(i), Mem(j), cMem) } j = uv(p) # move pivot to position i call imexch( Mem(i), Mem(j), cMem) if( i - lv(p) < uv(p) - i ) # stack so shorter done first { lv( p + 1 ) = lv(p) uv( p + 1 ) = i - 1 lv(p) = i + 1 } else { lv( p + 1 ) = i + 1 uv( p + 1 ) = uv(p) uv(p) = i - 1 } p = p + 1 # push onto stack } return end #-h- imput 447 asc 25-mar-82 06:48:42 v1.1 (sw-tools v1.1) ## IMPut -- Put a token into the in-memory sort area. integer function imput( table, buf) pointer table character buf(ARB) DS_DECL( Mem, 1) pointer text pointer sdupl integer i imput = ERR if( Mem( table + LAST_PUT ) < Mem( table + LAST_PTR ) ) { text = sdupl(buf) if( text != LAMBDA ) { i = Mem( table + LAST_PUT ) + 1 Mem( table + LAST_PUT ) = i Mem(i) = cvt_to_cptr(text) imput = OK } } return end #-h- imexch 175 asc 25-mar-82 06:48:44 v1.1 (sw-tools v1.1) ## IMExch -- Exchange linbuf(lp1) with linbuf(lp2) . subroutine imexch( lp1, lp2, linbuf) character linbuf(ARB) integer k, lp1, lp2 k = lp1 lp1 = lp2 lp2 = k return end #-h- imcomp 320 asc 25-mar-82 06:48:45 v1.1 (sw-tools v1.1) ## IMComp -- Compare two strings in in-memory sort area. integer function imcomp( i, j, lin) integer i, j, k, l character lin(ARB) k = i l = j while( lin(k) == lin(l) ) { if( lin(k) == EOS ) return(0) # strings are equal k = k + 1 l = l + 1 } if( lin(k) < lin(l) ) return(-1) else return(1) end #-h- imuniq 417 asc 25-mar-82 06:48:47 v1.1 (sw-tools v1.1) subroutine imuniq(table) pointer table DS_DECL(Mem, 1) integer imcomp integer last, out, cur, next last = Mem(table + LAST_PUT) out = table + START_DATA for (cur = table + START_DATA; cur <= last; cur = next) { for (next = cur + 1; next <= last; next = next + 1) if (imcomp(Mem(cur), Mem(next), cMem) != 0) break Mem(out) = Mem(cur) out = out + 1 } Mem(table + LAST_PUT) = out - 1 return end #-h- imrset 117 asc 25-mar-82 06:48:48 v1.1 (sw-tools v1.1) subroutine imrset(table) pointer table DS_DECL(Mem,1) Mem (table + LAST_GET) = table + START_DATA - 1 return end #-h- lnedit.w 41810 asc 25-mar-82 06:52:57 v1.1 (sw-tools v1.1) #-h- cledit 1486 asc 25-mar-82 06:44:47 v1.1 (sw-tools v1.1) ## CLEdit - Common block for intra-line editing routines. common /cledit/ hastab, lc1, nc, nmaxpc, npc, oc, omaxpc, opc, pc1, qp, tabs(MAXLINE), undcur, fl(MAXLINE), nl(MAXLINE), npl(MAXLINE), ol(MAXLINE), opl(MAXLINE), oq(MAXLINE), tmplin(MAXLINE), undlin(MAXLINE) integer hastab # YES if output device has hardware tabs integer lc1 # First logical character after prompt integer nc # New logical cursor position integer nmaxpc # New maximum physical cursor position written integer npc # New physical cursor position integer oc # Old logical cursor position integer omaxpc # Old maximum physical column written integer opc # Old physical cursor position integer pc1 # First physical character after prompt integer qp # Pointer to next char in output queue integer tabs # Array of tab stops -- YES(set) | NO(reset) integer undcur # Logical cursor postion of line in `undo' buffer character fl # Full logical line (with prompt) character nl # New logical line character npl # New physical line character ol # Old logical line character opl # Old physical line character oq # Output queue for line refreshing character tmplin # Scratch line buffer character undlin # Line in `undo' buffer # Note: All the line editing routines expect to have `ol' and # `oc' set to the current state of the line on the screen # when they are invoked. All routines are expected to export # `nl' and `nc' as the (desired) state of the line on the screen. #-h- coldcm 204 asc 25-mar-82 06:44:48 v1.1 (sw-tools v1.1) # /coldcm/ - common block holding `last command stack' for shell # put on a file named `colccm' # used only by the shell common /coldcm/ oldcmd(MAXLINE) character oldcmd # just one line held for now... #-h- lnedit.r 39901 asc 25-mar-82 06:44:55 v1.1 (sw-tools v1.1) #-h- defns 1261 asc 25-mar-82 06:43:14 v1.1 (sw-tools v1.1) ## defns - Definitions for intra-line editing. define(APPENDPREV,1) # ^A define(DIRECTORYLIST,4) # ^D define(EDITLINE,5) # ^E define(ENDOFFILE,26) # ^Z define(LINEDELETE,21) # ^U define(RECOGNIZEFILE,6) # ^F define(RETYPELINE,18) # ^R define(WORDDELETE,23) # ^W # The following definitions are required to avoid potential name # conflicts in `rlib'. define(alphan,le_alphan) define(bckupc,le_bckupc) define(d2eol,le_d2eol) define(dnoise,le_dnoise) define(ds,le_ds) define(fclosd,le_fclosd) define(fgdrpr,le_fgdrpr) define(flushq,le_flushq) define(fopend,le_fopend) define(gthist,le_gthist) define(insstr,le_insstr) define(ledit,le_ledit) define(leinit,le_leinit) define(lerror,le_lerror) define(ll2pl,le_ll2pl) define(lngest,le_lngest) define(mvcurq,le_mvcurq) define(ngtnum,le_ngtnum) define(pbcmd,le_pbcmd) define(putchf,le_putchf) define(putchq,le_putchq) define(putstf,le_putstf) define(putstq,le_putstq) define(rawio,le_rawio) define(rawtxt,le_rawtxt) define(recogf,le_recogf) define(saveln,le_saveln) define(scn4ch,le_scn4ch) define(scnbbw,le_scnbbw) define(scnbck,le_scnbck) define(scnblw,le_scnblw) define(scnebw,le_scnebw) define(scnelw,le_scnelw) define(spawnd,le_spawnd) define(spnbck,le_spnbck) define(updlin,le_updlin) define(whites,le_whites) #-h- lnedit 4856 asc 25-mar-82 06:43:17 v1.1 (sw-tools v1.1) ## LnEdit - Prompt for command line, with unCOOKED editing. integer function lnedit( pstr, lin, ichn) include coldcm integer cmdnum, i, ichn, imode, j, junk, k, len, ochn, omode, savmod integer index, length, prompt, recogf, scnbck, spawn, spnbck, stmode, isatty integer gthist, rawio character lin(ARB), pid(PIDSIZE), pstr(ARB), tmp(FILENAMESIZE) character c character ledit character bsblbs(4), crlf(3), ctrlr(5), ctrlu(5), ctrlz(5) character rubcmd(4), wrdrub(6) character ngetch string bol "%" string dstr "d " string pthtrm " /\" # Terminator array for backscan string filtrm " ,<>@@" # Terminator string for filename string fldtrm " /\@@~>" # Terminator string for field of path data bsblbs/BACKSPACE, ' ', BACKSPACE, EOS/ data crlf/CR, LF, EOS/ data ctrlr/'^', 'R', CR, LF, EOS/ data ctrlu/'^', 'U', CR, LF, EOS/ data ctrlz/'^', 'Z', CR, LF, EOS/ data rubcmd/EDITLINE, 'x', ENDOFFILE, EOS/ data wrdrub/' ', EDITLINE, 'B', 'D', ENDOFFILE, EOS/ data ochn /EOF/ if( rawio( ichn, ochn, savmod) == NO ) # Can't do unCOOKED io. return( prompt( pstr, lin, ichn)) i = 1 call putlin( crlf, ochn) call putlin( pstr, ochn) lin(1) = EOS repeat { c = ngetch( c, ichn) if( c == ENDOFFILE ) { call putlin( ctrlz, ochn) lnedit = EOF lin(1) = EOS return } else if( c == CR ) # CARRIAGE_RETURN break else if( c == LF ) call putch( LF, ochn) else if( c == BACKSPACE | c == RUBOUT ) { if( i > 1 ) { if( lin(i-1) == '@t' ) call pbstr( rubcmd) else { call putlin(bsblbs, ochn) i = i - 1 lin(i) = EOS } } else lin(i) = EOS } else if( c == LINEDELETE ) { call putlin( ctrlu, ochn) call putlin( pstr, ochn) i = 1 lin(i) = EOS } else if( c == RETYPELINE ) { call putlin( ctrlr, ochn) lin(i) = EOS call putlin( pstr, ochn) call putlin( lin, ochn) } else if( c == WORDDELETE ) { call pbstr( wrdrub) # i = spnbck( lin, i, bsblbs, ochn, fldtrm) # i = scnbck( lin, i, bsblbs, ochn, fldtrm) # lin(i) = EOS } else if( c == RECOGNIZEFILE | c == ESC ) { lin(i) = EOS j = scnbck( lin, i, EOS, ochn, filtrm) call scopy( lin, j, tmp, 1) len = length(tmp) if( recogf(tmp) != ERR ) { if( tmp(len+1) != EOS ) # Progress was made... { call scopy( tmp, len+1, lin, i) call putlin( lin(i), ochn) i = length(lin) + 1 } else { j = scnbck( lin, i, EOS, ochn, filtrm) k = 1 call stcopy( dstr, 1, tmp, k) call scopy( lin, j, tmp, k) j = scnbck( tmp(k), length(tmp(k))+1, EOS, ochn, pthtrm) + k - 1 call insstr( bol, tmp, j) call putlin( crlf, ochn) call spawnd( tmp) call putlin( crlf, ochn) call putlin( pstr, ochn) lin(i) = EOS call putlin( lin, ochn) } } else call putch( BELL, ochn) } else if( c == DIRECTORYLIST ) { call putlin( "^Directory", ochn) call putlin( crlf, ochn) call spawnd( dstr) call putlin( crlf, ochn) call putlin( pstr, ochn) lin(i) = EOS call putlin( lin, ochn) } else if( c == APPENDPREV ) { if( lin(1) == '!' ) # Retrieve line from history. i = gthist( lin, i) else { i = 1 call stcopy( oldcmd, 1, lin, i) } call putlin( "^Append", ochn) call putlin( crlf, ochn) call putlin( pstr, ochn) call putlin( lin, ochn) } else if( c == EDITLINE ) { if( (i == 1 & lin(i) == EOS) | lin(1) == '!' ) { if( lin(1) == '!' ) # Retrieve command from history. { i = gthist( lin, i) i = 1 call putlin( crlf, ochn) call putlin( pstr, ochn) } else call strcpy( oldcmd, lin) # Retrieve previous command. call putlin( lin, ochn) call putch( CR, ochn) call putlin( pstr, ochn) } else if( i > 1 ) { i = i - 1 call putch( BACKSPACE, ochn) } c = ledit( pstr, lin, i, ichn, ochn) if( lin(i) != EOS ) { call putch( lin(i), ochn) i = i + 1 } if( c == CR ) # CARRIAGE_RETURN break } else if( c == VT ) # Pump out 8 LFs for a Vertical '@t'. for( j = 1 ; j <= 8 ; j = j + 1 ) call putch( LF, ochn) else if( c == FF ) # Pump out 24 LFs for a Form Feed. for( j = 1 ; j <= 24 ; j = j + 1 ) call putch( LF, ochn) else if( c < ' ' & c != '@t' ) # No control chars, please... call putch( BELL, ochn) else { lin(i) = c i = i + 1 lin(i) = EOS call putch( c, ochn) } } call putch( CR, ochn) #call putlin( crlf, ochn) if( lin(1) != EOS ) # Save command for reedit. { lin(i) = EOS call strcpy( lin, oldcmd) } lin(i) = '@n' lin(i+1) = EOS savmod = stmode( ichn, savmod) # reset mode on unit return(i) end #-h- alphan 210 asc 25-mar-82 06:43:20 v1.1 (sw-tools v1.1) ## AlphaN - Return YES if c is a LETTER or DIGIT, NO otherwise. integer function alphan(c) character c integer type if( type(c) == LETTER | type(c) == DIGIT ) alphan = YES else alphan = NO return end #-h- bckupc 647 asc 25-mar-82 06:43:21 v1.1 (sw-tools v1.1) ## BckUpC - Back up a character position; erase char if `erase' == YES. subroutine bckupc( ochn, erase) character c integer erase, i, ochn integer tabpos include cledit character bs(2), bsblbs(4), rubstr(4) data bs /BACKSPACE, EOS/ data bsblbs /BACKSPACE, ' ', BACKSPACE, EOS/ if( erase == YES ) call strcpy( bsblbs, rubstr) else call strcpy( bs, rubstr) c = opl(opc-1) if( c == '@t' ) { call putstq( bs, ochn) i = opc for( ; tabpos( i, tabs) == NO & i > 1 & opl(i-1) == '@t' ; i = i - 1 ) call putstq( bs, ochn) } else if( c == ' ' ) call putstq( bs, ochn) else call putstq( rubstr, ochn) return end #-h- d2eol 272 asc 25-mar-82 06:43:23 v1.1 (sw-tools v1.1) ## D2EOL - Delete to End-of-line (omaxpc) on `ochn'. integer function d2eol( ochn) integer i, i1, i2, ochn include cledit i1 = opc i2 = omaxpc for( i = i1 ; i <= i2 ; i = i + 1 ) call putchq( ' ', ochn) d2eol = i2 - i1 + 1 # Number of blanks we output. return end #-h- dnoise 726 asc 25-mar-82 06:43:24 v1.1 (sw-tools v1.1) ## DNoise - Remove noise from filename `fil'. Noise is defined as: ## version numbers of `1', trailing `.', and `.dir' extensions. ## Return YES/NO if `fil' is a `.dir' file. integer function dnoise( fil) character fil(ARB) integer i, isdir integer equal, length # function(s) string dot1 ".1" string dotdir ".dir" i = length( fil) if( i > 2 ) if( equal( fil(i-1), dot1) ) # Remove trailing ".1" { i = i - 2 fil(i+1) = EOS } if( fil(i) == '.' & i != 1 ) # Remove trailing "." { fil(i) = EOS i = i - 1 } isdir = NO if( i > 3 ) if( equal( fil(i-3), dotdir) ) # Replace ".dir" with "/". { i = i - 3 fil(i) = '/' fil(i+1) = EOS isdir = YES } dnoise = isdir return end #-h- ds 1077 asc 25-mar-82 06:43:26 v1.1 (sw-tools v1.1) integer function ds( inpstr, outstr) character buf(MAXLINE), name(FILENAMESIZE), direc(FILENAMESIZE) character pat(MAXLINE), path(FILENAMESIZE), tmpnam(FILENAMESIZE) character inpstr(ARB), outstr(ARB) integer j, i, junk, gtftok, dirfid, dnoise integer fgdrpr, fopend, found, length integer depth, ptr(10) integer len, equal, lngest, patlen found = NO len = length(inpstr) if( len == 0 | inpstr(len) == '/' ) { inpstr(len+1) = '*' inpstr(len+2) = EOS } call fold(inpstr) call resdef( inpstr, path) call exppth(path, depth, ptr, buf) j = ptr(depth) pat(1) = EOS junk = gtftok(path, j, pat) j = ptr(depth) path(j) = EOS call dirfil(path, name, direc) if( fopend( name, dirfid) == ERR ) { ds = NO return } patlen = length(pat) while( fgdrpr( dirfid, name) == OK ) { call strcpy( name, tmpnam) tmpnam(patlen+1) = EOS if( equal( tmpnam, pat) == NO & pat(1) != '*' ) next junk = dnoise( name) if( found == NO ) { call strcpy( name, outstr) found = YES } i = lngest( name, outstr) outstr(i+1) = EOS } call fclosd( dirfid) ds = found return end #-h- fclosd 213 asc 25-mar-82 06:43:28 v1.1 (sw-tools v1.1) ## FClosD - (VMS) Close directory file opened as `fd'. ## Use this version until `fgdrpr' & co. are taught to use ## RMS $PARSE and $SEARCH. subroutine fclosd( fd) integer fd call close(fd) return end #-h- fgdrpr 1308 asc 25-mar-82 06:43:30 v1.1 (sw-tools v1.1) ## FGDrPr - (VMS) Get (next) filename `fil' from directory open on `fd'. ## This routine should probably be rewritten to use RMS ## $PARSE and $SEARCH directives. If you change it, be sure ## to fix `fopend' and `fclosd' as well... ## ## Note: `j' & `n' are expected to retain their values between calls... integer function fgdrpr( fd, fil) character fil(ARB) character buf(MAXLINE) integer fd integer count, fdb, i, j, junk, len, n integer getfdb, gets, itoc, length # function(s) integer*4 vers logical*1 tmp(4), low, high equivalence (tmp(1),vers), (low,tmp(1)), (high,tmp(2)) data j /0/ data n /0/ data vers /0/ fdb = getfdb(fd) if( j >= n ) # Read next record and extract filename. { n = gets( fdb, buf, MAXLINE) if( n == ERR ) { fgdrpr = ERR fil(1) = EOS return } count = buf(4) # Byte count of directory entry record. j = 5 for( i = 1 ; i <= count ; i = i + 1 ) { fil(i) = buf(j) j = j + 1 } fil(i) = '.' i = i + 1 if( mod( j, 2) == 0 ) # Align on even byte boundary. j = j + 1 len = i # Save length of filename. } i = len low = buf(j) high = buf(j+1) j = j + 8 # Point to next version number. junk = itoc(vers, fil(i), 10) # Tack on the version number. i = length(fil) + 1 fil(i) = EOS call fold(fil) fgdrpr = OK return end #-h- flushq 158 asc 25-mar-82 06:43:31 v1.1 (sw-tools v1.1) ## Flushq - Flush `oq' to `ochn'. subroutine flushq( ochn) integer ochn include cledit oq(qp) = EOS call putlin( oq, ochn) qp = 1 oq(qp) = EOS return end #-h- fopend 308 asc 25-mar-82 06:43:33 v1.1 (sw-tools v1.1) ## FOpenD - (VMS) Open directory file `fil' for reading; return `fd'. ## Use this version until `fgdrpr' & co. are taught to ## use RMS $PARSE and $SEARCH. integer function fopend( fil, fd) character fil(ARB) filedes fd integer open # Function(s) fd = open( fil, READ) fopend = fd return end #-h- gthist 256 asc 25-mar-82 06:43:34 v1.1 (sw-tools v1.1) ### GtHist Get a line from the history file for `lnedit'. integer function gthist( lin, i) character lin(ARB) integer i, j integer edline # function(s) lin(i) = '@n' lin( i + 1 ) = EOS j = edline(lin) if( j < 1 ) j = 1 lin(j) = EOS return(j) end #-h- insstr 248 asc 25-mar-82 06:43:36 v1.1 (sw-tools v1.1) ## InsStr - Insert string `s1' at position `i' of string `s2'. subroutine insstr( s1, s2, i) character s1(ARB), s2(ARB), t(MAXLINE) integer i, j call scopy( s2, i, t, 1) j = i call stcopy( s1, 1, s2, j) call stcopy( t, 1, s2, j) return end #-h- ledit 10256 asc 25-mar-82 06:43:41 v1.1 (sw-tools v1.1) ## LEdit - perform character editing on `lin'. character function ledit( pstr, lin, cur, ichn, ochn) include cledit integer cur, ichn, i, j, n, ochn, status integer addstr, index, ll2pl, length, max, min integer savcur, scn4ch, scnbbw, scnblw, scnebw, scnelw, type character c, lin(ARB), pstr(ARB), savlin(MAXLINE) character ctrlr(5), delstr(4), finstr(3) data ctrlr /'^', 'R', CR, LF, EOS/ data delstr /'d', ' ', EOS, EOS/ # Default `delete' command. data finstr /'f', ' ', EOS/ # Default `find' command. character ngetch, ngtnum hastab = NO #!!! Make this a switch call leinit( pstr, lin, cur, ochn) call strcpy( nl, savlin) savcur = nc call saveln( nl, nc) call updlin( ochn) repeat { n = 0 c = ngtnum(n, ichn) # Get num. prefix (if any) & next char. select(c) # Dispatch on character { case 'u': # Restore line before last change. { call strcpy( undlin, nl) nc = undcur call saveln( ol, oc) } case 'U': # Restore line to state at entry. { call strcpy( savlin, nl) nc = savcur call saveln( ol, oc) } case RETYPELINE: # Redisplay prompt and line. { if( ol(oc) != EOS ) call putchq( ol(oc), ochn) call putstf( ctrlr, ochn) ol(1) = EOS oc = 1 call putstf( pstr, ochn) } case ' ': # Move -> chars. { if( nc + n > length(ol) + 1 ) n = length(ol) - nc + 1 nc = nc + n } case BACKSPACE, 'h': # Move <- chars. { if( n >= nc ) n = nc - 1 nc = nc - n } case '%', '0': # Move to beginning of line. nc = 1 case '$': # Move to end of line nc = length(ol) # Move -> words. case 'w': nc = scnblw( ol, oc, n) case 'W': nc = scnbbw( ol, oc, n) case 'e': nc = scnelw( ol, oc, n) case 'E': nc = scnebw( ol, oc, n) case 'f': # Move thru th instance of char. { finstr(1) = c c = ngetch( c, ichn) if( (c >= ' ' | c == '@t') & ol(oc) != EOS ) { finstr(2) = c nc = scn4ch( ol, oc, c, n) } } case 't': # Move to th instance of char. { finstr(1) = c c = ngetch( c, ichn) if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 ) { finstr(2) = c nc = scn4ch( ol, oc+1, c, n) - 1 } } case 'F': # Move <- thru th instance of char. { finstr(1) = c c = ngetch( c, ichn) i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc ) { finstr(2) = c n = -n nc = scn4ch( ol, oc, c, n) n = -n } } case 'T': # Move <- to th instance of char. { finstr(1) = c c = ngetch( c, ichn) i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc - 1 ) { finstr(2) = c n = -n nc = scn4ch( ol, oc-2, c, n) + 1 n = -n } } case ';': # ReQueue last `find' command. call pbcmd( EOS, n, finstr) case ',': # ReQueue last `find' in reverse. { if( finstr(1) == 'f' ) finstr(1) = 'F' else if( finstr(1) == 'F' ) finstr(1) = 'f' else if( finstr(1) == 't' ) finstr(1) = 'T' else finstr(1) = 't' call pbcmd( EOS, n, finstr) } case 'd': # Delete text object(s). { call saveln( ol, oc) c = ngtnum( n, ichn) # Allow count to follow `d' cmd. select(c) # Dispatch for DELETE command { case '$': # Delete from cursor thru EOL. nl(nc) = EOS # nc will be adjusted by `updlin'. case '%': # Delete from BOL thru cursor. { call scopy( ol, oc+1, nl, 1) nc = 1 } case 'd': # Delete entire line. { delstr(2) = c delstr(3) = EOS nl(1) = EOS nc = 1 } case ' ': # Delete -> chars. { delstr(2) = c delstr(3) = EOS if( oc + n > length(ol) + 1 ) n = length(ol) - oc + 1 call scopy( ol, oc+n, nl, oc) } case 'w', 'W', 'e', 'E': # Delete -> words. { delstr(2) = c delstr(3) = EOS if( c == 'w' ) i = scnblw( ol, oc, n) else if( c == 'W' ) i = scnbbw( ol, oc, n) else if( c == 'e' ) i = scnelw( ol, oc, n) else i = scnebw( ol, oc, n) if( ol(i) != EOS & ol(i+1) != EOS & ( c == 'e' | c == 'E' ) ) i = i + 1 if( i == oc & ol(i+1) == EOS ) # Rubout last char. i = i + 1 call scopy( ol, i, nl, nc) } case 'b', 'B': # Delete <- words. { delstr(2) = c delstr(3) = EOS n = -n if( c == 'b' ) nc = scnblw( ol, oc, n) else nc = scnbbw( ol, oc, n) n = -n if( nc == oc & (ol(oc) == EOS | ol(oc+1) == EOS) ) nl(nc) = EOS else call scopy( ol, oc, nl, nc) } case 'f': # Delete -> thru th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c if( (c >= ' ' | c == '@t') & ol(oc) != EOS ) { i = scn4ch( ol, oc, c, n) if( i > oc ) call scopy( ol, i+1, nl, oc) } } case 't': # Delete -> to th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 ) { i = scn4ch( ol, oc+1, c, n) if( i > oc + 1 ) call scopy( ol, i, nl, oc) } } case 'F': # Delete <- thru th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc ) { n = - n i = scn4ch( ol, oc, c, n) n = -n call scopy( ol, oc, nl, i) } } case 'T': # Delete <- to th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc - 1 & oc > 2 ) { n = -n nc = scn4ch( ol, oc-2, c, n) + 1 n = -n call scopy( ol, oc, nl, nc) } } default: # Illegal object specified to `Delete' cmd. call lerror( 0, ochn) } } case '.': # ReQueue last `delete' command. call pbcmd( EOS, n, delstr) case 'b', 'B': # Move cursor <- words. { n = -n if( c == 'b' ) nc = scnblw( ol, oc, n) else nc = scnbbw( ol, oc, n) n = -n } case 'r': # Replace character under cursor. { c = ngetch( c, ichn) call saveln( ol, oc) if( c >= ' ' | c == '@t' ) nl(nc) = c } case 'x': # Queue a `d ' command. call pbcmd( EOS, n, "d ") case 'X': # Delete <- chars. { call saveln( ol, oc) if( n >= oc ) n = oc - 1 call strcpy( nl, ol) nc = oc - n call scopy( ol, oc, nl, nc) } case 'D': # Queue a `d$' command call pbcmd( EOS, n, "d$") case 'A': # Queue a `$a' command call pbcmd( "$", n, "a") case 'I': # Queue a `%i' command call pbcmd( "%", n, "i") case 'C': # Queue a `c$' command. call pbcmd( EOS, n, "c$") case 'a': # Append text after cursor. { call saveln( ol, oc) if( ol(oc) != EOS ) { call putchf( ol(oc), ochn) oc = oc + 1 } call rawtxt( oc, oc, n, ichn, ochn) } case 'i': # Insert text before cursor. { call saveln( ol, oc) call rawtxt( oc, oc, n, ichn, ochn) } case 'R': # Replace (overwrite) text at cursor. { call saveln( ol, oc) call rawtxt( oc, 0, n, ichn, ochn) } case 's': # Substitute new text for next chars. { call saveln( ol, oc) i = min( oc+n-1, length(ol)) c = nl(i) nl(i) = '$' # Mark end of text to be replaced. call updlin( ochn) nl(i) = c n = 1 call rawtxt( oc, i+1, n, ichn, ochn) } case 'c': # Change text object { c = ngtnum( n, ichn) # Allow count to follow `c' cmd. call saveln( ol, oc) select(c) # Dispatch for Change { case '$': # Change text from cursor thru EOL. { call rawtxt( oc, length(ol)+1, n, ichn, ochn) } case '%': # Change text from BOL thru cursor. { c = nl(oc) nl(oc) = '$' nc = 1 call updlin( ochn) nl(oc) = c call rawtxt( nc, oc+1, n, ichn, ochn) } # Change -> words. case 'w', 'W', 'e', 'E': { if( c == 'w' ) i = scnblw( ol, oc, n) else if( c == 'W' ) i = scnbbw( ol, oc, n) else if( c == 'e' ) i = scnelw( ol, oc, n) else i = scnebw( ol, oc, n) if( i > 1 & ol(i+1) != EOS & (c == 'w' | c == 'W') ) i = i - 1 c = nl(i) nl(i) = '$' call updlin( ochn) nl(i) = c call rawtxt( oc, i+1, n, ichn, ochn) } default: # Illegal object specified to `Change' cmd. call lerror( 0, ochn) } } case CR: # CARRIAGE_RETURN -> return to caller break case ENDOFFILE, EDITLINE: # Move cursor to EOL. { nc = length(nl) call updlin( ochn) if( c == EDITLINE ) # Force CARRIAGE_RETURN. c = CR break } default: call lerror( 0, ochn) } call updlin( ochn) # Refresh line. call strcpy( nl, ol) oc = nc } nl(nc+1) = EOS call strcpy( nl, lin) cur = nc ledit = c return end #-h- leinit 686 asc 25-mar-82 06:43:45 v1.1 (sw-tools v1.1) ## LEInit - Initialize intra-line editing variables. subroutine leinit( pstr, lin, curpos, ochn) character pstr(ARB), lin(ARB) integer cur, curpos, len, ochn integer length, ll2pl, max include cledit len = max( length( lin), 1) for( cur = curpos ; cur > len ; cur = cur - 1 ) call putch( BACKSPACE, ochn) call settab( EOS, tabs) lc1 = 1 call stcopy( pstr, 1, fl, lc1) pc1 = lc1 - 1 pc1 = ll2pl( fl, lc1-1, npl, npc) + 1 call scopy( lin, 1, fl, lc1) nmaxpc = ll2pl( fl, cur+lc1-1, npl, npc) call strcpy( npl, opl) omaxpc = nmaxpc opc = npc call strcpy( lin, nl) call strcpy( nl, ol) call strcpy( nl, undlin) nc = cur oc = cur undcur = cur qp = 1 oq(qp) = EOS return end #-h- lerror 173 asc 25-mar-82 06:43:46 v1.1 (sw-tools v1.1) ## LError - Process errors for intra-line editor. subroutine lerror( errcod, ochn) integer errcod, ochn # For now, just ring bell... call putch( BELL, ochn) return end #-h- ll2pl 1015 asc 25-mar-82 06:43:48 v1.1 (sw-tools v1.1) ## LL2PL Convert logical line to physical line; compute cursor posn. ## Set `pc' to physical position corresponding to logical `lc'. ## Return the maximum physical column written. integer function ll2pl( ll, lc, pl, pc) character c, ll(ARB), pl(ARB) integer i, lc, maxpc, pc, savepc integer max, tabpos # Function(s). include cledit pc = 1 maxpc = 1 savepc = 1 for( i = 1 ; ll(i) != EOS ; i = i + 1 ) { c = ll(i) if( c >= ' ' & c < RUBOUT ) #!!! Warning: ASCII assumed !!! { pl(pc) = c pc = pc + 1 } else if( c == '@t' ) { repeat { pl(pc) = '@t' pc = pc + 1 } until( tabpos( pc, tabs) == YES ) } else # Misc. control char; reserve 2 columns. { pl(pc) = c pl(pc+1) = c pc = pc + 2 } maxpc = max( maxpc, pc) if( i == lc ) # Save this pc. savepc = pc } pl(maxpc) = EOS if( savepc > 1 ) pc = max( savepc-1, pc1) else pc = max( maxpc, pc1) maxpc = max( maxpc-1, pc1) # Point at last char. written. ll2pl = maxpc return end #-h- lngest 253 asc 25-mar-82 06:43:50 v1.1 (sw-tools v1.1) ## lngest - Return length of the longest substring common to two strings. integer function lngest( s1, s2) integer i character s1(ARB), s2(ARB) for( i = 1 ; s1(i) == s2(i) & s1(i) != EOS & s2(i) != EOS ; i = i + 1 ) ; lngest = i - 1 return end #-h- mvcurq 930 asc 25-mar-82 06:43:52 v1.1 (sw-tools v1.1) ## MvCurQ - Queue chars to move cursor from `c1' to `c2'. integer function mvcurq( bcklin, fwdlin, c1, c2, ochn) character bcklin(ARB), fwdlin(ARB) integer c1, c2, i, ochn integer putchq # Function(s). include cledit if( c1 <= c2 ) # Move cursor right. { for( i = c1 ; i <= c2 ; ) { if( fwdlin(i) == EOS ) { i = i + putchq( ' ', ochn) break } i = i + putchq( fwdlin(i), ochn) } i = i + putchq( BACKSPACE, ochn) } else # Move cursor left. { if( c1 - c2 < c2 + 2 ) { for( i = c1 ; i > c2 ; i = i + putchq( BACKSPACE, ochn) ) ; } else { call putchq( CR, ochn) for( i = 1 ; i < pc1 ; i = i + 1 ) call putchq( fl(i), ochn) while( i <= c2 ) { if( fwdlin(i) == EOS ) { i = i + putchq( ' ', ochn) break } i = i + putchq( fwdlin(i), ochn) } i = i + putchq( BACKSPACE, ochn) } } mvcurq = i return end #-h- ngtnum 520 asc 25-mar-82 06:43:53 v1.1 (sw-tools v1.1) ## NGtNum - Get numeric prefix (if any) for intra-line commands. character function ngtnum(n, ichn) character c, ngetch character numstr(12) integer i, n, ichn integer ctoi, type c = ngetch( c, ichn) if( c != '0' ) # Leading zeroes get passed back to caller. for( i = 1 ; type(c) == DIGIT ; i = i + 1 ) { numstr(i) = c c = ngetch( c, ichn) } if( i > 1 ) # Convert to integer. { numstr(i) = EOS i = 1 n = ctoi( numstr, i) } else if( n == 0 ) # Set default count. n = 1 ngtnum = c return end #-h- pbcmd 353 asc 25-mar-82 06:43:55 v1.1 (sw-tools v1.1) ## PBCmd - Put back a command for the intra-line editor. define(NUMSTRSIZE,11) subroutine pbcmd( prefix, num, cmdstr) character cmdstr(ARB), numstr(NUMSTRSIZE), prefix(ARB) integer junk, num integer itoc call pbstr( cmdstr) junk = itoc( num, numstr, NUMSTRSIZE) call pbstr( numstr) if( prefix(1) != EOS ) call pbstr( prefix) return end #-h- putchf 166 asc 25-mar-82 06:43:56 v1.1 (sw-tools v1.1) ## PutChF - Put character on `ochn' and flush queue. subroutine putchf( c, ochn) character c integer ochn call putchq( c, ochn) call flushq( ochn) return end #-h- putchq 1026 asc 25-mar-82 06:43:58 v1.1 (sw-tools v1.1) ## PutChQ - Put character into output queue. Flush queue if required. integer function putchq( c, ochn) character c integer cnt, i, ochn integer max, tabpos include cledit i = opc cnt = 1 if( c == '@t' ) { opl(opc) = '@t' for( opc = opc + 1 ; tabpos( opc, tabs) == NO ; opc = opc + 1 ) { opl(opc) = '@t' cnt = cnt + 1 } } else if( c == CR ) # CARRIAGE_RETURN opc = 1 else if( c == BACKSPACE ) opc = max( opc - 1, 1) else if( c >= ' ' ) { opl(opc) = c opc = opc + 1 } else if( c != '@n' ) { opl(opc) = c opl(opc+1) = c opc = opc + 2 cnt = 2 } if( qp + cnt >= MAXLINE ) # Queue overflow. Flush it. call flushq( ochn) if( c == '@t' & hastab == NO ) for( ; cnt > 0 ; cnt = cnt - 1 ) { oq(qp) = ' ' qp = qp + 1 } else if( c >= ' ' | c == BACKSPACE | c == CR | c == '@n' ) { oq(qp) = c qp = qp + 1 } else { oq(qp) = '^' oq(qp+1) = c + '@@' #!!! Warning: ASCII assumed !!! qp = qp + 2 } putchq = opc - i # Number of physical columns we've moved. return end #-h- putstf 180 asc 25-mar-82 06:44:00 v1.1 (sw-tools v1.1) ## PutStF - Put string into output queue; flush queue. subroutine putstf( str, ochn) character str(ARB) integer i, ochn call putstq( str, ochn) call flushq( ochn) return end #-h- putstq 196 asc 25-mar-82 06:44:01 v1.1 (sw-tools v1.1) ## PutStQ - Put string into output queue. subroutine putstq( str, ochn) character str(ARB) integer i, ochn for( i = 1 ; str(i) != EOS ; i = i + 1 ) call putchq( str(i), ochn) return end #-h- rawio 586 asc 25-mar-82 06:44:03 v1.1 (sw-tools v1.1) ## rawio - determine if rawpmt can be used on unit integer function rawio( in, out, savmod) integer in, out, savmod integer create, stmode, isatty, gtmode string ttystr TTY_NAME if( out == EOF ) # need to open echo unit { out = create( ttystr, WRITE) if( out != ERR ) if( stmode(out, RARE) != RARE ) { call close(out) out = ERR } } rawio = NO if( isatty(in) == YES & out != ERR ) { savmod = gtmode(in) # save current mode if( stmode( in, RARE) == RARE ) # can do rare mode rawio = YES else savmod = stmode( in, savmod) } return end #-h- rawtxt 1731 asc 25-mar-82 06:44:05 v1.1 (sw-tools v1.1) ## Rawtxt - Get raw text for insert, append, change, and replace. subroutine rawtxt( fstcol, lstcol, n, ichn, ochn) integer end, i, ichn, fstcol, lstcol, n, ochn, olen, start integer length, max, whites # Function(s). character c, tail(MAXLINE) character getch include cledit start = fstcol end = lstcol olen = length(ol) if( end != 0 ) call scopy( ol, end, tail, 1) # Save rest of line. else call strcpy( ol, tail) i = start for( c = getch( c, ichn) ; c != ENDOFFILE & c != ESC ; c = getch( c, ichn) ) { if( c == EDITLINE ) { call putbak( EDITLINE) break } if( c == CR ) # CARRIAGE_RETURN { call putbak( CR) break } if( c == RUBOUT | c == BACKSPACE ) { if( i > start ) { i = i - 1 call bckupc( ochn, NO) call flushq( ochn) } } else if( c == WORDDELETE ) { for( ; i > start & whites(nl(i-1)) == YES ; i = i - 1 ) call bckupc( ochn, NO) for( ; i > start & whites(nl(i-1)) == NO ; i = i - 1 ) call bckupc( ochn, YES) call flushq( ochn) } else if( c >= ' ' | c == '@t' ) { nl(i) = c ol(i) = c call putchf( c, ochn) i = i + 1 nl(i) = EOS } else call putch( BELL, ochn) } nl(i) = EOS if( i > olen ) ol(i) = EOS oc = i call scopy( nl, start, tmplin, 1) # Insert text times. if( (length(tmplin)*n + start) < MAXLINE ) # Everything fits. for( n = n - 1 ; n > 0 ; n = n - 1 ) call stcopy( tmplin, 1, nl, i) nc = max( i - 1, start) if( end != 0 ) # Not overwrite mode. call strcpy( tail, tmplin) else call scopy( tail, i, tmplin, 1) if( (length(tmplin) + i) < MAXLINE ) # Everything fits. call stcopy( tmplin, 1, nl, i) else call putc( BELL, ochn) nl(i) = EOS return end #-h- recogf 482 asc 25-mar-82 06:44:07 v1.1 (sw-tools v1.1) ## recogf - Recognize longest unique filename substring matching %`str'. ## complete the string in `str'. integer function recogf(str) integer i, j integer ds, length character outstr(FILENAMESIZE), str(ARB) j = length(str) i = j if( i > 0 ) repeat { if( str(i) == '/' | str(i) == '\' ) break i = i - 1 } until( i == 0 ) if( ds( str, outstr) == NO ) { recogf = ERR return } else { call scopy( outstr, 1, str, i+1) recogf = OK } return end #-h- saveln 175 asc 25-mar-82 06:44:08 v1.1 (sw-tools v1.1) ## SaveLn - Save line state for `undo' subroutine saveln( lin, cur) character lin(ARB) integer cur include cledit call strcpy( lin, undlin) undcur = cur return end #-h- scn4ch 561 asc 25-mar-82 06:44:10 v1.1 (sw-tools v1.1) ## Scn4Ch - Scan for th occurence of char . Update . integer function scn4ch( lin, i, c, n) integer i, j, k, n integer index # function(s) character c, lin(ARB) if( n > 0 ) { for( j = i ; index( lin(j+1), c) > 0 & n > 0 ; n = n - 1 ) { if( lin(j) == c ) j = j + 1 for( ; lin(j) != c & lin(j) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { k = index( lin, c) for( j = i ; k < j & n < 0 ; n = n + 1 ) { if( lin(j) == c ) j = j - 1 for( ; lin(j) != c ; j = j - 1 ) ; } } scn4ch = j return end #-h- scnbbw 684 asc 25-mar-82 06:44:12 v1.1 (sw-tools v1.1) ## ScnBBW - Scan to beginning of th (big) word. Update . integer function scnbbw( lin, i, n) integer i, j, n integer whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { for( ; whites(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { for( j = i ; j > 1 & n < 0 ; n = n + 1 ) { if( whites(lin(j-1)) == YES ) # At beginning of word. j = j - 1 for( ; whites(lin(j)) == YES & j > 1 ; j = j - 1 ) ; for( ; j > 1 ; j = j - 1) if( whites( lin(j-1)) == YES ) break } } return(j) end #-h- scnbck 727 asc 25-mar-82 06:44:13 v1.1 (sw-tools v1.1) ## ScnBck - Scan backwards until a terminator or boundary is reached. ## Return the index of the last character scanned before terminator. ## Output string `rubstr' on `chn' as each char is scanned. integer function scnbck( str, col, rubstr, chn, trmara) integer i, chn, col integer index character rubstr(ARB), str(ARB), trmara(ARB) if( col > 1 ) { i = col - 1 # Point to last char entered. for( ; index( trmara, str(i)) == 0 & i > 1 ; i = i - 1 ) if( rubstr(1) != EOS ) call putlin( rubstr, chn) if( i == 1 & index( trmara, str(i)) == 0 ) { if( rubstr(1) != EOS ) call putlin( rubstr, chn) } else i = i + 1 # Point to next char to be entered. } else i = 1 scnbck = i return end #-h- scnblw 1065 asc 25-mar-82 06:44:15 v1.1 (sw-tools v1.1) ## ScnBLW - Scan to beginning of th (little) word. Update . integer function scnblw( lin, i, n) integer i, j, n integer alphan, whites # function(s) character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( alphan(lin(j)) == YES ) for( ; alphan(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; else if( alphan(lin(j)) == NO & whites(lin(j)) == NO ) for( ; alphan(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { for( j = i ; j > 1 & n < 0 ; n = n + 1 ) { for( j = j - 1 ; j > 1 ; j = j - 1 ) if( whites( lin(j)) == NO ) break if( j > 1 ) if( alphan( lin(j)) == YES ) for( ; j > 1 ; j = j - 1 ) if( alphan( lin(j-1)) == NO ) break if( j > 1 ) if( alphan( lin(j)) == NO ) for( ; alphan(lin(j-1)) == NO & whites(lin(j-1)) == NO ; j = j - 1 ) if( j <= 2 ) break } } return(j) end #-h- scnebw 550 asc 25-mar-82 06:44:17 v1.1 (sw-tools v1.1) #### WARNING! case where n<0 has not been implemented. ## ScnEBW - Scan to end of th (big) word. Update . integer function scnebw( lin, i, n) integer i, j, n integer whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( whites(lin(j+1)) == YES ) # At end of word. j = j + 1 for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { j = i } scnebw = j return end #-h- scnelw 763 asc 25-mar-82 06:44:19 v1.1 (sw-tools v1.1) #### WARNING! case where n<0 has not been implemented. ## ScnELW - Scan to end of th (little) word. Update . integer function scnelw( lin, i, n) integer i, j, n integer alphan, whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( lin(j) != EOS & lin(j+1) != EOS ) j = j + 1 for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; if( alphan(lin(j)) == YES ) { if( alphan(lin(j+1)) == YES ) for( ; alphan(lin(j+1)) == YES ; j = j + 1 ) ; } else if( alphan(lin(j+1)) == NO & whites(lin(j+1)) == NO ) for( ; alphan(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { j = i } scnelw = j return end #-h- spawnd 410 asc 25-mar-82 06:44:20 v1.1 (sw-tools v1.1) ## SpawnD -- Spawn the directory lister with an argument string. subroutine spawnd(args) character args(ARB), image(FILENAMESIZE), pid(PIDSIZE) integer loccom, spawn integer junk, init string d "d" string spath "@e~usr/@e~bin/@e@n" string suffix IMAGE_SUFFIX data init /YES/ if( init == YES ) { init = NO junk = loccom( d, spath, suffix, image) } junk = spawn( image, args, pid, WAIT) return end #-h- spnbck 661 asc 25-mar-82 06:44:22 v1.1 (sw-tools v1.1) ## SpnBck - Span backwards until a non-separator or boundry is reached. ## Return the index of the last character scanned before separator. ## Output string `rubstr' on `chn' as each char is scanned. integer function spnbck( str, col, rubstr, chn, separa) integer i, chn, col integer index character rubstr(ARB), str(ARB), separa(ARB) if( col > 1 ) { i = col - 1 # Point to last char entered. for( ; index( separa, str(i)) > 0 & i > 1 ; i = i - 1 ) if( rubstr(1) != EOS ) call putlin( rubstr, chn) if( i == 1 ) { if( rubstr(1) != EOS ) call putlin( rubstr, chn) } else i = i + 1 } else i = 1 spnbck = i return end #-h- updlin 1197 asc 25-mar-82 06:44:24 v1.1 (sw-tools v1.1) ## UpdLin - Update line on screen. subroutine updlin( ochn) integer ochn integer i, j, k integer d2eol, index, length, ll2pl, max, min, mvcurq, putchq # Function(s). include cledit nc = max( min( nc, length(nl) ), 1) # Make sure 1 <= nc <= length(nl). call scopy( ol, 1, fl, lc1) omaxpc = ll2pl( fl, oc+lc1-1, opl, opc) call scopy( nl, 1, fl, lc1) nmaxpc = ll2pl( fl, nc+lc1-1, npl, npc) # Translate log. line to phy. line. for( i = pc1 ; opl(i) == npl(i) ; i = i + 1 ) # Find 1st difference. if( opl(i) == EOS | npl(i) == EOS ) break if( npl(i) != opl(i) ) # Line has changed. { i = mvcurq( opl, npl, opc, i, ochn) # Move cursor there. if( nmaxpc == omaxpc & index( ol, '@t') == 0 ) # Save some repainting. { for( j = nmaxpc ; j > i ; j = j - 1 ) if( opl(j) != npl(j) ) break } else j = nmaxpc for( k = i ; k <= j & npl(k) != EOS ; ) # Output new text. k = k + putchq( npl(k), ochn) if( nmaxpc < omaxpc ) # Delete to end-of-line. k = k + d2eol( ochn) npc = mvcurq( npl, npl, k, npc, ochn) # Move cursor to desired position. } else # Just move cursor. npc = mvcurq( npl, npl, opc, npc, ochn) call flushq( ochn) return end #-h- whites 168 asc 25-mar-82 06:44:26 v1.1 (sw-tools v1.1) ## WhiteS - Return yes if char is `whitespace' ('@t' | ' '). integer function whites( c) character c if( c == '@t' | c == ' ' ) return(YES) else return(NO) end #-h- misc.r 22935 asc 06-apr-82 15:09:26 j (sventek j) #-h- acopy 280 asc 06-apr-82 15:06:50 j (sventek j) ## ACopy -- Copy `size' characters from `ifd' to `ofd'. subroutine acopy( ifd, ofd, size) character getch # function(s) character c filedes ifd, ofd integer i, size for( i = 1 ; i <= size ; i = i + 1 ) { if( getch( c, ifd) != EOF ) call putch( c, ofd) } return end #-h- addset 241 asc 06-apr-82 15:06:51 j (sventek j) ## AddSet -- Put `c' in `string(j)' if it fits; increment `j'. integer function addset( c, str, j, maxsiz) integer j, maxsiz character c, str(maxsiz) if( j > maxsiz ) return(NO) else { str(j) = c j = j + 1 return(YES) } end #-h- addstr 226 asc 06-apr-82 15:06:52 j (sventek j) integer function addstr(s, str, j, maxsiz) character s(ARB), str(ARB) integer j, maxsiz, i integer length if ((length(s) + j) > maxsiz) return(NO) for (i=1; s(i) != EOS; i=i+1) call chcopy(s(i), str, j) return(YES) end #-h- adrfil 222 asc 06-apr-82 15:06:53 j (sventek j) ## AdrFil -- Get name of software tools user-info database. subroutine adrfil(file) character file(FILENAMESIZE) string addr "address" call getdir( MSGDIRECTORY, LOCAL, file) call concat( file, addr, file) return end #-h- alldig 284 asc 06-apr-82 15:06:54 j (sventek j) ## AllDig -- Return YES if `str' is all digits. integer function alldig(str) integer i integer type # function(s) character str(ARB) if( str(1) == EOS ) return(NO) for( i = 1 ; str(i) != EOS ; i = i + 1 ) if( type( str(i) ) != DIGIT ) return(NO) return(YES) end #-h- badarg 247 asc 06-apr-82 15:06:55 j (sventek j) ## BadArg -- Output `invalid argument' message. subroutine badarg(arg) character arg(ARB) string msg1 "? Ignoring invalid argument `" string msg2 "'@n" call putlin( msg1, ERROUT) call putlin( arg, ERROUT) call putlin( msg2, ERROUT) return end #-h- bubble 307 asc 06-apr-82 15:06:56 j (sventek j) ## Bubble -- bubble sort v(1)...v(n) increasing. subroutine bubble( v, n) integer i, j, k, n, v(ARB) for( i = n ; i > 1 ; i = i - 1 ) for( j = 1 ; j < i ; j = j + 1 ) if( v(j) > v( j + 1 ) ) # compare { k = v(j) # exchange v(j) = v( j + 1 ) v( j + 1 ) = k } return end #-h- cant 326 asc 06-apr-82 15:06:56 j (sventek j) ### Can't -- Display the bad news that `file' can't be opened; then exit #subroutine cant(file) # #character file(ARB) # #string msg1 "? Can't open file named `" #string msg2 "'@n" # #call putlin( msg1, ERROUT) #call putlin( file, ERROUT) #call putlin( msg2, ERROUT) #call endst(ERR) # Indicate error to parent process. #end #-h- chcopy 128 asc 06-apr-82 15:06:57 j (sventek j) # subroutine chcopy(c, buf, i) # # character c, buf(ARB) # integer i # # buf(i) = c # i = i + 1 # buf(i) = EOS # # return # end #-h- clower 367 asc 06-apr-82 15:06:58 j (sventek j) # ## clower - change letter to lower case # character function clower(c) # # character c, k # # if (c >= 'A' & c <= 'Z') # { #avoid integer overflow in byte machines # k = 'a' - 'A' # clower = c + k # } # else # clower = c # # return # end #-h- concat 191 asc 06-apr-82 15:06:59 j (sventek j) # subroutine concat(first, second, out) # # character first(ARB), second(ARB), out(ARB) # integer i # # i = 1 # call stcopy(first, 1, out, i) # call scopy(second, 1, out, i) # # return # end #-h- ctoc 263 asc 06-apr-82 15:07:00 j (sventek j) ### CToC Convert EOS-terminated string to EOS-terminated string integer function ctoc(from, to, len) integer len character from(ARB), to(len) integer i for( i = 1 ; i < len & from(i) != EOS ; i = i + 1 ) to(i) = from(i) to(i) = EOS return( i - 1 ) end #-h- ctodi 486 asc 06-apr-82 15:07:01 j (sventek j) ## CToDI -- Convert character string to pair of integers. subroutine ctodi( buf, i, di) character buf(ARB), hi(10), lo(6), temp(MAXCHARS) integer di(2), i, j, len integer ctoi, getwrd # function(s) len = getwrd( buf, i, temp) if( len <= 4 ) { hi(1) = EOS call strcpy( temp, lo) } else { len = len - 4 for( j = 1 ; j <= len ; j = j + 1 ) hi(j) = temp(j) hi(j) = EOS call scopy( temp, j, lo, 1) } j = 1 di(1) = ctoi( hi, j) j = 1 di(2) = ctoi( lo, j) return end #-h- ctoi 470 asc 06-apr-82 15:07:02 j (sventek j) ## CToI -- Convert string at `in(i)' to integer; increment `i'. integer function ctoi( in, i) character in(ARB) integer index # function(s) integer d, i, sign string digits "0123456789" while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 sign = 1 if( in(i) == '-' ) { sign = -1 i = i + 1 } for( ctoi = 0 ; in(i) != EOS ; i = i + 1 ) { d = index( digits, in(i) ) if( d == 0 ) # non-digit break ctoi = 10 * ctoi + d - 1 } return( sign * ctoi ) end #-h- cupper 370 asc 06-apr-82 15:07:03 j (sventek j) # ## cupper - change letter to upper case # character function cupper(c) # # character c, k # # if (c >= 'a' & c <= 'z') # { #avoid overflow with byte-oriented machines # k = 'A' - 'a' # cupper = c + k # } # else # cupper = c # # return # end #-h- disize 378 asc 06-apr-82 15:07:04 j (sventek j) ## DiSize -- determine size of `file' in characters as a double integer integer function dsize(file, di) character getch # function(s) character c, file(ARB) integer open # function(s) integer di(2) filedes fd initdi(di) fd = open( file, READ) if( fd == ERR ) return(ERR) else { while (getch( c, fd) != EOF ) incrdi(di) call close(fd) } return(OK) end #-h- ditoc 515 asc 06-apr-82 15:07:05 j (sventek j) ## DIToC -- Convert a pair of integers to a character string. integer function ditoc( di, buf, size) integer di(2), i, j, n, size integer itoc # function(s) character buf(size), lo(5), temp(MAXCHARS) n = itoc( di(2), lo, 5) if( di(1) > 0 ) { i = itoc( di(1), temp, MAXCHARS) + 1 for( j = n + 1 ; j <= 4 ; j = j + 1 ) call chcopy( '0', temp, i) } else temp(1) = EOS call concat( temp, lo, temp) n = length(temp) + 1 - size i = max( n, 1) call scopy( temp, i, buf, 1) return( length(buf) ) end #-h- equal 340 asc 06-apr-82 15:07:06 j (sventek j) # ## equal - compare str1 to str2; return YES if equal, NO if not # integer function equal (str1, str2) # character str1(ARB), str2(ARB) # integer i # # for (i=1; str1(i) == str2(i); i=i+1) # if (str1(i) == EOS) # { # equal = YES # return # } # equal = NO # return # end #-h- error 136 asc 06-apr-82 15:07:07 j (sventek j) ## Error -- Print message and terminate execution. subroutine error (line) character line(ARB) call remark (line) call endst(ERR) end #-h- exppth 326 asc 06-apr-82 15:07:08 j (sventek j) ## ExpPth -- Pointers in `ptr' to fields of `path'. subroutine exppth( path, depth, ptr, buf) character buf(ARB), path(ARB) integer depth, i, ptr(MAXDIRECTS) integer gtftok # function(s) depth = 0 i = 1 repeat { depth = depth + 1 ptr(depth) = i } until( gtftok( path, i, buf) == 0 ) depth = depth - 1 return end #-h- fcopy 196 asc 06-apr-82 15:07:09 j (sventek j) ## FCopy -- Copy file `in' to file `out'. subroutine fcopy( in, out) character c character getch # function(s) filedes in, out while( getch( c, in) != EOF ) call putch( c, out) return end #-h- fmtdat 1500 asc 06-apr-82 15:07:10 j (sventek j) ## FmtDat -- Format date and time information. subroutine fmtdat( date, time, now, form) character date(10), time(9), temp(3) integer now(7), form integer i, j, k integer itoc # function(s) string months "JanFebMarAprMayJunJulAugSepOctNovDec" # if form == DIGIT, return mm/dd/yy in date # if form == LETTER, return dd-Mmm-yy in date # return hh:mm:ss in time k = 1 if( form == DIGIT ) { if( itoc( now(2), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '/', date, k) if( itoc( now(3), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '/', date, k) if( itoc( mod( now(1), 100), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) } else { if( itoc( now(3), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '-', date, k) for( j = 3 * ( now(2) - 1 ) + 1 ; k <= 6 ; j = j + 1 ) call chcopy( months(j), date, k) call chcopy( '-', date, k) if( itoc( mod( now(1), 100), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) } k = 1 if( itoc( now(4), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) call chcopy( ':', time, k) if( itoc( now(5), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) call chcopy( ':', time, k) if( itoc( now(6), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) return end #-h- fold 203 asc 06-apr-82 15:07:11 j (sventek j) # ## fold - fold all letters to lower case # subroutine fold (token) # character token(ARB), clower # integer i # # for (i=1; token(i) != EOS; i=i+1) # token(i) = clower(token(i)) # return # end #-h- fsize 344 asc 06-apr-82 15:07:12 j (sventek j) ## FSize -- Determine size of `file' in characters. integer function fsize(file) character getch # function(s) character c, file(ARB) integer open # function(s) filedes fd fd = open( file, READ) if( fd == ERR ) fsize = ERR else { for( fsize = 0 ; getch( c, fd) != EOF ; fsize = fsize + 1 ) ; call close(fd) } return end #-h- fskip 231 asc 06-apr-82 15:07:13 j (sventek j) ## FSkip -- Skip `n' characters on file `fd'. subroutine fskip( fd, n) character getch # function(s) character c filedes fd integer i, n for( i = 1 ; i <= n ; i = i + 1 ) if( getch( c, fd) == EOF ) break return end #-h- getc 142 asc 06-apr-82 15:07:14 j (sventek j) # ## getc - get character from STDIN # character function getc(c) # # character c # character getch # # getc = getch(c, STDIN) # return # end #-h- getwrd 367 asc 06-apr-82 15:07:15 j (sventek j) ## GetWrd -- Get non-blank word from `in(i)' into `out'; increment `i'. integer function getwrd( in, i, out) character in(ARB), out(ARB) integer i, j while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 j = 1 while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' ) { out(j) = in(i) i = i + 1 j = j + 1 } out(j) = EOS getwrd = j - 1 return end #-h- gitocf 940 asc 06-apr-82 15:07:16 j (sventek j) integer function gitocf(int, str, size, base, width, fc) integer mod integer int, size, base, width character str(size), fc integer intval, b, i, d, j character k string digits "0123456789abcdefghijklmnopqrstuvwxyz" intval = abs(int) b = base if (b < 2 | b > 36) b = 10 str(1) = EOS i = 1 repeat { # generate digits i = i + 1 d = mod(intval, b) + 1 str(i) = digits(d) intval = intval / b } until (intval == 0 | i >= size) if (int < 0 & i < size) { # then sign i = i + 1 str(i) = '-' } while (i <= width) if (i >= size) break else { i = i + 1 str(i) = fc } gitocf = i - 1 for (j = 1; j < i; j = j + 1) { # then reverse k = str(i) str(i) = str(j) str(j) = k i = i - 1 } return end #-h- gtftok 329 asc 06-apr-82 15:07:17 j (sventek j) # integer function gtftok(buf, i, token) # # character buf(ARB), token(ARB) # integer i, j # # if (buf(i) == '/') # i = i + 1 # j = 1 # while (buf(i) != '/' & buf(i) != EOS) # { # token(j) = buf(i) # i = i + 1 # j = j + 1 # if (buf(i-1) == '\') # break # } # token(j) = EOS # gtftok = j - 1 # # return # end #-h- impath 544 asc 06-apr-82 15:07:18 j (sventek j) ### impath - generate search path for standard images to be spawned #subroutine impath(path) # #character path(ARB) #integer i, j, n #integer length # #string spath "~usr/@e~bin/@e@n" # usr:bin # #call tooldr(path, PATH) # get ~/tools/ #n = length(path) + 2 # move string up one location #for ([j=n; i=n-1]; i > 0; [i=i-1; j=j-1]) # path(j) = path(i) #path(1) = EOS # search current directory first #for ([i=1; j=n+1]; spath(i) != '@n'; [i=i+1; j=j+1]) # path(j) = spath(i) #call chcopy('@n', path, j) # terminate path # #return #end #-h- index 255 asc 06-apr-82 15:07:20 j (sventek j) # ## index - find character c in string str # integer function index(str, c) # character c, str(ARB) # # for (index = 1; str(index) != EOS; index = index + 1) # if (str(index) == c) # return # index = 0 # return # end #-h- indexs 451 asc 06-apr-82 15:07:21 j (sventek j) ### IndexS -- Return index of `sub' in `str'. #integer function indexs( str, sub) # #character str(ARB), sub(ARB) #integer i, j, k # #for( i = 1 ; str(i) != EOS ; i = i + 1 ) #{ # j = i # for( k = 1 ; ; k = k + 1 ) # { # if( sub(k) == EOS ) # found it. # return(i) # else if( str(j) == EOS ) # ran out of string. # return(0) # else if( str(j) != sub(k) ) # try next posn. # break # j = j + 1 # } #} #return(0) # #end #-h- itoc 613 asc 06-apr-82 15:07:22 j (sventek j) ## IToC -- Convert integer `int' to character string in `str'. integer function itoc( int, str, size) integer mod # function(s) integer d, i, int, intval, j, k, size character str(size) string digits "0123456789" intval = abs(int) str(1) = EOS i = 1 repeat # generate digits { i = i + 1 d = mod( intval, 10) str(i) = digits( d + 1 ) intval = intval / 10 } until( intval == 0 | i >= size ) if( int < 0 & i < size ) # then sign { i = i + 1 str(i) = '-' } itoc = i - 1 for( j = 1 ; j < i ; j = j + 1 ) # then reverse { k = str(i) str(i) = str(j) str(j) = k i = i - 1 } return end #-h- length 184 asc 06-apr-82 15:07:23 j (sventek j) # ## length - compute length of string # integer function length (str) # # character str(ARB) # # for (length=0; str(length+1) != EOS; length = length + 1) # ; # return # end #-h- putc 118 asc 06-apr-82 15:07:23 j (sventek j) # ## putc - put character onto STDOUT # subroutine putc (c) # # character c # # call putch (c, STDOUT) # return # end #-h- putdec 387 asc 06-apr-82 15:07:24 j (sventek j) # ## putdec - put decimal integer n in field width >= w # subroutine putdec(n,w) # character chars(MAXCHARS) # integer itoc # integer i,n,nd,w # # nd = itoc(n,chars,MAXCHARS) # for(i = nd+1; i <= w; i = i+1) # call putc(' ') # for(i = 1; i <= nd; i = i+1) # call putc(chars(i)) # return # end #-h- putint 264 asc 06-apr-82 15:07:25 j (sventek j) ## PutInt -- Output integer `n' on `fd' in field `w' characters wide. subroutine putint( n, w, fd) character chars(MAXCHARS) filedes fd integer itoc # function(s) integer junk, n, w junk = itoc( n, chars, MAXCHARS) call putstr( chars, w, fd) return end #-h- putlnl 295 asc 06-apr-82 15:07:26 j (sventek j) ### putlnl - putlin, then flush, if necessary #subroutine putlnl(buf, int) # #character buf(ARB) #integer int, i # #for (i=1; buf(i) != EOS; i=i+1) # call putch(buf(i), int) #if (i > 1) # { # if (buf(i-1) != '@n') # call putch('@n', int) # } #else # call putch('@n', int) # #return #end #-h- putptr 276 asc 06-apr-82 15:07:27 j (sventek j) ## PutPtr -- Output pointer `ptr' as a character string on `fd'. subroutine putptr( ptr, fd) linepointer ptr filedes fd integer junk integer ptrtoc # function(s) character temp(LINEPTRSIZE) junk = ptrtoc( ptr, temp, LINEPTRSIZE) call putlin( temp, fd) return end #-h- putstr 397 asc 06-apr-82 15:07:28 j (sventek j) ## PutStr -- Output `str' on `fd' in field `w' characters wide. subroutine putstr( str, w, fd) character str(ARB) filedes fd integer length # function(s) integer w len = length(str) for( i = len + 1 ; i <= w ; i = i + 1 ) call putch( ' ', fd) for( i = 1 ; i <= len ; i = i + 1 ) call putch( str(i), fd) for( i = ( -w ) - len ; i > 0 ; i = i - 1 ) call putch( ' ', fd) return end #-h- query 287 asc 06-apr-82 15:07:29 j (sventek j) ## Query -- Print usage message, if requested. subroutine query(msg) character msg(ARB) integer getarg # function(s) character arg1(3), arg2(1) if( getarg( 1, arg1, 3) != EOF & getarg( 2, arg2, 1) == EOF ) if( arg1(1) == '?' & arg1(2) == EOS ) call error(msg) return end #-h- scopy 303 asc 06-apr-82 15:07:30 j (sventek j) # ## scopy - copy string at from(i) to to(j) # subroutine scopy(from, i, to, j) # character from(ARB), to(ARB) # integer i, j, k1, k2 # # k2 = j # for (k1 = i; from(k1) != EOS; k1 = k1 + 1) { # to(k2) = from(k1) # k2 = k2 + 1 # } # to(k2) = EOS # return # end #-h- sdrop 355 asc 06-apr-82 15:07:31 j (sventek j) ### SDrop Drop characters from a string APL-style integer function sdrop( from, to, chars) character from(ARB), to(ARB) integer chars integer len, start integer ctoc, length, min len = length(from) if( chars < 0 ) return( ctoc( from, to, len + chars + 1)) else { start = min( chars, len) return( ctoc( from( start + 1), to, len + 1 )) } end #-h- shell 398 asc 06-apr-82 15:07:32 j (sventek j) ## Shell -- Shell sort v(1)...v(n) increasing. subroutine shell( v, n) integer gap, i, j, jg, k, n, v(ARB) for( gap = n / 2 ; gap > 0 ; gap = gap / 2 ) for( i = gap + 1 ; i <= n ; i = i + 1 ) for( j = i - gap ; j > 0 ; j = j - gap ) { jg = j + gap if( v(j) <= v(jg) ) # compare break k = v(j) # exchange v(j) = v(jg) v(jg) = k } return end #-h- skipbl 171 asc 06-apr-82 15:07:33 j (sventek j) ## SkipBl -- Skip blanks and tabs at `lin(i)'. subroutine skipbl( lin, i) character lin(ARB) integer i while( lin(i) == ' ' | lin(i) == '@t' ) i = i + 1 return end #-h- stake 352 asc 06-apr-82 15:07:34 j (sventek j) ### STake take characters from a string APL-style integer function stake( from, to, chars) character from(ARB), to(ARB) integer chars integer len, start integer ctoc, length, max len = length(from) if( chars < 0 ) { start = max( len + chars, 0) return( ctoc( from( start + 1), to, len + 1)) } else return( ctoc( from, ro, chars + 1)) end #-h- stcopy 262 asc 06-apr-82 15:07:35 j (sventek j) ### stcopy - copy string at from(i) to to(j); increment j # subroutine stcopy(from, i, to, j) # character from(ARB), to(ARB) # integer i, j, k # # for (k=i; from(k) != EOS; k=k+1) # { # to(j) = from(k) # j = j + 1 # } # to(j) = EOS # # return # end #-h- strcmp 488 asc 06-apr-82 15:07:36 j (sventek j) # ## strcmp - compare 2 strings # # integer function strcmp (str1, str2) # character str1(ARB), str2(ARB) # integer i # # for (i=1; str1(i) == str2(i); i=i+1) # { # if (str1(i) == EOS) # { # strcmp = 0 # return # } # } # if (str1(i) == EOS) # strcmp = -1 # else if (str2(i) == EOS) # strcmp = + 1 # else if (str1(i) < str2(i)) # strcmp = -1 # else # strcmp = +1 # return # end #-h- strcpy 181 asc 06-apr-82 15:07:37 j (sventek j) # subroutine strcpy(in, out) # # character in(ARB), out(ARB) # integer i # # i = 0 # repeat # { # i = i + 1 # out(i) = in(i) # } # until (in(i) == EOS) # # return # end #-h- strim 257 asc 06-apr-82 15:07:38 j (sventek j) ### STrim trim trailing blanks and tabs from a string integer function strim(str) character str(ARB) integer i, lnb lnb = 0 for( i = 1 ; str(i) != EOS ; i = i + 1 ) if( str(i) != ' ' & str(i) != '@t' ) lnb = i str(lnb + 1) = EOS return(lnb) end #-h- tooldr 393 asc 06-apr-82 15:07:39 j (sventek j) subroutine tooldr(dir, dtype) character dir(FILENAMESIZE) integer dtype ifdef(TREE_STRUCT_FILE_SYS) character temp(FILENAMESIZE) string suffix "tools/" enddef ifnotdef(TREE_STRUCT_FILE_SYS) call homdir(dir, dtype) elsedef call homdir(temp, PATH) call concat(temp, suffix, temp) if (dtype == PATH) call strcpy(temp, dir) else call mklocl(temp, dir) enddef return end #-h- type 245 asc 06-apr-82 15:07:40 j (sventek j) # ## type - determine type of character # integer function type (c) # # character c # # if ((c >= 'a' & c <= 'z') | (c >= 'A' & c <= 'Z')) # type = LETTER # else if (c >= '0' & c <= '9') # type = DIGIT # else # type = c # return # end #-h- upper 207 asc 06-apr-82 15:07:40 j (sventek j) # ## upper - fold all alphas to upper case # subroutine upper (token) # # character token(ARB), cupper # integer i # # for (i=1; token(i) != EOS; i=i+1) # token(i) = cupper(token(i)) # return # end #-h- wkday 340 asc 06-apr-82 15:07:41 j (sventek j) # WkDay -- Get day-of-week corresponding to `month', `day', and `year'. integer function wkday( month, day, year) integer month, day, year integer lm, ld, ly lm = month - 2 ld = day ly = mod( year, 100) if( lm <= 0 ) { lm = lm + 12 ly = ly - 1 } wkday = mod( ld + ( 26 * lm - 2 ) / 10 + ly + ly / 4 - 34, 7) + 1 return end #-h- dstime 927 asc 06-apr-82 15:07:42 j (sventek j) # dstime - determine whether date is day-light savings time or not # # this routine uses the following algorithm: # # if the month specified is > 4 (April) and < 10 (October), then YES # if the month specified is < 4 or > 10, then NO # if the month = 4, and the day is < the last Sunday, then NO # else YES # if the month = 10, and the day is < the last Sunday, then YES # else NO integer function dstime(date) integer date(7), i integer wkday if (date(2) > 4 & date(2) < 10) return(YES) else if (date(2) == 4) # April { for (i = 30; i > 0; i = i - 1) if (wkday(4, i, date(1)) == 1) # found Sunday break if (date(3) < i) return(NO) else return(YES) } else if (date(2) == 10) # October { for (i = 31; i > 0; i = i - 1) if (wkday(10, i, date(1)) == 1) # found Sunday break if (date(3) < i) return(YES) else return(NO) } else return(NO) end #-h- packsub.r 1478 asc 25-mar-82 06:53:22 v1.1 (sw-tools v1.1) #-h- inpack 182 asc 25-mar-82 06:50:26 v1.1 (sw-tools v1.1) ## InPack -- Initialze data for packing subroutines. subroutine inpack( nxtcol, rightm, buf, fd) filedes fd integer nxtcol, rightm character buf(ARB) nxtcol = 1 return end #-h- dopack 813 asc 25-mar-82 06:50:27 v1.1 (sw-tools v1.1) ## DoPack -- Pack words at TAB stops and flush lines as required. subroutine dopack( word, nxtcol, rightm, buf, fd) filedes fd integer i, j, nxtcol, nxttab, rightm integer length # function(s) character buf(ARB), word(ARB) if( nxtcol == 1 ) # must have at least one word/line call stcopy( word, 1, buf, nxtcol) else { i = length(buf) + 1 # next free array element nxttab = ( ( ( nxtcol - 1 ) / 16 + 1 ) * 16 ) + 1 # next tab stop j = nxttab + length(word) - 1 # last occupied column if( j > rightm ) { call flpack( nxtcol, rightm, buf, fd) i = 1 nxttab = nxtcol j = length(word) } if( ( nxttab - nxtcol ) > 8 ) call chcopy( '@t', buf, i) if( ( nxttab - nxtcol ) > 0 ) call chcopy( '@t', buf, i) call scopy( word, 1, buf, i) nxtcol = j + 1 } return end #-h- flpack 264 asc 25-mar-82 06:50:29 v1.1 (sw-tools v1.1) ## FlPack -- Flush buffer of packed words. subroutine flpack( nxtcol, rightm, buf, fd) filedes fd integer nxtcol, rightm character buf(ARB) if( nxtcol > 1 ) # something to flush { call putlin( buf, fd) call putch( '@n', fd) nxtcol = 1 } return end #-h- pattern.r 12848 asc 06-apr-82 15:09:36 j (sventek j) #-h- patdef 748 asc 06-apr-82 15:07:57 j (sventek j) ## definitions for the pattern matching routines # put on a file named 'patdef' # Used by pattern.r and ed & sedit tools define(ANY,'?') define(BOL,'%') define(BOT,'{') define(CCL,'[') define(CCLEND,']') define(CHAR,'a') define(CLOSIZE,4) define(CLOSURE,'*') define(CLOSURE1,'+') # closure of one or more occurrences # i.e. (pat)+ == (pat)(pat)* define(COUNT,1) define(EOL,'$') define(EOT,'}') define(MAXTAG,10) define(NCCL,'n') define(PREVCL,2) define(START,3) define(DITTO,(-3)) define(SECTION,(-4)) # /ctag/ - common block to hold section limits for ch # put in a file called 'ctag' # Used by find, ch, and ed #common /ctag/ taglim(MAXTAG2) #integer taglim define(I_CTAG,common/ctag/taglim(arith(2,*,MAXTAG)) integer taglim) #-h- addint 210 asc 06-apr-82 15:07:58 j (sventek j) ### AddInt Put c into str if it fits, increment j integer function addint( c, str, j, maxsiz) integer j, maxsiz, str(maxsiz) character c if( j > maxsiz ) return(NO) str(j) = c j = j + 1 return(YES) end #-h- amatch 1141 asc 06-apr-82 15:07:59 j (sventek j) ## AMatch -- Look for match starting at `lin(from)'. (non-recursive) integer function amatch( lin, from, pat) character lin(MAXLINE) integer omatch, patsiz # function(s) integer from, i, j, offset, pat(MAXPAT), stack stack = 0 offset = from # next unexamined input character for( j = 1 ; pat(j) != EOS ; j = j + patsiz( pat, j) ) { if( pat(j) == CLOSURE ) # a closure entry { stack = j j = j + CLOSIZE # step over CLOSURE for( i = offset ; lin(i) != EOS ; ) # match as many as if( omatch( lin, i, pat, j) == NO ) # possible break pat( stack + COUNT ) = i - offset pat( stack + START ) = offset offset = i # character that made us fail } else if( omatch( lin, offset, pat, j) == NO ) # non-closure { for( ; stack > 0 ; stack = pat( stack + PREVCL ) ) if( pat( stack + COUNT ) > 0 ) break if( stack <= 0 ) # stack is empty return(0) # return failure pat( stack + COUNT ) = pat( stack + COUNT ) - 1 j = stack + CLOSIZE offset = pat( stack + START ) + pat( stack + COUNT ) } } # else omatch succeeded return(offset) # success end #-h- catsub 784 asc 06-apr-82 15:08:00 j (sventek j) ## CatSub -- Add replacement text to end of new. subroutine catsub( lin, from, to, sub, new, k, maxnew) integer addset, itoc, ctoi # function(s) integer from, i, j, junk, k, maxnew, to character lin(MAXLINE), new(maxnew), sub(MAXPAT) I_CTAG # include ctag common block for( i = 1 ; sub(i) != EOS ; i = i + 1 ) { if( sub(i) == DITTO ) for( j = from ; j < to ; j = j + 1 ) junk = addset( lin(j), new, k, maxnew) else if( sub(i) == SECTION ) { i = i + 1 n = sub(i) if( n <= 0 | n > MAXTAG ) { call remark( "? In CatSub: illegal section." ) next } for( j = taglim( 2 * n - 1 ) ; j < taglim( 2 * n ) ; j = j + 1 ) junk = addset( lin(j), new, k, maxnew) } else junk = addset( sub(i), new, k, maxnew) } return end #-h- dodash 450 asc 06-apr-82 15:08:01 j (sventek j) ## DoDash -- Expand array(i-1)-array(i+1) into set(j)... from valid . subroutine dodash( valid, array, i, set, j, maxset) character esc # function(s) integer addset, index # function(s) integer i, j, junk, k, limit, maxset character array(ARB), set(maxset), valid(ARB) i = i + 1 j = j - 1 limit = index( valid, esc( array, i) ) for( k = index( valid, set(j) ) ; k <= limit ; k = k + 1 ) junk = addset( valid(k), set, j, maxset) return end #-h- esc 802 asc 06-apr-82 15:08:02 j (sventek j) ## Esc -- Map `array(i)' into escaped character, if appropriate. character function esc( array, i) character array(ARB), c character clower # function(s) integer i, j if( array(i) != ESCAPE ) esc = array(i) else if( array( i + 1 ) == EOS ) # ESCAPE not special at end esc = ESCAPE else { i = i + 1 c = clower( array(i) ) if( c == 'n' ) esc = '@n' else if( c == 't' ) esc = '@t' else if( c == 'r' ) esc = CR else if( c == 'b' ) esc = BACKSPACE else if( c == 'e' ) esc = EOS else if( c == 'f' ) esc = FF else if( c == 'l' ) esc = LF else if( c >= '0' & c <= '7' ) { esc = 0 for( j=i ; j < i+3 & ( array(j) >= '0' & array(j) <= '7' ) ; j=j+1 ) esc = 8 * esc + ( array(j) - '0' ) i = j - 1 } else esc = c } return end #-h- filset 1037 asc 06-apr-82 15:08:04 j (sventek j) ## FilSet -- Expand set at `array(i)' into `set(j)'; stop at `delim'. subroutine filset( delim, array, i, set, j, maxset) character esc # function(s) integer addset, index # function(s) integer i, j, junk, maxset character array(ARB), delim, set(maxset) string digits "0123456789" string lowalf "abcdefghijklmnopqrstuvwxyz" string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" for( ; array(i) != delim & array(i) != EOS ; i = i + 1 ) { if( array(i) == ESCAPE ) junk = addset( esc( array, i), set, j, maxset) else if( array(i) != '-' ) junk = addset( array(i), set, j, maxset) else if( j <= 1 | array( i + 1 ) == EOS ) # literal - junk = addset( '-', set, j, maxset) else if( index( digits, set( j - 1 ) ) > 0 ) call dodash( digits, array, i, set, j, maxset) else if( index( lowalf, set( j - 1 ) ) > 0 ) call dodash( lowalf, array, i, set, j, maxset) else if( index( upalf, set( j - 1 ) ) > 0 ) call dodash( upalf, array, i, set, j, maxset) else junk = addset( '-', set, j, maxset) } return end #-h- getccl 675 asc 06-apr-82 15:08:05 j (sventek j) ## GetCCl -- Expand character class at `arg(i)' into `pat(j)'. integer function getccl( arg, i, pat, j) character arg(MAXARG), tpat(MAXPAT) integer addint # function(s) integer i, j, jstart, junk, k, pat(MAXPAT) i = i + 1 # skip over [ if( arg(i) == NOT ) { junk = addint( NCCL, pat, j, MAXPAT) i = i + 1 } else junk = addint( CCL, pat, j, MAXPAT) jstart = j junk = addint( 0, pat, j, MAXPAT) # leave room for count k = 1 call filset( CCLEND, arg, i, tpat, k, MAXPAT) tpat(k) = EOS for( k = 1 ; tpat(k) != EOS ; k = k + 1 ) junk = addint( tpat(k), pat, j, MAXPAT) pat(jstart) = j - jstart - 1 if( arg(i) == CCLEND ) return(OK) else return(ERR) end #-h- getpat 215 asc 06-apr-82 15:08:06 j (sventek j) ## GetPat -- Convert argument `arg' into pattern `pat'. integer function getpat( arg, pat) character arg(MAXARG) integer pat(MAXPAT) integer makpat # function(s) getpat = makpat( arg, 1, EOS, pat) return end #-h- getsub 203 asc 06-apr-82 15:08:07 j (sventek j) ## GetSub -- Get substitution pattern into `sub'. integer function getsub( arg, sub) character arg(MAXARG), sub(MAXPAT) integer maksub # function(s) getsub = maksub( arg, 1, EOS, sub) return end #-h- locate 319 asc 06-apr-82 15:08:08 j (sventek j) ## Locate -- Look for `c' in character class at `pat(offset)'. integer function locate( c, pat, offset) character c integer i, offset, pat(MAXPAT) # size of class is at pat(offset), characters follow for( i = offset + pat(offset) ; i > offset ; i = i - 1 ) if( c == pat(i) ) return(YES) return(NO) end #-h- makpat 2072 asc 06-apr-82 15:08:09 j (sventek j) ## MakPat -- Make pattern from `arg(from)', terminate at `delim'. integer function makpat( arg, from, delim, pat) character esc # function(s) character arg(MAXARG), delim integer addint, getccl, stclos # function(s) integer from, i, j, junk, lastcl, lastj, lj, pat(MAXPAT) integer tagcnt, tagi, tagstk(MAXTAG) j = 1 # pat index lastj = 1 lastcl = 0 tagi = 0 tagcnt = 0 for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 ) { lj = j if( arg(i) == ANY ) junk = addint( ANY, pat, j, MAXPAT) else if( arg(i) == BOL & i == from ) junk = addint( BOL, pat, j, MAXPAT) else if( arg(i) == EOL & arg( i + 1 ) == delim ) junk = addint( EOL, pat, j, MAXPAT) else if( arg(i) == CCL ) { if( getccl( arg, i, pat, j) == ERR ) break } else if( ( arg(i) == CLOSURE | arg(i) == CLOSURE1 ) & i > from ) { lj = lastj if( pat(lj) == BOL | pat(lj) == EOL | pat(lj) == CLOSURE | pat(lj) == CLOSURE1 ) break # error if( arg(i) == CLOSURE1 ) # duplicate last pattern for( lastj = j ; lj < lastj ; lj = lj + 1 ) junk = addint( pat(lj), pat, j, MAXPAT) lastcl = stclos( pat, j, lastj, lastcl) } else if( arg(i) == BOT ) { if( tagi > MAXTAG | tagcnt > MAXTAG ) { # call remark("? Too many tags.") break } tagcnt = tagcnt + 1 tagi = tagi + 1 tagstk(tagi) = tagcnt junk = addint( BOT, pat, j, MAXPAT) junk = addint( tagcnt, pat, j, MAXPAT) } else if( arg(i) == EOT ) { if( tagi <= 0 ) { # call remark("? Missing tag start symbol.") break } n = tagstk(tagi) tagi = tagi - 1 junk = addint( EOT, pat, j, MAXPAT) junk = addint( n, pat, j, MAXPAT) } else { junk = addint( CHAR, pat, j, MAXPAT) junk = addint( esc( arg, i), pat, j, MAXPAT) } lastj = lj } if( arg(i) != delim ) # terminated early return(ERR) else if( addint( EOS, pat, j, MAXPAT) == NO ) # no room return(ERR) else if( tagi > 0 ) { # call remark("? Missing tag end symbol.") return(ERR) } else return(i) end #-h- maksub 785 asc 06-apr-82 15:08:11 j (sventek j) ## MakSub -- Make substitution string in `sub'. integer function maksub( arg, from, delim, sub) character esc # function(s) character arg(MAXARG), delim, sub(MAXPAT) integer addset, type, ctoi # function(s) integer from, i, j, junk j = 1 for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 ) { if( arg(i) == AND ) junk = addset( DITTO, sub, j, MAXPAT) else if( arg(i) == '$' & type( arg( i + 1 ) ) == DIGIT ) { i = i + 1 n = ctoi( arg, i) junk = addset( SECTION, sub, j, MAXPAT) junk = addset( n, sub, j, MAXPAT) i = i - 1 } else junk = addset( esc( arg, i), sub, j, MAXPAT) } if( arg(i) != delim ) # missing delimiter return(ERR) else if( addset( EOS, sub, j, MAXPAT) == NO ) # no room return(ERR) else return(i) end #-h- match 268 asc 06-apr-82 15:08:12 j (sventek j) ## Match -- Find match anywhere on line . integer function match( lin, pat) character lin(MAXLINE) integer amatch # function(s) integer i, pat(MAXPAT) for( i = 1 ; lin(i) != EOS ; i = i + 1 ) if( amatch( lin, i, pat) > 0 ) return(YES) return(NO) end #-h- omatch 1002 asc 06-apr-82 15:08:13 j (sventek j) ## OMaTch -- try to match a single pattern at `pat(j)'. integer function omatch( lin, i, pat, j) character lin(MAXLINE) integer locate # function(s) integer bump, i, j, pat(MAXPAT) I_CTAG # include ctag common block omatch = NO if( lin(i) == EOS ) return bump = -1 if( pat(j) == CHAR ) { if( lin(i) == pat( j + 1 ) ) bump = 1 } else if( pat(j) == BOL ) { if( i == 1 ) bump = 0 } else if( pat(j) == ANY ) { if( lin(i) != '@n' ) bump = 1 } else if( pat(j) == EOL ) { if( lin(i) == '@n' ) bump = 0 } else if( pat(j) == CCL ) { if( locate( lin(i), pat, j + 1 ) == YES ) bump = 1 } else if( pat(j) == NCCL ) { if( lin(i) != '@n' & locate( lin(i), pat, j + 1 ) == NO ) bump = 1 } else if( pat(j) == BOT ) { n = pat( j + 1 ) taglim( 2 * n - 1 ) = i bump = 0 } else if( pat(j) == EOT ) { n = pat( j + 1 ) taglim( 2 * n ) = i bump = 0 } else call error( "? In omatch: cant happen." ) if( bump >= 0 ) { i = i + bump omatch = YES } return end #-h- patsiz 444 asc 06-apr-82 15:08:14 j (sventek j) ## PatSiz -- Return size of pattern entry at `pat(n)'. integer function patsiz( pat, n) integer n, pat(MAXPAT) if( pat(n) == CHAR | pat(n) == BOT | pat(n) == EOT ) patsiz = 2 else if( pat(n) == BOL | pat(n) == EOL | pat(n) == ANY ) patsiz = 1 else if( pat(n) == CCL | pat(n) == NCCL ) patsiz = pat( n + 1 ) + 2 else if( pat(n) == CLOSURE ) # optional patsiz = CLOSIZE else call error( "? In patsiz: cant happen." ) return end #-h- stclos 571 asc 06-apr-82 15:08:15 j (sventek j) ## StClos -- Insert closure entry at `pat(j)'. integer function stclos( pat, j, lastj, lastcl) integer addint # function(s) integer j, jp, jt, junk, lastcl, lastj, pat(MAXPAT) for( jp = j - 1 ; jp >= lastj ; jp = jp - 1 ) # make a hole { jt = jp + CLOSIZE junk = addint( pat(jp), pat, jt, MAXPAT) } j = j + CLOSIZE stclos = lastj junk = addint( CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addint( 0, pat, lastj, MAXPAT) # COUNT junk = addint( lastcl, pat, lastj, MAXPAT) # PREVCL junk = addint( 0, pat, lastj, MAXPAT) # START return end #-h- pb.r 1267 asc 25-mar-82 06:53:30 v1.1 (sw-tools v1.1) #-h- ngetch 317 asc 25-mar-82 06:51:12 v1.1 (sw-tools v1.1) # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd PB_DECL(1) if (pbp > 0) { c = pbbuf(pbp) pbp = pbp - 1 } else if (fd == ERR) c = EOF else c = getch(c, fd) ngetch = c return end #-h- pbinit 85 asc 25-mar-82 06:51:13 v1.1 (sw-tools v1.1) subroutine pbinit(size) integer size PB_DECL(1) pbp = 0 pbsize = size return end #-h- putbak 233 asc 25-mar-82 06:51:15 v1.1 (sw-tools v1.1) # putbak - push character back onto input subroutine putbak(c) character c PB_DECL(1) pbp = pbp + 1 if (pbp > pbsize) call error("putbak - too many characters pushed back.") pbbuf(pbp) = c return end #-h- pbstr 340 asc 25-mar-82 06:51:16 v1.1 (sw-tools v1.1) # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i PB_DECL(1) for (i = length(in); i > 0; i = i - 1) { pbp = pbp + 1 if (pbp > pbsize) call error("pbstr - too many characters pushed back.") pbbuf(pbp) = in(i) } return end #-h- rawpmt.r 10316 asc 25-mar-82 06:53:32 v1.1 (sw-tools v1.1) #-h- defns 660 asc 25-mar-82 06:51:23 v1.1 (sw-tools v1.1) define(BELL,7) # ^G define(CARRIAGERETURN,13) # CR define(ENDOFFILE,26) # ^Z define(ESC,27) # ASCII ESC define(RETYPELINE,18) # ^R define(VERIFYLINE,22) # ^V define(LINEDELETE,21) # ^U define(RUBOUT,127) # DEL | RUB define(WORDDELETE,23) # ^W define(DIRECTORYLIST,4) # ^D define(RECOGNIZEFILE,6) # ^F define(EXPAND,YES) define(NO_EXPAND,NO) # # the following definitions are to prevent overloading the global name space # define(ds,praw01) define(insstr,praw02) define(lngest,praw03) define(rawio,praw04) define(recogf,praw05) define(redisp,praw06) define(rwpmpt,praw07) define(scnbck,praw08) define(spawnd,praw09) define(spnbck,praw10) #-h- rawpmt 433 asc 25-mar-82 06:51:24 v1.1 (sw-tools v1.1) integer function rawpmt(pstr, lin, in) character pstr(ARB), lin(MAXLINE), tmp(MAXLINE) integer in, n integer rwpmpt string altpst " _" altpst(1) = pstr(1) n = rwpmpt(pstr, lin, in) if (n == EOF | n == 1) return(n) while (lin(n) == '@n' & lin(n-1) == ESCAPE) { lin(n-1) = ' ' # @'@n' => ' ' if (rwpmpt(altpst, tmp, in) == EOF) return(EOF) call stcopy(tmp, 1, lin, n) n = n - 1 # point at '@n' } return(n) end #-h- ds 976 asc 25-mar-82 06:51:26 v1.1 (sw-tools v1.1) ## ds - perform directory search for longest string matching `inpstr'. integer function ds(inpstr, outstr) integer found, len, depth, ptr(MAXDIRECTS), j, junk, desc integer length, gtftok, opendr, gdrprm, equal, lngest character inpstr(ARB), outstr(ARB), path(FILENAMESIZE), pat(FILENAMESIZE), c string star "*" found = 0 len = length(inpstr) if (len == 0 | inpstr(len) == '/') call concat(inpstr, star, pat) else call strcpy(inpstr, pat) call mkpath(pat, path) call fold(path) call exppth(path, depth, ptr, pat) j = ptr(depth) pat(1) = EOS junk = gtftok(path, j, pat) j = ptr(depth) path(j) = EOS if (opendr(path, desc) == ERR) return(found) len = length(pat) + 1 while (gdrprm(desc, path) != EOF) { c = path(len) path(len) = EOS if (equal(path, pat) == NO & pat(1) != '*') next path(len) = c if (found == 0) call strcpy(path, outstr) found = found + 1 j = lngest(path, outstr) + 1 outstr(j) = EOS } call closdr(desc) return(found) end #-h- insstr 326 asc 25-mar-82 06:51:28 v1.1 (sw-tools v1.1) ## insstr - insert string `s1' at position `i' of string `s2'. subroutine insstr(s1, s2, i) character s1(ARB), s2(ARB) integer i, j, k, l integer length k = length(s2) + 1 for (j=k+length(s1); k >= i; k=k-1) { s2(j) = s2(k) j = j - 1 } l = 1 for (k=i; k <= j; k=k+1) { s2(k) = s1(l) l = l + 1 } return end #-h- lngest 240 asc 25-mar-82 06:51:29 v1.1 (sw-tools v1.1) ## lngest - return length of the longest substring common to two strings integer function lngest(s1, s2) integer i character s1(ARB), s2(ARB) for (i=1; s1(i) == s2(i); i=i+1) if (s1(i) == EOS | s2(i) == EOS) break return(i-1) end #-h- rawio 585 asc 25-mar-82 06:51:33 v1.1 (sw-tools v1.1) ## rawio - determine if rawpmt can be used on unit integer function rawio(in, out, savmod) integer in, out, savmod integer create, stmode, isatty, gtmode string ttystr TTY_NAME if (out == EOF) # need to open echo unit { out = create(ttystr, WRITE) if (out != ERR) if (stmode(out, RARE) != RARE) { call close(out) out = ERR } } rawio = NO if (isatty(in) == YES & out != ERR) { savmod = gtmode(in) # save current mode if (stmode(in, RARE) == RARE) # can do rare mode rawio = YES else savmod = stmode(in, savmod) } return end #-h- recogf 426 asc 25-mar-82 06:51:34 v1.1 (sw-tools v1.1) ## recogf - recognize longest unique filename substring matching %`str'. ## complete the string in `str'. integer function recogf(str) integer i integer ds, length character str(ARB), outstr(FILENAMESIZE) i = length(str) if (i > 0) repeat { if (str(i) == '/' | str(i) == '\') break i = i - 1 } until (i == 0) recogf = ds(str, outstr) if (recogf != 0) call scopy(outstr, 1, str, i+1) return end #-h- redisp 761 asc 25-mar-82 06:51:37 v1.1 (sw-tools v1.1) ## redisp - redisplay prompt and line on int, expanding control characters ## as required subroutine redisp(pstr, lin, int, temp, ifexpd) character pstr(ARB), lin(ARB), temp(ARB) integer int, ifexpd, i, j string crlf "@r@l" i = 1 while (pstr(i) != EOS) { for (j=1; pstr(i) != '@n' & pstr(i) != EOS; j=j+1) { temp(j) = pstr(i) i = i + 1 } if (pstr(i) == '@n') { call scopy(crlf, 1, temp, j) i = i + 1 } else temp(j) = EOS call putlin(temp, int) } j = 1 for (i=1; lin(i) != EOS; i=i+1) { if (lin(i) < ' ') { call chcopy('^', temp, j) if (ifexpd == EXPAND) call chcopy(lin(i)+'@@', temp, j) } else call chcopy(lin(i), temp, j) } temp(j) = EOS call putlin(temp, int) return end #-h- rwpmpt 3331 asc 25-mar-82 06:51:39 v1.1 (sw-tools v1.1) integer function rwpmpt(pstr, lin, in) character pstr(ARB), lin(MAXLINE), c, tmp(MAXLINE) character getch integer in, i, j, k, l, out, savmod integer prompt, scnbck, spnbck, length, recogf, index, rawio, stmode string bol "%" string dstr "fd " string bsblbs "@b @b" string crlf "@r@l" string ctrld "^Directory list@r" string ctrlr "^Retype line@r@l" string ctrlu "^Undo line@r@l" string ctrlv "^Verify line@r@l" string ctrlz "^Z@r" string fldtrm " @t/\@@<>" # terminator string for field of pathname string filtrm " <>@@" # terminator string for filenames string pthtrm " /\" # terminator string for pathnames string valctl "@f@t" # valid control characters data out /EOF/ if (rawio(in, out, savmod) == NO) return(prompt(pstr, lin, in)) i = 1 call putlin(crlf, out) call redisp(pstr, EOS, out, tmp, NO_EXPAND) lin(1) = EOS repeat { c = getch(c, in) if (c == ENDOFFILE) { call putlin(ctrlz, out) lin(1) = EOS return(EOF) } else if (c == CARRIAGERETURN) break else if (c == BACKSPACE | c == RUBOUT) { if (i > 1) { call putlin(bsblbs, out) i = i - 1 lin(i) = EOS } else lin(i) = EOS } else if (c == LINEDELETE) { call putlin(ctrlu, out) call redisp(pstr, EOS, out, tmp, NO_EXPAND) i = 1 lin(i) = EOS } else if (c == RETYPELINE) { call putlin(ctrlr, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == VERIFYLINE) { call putlin(ctrlv, out) call redisp(pstr, lin, out, tmp, EXPAND) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == WORDDELETE) { i = spnbck(lin, i, bsblbs, out, fldtrm) i = scnbck(lin, i, bsblbs, out, fldtrm) lin(i) = EOS } else if (c == DIRECTORYLIST) { call putlin(ctrld, out) call spawnd(dstr) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == RECOGNIZEFILE) { lin(i) = EOS j = scnbck(lin, i, EOS, out, filtrm) call scopy(lin, j, tmp, 1) k = length(tmp) + 1 l = recogf(tmp) if (l != 0) { if (tmp(k) != EOS | l == 1) # Progress was made { if (tmp(k) != EOS) call scopy(tmp, k, lin, i) else { lin(i) = ' ' lin(i+1) = EOS } call putlin(lin(i), out) i = length(lin) + 1 } else { k = 1 call stcopy(dstr, 1, tmp, k) call scopy(lin, j, tmp, k) j = scnbck(tmp(k), length(tmp(k))+1, EOS, out, pthtrm) + k - 1 call insstr(bol, tmp, j) call putlin(crlf, out) call putch('#', out) call putlin(tmp, out) call putch(CARRIAGERETURN, out) call spawnd(tmp) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } } else call putch(BELL, out) } else if (c < ' ' & index(valctl, c) == 0) call putch(BELL, out) else { lin(i) = c i = i + 1 lin(i) = EOS if (index(valctl, c) == 0) call putch(c, out) else call putch('^', out) # all characters occupy one column } } call putch(CARRIAGERETURN, out) lin(i) = '@n' lin(i+1) = EOS savmod = stmode(in, savmod) # reset mode on unit return(i) end #-h- scnbck 684 asc 25-mar-82 06:51:42 v1.1 (sw-tools v1.1) ## scnbck - scan backwards until a terminator or boundary is reached. ## return the index of the last character scanned before terminator. ## output string `rubstr' on `chn' as each character is scanned. integer function scnbck(str, col, rubstr, chn, trmara) integer i, chn, col integer index character rubstr(ARB), str(ARB), trmara(ARB) if (col > 1) { i = col - 1 # point to last char entered. for ( ; index(trmara, str(i)) == 0 & i > 1; i=i-1) if (rubstr(1) != EOS) call putlin(rubstr, chn) if (i == 1 & index(trmara, str(i)) == 0) { if (rubstr(1) != EOS) call putlin(rubstr, chn) } else i = i + 1 } else i = 1 return(i) end #-h- spawnd 362 asc 25-mar-82 06:51:43 v1.1 (sw-tools v1.1) subroutine spawnd(args) character args(ARB), image(FILENAMESIZE), pid(PIDSIZE) integer loccom, spawn integer junk, init string d "fd" string spath "@e~usr/@e~bin/@e@n" string suffix IMAGE_SUFFIX data init /YES/ if (init == YES) { init = NO junk = loccom(d, spath, suffix, image) } junk = spawn(image, args, pid, WAIT) return end #-h- spnbck 656 asc 25-mar-82 06:51:45 v1.1 (sw-tools v1.1) ## spnbck - span backwards until a non-separator or boundary is reached. ## return the index of the last character scanned before separator, ## output string `rubstr' on `chn' as each character is scanned. integer function spnbck(str, col, rubstr, chn, separa) integer i, chn, col integer index character rubstr(ARB), str(ARB), separa(ARB) if (col > 1) { i = col - 1 # point to last char entered. for ( ; index(separa, str(i)) > 0 & i > 1; i=i-1) if (rubstr(1) != EOS) call putlin(rubstr, chn) if (i == 1) { if (rubstr(1) != EOS) call putlin(rubstr, chn) } else i = i + 1 } else i = 1 return(i) end #-h- tabsubs.r 2220 asc 25-mar-82 06:53:36 v1.1 (sw-tools v1.1) #-h- argtab 401 asc 25-mar-82 06:51:54 v1.1 (sw-tools v1.1) ## ArgTab -- Fetch tab information from argument list. subroutine argtab(buf) character buf(MAXLINE), n(4) integer i, j, k integer getarg, alldig # function(s) i = 1 for( j = 1 ; getarg( j, n, 4) != EOF ; j = j + 1 ) { k = 1 if( n(1) == '+' ) k = k + 1 if( alldig( n(k) ) == YES ) { if( i > 1 ) call chcopy( ' ', buf, i) call stcopy( n, 1, buf, i) } } return end #-h- gtword 623 asc 25-mar-82 06:51:56 v1.1 (sw-tools v1.1) ## GtWord -- Get next word from `in(i)' into `out'; incr `i' to `size' chars. integer function gtword( in, i, out, size) character in(ARB), out(ARB) integer i, size, j, overfl while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 overfl = YES # assume word too big for( j = 1 ; j <= size ; j = j + 1 ) { if( in(i) == EOS | in(i) == ' ' | in(i) == '@t' | in(i) == '@n' ) { overfl = NO break } else { out(j) = in(i) i = i + 1 } } out(j) = EOS if( overfl == YES ) # skip extra characters while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' ) i = i + 1 return( j - 1 ) end #-h- settab 711 asc 25-mar-82 06:51:58 v1.1 (sw-tools v1.1) ## SetTab -- Set initial tab stops. subroutine settab( buf, tabs) integer i, j, k, l, m, p, ptr, tabs(MAXLINE) integer alldig, ctoi, gtword # function(s) character n(4), buf(MAXLINE) p = 0 for( i = 1 ; i <= MAXLINE ; i = i + 1 ) tabs(i) = NO ptr = 1 for( j = 1 ; gtword( buf, ptr, n, 4) > 0 ; j = j + 1 ) { k = 1 if( n(1) == '+' ) k = k + 1 if( alldig( n(k) ) == NO ) next l = ctoi( n, k) if( l <= 0 | l > MAXLINE ) next if( n(1) != '+' ) { p = l tabs(p) = YES } else { if( p == 0 ) p = l + 1 for( m = p ; m <= MAXLINE ; m = m + l ) tabs(m) = YES } } if( p == 0 ) { for( i = 9 ; i <= MAXLINE ; i = i + 8 ) tabs(i) = YES } return end #-h- tabpos 193 asc 25-mar-82 06:51:59 v1.1 (sw-tools v1.1) ## TabPos -- Return YES if `col' is a tab stop. integer function tabpos( col, tabs) integer col, i, tabs(MAXLINE) if( col > MAXLINE ) tabpos = YES else tabpos = tabs(col) return end #-h- tb.r 1568 asc 25-mar-82 06:53:38 v1.1 (sw-tools v1.1) #-h- tbsym 51 asc 25-mar-82 06:52:05 v1.1 (sw-tools v1.1) define(INCLUDE_CTB,common/ctb/table pointer table) #-h- tbinit 231 asc 25-mar-82 06:52:07 v1.1 (sw-tools v1.1) ## TbInit -- Initialize simple lookup table. subroutine tbinit(size) integer size INCLUDE_CTB pointer mktabl call dsinit(size) # initialize dynamic storage table = mktabl(1) # create symbol table in dynamic storage return end #-h- tbinst 545 asc 25-mar-82 06:52:08 v1.1 (sw-tools v1.1) ## TbInst -- Enter a new symbol definition, discarding any old one. subroutine tbinst( name, defn) character name(ARB), defn(ARB) INCLUDE_CTB integer lookup, enter # function(s) pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "? In tbinst: no room for new definition." ) return end #-h- tblook 449 asc 25-mar-82 06:52:10 v1.1 (sw-tools v1.1) ## TbLook -- Look up a defined identifier, return its definition. integer function tblook( id, defn) character id(ARB), defn(ARB) INCLUDE_CTB DS_DECL( Mem, 1) integer i, j integer lookup # function(s) pointer locn tblook = lookup( id, locn, table) if( tblook == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end