#-h- minprim.mar 48071 asc 06-may-81 23:18:22 [002,100] #-h- start.mac 3288 asc 29-apr-81 09:47:16 [002,100] .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$: mov r2,r$endl ; save lun for later 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 29-apr-81 09:30:56 [002,100] .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- cant.mac 632 asc 29-apr-81 09:30:57 [002,100] .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 29-apr-81 09:30:59 [002,100] .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 29-apr-81 09:31:01 [002,100] .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 29-apr-81 09:31:03 [002,100] .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- efnsubs.mac 2436 asc 29-apr-81 09:31:06 [002,100] .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:: mov #1,r0 ; starting efn number mov #16.,r1 ; limit for first pass mov #low,r2 ; address of efn mask call getbit ; get a free efn bcc 10$ ; c clear => success mov #24.,r1 ; limit for second pass mov #high,r2 ; address of efn mask call getbit ; get a free efn bcc 10$ ; c clear => success mov #err,r0 ; return ERR 10$: return ; ; subroutine getbit ; ; inputs: ; r0 starting EFN number ; r1 limit EFN ; r2 address of relevant EFN mask ; ; outputs: ; r0 EFN to return, if success - next EFN to try if not ; r1 unchanged ; r2 unchanged ; c bit set if error ; c bit clear if successful ; getbit: mov r3,-(sp) ; save r3 mov #1,r3 ; initialize bit mask 90$: cmp r0,r1 ; see if limit exceeded bgt 110$ ; if r0 > r1, YES bit r3,(r2) ; is the bit set? beq 100$ ; if == 0, NO - done clc ; clear c bit rol r3 ; rotate mask bit one left inc r0 ; next event flag number br 90$ ; try next bit 100$: bis r3,(r2) ; set bit to indicate allocation clc ; c clear => success br 120$ 110$: sec ; c set => failure 120$: mov (sp)+,r3 ; restore r3 return ; ; subroutine putefn(efn) ; putefn:: mov @efn(ap),r0 ; get EFN to return r$pefn:: tst r0 ; test value of efn ble 50$ ; if <= 0, invalid EFN cmp r0,#24. ; see if too large bgt 50$ ; if >, invalid EFN mov #low,r1 ; assume EFN <= 16. cmp r0,#16. ; is this true? ble 20$ ; YES sub #16.,r0 ; correct for high mask numbers mov #high,r1 ; address of mask 20$: mov #1,r2 ; initialize bit mask 30$: dec r0 ; subtract 1 from counter beq 40$ ; if == 0, have correct mask bit in r2 clc ; clear c bit rol r2 ; shift one bit left br 30$ ; try again 40$: bic r2,(r1) ; clear bit to indicate that it is free 50$: return .page #-h- files.mac 2153 asc 29-apr-81 09:31:12 [002,100] .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- gmcrst.mac 1877 asc 29-apr-81 16:17:54 [002,100] .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 29-apr-81 09:31:24 [002,100] .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 29-apr-81 09:31:26 [002,100] .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 29-apr-81 09:31:28 [002,100] .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 29-apr-81 09:31:33 [002,100] .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 29-apr-81 09:31:36 [002,100] .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 1496 asc 29-apr-81 09:31:38 [002,100] .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 r$rput:: tst r0 ; any bytes to write? ble 5$ ; NO qiow$s #io.wal,@int(ap),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 1075 asc 29-apr-81 09:31:41 [002,100] .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 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 841 asc 29-apr-81 11:11:20 [002,100] .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 20$: bic #177770,r2 ; mask to 3 bits beq 30$ ; no leading zeroes 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 29-apr-81 09:31:43 [002,100] .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 29-apr-81 09:59:33 [002,100] .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 29-apr-81 16:56:20 [002,100] .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 3727 asc 06-may-81 23:07:38 [002,100] .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 .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 bcs 100$ ; c set => parse error movb @access(ap),r.acc(r1) ; store access mode in RFDB 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 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$: ; cmpb #prin$r,r.acc(r1) ; PRINT access? ; beq 81$ ; YES, open new file ofnb$ ,#fo.upd ; open existing file for write bcs 81$ ; c set => error, try new file cmpb #rdwr$r,r.acc(r1) ; READWRITE access? beq 85$ ; YES, don't delete call .dlfnb ; delete existing file bitb #fd.ftn!fd.cr,f.ratt(r0); any implied carriage control? bne 81$ ; yes movb #fd.cr,f.ratt(r0) ; new file is LIST carriage control 81$: 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 bcc 85$ ; c clear => success ofnb$ ,#fo.upd ; try to reopen existing file ; this is needed if the user has ; write access to the file, but ; not delete access (YEP!) 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 return .page #-h- rparse.mac 2002 asc 29-apr-81 09:31:57 [002,100] .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 29-apr-81 09:32:01 [002,100] .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 29-apr-81 09:47:39 [002,100] .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 29-apr-81 12:48:25 [002,100] .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 29-apr-81 11:11:17 [002,100] .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- ttysubs.mac 344 asc 29-apr-81 09:32:07 [002,100] .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- rdata.mac 2832 asc 29-apr-81 09:32:09 [002,100] .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 0 ; next available lun ; ; 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 5973 asc 29-apr-81 20:34:43 [002,100] #-h- chcopy.mac 524 asc 29-apr-81 13:10:05 [002,100] .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 29-apr-81 13:10:07 [002,100] .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 29-apr-81 13:10:08 [002,100] .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 29-apr-81 13:10:09 [002,100] .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 729 asc 29-apr-81 13:10:11 [002,100] .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:: 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 29-apr-81 13:10:12 [002,100] .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 29-apr-81 13:10:13 [002,100] .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 29-apr-81 13:10:14 [002,100] .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 29-apr-81 13:10:16 [002,100] .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 40018 asc 08-may-81 08:52:30 [002,100] #-h- appred.mac 540 asc 17-apr-81 16:46:45 [002,102] .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 17-apr-81 16:45:28 [002,102] .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 17-apr-81 16:45:30 [002,102] .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 17-apr-81 16:45:32 [002,102] .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 29-apr-81 12:56:31 [002,100] .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 17-apr-81 16:45:36 [002,102] .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- f11hdr.mac 705 asc 17-apr-81 16:45:39 [002,102] .title f11hdr ;+ ; integer function f11hdr(desc, buf) ;- ap=%5 desc=2 buf=4 .mcall fdof$l,nbof$l,qiow$s fdof$l nbof$l .psect $r.roi,con,ro,rel,lcl,i .enabl lsb f11hdr:: mov @desc(ap),r1 ; RFDB address mov r.fdb(r1),r0 ; FDB address movb f.lun(r0),r1 ; lun add #f.fnb+n.fid,r0 ; FID address clr -(sp) ; end of attribute list mov buf(ap),-(sp) ; address of 512 byte buffer for header mov (pc)+,-(sp) ; read file header .byte -12,0 mov sp,r2 ; address of attribute list qiow$s #io.rat,r1,r$ioef,,#r$iosb,, ; read header bcs 10$ ; c set => error tstb r$iosb ; error? blt 10$ ; YES mov #ok,r0 br 20$ 10$: mov #err,r0 20$: add #6,sp ; restore stack return .end #-h- fdel.mac 348 asc 17-apr-81 16:45:41 [002,102] .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 28-apr-81 10:21:30 [002,100] .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 17-apr-81 16:46:55 [002,102] .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- fmtdat.mac 807 asc 17-apr-81 16:45:42 [002,102] .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 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 17-apr-81 16:45:45 [002,102] .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- fmtuic.mac 425 asc 17-apr-81 16:45:47 [002,102] .title 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 .end #-h- getarg.mac 951 asc 17-apr-81 16:45:49 [002,102] .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 2089 asc 17-apr-81 16:45:52 [002,102] .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 qiow$s #io.rne!tf.ral,@int(ap),r$ioef,,,, 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 .end #-h- getdir.mac 762 asc 30-apr-81 11:06:46 [002,100] .title getdir ;+ ; subroutine getdir(key, type, buf) ;- ; ; local data ; .psect $r.rod,con,ro,rel,lcl,d ptr: .word bin,usr,tmp,lpr,mal,man bin: .asciz "ST0:[105,1]" usr: .asciz "ST0:[105,2]" tmp: .asciz "ST1:[105,3]" lpr: .asciz "ST1:[105,4]" mal: .asciz "ST0:[105,5]" man: .asciz "ST0:[105,6]" .even ; ; ap=%5 key=2 type=4 buf=6 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb getdir:: clrb @buf(ap) ; assume invalid key mov @key(ap),r0 ; get value of key blt 100$ ; if key < 0, invalid cmp r0,#6 ; too large? bgt 100$ ; YES dec r0 ; key - 1 clc ; rol r0 ; 2 * (key - 1) mov ptr(r0),r0 ; source address mov buf(ap),r1 ; destination address 10$: movb (r0)+,(r1)+ ; copy character bne 10$ ; if not EOS, do again 100$: return .end #-h- getlin.mac 1642 asc 01-may-81 10:59:07 j .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 call r$rput ; put secondary prompt 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 17-apr-81 16:46:56 [002,102] .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 29-apr-81 13:05:35 [002,100] .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 17-apr-81 16:46:00 [002,102] .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 17-apr-81 16:46:01 [002,102] .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- getuid.mac 438 asc 17-apr-81 16:46:03 [002,102] .title 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 .end #-h- glocnm.mac 1152 asc 29-apr-81 12:56:39 [002,100] .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 28-apr-81 10:21:33 [002,100] .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 17-apr-81 16:46:05 [002,102] .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- markl.mac 482 asc 17-apr-81 16:46:06 [002,102] .title markl ;+ ; subroutine markl(int, addres) ;- ap=%5 int=2 addres=4 .psect $r.roi,con,ro,rel,lcl,i .enabl lsb markl:: 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 100$: return .end #-h- otoc.mac 1054 asc 17-apr-81 16:46:09 [002,102] .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 1839 asc 01-may-81 10:59:14 j .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(sp),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 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 17-apr-81 16:46:14 [002,102] .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 17-apr-81 16:46:16 [002,102] .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 17-apr-81 16:46:17 [002,102] .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 29-apr-81 12:56:47 [002,100] .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 749 asc 08-may-81 08:48:09 [002,100] .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 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 17-apr-81 16:46:20 [002,102] .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 17-apr-81 16:46:47 [002,102] .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 22-apr-81 07:02:12 [002,102] .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 17-apr-81 16:46:25 [002,102] .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 17-apr-81 16:46:26 [002,102] .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 483 asc 28-apr-81 10:21:41 [002,100] .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:: call r$gefn ; get a free event flag mrkt$s r0,@sec(ap),#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 return .end #-h- sndarg.mac 2049 asc 30-apr-81 12:31:32 [002,100] .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- spwsubs.mac 538 asc 17-apr-81 16:46:30 [002,102] .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 20-apr-81 13:47:55 [002,102] .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 17-apr-81 16:46:34 [002,102] .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 22-apr-81 07:02:16 [002,102] .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 28-apr-81 10:21:28 [002,100] .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 22-apr-81 07:02:19 [002,102] .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 720 asc 08-may-81 08:48:10 [002,100] .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 put$ r.fdb(r1),buf(ap),@n(ap) ; write the next record bcs 10$ ; c set => error mov @n(ap),r0 ; return number of bytes written return 10$: mov #err,r0 ; return(ERR) return .end #-h- lib.m 6281 asc 29-apr-81 20:35:21 [002,100] #-h- clower.mac 601 asc 17-apr-81 17:56:11 [002,102] .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 17-apr-81 17:56:13 [002,102] .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 17-apr-81 17:56:15 [002,102] .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 761 asc 23-apr-81 11:39:17 [002,102] .title impath ;+ ; subroutine impath(path) ;- .psect $r.rod,con,ro,rel,lcl,d spath: .asciz "~usr/" .asciz "~bin/" .byte 12,0 spathl=.-spath .even .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 r0,-(sp) ; address to place home directory in mov #1,-(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 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- matchc.mac 1259 asc 17-apr-81 17:56:17 [002,102] .title matchc ; ; this routine implements the following fortran interface ; ; i = matchc(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 matchc:: 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 17-apr-81 17:56:19 [002,102] .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 17-apr-81 17:56:23 [002,102] .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 17-apr-81 17:56:21 [002,102] .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 22288 asc 15-may-81 10:10:05 [002,100] #-h- amove 438 asc 23-apr-81 09:48:41 [002,102] ## function amove -- rename files integer function amove(name1, name2) character name1(FILENAMESIZE), name2(FILENAMESIZE) integer open, old, new, create, rename old = open(name1, READ) if (old == ERR) amove = ERR else { new = create(name2, WRITE) if (new == ERR) amove = ERR else { call fcopy(old, new) call close(old) call close(new) call remove(name1) amove = OK } } return end #-h- bckspn 796 asc 26-jan-81 08:28:30 [002,100] 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, RBRACK) + 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 23-jan-81 10:14:23 [002,100] 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 11-feb-81 12:04:43 [002,101] 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 440 asc 23-jan-81 10:14:24 [002,100] 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, COLON, temp) call stddev(temp) # set default device call jcopys(out, i, RBRACK, temp) call stddir(temp, desc) call closdr(desc) cwdir = OK } else cwdir = ERR return end #-h- decnfo 1065 asc 23-jan-81 10:14:25 [002,100] 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(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 subroutine decnfo(dbuf, date, group, member, protec, eof) integer group, member, protec, eof character date(ARB), dbuf(512) integer revise, idoff, free 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(EFBL), eof, 2, -1) call cpybyt(dbuf(FFBY), free, 2, -1) if (free <= 0) eof = eof - 1 return end #-h- dnoise 305 asc 23-jan-81 10:14:26 [002,100] # subroutine to strip out white noise (;1 and .;1) subroutine dnoise(file) character file(ARB) integer i integer index, equal i = index(file, SEMICOL) if (equal(file(i), ";1") == YES) { file(i) = EOS i = index(file, PERIOD) if (file(i+1) == EOS) file(i) = EOS } return end #-h- enbint 308 asc 23-jan-81 10:14:27 [002,100] 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 862 asc 23-jan-81 10:14:28 [002,100] subroutine extpnm(lin, task) character lin(ARB), task(PIDSIZE) integer j, i integer matchc, equal, length string tskequ "TASK=" string tskeql "task=" string run "RUN" j = matchc(lin, tskequ) if (j == 0) j = matchc(lin, tskeql) if (j > 0) { i = 1 for (j=j+5; lin(j) != EOS & lin(j) != SLASH & 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) if (equal(task, run) == YES) i = 1 else i = i - 1 call trndev("ti", 0, task(i)) if (i > 1) { task(i+1) = task(i) task(i) = lin(i) } j = index(task, COLON) if (j < PIDSIZE) task(j) = EOS else task(PIDSIZE) = EOS } for (i=length(task)+1; i < PIDSIZE; i=i+1) task(i) = BLANK task(i) = EOS call upper(task) return end #-h- fxlate 706 asc 23-jan-81 10:14:29 [002,100] 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) == SLASH) { j = 1 if (realdv(out) == YES) { for (i=2; out(i) != SLASH & out(i) != EOS; i=i+1) call chcopy(out(i), temp, j) call chcopy(COLON, temp, j) } else i = 1 if (out(i) == SLASH) { call chcopy(LBRACK, temp, j) for (i=i+1; out(i) != SLASH & out(i) != EOS; i=i+1) call chcopy(out(i), temp, j) call chcopy(RBRACK, temp, j) if (out(i) == SLASH) call stcopy(out, i+1, temp, j) } temp(j) = EOS } else call strcpy(out, temp) call resdef(temp, type, out) return end #-h- gdraux 361 asc 23-jan-81 10:14:31 [002,100] subroutine gdraux(desc, file, aux, date) 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) = BLANK date(i) = EOS } else call getaux(hbuf, aux, date) return end #-h- gdrprm 233 asc 29-apr-81 13:00:20 [002,100] 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 719 asc 23-jan-81 10:14:33 [002,100] 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) == DOLLAR | parent(1) == PERIOD) & parent(2) != parent(1)) { if (parent(6) >= DIG9) 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) = DOLLAR # place $ in first character if (parent(4) == COLON) { parent(4) = parent(3) parent(3) = DIG0 } call strcpy(".1", parent(5)) spstat= OK } } call strcpy(parent, pid) return(spstat) end #-h- getaux 897 asc 17-apr-81 17:20:19 [002,102] subroutine getaux(hbuf, aux, date) character aux(ARB), date(ARB), hbuf(512) integer group, member, protec, j, itocf, eof, length character idate(14) string twoblk " " call decnfo(hbuf, idate, group, member, protec, eof) # # aux field is formatted as protec date size owner # call fmtpro(protec, aux) call concat(aux, twoblk, aux) # # now format the time field of aux as well as sortable date string # idate returned from decnfo in format DDMMMYYHHMMSS # j = length(aux) + 1 call frmdat(idate, aux(j)) call concat(aux, twoblk, aux) call srttim(idate, date) # generate sortable date string # # now display size of file in blocks # j = length(aux) + 1 j = j + itocf(eof, 7, BLANK, aux(j), 8) call stcopy(twoblk, 1, aux, j) # # now format owner # call fmtuic(group, member, idate) call resuic(idate, idate) call strcpy(idate, aux(j)) call fold(aux) return end #-h- gwdir 230 asc 23-jan-81 10:14:37 [002,100] 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 259 asc 23-apr-81 10:45:58 [002,102] subroutine homdir(home) character home(ARB) integer i, grp, mem integer length call trndev("ho", 0, home) if (home(1) == EOS) call trndev("sy", 0, home) call fold(home) i = length(home) + 1 call getuid(grp, mem) call fmtuic(grp, mem, home(i)) return end #-h- intsrv 81 asc 23-jan-81 10:14:38 [002,100] subroutine intsrv integer junk integer kill junk = kill(EOS) return end #-h- itocf 254 asc 23-jan-81 10:14:39 [002,100] 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 23-jan-81 10:14:40 [002,100] # 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 505 asc 23-jan-81 10:14:41 [002,100] # 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) == DOLLAR) # 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 884 asc 15-may-81 10:08:44 [002,100] ## 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) != NEWLINE; i=i+length(spath(i))+1) { call concat(spath(i), comand, temp) n = length(temp) + 1 if (index(comand, PERIOD) > 0) { if (flfind(temp, path, type) != ERR) return(type) } else { for (j=1; suffix(j) != NEWLINE; 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 677 asc 23-apr-81 17:17:25 [002,100] subroutine mailid(sender) character sender(ARB), loguic(10), uic(10), buf(100) integer i, grp, mem, fdb, openf, gets, junk, getwrd, equal, found 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) != BLANK & buf(i) != EOS; i=i+1) ; junk = getwrd(buf, i, uic) if (equal(uic, loguic) == YES) { found = YES break } } call closef(fdb) } if (found == NO) call strcpy(loguic, sender) return end #-h- main 45 asc 27-apr-81 23:53:36 [002,100] call initst call main call endst(OK) end #-h- mklocl 109 asc 23-jan-81 10:14:45 [002,100] # subroutine mklocl(in, out) # # character in(ARB), out(ARB) # # call fxlate(in, PATH, out) # # return # end #-h- mkpath 570 asc 23-jan-81 10:14:46 [002,100] 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(SLASH, out, j) for (i=1; temp(i) != COLON; i=i+1) call chcopy(temp(i), out, j) i = i + 1 if (temp(i) == LBRACK) { call chcopy(SLASH, out, j) for (i=i+1; temp(i) != RBRACK; i=i+1) call chcopy(temp(i), out, j) i = i + 1 if (temp(i) != EOS) { call chcopy(SLASH, out, j) call stcopy(temp, i, out, j) } } out(j) = EOS } return end #-h- opendr 338 asc 22-apr-81 07:16:45 [002,102] 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, RBRACK) != length(file)) opendr = ERR else { call concat(file, stars, file) opendr = dopen(file, desc) } return end #-h- ptrtoc 457 asc 11-feb-81 11:42:19 [002,101] 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(BLANK, 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 439 asc 23-jan-81 10:14:48 [002,100] 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 == SLASH | 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 319 asc 23-jan-81 10:14:49 [002,100] ## remove -- removes file named buf subroutine remove(buf) character buf(FILENAMESIZE) integer int, open, fdel int = open(buf, READ) if (int != ERR) { if (fdel(int) == ERR) { call putlin(buf, ERROUT) call remark(' not deleted--privilege violation') } call close(int) } return end #-h- resdef 626 asc 23-jan-81 10:14:51 [002,100] 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, COLON) > 0) call jcopys(in, i, COLON, out) else call trndev("SY", 0, out) if (in(i) != EOS) { j = length(out) + 1 if (in(i) == LBRACK & index(in, RBRACK) > 0) call jcopys(in, i, RBRACK, 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 976 asc 23-jan-81 10:14:52 [002,100] # resolve ~name construct in path names subroutine restil(path, out) character path(ARB), out(ARB), token(FILENAMESIZE) integer i, junk, key, j integer gtftok, equal string bin "bin" string usr "usr" string tmp "tmp" string lpr "lpr" string mail "mail" string man "man" call strcpy(path, out) # assume not ~name if (path(1) == TILDE) { i = 2 junk = gtftok(path, i, token) call fold(token) if (equal(token, bin) == YES) key = BINDIRECTORY else if (equal(token, usr) == YES) key = USRDIRECTORY else if (equal(token, tmp) == YES) key = TMPDIRECTORY else if (equal(token, lpr) == YES) key = LPRDIRECTORY else if (equal(token, mail) == YES) key = MAILDIRECTORY else if (equal(token, man) == YES) key = MANDIRECTORY else key = ERR if (key != ERR) { call getdir(key, LOCAL, token) j = 1 call stcopy(token, 1, out, j) if (path(i) == SLASH) i = i + 1 call strcpy(path(i), out(j)) } } return end #-h- resuic 827 asc 23-apr-81 12:51:05 [002,102] 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 29-apr-81 13:54:16 [002,100] ## 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 2120 asc 01-may-81 08:04:08 j 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, matchc, 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 (matchc(argbuf, blkgtr) == 0) # no redirect, add it { if (filnfo(STDOUT, outfil, junk) == OK) { opnout = STDOUT call appred(STDOUT, GREATER, outfil, argbuf) } } i = matchc(argbuf, blkqmk) if (i != 0) { c = argbuf(i+2) if (c == BLANK | c == TAB | c == EOS) i = 0 } if (i == 0) { if (filnfo(ERROUT, errfil, junk) == OK) { opnerr = ERROUT call appred(ERROUT, QMARK, 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 23-jan-81 12:09:16 [002,100] subroutine sreset(int, file) character file(ARB) integer int, junk integer assign if (int != ERR) junk = assign(file, int, APPEND) return end #-h- srttim 871 asc 23-jan-81 10:14:57 [002,100] subroutine srttim(in, out) character in(ARB), out(ARB) character month(4, 12), buf(4), number(13) integer i, j, equal data month/LETJ,LETA,LETN,EOS,LETF,LETE,LETB,EOS,LETM,LETA,LETR,EOS, LETA,LETP,LETR,EOS,LETM,LETA,LETY,EOS,LETJ,LETU,LETN,EOS, LETJ,LETU,LETL,EOS,LETA,LETU,LETG,EOS,LETS,LETE,LETP,EOS, LETO,LETC,LETT,EOS,LETN,LETO,LETV,EOS,LETD,LETE,LETC,EOS/ data number/LETA,LETB,LETC,LETD,LETE,LETF, LETG,LETH,LETI,LETJ,LETK,LETL, LETM/ 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 23-jan-81 10:14:58 [002,100] 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 554 asc 29-apr-81 13:54:19 [002,100] ## 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) = PERIOD 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 15-may-81 10:08:50 [002,100] 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- lib.r 92191 asc 28-may-81 08:10:21 [002,100] #-h- ds.r 12819 asc 27-apr-81 23:50:09 [002,100] #-h- dsdef 748 asc 01-apr-81 09:54:44 [002,006] # 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 607 asc 30-mar-81 15:25:49 [002,006] # 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 #-t- dsinit 555 local 09/22/80 15:38:32 #-h- dsfree 959 asc 30-mar-81 15:25:51 [002,006] # 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 #-t- dsfree 1078 local 09/22/80 15:38:50 #-h- dsget 648 asc 30-mar-81 15:25:53 [002,006] # 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 #-t- dsget 995 local 09/22/80 15:38:50 #-h- dsdump 808 asc 30-mar-81 15:25:55 [002,006] # 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 (BLANK, 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 (BLANK, 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 #-t- dsdump 756 local 09/22/80 15:38:53 #-h- dsdbiu 1099 asc 30-mar-81 15:25:56 [002,006] # 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 (BLANK, 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 (NEWLINE, ERROUT) } } if (l != 0) call putch (NEWLINE, ERROUT) return end #-t- dsdbiu 839 local 09/22/80 15:38:55 #-h- mktabl 600 asc 30-mar-81 15:45:45 [002,006] # 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 do i = 1, ST_HTABSIZE; { st = st + 1 Mem (st) = LAMBDA # null link } } return end #-t- mktabl 386 local 09/22/80 15:38:38 #-h- rmtabl 496 asc 30-mar-81 15:26:00 [002,006] # rmtabl --- remove a symbol table, deleting all entries subroutine rmtabl (st) pointer st DS_DECL(Mem, 1) integer i pointer walker, bucket, node bucket = st do i = 1, ST_HTABSIZE; { bucket = bucket + 1 walker = Mem (bucket) while (walker != LAMBDA) { node = walker walker = Mem (node + ST_LINK) call dsfree (node) } } call dsfree (st) return end #-t- rmtabl 444 local 09/22/80 15:38:40 #-h- sctabl 1575 asc 30-mar-81 15:26:02 [002,006] # sctabl --- scan symbol table, returning next entry or EOF integer function sctabl (table, sym, info, posn) pointer table, posn 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) sctabl = 1 # not EOF return } else { bucket = bucket + 1 if (bucket > ST_HTABSIZE) break j = table + bucket walker = Mem (j) } } posn = 0 sctabl = EOF return end #-t- sctabl 1554 local 09/22/80 15:38:40 #-h- stlu 781 asc 30-mar-81 15:26:05 [002,006] # 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 #-t- stlu 705 local 09/22/80 15:38:48 #-h- delete 388 asc 30-mar-81 15:26:06 [002,006] # 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 #-t- delete 336 local 09/22/80 15:38:32 #-h- lookup 584 asc 30-mar-81 15:26:07 [002,006] # 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) { lookup = NO return } nodsiz = Mem (st) kluge = node + ST_DATA for (i = 1; i <= nodsiz; i = i + 1) { info (i) = Mem (kluge) kluge = kluge + 1 } lookup = YES return end #-t- lookup 519 local 09/22/80 15:38:37 #-h- enter 963 asc 30-mar-81 15:41:57 [002,006] # 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 #-t- enter 794 local 09/22/80 15:38:32 #-h- sdupl 475 asc 31-mar-81 07:24:18 [002,006] # 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 594 asc 31-mar-81 08:01:04 [002,006] # 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 502 asc 31-mar-81 07:30:52 [002,006] # 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 2930 asc 27-apr-81 23:51:31 [002,100] #-h- defns 344 asc 24-apr-81 10:56:42 [002,100] # 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 388 asc 24-apr-81 10:55:39 [002,100] integer function gethdr(fd, buf, name, size) character buf(MAXLINE), c, name(FILENAMESIZE) integer ctoi, equal, getlin, getwrd 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 519 asc 24-apr-81 10:55:40 [002,100] integer function inihlp(file, ptrara, ptrsiz, unit) integer ptrsiz, unit, i linepointer ptrara(ptrsiz) character file(FILENAMESIZE) integer open, gethdr INCL_CHELP call close(unit) # close it if previously opened unit = open(file, READ) if (unit != ERR) { for (i=1; i < ptrsiz; i=i+1) { call markl(unit, ptrara(i)) if (gethdr(unit, buf, name, size) != YES) break call fskip(unit, size) } call ptrcpy(NULLPOINTER, ptrara(i)) inihlp = OK } else inihlp = ERR return end #-h- mrkhlp 704 asc 24-apr-81 10:55:41 [002,100] integer function mrkhlp(unit, ptrara, key, outara) linepointer ptrara(ARB), outara(ARB) integer unit, j, i, junk, doall integer equal, gethdr, ptreq 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), unit) junk = gethdr(unit, 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) mrkhlp = OK else mrkhlp = ERR return end #-h- puthlp 665 asc 24-apr-81 10:55:42 [002,100] subroutine puthlp(unit, outara, key, out, putout) linepointer outara(ARB) integer unit, out, i, dosumm, junk integer gethdr, getlin, equal, ptreq character key(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), unit) junk = gethdr(unit, buf, name, size) if (dosumm == YES) { junk = getlin(buf, unit) call putout(buf, out) } else { size = size - getlin(buf, unit) for (junk = getlin(buf, unit); size > 0; junk = getlin(buf, unit)) { call putout(buf, out) size = size - junk } } } return end #-h- imsort.r 3628 asc 27-apr-81 23:50:19 [002,100] #-h- imsym 295 asc 07-apr-81 16:50:15 [002,101] 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 423 asc 07-apr-81 16:50:17 [002,101] 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 287 asc 07-apr-81 16:50:19 [002,101] 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) imget = OK } else imget = EOF return end #-h- imsort 1349 asc 07-apr-81 16:50:21 [002,101] ## 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), ctlara(5) 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 364 asc 07-apr-81 16:50:23 [002,101] 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 210 asc 07-apr-81 16:50:26 [002,101] ## 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 266 asc 07-apr-81 16:50:27 [002,101] 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)) imcomp = -1 else imcomp = 1 return end #-h- logpmt.r 19689 asc 27-apr-81 23:50:26 [002,100] #-h- defns 3401 asc 22-apr-81 13:07:25 [002,102] # additional definitions for logpmt # put on a file called 'logsym' # Used only by logpmt define(MAXPAT,132) define(GLOBAL,LETG) define(CURLINE,PERIOD) define(PREVLINE,MINUS) define(NEXTLINE,PLUS) define(LASTLINE,DOLLAR) define(SCAN,SLASH) define(BACKSCAN,BACKSLASH) 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 # is equal to 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,PLUS) define(BACKWARD,MINUS) 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) # definitions to avoid collisions in the global name space # these definitions turn readable routine names into garbage define(archiv,plog01) define(clrbuf,plog02) 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(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 1720 asc 22-apr-81 13:07:29 [002,102] integer function logpmt(pstr, line, int) character pstr(ARB), line(ARB), c character clower integer int, init, k, i, access, junk integer prompt, edline, index, equal, dohist I_CLOG01 string null "" string whites " @t@n" data init /YES/ if (init == YES) { init = NO call setbuf } repeat { k = prompt(pstr, line, int) # call putlin("k = ", ERROUT) # call putint(k, 1, ERROUT) # call putch(NEWLINE, ERROUT) if (k == EOF) call strcpy(null, line) else if (line(1) == BANG) { c = clower(line(2)) # call putlin("c = ", ERROUT) # call putch(c, ERROUT) # call putch(NEWLINE, ERROUT) if (c == LETH | c == LETB) { for (i=3; IS_LETTER(line(i)); i=i+1) ; # call putlin("i = ", ERROUT) # call putint(i, 1, ERROUT) # call putch(NEWLINE, ERROUT) junk = dohist(lastln, line, i) k = ERR } else if (c == LETW) { for (i=3; line(i) != EOS; i=i+1) if (index(whites, line(i)) > 0) break # call putlin("i = ", ERROUT) # call putint(i, 1, ERROUT) # call putch(NEWLINE, ERROUT) call skipbl(line, i) access = WRITE if (line(i) == GREATER) { i = i + 1 if (line(i) == GREATER) { i = i + 1 access = APPEND } } call scopy(line, i, line, 1) i = index(line, NEWLINE) if (i > 0) line(i) = EOS k = EOF } else if (c == LETQ) { call strcpy(null, line) k = EOF } else { k = edline(line) call putlin(pstr, ERROUT) call putlin(line, ERROUT) } } else if (line(1) == ESCAPE & line(2) == BANG) { call scopy(line, 2, line, 1) k = k - 1 } } until (k != ERR) # call remark(line) if (k != EOF) call archiv(line) else call clrbuf(line, access) return(k) end #-h- archiv 193 asc 21-apr-81 08:11:26 [002,102] # formerly known as archiv subroutine archiv(line) character line(ARB) integer junk integer inject if (line(1) != NEWLINE) # don't log blank lines junk = inject(line) return end #-h- clrbuf 695 asc 21-apr-81 08:11:26 [002,102] ## clrbuf - dispose of editor scratch file /*/sor/edr/clrbuf subroutine clrbuf(file, access) character file(FILENAMESIZE), c character getch integer access, out integer open, create I_CLOG03 call close(scr) if (file(1) != EOS) # user wants file saved { scr = open(scrfil, READ) # reopen scrfil at beginning if (scr != ERR) # better not be any errors { out = create(file, 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) } } call remove(scrfil) return end #-h- dohist 528 asc 21-apr-81 08:11:28 [002,102] # formerly known as dohist integer function dohist(line, lin, i) character lin(ARB), direc integer line, i, screen, curscr, ctoi, lin1, lin2, dolist I_CLOG01 data screen, curscr/SCREENSIZE, SCREENSIZE/ call skipbl(lin, i) if (lin(i) == NEWLINE) 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 902 asc 21-apr-81 08:11:29 [002,102] ## dolist - print lines 'from' through 'to' with control chars expanded integer function dolist(from, to, ch) integer gettxt integer from, i, j, to, k, num, xpand character c, ch I_CLOG01 I_CLOG04 xpand = NO if (ch == LETL | ch == BIGL) 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(BLANK, STDOUT) for (k=1; txt(k) != EOS; k=k+1) if (txt(k) >= BLANK | txt(k) == NEWLINE) call putch(txt(k), STDOUT) else if (xpand == NO) call putch(txt(k), STDOUT) else { call putch(CARET, STDOUT) c = txt(k) + ATSIGN call putch(c, STDOUT) } } curln = to dolist = OK return end #-h- edline 971 asc 21-apr-81 08:11:31 [002,102] # formerly known as edline integer function edline(line) character line(ARB), sub(MAXPAT) integer i, junk, status, gflag, linsts, final integer gettxt, length, getlst, optpat, getrhs, subst I_CLOG04 I_CLOG01 string badlin "# invalid line number@n" string badpat "# invalid substitution@n" i = 2 status = OK if (getlst(line, i, linsts) == OK) if (line2 == frstln) linsts = ERR else if (line(i) == LETS | line(i) == BIGS) { status = ERR i = i + 1 if (optpat(line, i, LEFT_HAND_SIDE) == OK) andif (getrhs(line, i, sub, gflag) == OK) { junk = gettxt(line2) # fetch line status = subst (txt, line, sub, gflag) # modify line } } else { junk = gettxt(line2) call strcpy(txt, line) } if (linsts == ERR) { final = ERR call strcpy(badlin, line) } else if (status == ERR) { final = ERR call strcpy(badpat, line) } else final = length(line) curln = lastln return(final) end #-h- getb 492 asc 21-apr-81 08:11:33 [002,102] ## getb - retrieve 'value' of 'type' in buf(index) /*/sor/edr/getb subroutine getb (index, type, value) integer index, type integer value(2) I_CLOG00 # ------ IAS and VMS version (16- and 32--bit words) 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 219 asc 21-apr-81 08:11:34 [002,102] ## getind - locate line index in buffer /*/sor/edr/getind integer function getind(line) integer line, k, j I_CLOG01 k = LINE0 for (j=frstln; j < line; j=j+1) call getb (k, NEXT, k) return(k) end #-h- getlst 659 asc 21-apr-81 08:11:35 [002,102] ## getlst - collect line numbers at lin(i), increment i /*/sor/edr/getlst integer function getlst(lin, i, status) character lin(MAXLINE) integer getone 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) != COMMA & lin(i) != SEMICOL) break if (lin(i) == SEMICOL) 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 1057 asc 21-apr-81 08:11:36 [002,102] ## getnum - convert one term to line number /*/sor/edr/getnum integer function getnum(lin, i, pnum, status) character lin(MAXLINE) integer ctoi, index, optpat, ptscan, prevln, nextln 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 1015 asc 21-apr-81 08:11:38 [002,102] ## getone - evaluate one line number expression /*/sor/edr/getone integer function getone(lin, i, num, status) character lin(MAXLINE) integer getnum 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) != PLUS & lin(i) != MINUS) { status = EOF break } if (lin(i) == PLUS) 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 732 asc 21-apr-81 08:11:39 [002,102] ## getrhs - get substitution string for 's' command /*/sor/edr/getrhs integer function getrhs(lin, i, sub, gflag) character lin(MAXLINE), sub(MAXPAT) integer maksub, length, index integer gflag, i, j character clower 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(NEWLINE, lin, j) # add trailing NEWLINE } 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 482 asc 21-apr-81 08:11:41 [002,102] ## gettxt - locate text for line, copy to txt /*/sor/edr/gettxt integer function gettxt(line) integer getind, getlin integer line, len, j, k, junk integer loc(2) I_CLOG00 I_CLOG03 I_CLOG04 I_CLOG01 string null "" if (line > frstln & line <= lastln) { k = getind(line) 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 220 asc 21-apr-81 08:11:42 [002,102] # formerly known as gtfndx integer function gtfndx(newind) I_CLOG00 if (lastbf + BUFENT <= MAXBUF) { newind = lastbf lastbf = lastbf + BUFENT } else newind = ERR gtfndx = newind return end #-h- inject 833 asc 21-apr-81 08:11:43 [002,102] ## inject - insert lin after curln, write scratch /*/sor/edr/inject integer function inject(lin) character lin(MAXLINE) integer gtfndx integer k1, newind 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) call markl(scr, scrend) 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 205 asc 21-apr-81 08:11:44 [002,102] ## nextln - get line after 'line' /*/sor/edr/nextln integer function nextln(line) integer line I_CLOG01 nextln = line + 1 if (nextln > lastln) nextln = frstln return end #-h- optpat 836 asc 21-apr-81 08:11:46 [002,102] ## optpat - make pattern if specified at lin(i) /*/sor/edr/optpat integer function optpat(lin, i, type) character lin(MAXLINE) integer makpat, index, length integer i, type, j 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 NEWLINE call chcopy(lin(i), lin, j) # add delimiter call chcopy(NEWLINE, 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 205 asc 21-apr-81 08:11:47 [002,102] ## prevln - get line before 'line' /*/sor/edr/prevln integer function prevln(line) integer line I_CLOG01 prevln = line - 1 if (prevln < frstln) prevln = lastln return end #-h- ptscan 495 asc 21-apr-81 08:11:48 [002,102] ## ptscan - scan for next occurrence of pattern /*/sor/edr/ptscan integer function ptscan(way, num) integer gettxt, match, nextln, prevln integer k, num, way 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) { ptscan = OK return } } until (num == curln) ptscan = ERR return end #-h- relink 194 asc 21-apr-81 08:11:49 [002,102] ## relink - rewrite two half line links /*/sor/edr/relink 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 480 asc 21-apr-81 08:11:50 [002,102] ## setb - Set 'type' in buf(index) to 'value' /*/sor/edr/setb subroutine setb (index, type, value) integer index, type integer value(2) I_CLOG00 # ------ VMS and IAS version (32- and 16-bit words) 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 618 asc 21-apr-81 08:11:51 [002,102] ## setbuf - create scratch file, set up line 0 /*/sor/edr/setbuf subroutine setbuf integer create, gtfndx integer k, junk 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) call markl (scr, scrend) 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 1049 asc 21-apr-81 08:11:53 [002,102] # formerly known as subst ## subst - substitute "sub" for occurrences of pattern integer function subst (old, new, sub, gflag) character old(MAXLINE), new(MAXLINE), sub(MAXPAT) integer addset, amatch 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- misc.r 19705 asc 01-may-81 07:56:09 j #-h- acopy 264 asc 23-apr-81 16:53:02 [002,100] ## acopy - copy size characters from fdi to fdo subroutine acopy (fdi, fdo, size) character getch character c integer fdi, fdo, i, size for (i=1; i<=size; i=i+1) { if (getch(c,fdi) != EOF) call putch (c, fdo) } return end #-h- addset 284 asc 23-apr-81 16:53:03 [002,100] ## 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) addset = NO else { str(j) = c j = j + 1 addset = YES } return end #-h- adrfil 167 asc 23-apr-81 16:53:03 [002,100] subroutine adrfil(file) character file(FILENAMESIZE) string addr "address" call getdir(MAILDIRECTORY, LOCAL, file) call concat(file, addr, file) return end #-h- alldig 283 asc 23-apr-81 16:53:04 [002,100] ## alldig - return YES if str is all digits integer function alldig (str) integer type, i character str(ARB) alldig = NO if (str(1) == EOS) return for (i=1; str(i) != EOS; i=i+1) if (type(str(i)) != DIGIT) return alldig = YES return end #-h- badarg 131 asc 23-apr-81 16:53:04 [002,100] subroutine badarg(arg) character arg(ARB) call putlin(arg, ERROUT) call remark(": ignoring invalid argument.") return end #-h- bubble 406 asc 23-apr-81 16:53:05 [002,100] ## 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 v(j+1)) #compare { k = v(j) #exchange v(j) = v(j+1) # v(j+1) = k # } return end #-h- cant 476 asc 28-apr-81 00:02:36 [002,100] # ## cant - print "file: can't open" and terminate execution # subroutine cant (file) # # character file (ARB) # character buf(15) # data buf(1), buf(2), buf(3), buf(4), buf(5), buf(6), buf(7), # buf(8), buf(9), buf(10), buf(11), buf(12), buf(13), buf(14), # buf(15) /COLON, BLANK, BLANK, # LETC, LETA, LETN, SQUOTE, LETT, BLANK, # LETO, LETP, LETE, LETN, NEWLINE, EOS/ # # call putlin (file, ERROUT) # call putlin (buf, ERROUT) # call endst(ERR) # end #-h- chcopy 128 asc 23-apr-81 16:53:06 [002,100] # subroutine chcopy(c, buf, i) # # character c, buf(ARB) # integer i # # buf(i) = c # i = i + 1 # buf(i) = EOS # # return # end #-h- clower 371 asc 23-apr-81 16:53:07 [002,100] # ## clower - change letter to lower case # character function clower(c) # # character c, k # # if (c >= BIGA & c <= BIGZ) # { #avoid integer overflow in byte machines # k = LETA - BIGA # clower = c + k # } # else # clower = c # # return # end #-h- concat 191 asc 23-apr-81 16:53:07 [002,100] # 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- ctodi 399 asc 25-apr-81 07:37:24 [002,100] subroutine ctodi(buf, i, di) character buf(ARB), temp(MAXCHARS), hi(10), lo(6) integer i, di(2), len, j integer getwrd, ctoi 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 828 asc 23-apr-81 16:53:08 [002,100] ## ctoi - convert string at in(i) to integer, increment i integer function ctoi(in, i) character in(ARB) integer index integer d, i, sign # string digits "0123456789" character digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ while (in(i) == BLANK | in(i) == TAB) i = i + 1 sign = 1 if (in(i) == MINUS) { 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 374 asc 23-apr-81 16:53:09 [002,100] # ## cupper - change letter to upper case # character function cupper(c) # # character c, k # # if (c >= LETA & c <= LETZ) # { #avoid overflow with byte-oriented machines # k = BIGA - LETA # cupper = c + k # } # else # cupper = c # # return # end #-h- ditoc 413 asc 25-apr-81 06:59:10 [002,100] integer function ditoc(di, buf, size) integer di(2), n, j, i, size integer itoc character buf(size), temp(MAXCHARS), lo(5) 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(DIG0, 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 23-apr-81 16:53:09 [002,100] # ## 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 142 asc 28-apr-81 00:02:38 [002,100] ## error - print message and terminate execution subroutine error (line) character line(ARB) call remark (line) call endst(ERR) end #-h- exppth 264 asc 23-apr-81 16:53:10 [002,100] subroutine exppth(path, depth, ptr, buf) character path(ARB), buf(ARB) integer depth, ptr(MAXDIRECTS), i, gtftok depth = 0 i = 1 repeat { depth = depth + 1 ptr(depth) = i } until(gtftok(path, i, buf) == 0) depth = depth - 1 return end #-h- fcopy 182 asc 23-apr-81 16:53:11 [002,100] ## fcopy - copy file in to file out subroutine fcopy (in, out) character c character getch integer in, out while (getch(c,in) != EOF) call putch(c, out) return end #-h- fmtdat 1555 asc 23-apr-81 16:53:12 [002,100] # 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 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(DIG0, date, k) call stcopy(temp, 1, date, k) call chcopy(SLASH, date, k) if (itoc(now(3), temp, 3) == 1) call chcopy(DIG0, date, k) call stcopy(temp, 1, date, k) call chcopy(SLASH, date, k) if (itoc(mod(now(1),100), temp, 3) == 1) call chcopy(DIG0, date, k) call stcopy(temp, 1, date, k) } else { if (itoc(now(3), temp, 3) == 1) call chcopy(DIG0, date, k) call stcopy(temp, 1, date, k) call chcopy(MINUS, date, k) for (j = 3 * (now (2) - 1) + 1; k <= 6; j=j+1) call chcopy(months(j), date, k) call chcopy(MINUS, date, k) if (itoc(mod(now(1),100), temp, 3) == 1) call chcopy(DIG0, date, k) call stcopy(temp, 1, date, k) } k = 1 if (itoc(now(4), temp, 3) == 1) call chcopy(DIG0, time, k) call stcopy(temp, 1, time, k) call chcopy(COLON, time, k) if (itoc(now(5), temp, 3) == 1) call chcopy(DIG0, time, k) call stcopy(temp, 1, time, k) call chcopy(COLON, time, k) if (itoc(now(6), temp, 3) == 1) call chcopy(DIG0, time, k) call stcopy(temp, 1, time, k) return end #-h- fold 203 asc 23-apr-81 16:53:13 [002,100] # ## 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 349 asc 23-apr-81 16:53:13 [002,100] ## fsize - determine size of file in characters integer function fsize (name) character getch character c, name(ARB) integer open integer fd fd = open (name, READ) if (fd == ERR) fsize = ERR else { for (fsize=0; getch(c,fd) != EOF; fsize=fsize+1) ; call close (fd) } return end #-h- fskip 210 asc 23-apr-81 16:53:14 [002,100] ## fskip - skip n characters on file fd subroutine fskip (fd, n) character getch character c integer fd, i, n for (i=1; i<=n; i=i+1) if (getch(c,fd) == EOF) break return end #-h- getc 142 asc 23-apr-81 16:53:14 [002,100] # ## getc - get character from STDIN # character function getc(c) # # character c # character getch # # getc = getch(c, STDIN) # return # end #-h- getwrd 415 asc 23-apr-81 16:53:15 [002,100] ## 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) == BLANK | in(i) == TAB) i = i + 1 j = 1 while (in(i) != EOS & in(i) != BLANK & in(i) != TAB & in(i) != NEWLINE) { out(j) = in(i) i = i + 1 j = j + 1 } out(j) = EOS getwrd = j - 1 return end #-h- gtftok 339 asc 23-apr-81 16:53:15 [002,100] # integer function gtftok(buf, i, token) # # character buf(ARB), token(ARB) # integer i, j # # if (buf(i) == SLASH) # i = i + 1 # j = 1 # while (buf(i) != SLASH & buf(i) != EOS) # { # token(j) = buf(i) # i = i + 1 # j = j + 1 # if (buf(i-1) == BACKSLASH) # break # } # token(j) = EOS # gtftok = j - 1 # # return # end #-h- impath 257 asc 23-apr-81 16:53:16 [002,100] ### impath - generate search path for standard images to be spawned # subroutine impath(path) # # character path(ARB) # integer i # # string spath "@e~usr/@e~bin/@e@n" # current:usr:bin # # for (i=1; i <= 15; i=i+1) # path(i) = spath(i) # # return # end #-h- index 255 asc 23-apr-81 16:53:17 [002,100] # ## 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- itoc 1027 asc 23-apr-81 16:53:17 [002,100] ## itoc - convert integer int to char string in str integer function itoc(int, str, size) integer mod integer d, i, int, intval, j, k, size character str(size) # string digits "0123456789" character digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ 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) = MINUS } 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 23-apr-81 16:53:18 [002,100] # ## 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 23-apr-81 16:53:19 [002,100] # ## putc - put character onto STDOUT # subroutine putc (c) # # character c # # call putch (c, STDOUT) # return # end #-h- putdec 389 asc 01-may-81 07:55:06 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(BLANK) # for(i = 1; i <= nd; i = i+1) # call putc(chars(i)) # return # end #-h- putint 270 asc 23-apr-81 16:53:20 [002,100] ## putint - output integer in specified field subroutine putint(n, w, fd) character chars(MAXCHARS) integer itoc integer n, w, fd, junk junk = itoc(n,chars,MAXCHARS) call putstr(chars, w, fd) return end #-h- putptr 183 asc 23-apr-81 16:53:20 [002,100] subroutine putptr(ptr, unit) linepointer ptr integer unit, junk integer ptrtoc character temp(LINEPTRSIZE) junk = ptrtoc(ptr, temp, LINEPTRSIZE) call putlin(temp, unit) return end #-h- putstr 368 asc 23-apr-81 16:53:21 [002,100] ## putstr - output character string in specified field subroutine putstr(str, w, fd) character str(ARB) character length integer w, fd len = length(str) for (i = len+1; i <= w; i=i+1) call putch(BLANK, 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(BLANK, fd) return end #-h- query 317 asc 23-apr-81 16:53:22 [002,100] # query - print usage message if user has requested one subroutine query (mesg) character mesg (ARB) integer getarg character arg1 (3), arg2 (1) if (getarg (1, arg1, 3) != EOF & getarg (2, arg2, 1) == EOF) if (arg1 (1) == QMARK & arg1 (2) == EOS) call error (mesg) return end #-h- scopy 303 asc 23-apr-81 16:53:22 [002,100] # ## 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- shell 577 asc 23-apr-81 16:53:23 [002,100] ## 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 186 asc 23-apr-81 16:53:23 [002,100] ## skipbl - skip blanks and tabs at lin(i) subroutine skipbl(lin, i) character lin(ARB) integer i while (lin(i) == BLANK | lin(i) == TAB) i = i + 1 return end #-h- stcopy 262 asc 23-apr-81 16:53:24 [002,100] ### 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 23-apr-81 16:53:25 [002,100] # ## 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 23-apr-81 16:53:25 [002,100] # 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- type 2149 asc 23-apr-81 16:53:26 [002,100] # ## type - determine type of character # integer function type (c) # # character c ## integer index ## character digits(11), lowalf(27), upalf(27) ## data digits(1) /DIG0/ ## data digits(2) /DIG1/ ## data digits(3) /DIG2/ ## data digits(4) /DIG3/ ## data digits(5) /DIG4/ ## data digits(6) /DIG5/ ## data digits(7) /DIG6/ ## data digits(8) /DIG7/ ## data digits(9) /DIG8/ ## data digits(10) /DIG9/ ## data digits(11) /EOS/ ## ## data lowalf(1) /LETA/ ## data lowalf(2) /LETB/ ## data lowalf(3) /LETC/ ## data lowalf(4) /LETD/ ## data lowalf(5) /LETE/ ## data lowalf(6) /LETF/ ## data lowalf(7) /LETG/ ## data lowalf(8) /LETH/ ## data lowalf(9) /LETI/ ## data lowalf(10) /LETJ/ ## data lowalf(11) /LETK/ ## data lowalf(12) /LETL/ ## data lowalf(13) /LETM/ ## data lowalf(14) /LETN/ ## data lowalf(15) /LETO/ ## data lowalf(16) /LETP/ ## data lowalf(17) /LETQ/ ## data lowalf(18) /LETR/ ## data lowalf(19) /LETS/ ## data lowalf(20) /LETT/ ## data lowalf(21) /LETU/ ## data lowalf(22) /LETV/ ## data lowalf(23) /LETW/ ## data lowalf(24) /LETX/ ## data lowalf(25) /LETY/ ## data lowalf(26) /LETZ/ ## data lowalf(27) /EOS/ ## ## data upalf(1) /BIGA/ ## data upalf(2) /BIGB/ ## data upalf(3) /BIGC/ ## data upalf(4) /BIGD/ ## data upalf(5) /BIGE/ ## data upalf(6) /BIGF/ ## data upalf(7) /BIGG/ ## data upalf(8) /BIGH/ ## data upalf(9) /BIGI/ ## data upalf(10) /BIGJ/ ## data upalf(11) /BIGK/ ## data upalf(12) /BIGL/ ## data upalf(13) /BIGM/ ## data upalf(14) /BIGN/ ## data upalf(15) /BIGO/ ## data upalf(16) /BIGP/ ## data upalf(17) /BIGQ/ ## data upalf(18) /BIGR/ ## data upalf(19) /BIGS/ ## data upalf(20) /BIGT/ ## data upalf(21) /BIGU/ ## data upalf(22) /BIGV/ ## data upalf(23) /BIGW/ ## data upalf(24) /BIGX/ ## data upalf(25) /BIGY/ ## data upalf(26) /BIGZ/ ## data upalf(27) /EOS/ ## ## if (index(lowalf, c) > 0) ## type = LETTER ## else if (index(upalf,c) >0) ## type = LETTER ## else if (index(digits,c) > 0) ## type = DIGIT ## else ## type = c # if ((c >= LETA & c <= LETZ) | (c >= BIGA & c <= BIGZ)) # type = LETTER # else if (c >= DIG0 & c <= DIG9) # type = DIGIT # else # type = c # return # end #-h- upper 207 asc 23-apr-81 16:53:28 [002,100] # ## 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 416 asc 01-may-81 07:55:09 j # wkday --- get day-of-week corresponding to month,day,year integer function wkday (month, day, year) integer month, day, year integer lmonth, lday, lyear lmonth = month - 2 lday = day lyear = mod(year, 100) if (lmonth <= 0) { lmonth = lmonth + 12 lyear = lyear - 1 } wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34, 7) + 1 return end #-h- packsub.r 1448 asc 27-apr-81 23:50:57 [002,100] #-h- inpack 191 asc 17-mar-81 09:13:50 [002,101] ## inpack - subroutine to initialize packing of words at TAB stops subroutine inpack(nxtcol, rightm, buf, unit) integer nxtcol, rightm, unit character buf(ARB) nxtcol = 1 return end #-h- dopack 780 asc 17-mar-81 09:13:51 [002,101] ## dopack - subroutine to pack words at TAB stops and flush lines subroutine dopack(word, nxtcol, rightm, buf, unit) integer nxtcol, rightm, unit, i, j, nxttab integer length character word(ARB), buf(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, unit) i = 1 nxttab = nxtcol j = length(word) } if ((nxttab - nxtcol) > 8) call chcopy(TAB, buf, i) if ((nxttab - nxtcol) > 0) call chcopy(TAB, buf, i) call scopy(word, 1, buf, i) nxtcol = j + 1 } return end #-h- flpack 291 asc 17-mar-81 09:13:53 [002,101] ## flpack - subroutine to flush buffers of packed words subroutine flpack(nxtcol, rightm, buf, unit) integer nxtcol, rightm, unit character buf(ARB) if (nxtcol > 1) # something to flush { call putlin(buf, unit) call putch(NEWLINE, unit) nxtcol = 1 } return end #-h- pattern.r 15835 asc 27-apr-81 23:51:02 [002,100] #-h- patdef 813 asc 09-apr-81 10:18:59 [002,101] ## definitions for the pattern matching routines # put on a file named 'patdef' # Used by pattern.r and ed & sedit tools define(ANY,QMARK) define(BOL,PERCENT) define(BOT,LBRACE) define(CCL,LBRACK) define(CCLEND,RBRACK) define(CHAR,LETA) define(CLOSIZE,4) define(CLOSURE,STAR) define(CLOSURE1,PLUS) # closure of one or more occurrences # i.e. (pat)+ == (pat)(pat)* define(COUNT,1) define(EOL,DOLLAR) define(EOT,RBRACE) define(MAXTAG,10) define(NCCL,LETN) 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- amatch 1345 asc 17-mar-81 10:05:27 [002,101] ## amatch (non-recursive) - look for match starting at lin(from) integer function amatch(lin, from, pat) character lin(MAXLINE), pat(MAXPAT) integer omatch, patsiz integer from, i, j, offset, 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 amatch = 0 # return failure return } pat(stack+COUNT) = pat(stack+COUNT) - 1 j = stack + CLOSIZE offset = pat(stack+START) + pat(stack+COUNT) } # else omatch succeeded amatch = offset return # success end #-h- dodash 466 asc 17-mar-81 10:05:28 [002,101] ## dodash - expand array(i-1)-array(i+1) into set(j)... from valid subroutine dodash(valid, array, i, set, j, maxset) character esc integer addset, index 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 1090 asc 17-mar-81 10:05:30 [002,101] ## esc - map array(i) into escaped character if appropriate character function esc(array, i) character array(ARB) integer i integer j if (array(i) != ESCAPE) esc = array(i) else if (array(i+1) == EOS) # \*a not special at end esc = ESCAPE else { i = i + 1 if (array(i) == LETN | array(i) == BIGN) esc = NEWLINE else if (array(i) == LETT | array(i) == BIGT) esc = TAB else if (array(i) == LETR | array(i) == BIGR) esc = CR else if (array(i) == LETB | array(i) == BIGB) esc = BACKSPACE else if (array(i) == LETE | array(i) == BIGE) esc = EOS else if (array(i) == LETF | array(i) == BIGF) esc = FF else if (array(i) == LETL | array(i) == BIGL) esc = LF else if (array(i) >= DIG0 & array(i) <= DIG7) { esc = 0 for (j=i; j=DIG0 & array(j)<=DIG7); j=j+1) esc = 8*esc + (array(j) - DIG0) i = j - 1 } else esc = array(i) } return end #-h- filset 2838 asc 17-mar-81 10:05:32 [002,101] ## filset - expand set at array(i) into set(j), stop at delim subroutine filset(delim, array, i, set, j, maxset) character esc integer addset, index integer i, j, junk, maxset character array(ARB), delim, set(maxset) string digits '0123456789' # character digits(11) string lowalf 'abcdefghijklmnopqrstuvwxyz' # character lowalf(27) string upalf 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' # character upalf(27) # data digits(1)/DIG0/, digits(2)/DIG1/, digits(3)/DIG2/ # data digits(4)/DIG3/, digits(5)/DIG4/, digits(6)/DIG5/ # data digits(7)/DIG6/, digits(8)/DIG7/, digits(9)/DIG8/ # data digits(10)/DIG9/, digits(11)/EOS/ # data lowalf(01)/LETA/ # data lowalf(02)/LETB/ # data lowalf(03)/LETC/ # data lowalf(04)/LETD/ # data lowalf(05)/LETE/ # data lowalf(06)/LETF/ # data lowalf(07)/LETG/ # data lowalf(08)/LETH/ # data lowalf(09)/LETI/ # data lowalf(10)/LETJ/ # data lowalf(11)/LETK/ # data lowalf(12)/LETL/ # data lowalf(13)/LETM/ # data lowalf(14)/LETN/ # data lowalf(15)/LETO/ # data lowalf(16)/LETP/ # data lowalf(17)/LETQ/ # data lowalf(18)/LETR/ # data lowalf(19)/LETS/ # data lowalf(20)/LETT/ # data lowalf(21)/LETU/ # data lowalf(22)/LETV/ # data lowalf(23)/LETW/ # data lowalf(24)/LETX/ # data lowalf(25)/LETY/ # data lowalf(26)/LETZ/ # data lowalf(27)/EOS/ # data upalf(01) /BIGA/ # data upalf(02) /BIGB/ # data upalf(03) /BIGC/ # data upalf(04) /BIGD/ # data upalf(05) /BIGE/ # data upalf(06) /BIGF/ # data upalf(07) /BIGG/ # data upalf(08) /BIGH/ # data upalf(09) /BIGI/ # data upalf(10) /BIGJ/ # data upalf(11) /BIGK/ # data upalf(12) /BIGL/ # data upalf(13) /BIGM/ # data upalf(14) /BIGN/ # data upalf(15) /BIGO/ # data upalf(16) /BIGP/ # data upalf(17) /BIGQ/ # data upalf(18) /BIGR/ # data upalf(19) /BIGS/ # data upalf(20) /BIGT/ # data upalf(21) /BIGU/ # data upalf(22) /BIGV/ # data upalf(23) /BIGW/ # data upalf(24) /BIGX/ # data upalf(25) /BIGY/ # data upalf(26) /BIGZ/ # data upalf(27) /EOS/ 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) != DASH) junk = addset(array(i), set, j, maxset) else if (j <= 1 | array(i+1) == EOS) # literal - junk = addset(DASH, 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(DASH, set, j, maxset) return end #-h- getccl 643 asc 17-mar-81 10:05:35 [002,101] ## getccl - expand char class at arg(i) into pat(j) integer function getccl(arg, i, pat, j) character arg(MAXARG), pat(MAXPAT) integer addset integer i, j, jstart, junk i = i + 1 # skip over [ if (arg(i) == NOT) { junk = addset(NCCL, pat, j, MAXPAT) i = i + 1 } else junk = addset(CCL, pat, j, MAXPAT) jstart = j junk = addset(0, pat, j, MAXPAT) # leave room for count call filset(CCLEND, arg, i, pat, j, MAXPAT) pat(jstart) = j - jstart - 1 if (arg(i) == CCLEND) getccl = OK else getccl = ERR return end #-h- getpat 204 asc 17-mar-81 10:05:36 [002,101] ## getpat - convert argument into pattern integer function getpat(arg, pat) integer arg(MAXARG), pat(MAXPAT) integer makpat getpat = makpat(arg, 1, EOS, pat) return end #-h- locate 392 asc 17-mar-81 10:05:37 [002,101] ## locate - look for c in char class at pat(offset) integer function locate(c, pat, offset) character c, pat(MAXPAT) integer i, offset # size of class is at pat(offset), characters follow for (i = offset + pat(offset); i > offset; i = i - 1) if (c == pat(i)) { locate = YES return } locate = NO return end #-h- makpat 2350 asc 17-mar-81 10:05:39 [002,101] ## makpat - make pattern from arg(from), terminate at delim integer function makpat(arg, from, delim, pat) character esc character arg(MAXARG), delim, pat(MAXPAT) integer addset, getccl, stclos integer from, i, j, junk, lastcl, lastj, lj 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 = addset(ANY, pat, j, MAXPAT) else if (arg(i) == BOL & i == from) junk = addset(BOL, pat, j, MAXPAT) else if (arg(i) == EOL & arg(i + 1) == delim) junk = addset(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(j) == CLOSURE | pat(lj) == CLOSURE1) break # error if (arg(i) == CLOSURE1) # duplicate last pattern for (lastj = j; lj < lastj; lj = lj + 1) junk = addset(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 = addset(BOT, pat, j, MAXPAT) junk = addset(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 = addset(EOT, pat, j, MAXPAT) junk = addset(n, pat, j, MAXPAT) } else { junk = addset(CHAR, pat, j, MAXPAT) junk = addset(esc(arg, i), pat, j, MAXPAT) } lastj = lj } if (arg(i) != delim) # terminated early makpat = ERR else if (addset(EOS, pat, j, MAXPAT) == NO) # no room makpat = ERR else if (tagi > 0) { # call remark("missing tag end symbol.") makpat = ERR } else makpat = i return end #-h- match 331 asc 17-mar-81 10:05:42 [002,101] ## match - find match anywhere on line integer function match(lin, pat) character lin(MAXLINE), pat(MAXPAT) integer amatch integer i for (i = 1; lin(i) != EOS; i = i + 1) if (amatch(lin, i, pat) > 0) { match = YES return } match = NO return end #-h- omatch 1242 asc 17-mar-81 10:05:43 [002,101] ## omatch - try to match a single pattern at pat(j) integer function omatch(lin, i, pat, j) character lin(MAXLINE), pat(MAXPAT) integer locate integer bump, i, j 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) != NEWLINE) bump = 1 } else if (pat(j) == EOL) { if (lin(i) == NEWLINE) 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) != NEWLINE & 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 521 asc 17-mar-81 10:05:44 [002,101] ## patsiz - returns size of pattern entry at pat(n) integer function patsiz(pat, n) character pat(MAXPAT) integer n 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 641 asc 17-mar-81 10:05:46 [002,101] ## stclos - insert closure entry at pat(j) integer function stclos(pat, j, lastj, lastcl) character pat(MAXPAT) integer addset integer j, jp, jt, junk, lastcl, lastj for (jp = j - 1; jp >= lastj; jp = jp - 1) { # make a hole jt = jp + CLOSIZE junk = addset(pat(jp), pat, jt, MAXPAT) } j = j + CLOSIZE stclos = lastj junk = addset(CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addset(0, pat, lastj, MAXPAT) # COUNT junk = addset(lastcl, pat, lastj, MAXPAT) # PREVCL junk = addset(0, pat, lastj, MAXPAT) # START return end #-h- catsub 852 asc 17-mar-81 10:05:47 [002,101] ## catsub - add replacement text to end of new. subroutine catsub(lin, from, to, sub, new, k, maxnew) integer addset , itoc, ctoi 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("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- getsub 223 asc 17-mar-81 10:05:49 [002,101] ## getsub - get substitution pattern into sub (/*/sor/chr) integer function getsub(arg, sub) character arg(MAXARG), sub(MAXPAT) integer maksub getsub = maksub(arg, 1, EOS, sub) return end #-h- maksub 892 asc 17-mar-81 10:05:50 [002,101] ## maksub - make substitution string in sub (/*/sor/chr) integer function maksub(arg, from, delim, sub) character esc character arg(MAXARG), delim, sub(MAXPAT) integer addset, type, ctoi 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) == DOLLAR & 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 maksub = ERR else if (addset(EOS, sub, j, MAXPAT) == NO) # no room maksub = ERR else maksub = i return end #-h- pb.r 1277 asc 27-apr-81 23:51:13 [002,100] #-h- pbdefs 93 asc 20-apr-81 17:03:39 [002,102] define(BUFSIZE,500) define(INCLUDE_CPB,common/cpb/bp, buf(BUFSIZE) integer pb character buf) #-h- pbinit 51 asc 20-apr-81 17:03:41 [002,102] subroutine pbinit INCLUDE_CPB bp = 0 return end #-h- ngetch 275 asc 20-apr-81 17:03:42 [002,102] # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd INCLUDE_CPB if (bp > 0) { c = buf(bp) bp = bp - 1 } else c = getch(c, fd) ngetch = c return end #-h- putbak 220 asc 20-apr-81 17:03:44 [002,102] # putbak - push character back onto input subroutine putbak(c) character c INCLUDE_CPB bp = bp + 1 if (bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end #-h- pbstr 328 asc 20-apr-81 17:03:45 [002,102] # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i INCLUDE_CPB for (i = length(in); i > 0; i = i - 1) { bp = bp + 1 if (bp > BUFSIZE) call error("Too many characters pushed back.") buf(bp) = in(i) } return end #-h- rawpmt.r 10229 asc 28-may-81 08:08:05 [002,100] #-h- defns 660 asc 22-apr-81 14:07:56 [002,102] 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 446 asc 22-apr-81 14:07:57 [002,102] 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) == NEWLINE & lin(n-1) == ESCAPE) { lin(n-1) = BLANK # @NEWLINE => BLANK if (rwpmpt(altpst, tmp, in) == EOF) return(EOF) call stcopy(tmp, 1, lin, n) n = n - 1 # point at NEWLINE } return(n) end #-h- ds 979 asc 22-apr-81 14:07:59 [002,102] ## 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) == SLASH) 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) != STAR) 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 22-apr-81 14:08:00 [002,102] ## 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 22-apr-81 14:08:01 [002,102] ## 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 22-apr-81 14:08:02 [002,102] ## 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 434 asc 22-apr-81 14:08:03 [002,102] ## 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) == SLASH | str(i) == BACKSLASH) 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 773 asc 22-apr-81 14:08:04 [002,102] ## 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) != NEWLINE & pstr(i) != EOS; j=j+1) { temp(j) = pstr(i) i = i + 1 } if (pstr(i) == NEWLINE) { 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) < BLANK) { call chcopy(CARET, temp, j) if (ifexpd == EXPAND) call chcopy(lin(i)+ATSIGN, temp, j) } else call chcopy(lin(i), temp, j) } temp(j) = EOS call putlin(temp, int) return end #-h- rwpmpt 3341 asc 22-apr-81 14:08:06 [002,102] 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 "d " 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) = BLANK 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(SHARP, 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 < BLANK & 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(CARET, out) # all characters occupy one column } } call putch(CARRIAGERETURN, out) lin(i) = NEWLINE lin(i+1) = EOS savmod = stmode(in, savmod) # reset mode on unit return(i) end #-h- scnbck 684 asc 22-apr-81 14:08:09 [002,102] ## 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 361 asc 28-may-81 08:03:53 [002,100] 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 656 asc 22-apr-81 14:08:11 [002,102] ## 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 2322 asc 27-apr-81 23:51:25 [002,100] #-h- argtab 371 asc 09-apr-81 08:45:15 [002,101] # argtab - fetch tab information from argument list subroutine argtab(buf) character buf(MAXLINE), n(4) integer i, j, k integer getarg, alldig i = 1 for (j=1; getarg(j, n, 4) != EOF; j=j+1) { k = 1 if (n(1) == PLUS) k = k + 1 if (alldig(n(k)) == YES) { if (i > 1) call chcopy(BLANK, buf, i) call stcopy(n, 1, buf, i) } } return end #-h- gtword 614 asc 09-apr-81 08:45:16 [002,101] # gtword - get next word from in(i) into out, increment i, up to size chars integer function gtword(in, i, out, size) character in(ARB), out(ARB) integer i, size, j, overfl while (in(i) == BLANK | in(i) == TAB) i = i + 1 overfl = YES # assume word too big for (j=1; j <= size; j=j+1) if (in(i) == EOS | in(i) == BLANK | in(i) == TAB | in(i) == NEWLINE) { 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) != BLANK & in(i) != TAB & in(i) != NEWLINE) i = i + 1 return(j-1) end #-h- settab 863 asc 09-apr-81 08:45:17 [002,101] # settab - set initial tab stops subroutine settab(buf, tabs) integer alldig integer tabs(MAXLINE), m, p, k, i, j, l , ptr integer gtword, ctoi 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) == PLUS) k = k + 1 if (alldig(n(k)) == NO) next l = ctoi(n,k) if (l<=0 | l>MAXLINE) next if (n(1)!=PLUS) { 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 226 asc 09-apr-81 08:45:18 [002,101] # 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 1635 asc 27-apr-81 23:51:28 [002,100] #-h- tbsym 51 asc 06-apr-81 10:39:00 [002,006] define(INCLUDE_CTB,common/ctb/table pointer table) #-h- tbinit 252 asc 06-apr-81 10:39:01 [002,006] # 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 586 asc 06-apr-81 10:39:01 [002,006] # tbinst - enter a new symbol definition, discarding any old one subroutine tbinst (name, defn) character name (ARB), defn (ARB) INCLUDE_CTB 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 tbinst: no room for new definition.") return end #-h- tblook 498 asc 06-apr-81 10:39:03 [002,006] # 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 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