#-h- io 842 asc 17-oct-80 17:36:14 # IO common block - put on a file called 'io' ## io -- common block with IAS io info for tools common / io / lastc(NNFILES), fdb(NNFILES), lfn(NNFILES), chtype(NNFILES), mode(NNFILES), filetp(NNFILES), filenm(FILENAMESIZE, NNFILES), buffer(MAXLINE, NNFILES) integer lastc # pointer to last character in unit's buffer # initialized to 0 for output, MAXLINE for input integer fdb # fdb address for unit; initialized in open subs logical*1 lfn # unit status; OPENED/CLOSED; init = CLOSED logical*1 chtype # character type ; RAW/COOKED; init = COOKED logical*1 mode # mode of io; INPUTMODE/OUTPUTMODE; init by openx logical*1 filetp # type of file; ASCII/BINARY; init by cre8at character filenm # file name associated with unit character buffer # line buffer for unit #-h- ossym 864 asc 17-oct-80 17:36:18 # Additional symbols for PDP 11/70 installation # Put on a file called 'ossym' define(MAXARGS,25) #max number of command line args allowed define(NNFILES,6) #max number of files allowed open at a time define(FREEUNIT,7) # free lun used for various and sundry stuff define(TTYUNIT,8) # free lun used for tty activities define(NEWREAD,99) #flag for creating new file define(SCRATCH,98) # flag for scratch file define(PRINT,97) # flag for print file define(INPUTMODE,0) # flag for mode of io define(OUTPUTMODE,1) define(OWNER,-1) #flag for receiving message for parent task define(CLOSED,0) # lfn(int) value if no file opened define(OPENED,1) # lfn(int) value if file is opened define(TERMINAL,2) # lfn(int) value if opened file is tty define(CHARACTERMASK,0) # used in calls to maskit define(INTEGERMASK,1) # used in calls to maskit #-h- carg 161 asc 17-oct-80 17:36:20 # CARG common block - put on a file called 'carg' ## carg common block common /carg/ nbrarg, ptr(MAXARGS), arg(ARGBUFSIZE) integer nbrarg, ptr character arg #-h- spsym 307 asc 17-oct-80 17:36:21 define(PIDSIZE,7) define(TREELIMIT,DIG9) define(SNDEFN,5) define(NSEC,5) define(SECONDS,2) define(GETEFN,6) define(SPNEFN,7) define(ARGBUFSIZE,256) define(WAIT,LETW) define(spawn,sspawn) define(ESCAPE,27) define(IO.RLB,8%1000) define(IO.WLB,8%400) define(IO.ATT,8%1400) define(IO.DET,8%2000) #-h- osprim.r 23242 asc 21-oct-80 15:42:15 #-h- defns 15 asc 06-may-80 16:04:20 include ossym #-h- inmap 92 asc 06-may-80 16:04:21 ##inmap - *stub* character function inmap (c) character c inmap = c return end #-h- outmap 94 asc 06-may-80 16:04:22 ##outmap - *stub* character function outmap(c) character c outmap = c return end #-h- getch 815 asc 06-may-80 16:04:24 ## getch - get characters from file f character function getch(c, f) include io character c integer f, gets, n, count integer inmap character rgetch if (chtype(f) == RAW) { getch = rgetch(c, f) return } if (mode(f) .ne. INPUTMODE) { lastc(f) = 0 mode(f) = INPUTMODE } n = lastc(f) if (n == 0 .or. buffer(n, f) == NEWLINE .or. n >= MAXLINE) { count = gets(fdb(f), buffer(1, f), MAXCARD) if (count < 0) { getch = EOF c = EOF return } buffer(count+1, f) = NEWLINE lastc(f) = 0 } lastc(f) = lastc(f) + 1 n = lastc(f) #use the following line if characters have to be mapped # c = inmap(buffer(n,f)) #otherwise, use this line c = buffer(n,f) getch = c return end #-h- putch 653 asc 06-may-80 16:04:25 ## putch -- put characters on file f subroutine putch(c, f) character c, outmap integer f, i, n include io if (chtype(f) == RAW) { call rputch(c, 1, f) return } if (mode(f) .ne. OUTPUTMODE) { mode(f) = OUTPUTMODE lastc(f) = 0 } n = lastc(f) if (n >= MAXLINE .or. c == NEWLINE) { call puts(fdb(f), buffer(1,f), n) lastc(f) = 0 } if (c .ne. NEWLINE) { lastc(f) = lastc(f) + 1 n = lastc(f) # use the following line if characters must be mapped # buffer(n, f) = outmap(c) # use the following line if no mapping needed buffer(n, f) = c } return end #-h- putlin 311 asc 06-may-80 16:04:27 ## putlin - put out line by repeated calls to putch subroutine putlin (b, f) character b(ARB) integer f, i integer length include io if (chtype(f) == RAW) { i = length(b) call rputch(b, i, f) } else for (i=1; b(i) .ne. EOS; i=i+1) call putch (b(i), f) return end #-h- getlin 989 asc 21-oct-80 15:41:49 ## getlin - get a line from file f integer function getlin (line, f) character line(ARB) integer f, i integer gets character getch include io if (lastc(f) != 0 & chtype(f) != RAW) for (i=1; ;i=i+1) { if (getch(line(i), f) == NEWLINE) { line(i+1) = EOS getlin = i return } if (line(i) == EOF) { getlin = EOF line(i) = EOS return } if (i >= MAXLINE-1) { line(i+1) = EOS getlin = i return } } else { if (mode(f) != INPUTMODE) mode(f) = INPUTMODE lastc(f) = 0 i = gets(fdb(f), line, MAXCARD) if (i < 0) { getlin = EOF line(1) = EOS } else if (i < MAXCARD) { line(i+1) = NEWLINE line(i+2) = EOS getlin = i + 1 } else { line(MAXLINE) = EOS getlin = MAXCARD } } return end #-h- getarg 574 asc 20-aug-80 08:36:28 ##getarg - get specified command line argument # arguments 0 -> nbrarg-1 are pointed to by ptr(1) -> ptr(nbrarg) # argument 0 is the name by which the function was invoked integer function getarg (n, array, maxsiz) character array(ARB) integer n, maxsiz include carg if (n >= nbrarg) #no argument n { array(1) = EOS getarg = EOF return } index = ptr(n+1) for (i=1; i < maxsiz; i=i+1) { array(i) = arg(index) if (arg(index) == EOS) break index = index + 1 } getarg = i-1 array(i) = EOS return end #-h- insub 245 asc 06-may-80 16:04:31 ## insub - determine if argument is STDIN substitution integer function insub (arg, file) character arg(ARB), file(ARB) if (arg(1) == LESS & arg(2) .ne. EOS) { insub = YES call scopy (arg, 2, file, 1) } else insub = NO return end #-h- outsub 444 asc 12-jun-80 09:15:17 ## outsub - determine if argument is output file substitution integer function outsub(c, arg, file, access) character arg(ARB), file(ARB), c integer access, i outsub = NO if (arg(1) == c) if (arg(2) == c) { if (arg(3) != EOS) { access = APPEND outsub = YES i = 3 } } else if (arg(2) != EOS) { outsub = YES access = WRITE i = 2 } if (outsub == YES) call scopy(arg, i, file, 1) return end #-h- delarg 327 asc 20-aug-80 08:36:29 ## delarg - delete reference to specified command line argument # see comments in getarg for how the arguments are stored subroutine delarg (n) integer n, i include carg if (n < nbrarg) # check for valid argument { for (i=n+1; i < nbrarg; i=i+1) ptr(i) = ptr(i+1) nbrarg = nbrarg - 1 } return end #-h- remark 229 asc 06-may-80 16:04:36 ##remark - print message; assure NEWLINE subroutine remark (line) character line(ARB) for (i=1; line(i) .ne. EOS; i=i+1) call putch (line(i), ERROUT) if (line(i-1) .ne. NEWLINE) call putch (NEWLINE, ERROUT) return end #-h- cre8at 1486 asc 06-may-80 16:04:37 ## cre8at -- creates file attached to lun=int define(CHARTYPE,0) define(BINTYPE,1) define(CCNONE,0) define(CCFORT,1) define(CCLIST,2) define(OLDAGE,-1) define(UNKAGE,0) define(NEWAGE,1) integer function cre8at(name,access,int) integer dsc(6) integer access, int, status, openf integer tty character name(ARB), ext(FILENAMESIZE) include io call mklocl(name, ext) call upper(ext) # convert file name to upper case call dscbld(dsc, ext) # build data-set descriptor for openf if (access == READ) status = openf(int, dsc, CHARTYPE, CCLIST, READ, OLDAGE, fdb(int)) else if (access == WRITE | access == READWRITE) status = openf(int, dsc, CHARTYPE, CCLIST, access, UNKAGE, fdb(int)) else if (access == APPEND) status = openf(int, dsc, CHARTYPE, CCLIST, APPEND, UNKAGE, fdb(int)) else if (access == NEWREAD) status = openf(int, dsc, CHARTYPE, CCLIST, READWRITE, NEWAGE, fdb(int)) else if (access == PRINT) status = openf(int, dsc, CHARTYPE, CCFORT, WRITE, UNKAGE, fdb(int)) else status = ERR if (status == ERR) cre8at = ERR else { if (status == CHARTYPE) filetp(int) = ASCII else filetp(int) = BINARY lastc(int) = 0 if (access == READ) mode(int) = INPUTMODE else mode(int) = OUTPUTMODE if (tty(int) == YES) lfn(int) = TERMINAL else lfn(int) = OPENED chtype(int) = COOKED call scopy(ext,1,filenm(1,int),1) # variables cre8at = int } return end #-h- close 351 asc 06-may-80 16:04:39 #---------------------------------------------------------------------- ## close -- close file subroutine close(int) integer int include io if (lfn(int) != CLOSED) { if (mode(int) == OUTPUTMODE & lastc(int) > 0) call putch(NEWLINE, int) # flush last line call closef(fdb(int)) lfn(int) = CLOSED } return end #-h- endr4 174 asc 18-jun-80 16:49:20 #---------------------------------------------------------------------- ## endr4 -- close all files and terminate rat4 program % subroutine endr4 % call r4exit(OK) end #-h- assign 380 asc 06-may-80 16:04:42 #------------------------------------------------------------------- ## assign - associate file name with specific internal specifier integer function assign (ext, int, access) character ext(ARB) integer int, access, cre8at include io assign = ERR if (int > 0 & int <= NNFILES) { call close(int) assign = cre8at(ext, access, int) } return end #-h- open 339 asc 06-may-80 16:04:43 #------------------------------------------------------------ ##open - associate filename with internal specifier; attach file integer function open (ext, access) integer access, int, cre8at, nxtlun character ext(ARB) include io if (nxtlun(int) == ERR) open = ERR else open = cre8at(ext, access, int) return end #-h- create 441 asc 06-may-80 16:04:44 #---------------------------------------------------------------- ## create - associate filename with internal specifier; create file integer function create(ext, access) character ext(ARB) integer access, int integer newacc integer cre8at, nxtlun include io if (nxtlun(int) == ERR) create = ERR else { if (access == READ) newacc = NEWREAD else newacc = access create = cre8at(ext, newacc, int) } return end #-h- tty 193 asc 08-may-80 11:35:51 integer function tty(int) integer int integer maskit include csclun call getlun(int, lundat) if (maskit(INTEGERMASK, 4, lundat(3)) != 0) tty = YES else tty = NO return end #-h- markl 251 asc 06-may-80 16:04:47 #---------------------------------------------------------------- ## markl - get file address for next line subroutine markl (int, addr) integer int integer addr(2), dum include io call mark (fdb(int), dum, addr(1), addr(2)) return end #-h- seek 194 asc 06-may-80 16:04:48 ## seek - position file at record 'offset' /*/sor/edr/seek subroutine seek(offset,int) integer offset(2), int include io call point (fdb(int), 0, offset(1), offset(2)) return end #-h- nxtlun 344 asc 19-jun-80 16:43:23 #---------------------------------------------------------------- ## integer function nxtlun -- finds next free logical unit integer function nxtlun(free) integer free include io for (free=1; free<=NNFILES; free=free+1) if (lfn(free) == CLOSED) break if (free > NNFILES) free = ERR nxtlun = free return end #-h- amove 519 asc 06-may-80 16:04:50 #------------------------------------------------------------- ## subroutine amove -- rename files subroutine amove(name1, name2) character name1(FILENAMESIZE), name2(FILENAMESIZE) integer open, old, new, create, rename include io old = open(name1, READ) if (old == ERR) call cant(name1) else { new = create(name2, WRITE) if (new == ERR) call cant(name2) else { call fcopy(old, new) call close(old) call close(new) call remove(name1) } } return end #-h- makarg 654 asc 19-jun-80 10:01:32 ## makarg - get command line arguments subroutine makarg include carg integer iend, index, getmsg, tog iend = getmsg(arg) nbrarg = 0 index = 1 for (i=1; i<=MAXARGS; i=i+1) { if (index <= iend) call skipbl (arg, index) if (index > iend) break ptr(i) = index if (arg(index) == SQUOTE .or. arg(index) == DQUOTE) { ptr(i) = index+1 tog = arg(index) for (index=index+1; arg(index) .ne. tog & arg(index) .ne. EOS; index=index+1) ; } else { while (arg(index) .ne. BLANK & arg(index) .ne. EOS) index = index + 1 } arg(index) = EOS index = index + 1 } nbrarg = i -1 return end #-h- gettyp 177 asc 06-may-80 16:04:53 ## gettyp - retrieve type of file (ASCII or BINARY) integer function gettyp (int, type) integer int, type include io type = filetp(int) gettyp = type return end #-h- initr4 1719 asc 17-oct-80 17:27:42 ## initr4 - initialize variables for software tools programs subroutine initr4 integer getarg, cre8at, insub, outsub, i, ioatt integer outacc,erracc, newast, oldast, itoc include carg include cspawn include io external extast string ttys "TI:" data outacc /WRITE/ data erracc /WRITE/ % data ioatt/"1400/ % #initialize /args/ common block nbrarg = 0 # initialize termination routines call getadr(newast, extast) call srda(newast, oldast) # establish kill handler iffore = NO ifback = NO call gettsk(filenm(1,1), i) # get task name call r50asc(6, filenm(1,1), tasknm) i = itoc(filenm(13,1), priost, 5) tasknm(PIDSIZE) = EOS # initialize /io/ common block variables for (i=1; i<=NNFILES; i=i+1) lfn(i) = CLOSED call asnlun(TTYUNIT, "TI", 0) call wtqio(ioatt, TTYUNIT) # attach terminal # set up list of command arguments call makarg #pick up file substitutions for standard files # initialize default files for standard input, output, and errout call scopy(ttys, 1, filenm(1, STDIN), 1) call scopy(ttys, 1, filenm(1, STDOUT), 1) call scopy(ttys, 1, filenm(1, ERROUT), 1) for (i=1; getarg(i, buffer(1,NNFILES), FILENAMESIZE) .ne. EOF; ) { if ( (insub(buffer(1,NNFILES),filenm(1,STDIN)) == YES) | (outsub(GREATER, buffer(1,NNFILES),filenm(1,STDOUT), outacc) == YES) | (outsub(QMARK, buffer(1,NNFILES), filenm(1,ERROUT), erracc) == YES) ) call delarg (i) else i = i + 1 } #open files if (cre8at(filenm(1,ERROUT), erracc, ERROUT) == ERR) call endr4 if (cre8at(filenm(1,STDIN), READ, STDIN) == ERR) call cant(filenm(1, STDIN)) if (cre8at(filenm(1,STDOUT), outacc, STDOUT) == ERR) call cant(filenm(1, STDOUT)) return end #-h- remove 409 asc 06-may-80 16:04:57 #---------------------------------------------------------- ## remove -- removes file named buf subroutine remove(buf) character buf(FILENAMESIZE) integer int, open, fdel include io int = open(buf, READ) if (int .ne. ERR) { if (fdel(fdb(int)) < 0) { call putlin(buf, ERROUT) call remark(' not deleted--privilege violation') } call close(int) } return end #-h- prompt 301 asc 06-may-80 16:04:58 integer function prompt(pstr, buf, int) integer int, n, tty, getlin, length character pstr(ARB), buf(ARB), crlf(2) data crlf/13, 10/ n = length(pstr) if (tty(int) == YES & n > 0) { call rputch(crlf, 2, int) call rputch(pstr, n, int) } prompt = getlin(buf, int) return end #-h- gtime 126 asc 06-may-80 16:04:59 # turn gtime call around to time subroutine gtime(ibuf) character ibuf(ARB) call time(ibuf) ibuf(9) = EOS return end #-h- gdate 127 asc 06-may-80 16:05:00 # turn gdate call around to date subroutine gdate(ibuf) character ibuf(ARB) call date(ibuf) ibuf(10) = EOS return end #-h- ctoo 686 asc 06-may-80 16:05:02 ## ctoo - convert string at in(i) to integer, increment i integer function ctoo(in, i) character in(ARB) integer index integer d, i # string digits "01234567" character digits(9) 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) /EOS/ while (in(i) == BLANK | in(i) == TAB) i = i + 1 for (ctoo = 0; in(i) != EOS; i = i + 1) { d = index(digits, in(i)) if (d == 0) # non-digit break ctoo = 8 * ctoo + d - 1 } return end #-h- oldmak 766 asc 21-aug-80 07:58:34 integer function oldmak(arg) integer iend, prompt, int, open, gotit character arg(ARB) string star "* " data gotit /NO/ if (gotit == YES) { call scopy(star, 1, arg, 1) iend = 2 } else { gotit = YES call getmcr(arg, iend) # get MCR command line, if available if (iend <= 0) # no MCR command line available { call scopy(star, 1, arg, 1) # copy dummy invocation name int = open("TI:", READWRITE) iend = prompt(star, arg(3), int) # read from unit int call close(int) if (iend == EOF) iend = 2 else iend = iend + 1 # point at last good character } } arg(iend+1) = EOS oldmak = iend return end #-h- otoc 851 asc 18-jun-80 17:30:27 # integer function otoc(int, str, size) # integer mod # integer d, i, int, intval, j, k, size # character str(size) # # string digits "01234567" # character digits(9) # 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) /EOS/ # # intval = abs(int) # str(1) = EOS # i = 1 # repeat { # generate digits # i = i + 1 # d = mod(intval, 8) # str(i) = digits(d+1) # intval = intval / 8 # } until (intval == 0 | i >= size) # otoc = 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- otoczf 257 asc 06-may-80 16:05:07 integer function otoczf(n, w, buf, size) character buf(ARB) integer n, w, size, m, otoc, i, length include cfmtbf m = w - otoc(n, temp, 20) for (i=1; i <= m; i=i+1) buf(i) = DIG0 call scopy(temp, 1, buf, i) otoczf = length(buf) return end #-h- rawmod 214 asc 06-may-80 16:05:08 integer function rawmod(unit, type) integer unit, type integer tty include io if (tty(unit) == YES & type == RAW) chtype(unit) = RAW else chtype(unit) = COOKED rawmod = chtype(unit) return end #-h- rgetch 285 asc 08-may-80 11:35:55 character function rgetch(c, lun) character c character maskit integer lun, func include crawtt % data func /"1030/ % call getadr(param, c) param(2) = 1 param(3) = 0 call wtqio(func, lun, 1,, iosb, param, ids) c = maskit(CHARACTERMASK, 127, c) rgetch = c return end #-h- rputch 221 asc 06-may-80 16:05:11 subroutine rputch(c, n, lun) character c(ARB) integer n, lun, func include crawtt % data func/"410/ % call getadr(param, c) param(2) = n param(3) = 0 call wtqio(func, lun, 1,, iosb, param, ids) return end #-h- r4exit 698 asc 19-jun-80 10:01:46 subroutine r4exit(status) integer junk, status, iokil, int integer kill include io include cspawn string kildir " killed." % data iokil/"12/ % if (iffore == YES) { junk = kill(forepc) call waitfr(efn, junk) } for (int = 1; int <= NNFILES; int = int + 1) call close(int) kildir(1) = 13 kildir(2) = 10 if (status == ERR) { call wtqio(TTYUNIT, iokil) n = 3 call stcopy(tasknm, 1, kildir, n) for ( ; n <= 9; n=n+1) kildir(n) = BLANK call rputch(kildir, 16, TTYUNIT) } # if (tasknm(1) == PERIOD & tasknm(2) == BIGS & tasknm(3) == BIGH) # { # kildir(3) = GREATER # call rputch(kildir, 3, TTYUNIT) # } call exit end #-h- extast 44 asc 06-may-80 16:05:14 subroutine extast call r4exit(ERR) end #-h- dscbld 475 asc 06-may-80 16:05:15 subroutine dscbld(dsc, filesp) integer dsc(6), start, stop integer index, length character filesp(FILENAMESIZE) start = 1 stop = start + index(filesp(start), COLON) dsc(1) = stop - start call getadr(dsc(2), filesp(start)) start = stop stop = start + index(filesp(start), RBRACK) dsc(3) = stop - start call getadr(dsc(4), filesp(start)) start = stop stop = start + length(filesp(start)) dsc(5) = stop - start call getadr(dsc(6), filesp(start)) return end #-h- getpnm 114 asc 06-may-80 16:05:16 subroutine getpnm(pname) character pname(ARB) include cspawn call scopy(tasknm, 1, pname, 1) return end #-h- getfdb 149 asc 06-may-80 16:05:17 integer function getfdb(int) integer int include io if (int >= 1 & int <= NNFILES) getfdb = fdb(int) else getfdb = ERR return end #-h- main 41 asc 09-may-80 09:40:33 call initr4 call main call endr4 end #-h- loccom 1002 asc 09-may-80 23:48:20 ## loccom - find command according to search path integer function loccom(comand, spath, path) character comand(ARB), spath(ARB), path(ARB), temp(FILENAMESIZE) integer i, n, int integer length, open, gettyp string scrext "" # extension for shell scripts string imgext ".tsk" # extension for image files #----- 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 call scopy(scrext, 1, temp, n) int = open(temp, READ) if (int != ERR) break call scopy(imgext, 1, temp, n) int = open(temp, READ) if (int != ERR) break } if (int != ERR) { loccom = gettyp(int, loccom) call close(int) call mklocl(temp, path) } else { loccom = ERR call scopy(comand, 1, path, 1) } return end #-h- scratf 729 asc 12-oct-80 16:25:10 ## 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) integer i, j, ctype, type, length call getpnm(temp) # get process name call upper(temp) # make sure it is upper case call getdir(TMPDIRECTORY, LOCAL, name) j = length(name) + 1 for (i=1; temp(i) != EOS; i=i+1) { ctype = type(temp(i)) if (ctype == DIGIT | ctype == LETTER) { name(j) = temp(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- argfil 366 asc 12-oct-80 16:25:11 subroutine argfil(pid, file) character pid(PIDSIZE), file(FILENAMESIZE) integer i, j, ctype, type, length call getdir(TMPDIRECTORY, LOCAL, file) j = length(file) + 1 for (i=1; pid(i) != EOS; i=i+1) { ctype = type(pid(i)) if (ctype == DIGIT | ctype == LETTER) { file(j) = pid(i) j = j + 1 } } call scopy(".ARG", 1, file, j) return end #-h- mailid 747 asc 12-oct-80 16:27:15 subroutine mailid(sender, mdirec) character sender(ARB), mdirec(ARB), loguic(20), uic(12), x, buf(MAXLINE) integer ids, i, grp, mem, int, open, getlin, junk, getwrd, equal, j, found equivalence (x, ids) call gettsk(buf, ids) x = buf(32) grp = ids x = buf(31) mem = ids call fmtuic(grp, mem, loguic) found = NO call adrfil(buf) int = open(buf, READ) if (int != ERR) { while (getlin(buf, int) != EOF) { i = 1 junk = getwrd(buf, i, sender) junk = getwrd(buf, i, mdirec) junk = getwrd(buf, i, uic) if (equal(uic, loguic) == YES) { found = YES break } } call close(int) } if (found == NO) { call scopy(loguic, 1, sender, 1) mdirec(1) = EOS } call fold(sender) return end #-h- fmtuic 272 asc 12-oct-80 16:27:17 subroutine fmtuic(group, member, buf) integer group, member, i, otoczf character buf(ARB) buf(1) = LBRACK i = 2 i = i + otoczf(group, 3, buf(i), ARB) buf(i) = COMMA i = i + 1 i = i + otoczf(member, 3, buf(i), ARB) buf(i) = RBRACK buf(i+1) = EOS return end #-h- osprimr.bld 68 asc 17-oct-80 17:36:50 pip osprim.obj@;*/de/nm rat4 osprim.r >osprim.f f4p osprim=osprim.f #-h- lib.r 17226 asc 30-oct-80 12:05:03 #-h- defns 386 asc 10-jun-80 16:57:55 ##################################################################### # # General purpose library routines # ##################################################################### #--------------------------------------------------------------------- # include symbol definitions # include symbols #--------------------------------------------------------------------- #-h- acopy 264 asc 10-jun-80 16:57:56 ## 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 10-jun-80 16:57:58 ## 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 12-oct-80 16:30:03 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 10-jun-80 16:57:59 ## 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- bubble 406 asc 10-jun-80 16:58:00 ## 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 456 asc 10-jun-80 16:58:01 ## 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 endr4 end #-h- chcopy 128 asc 18-jun-80 15:25:50 # 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 19-jun-80 10:21:48 # ## 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 18-jun-80 15:25:52 # 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- ctoi 744 asc 10-jun-80 16:58:06 ## ctoi - convert string at in(i) to integer, increment i integer function ctoi(in, i) character in(ARB) integer index integer d, i # 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 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 end #-h- cupper 374 asc 19-jun-80 10:21:51 # ## 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- equal 326 asc 10-jun-80 16:58:08 ## 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 137 asc 10-jun-80 16:58:09 ## error - print message and terminate execution subroutine error (line) character line(ARB) call remark (line) call endr4 end #-h- fcopy 182 asc 10-jun-80 16:58:10 ## 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- fold 203 asc 18-jun-80 15:25:56 # ## 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 10-jun-80 16:58:12 ## 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 10-jun-80 16:58:13 ## 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 133 asc 10-jun-80 16:58:14 ## getc - get character from STDIN character function getc(c) character c character getch getc = getch(c, STDIN) return end #-h- getwrd 415 asc 10-jun-80 16:58:15 ## 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- impath 407 asc 12-oct-80 16:30:06 ## impath - generate search path for standard images to be spawned subroutine impath(path) character path(ARB) integer i integer length i = 1 call getdir(USRDIRECTORY, LOCAL, path(i)) # search usr first i = i + length(path(i)) + 1 call getdir(BINDIRECTORY, LOCAL, path(i)) # search bin second i = i + length(path(i)) + 1 path(i) = NEWLINE # end of search path path(i+1) = EOS return end #-h- index 255 asc 18-jun-80 15:25:59 # ## 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 10-jun-80 16:58:17 ## 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 18-jun-80 15:26:01 # ## 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 110 asc 10-jun-80 16:58:20 ## putc - put character onto STDOUT subroutine putc (c) character c call putch (c, STDOUT) return end #-h- putdec 374 asc 10-jun-80 16:58:21 ## putdec - put decimal integer n in field width >= w subroutine putdec(n,w) character chars(MAXLINE) integer itoc integer i,n,nd,w nd = itoc(n,chars,MAXLINE) 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- scopy 303 asc 18-jun-80 15:26:03 # ## 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 10-jun-80 16:58:23 ## 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 10-jun-80 16:58:25 ## 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 18-jun-80 15:26:06 ### 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- type 2059 asc 10-jun-80 16:58:27 ## 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 18-jun-80 15:26:09 # ## 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- gtftok 318 asc 02-oct-80 09:02:35 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- exppth 264 asc 02-oct-80 09:02:36 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- putint 270 asc 06-oct-80 11:02:49 ## 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- putstr 368 asc 06-oct-80 11:02:50 ## 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- strcmp 464 asc 06-oct-80 11:02:53 ## 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- badarg 131 asc 17-oct-80 09:03:27 subroutine badarg(arg) character arg(ARB) call putlin(arg, ERROUT) call remark(": ignoring invalid argument.") return end #-h- inpack 191 asc 30-oct-80 11:55:59 ## 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 30-oct-80 11:56:00 ## 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 30-oct-80 11:56:00 ## 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- usage 131 asc 30-oct-80 11:56:01 subroutine usage(buf) character buf(ARB) string use "usage: " call putlin(use, ERROUT) call remark(buf) call endr4 end #-h- lib.bld 53 asc 17-oct-80 17:37:09 pip lib.obj@;*/de/nm rat4 lib.r >lib.f f4p lib=lib.f #-h- spawn.r 6937 asc 17-oct-80 17:37:13 #-h- spawn.q 1324 asc 17-oct-80 17:31:58 include ossym include spsym integer function spawn(image, args, pid, wait) character image(FILENAMESIZE), args(ARGBUFSIZE), pid(PIDSIZE), local(6), wait, mcrlin(80), filarg(FILENAMESIZE) character clower real mcr integer equal, unit, create, length, n, errsb(8), ids, bckspn include cspawn data local/LETL, LETO, LETC, LETA, LETL, EOS/ % data mcr/6RMCR.../ % if (clower(wait) == BACKGR) return(bckspn(image, args, pid)) call scopy(image, 1, mcrlin, 1) call fold(mcrlin) if (equal(mcrlin, local) == YES) call scopy(args, 1, mcrlin, 1) else { call genpnm(1, pid) call argfil(pid, filarg) unit = create(filarg, WRITE) if (unit == ERR) { spawn = ERR return } if (length(args) > 0) call putlin(args, unit) else call putch(BLANK, unit) call putch(NEWLINE, unit) call close(unit) call genrun(image, pid, priost, mcrlin) } n = length(mcrlin) efn = SPNEFN call extpnm(mcrlin, forepc) call scopy(forepc, 1, pid, 1) iffore = YES call wtqio(IO.DET, TTYUNIT) % call spawn(mcr,,, efn,, errsb,, mcrlin, n, 0,, ids) % if (ids <= 0) { iffore = NO spawn = ERR } else { call stopfr(SPNEFN, ids) iffore = NO if (errsb(1) > 1) spawn = ERR else spawn = OK } call wtqio(IO.ATT, TTYUNIT) return end #-h- genpnm.q 774 asc 16-oct-80 14:45:50 integer function genpnm(pnum, pid) character parent(PIDSIZE), pid(PIDSIZE) integer init, pnum, sperr data init/YES/ if (init == YES) { call getpnm(parent) if ((parent(1) == DOLLAR | parent(1) == PERIOD) & (parent(2) == BIGT | parent(2) == BIGB)) { if (parent(6) == TREELIMIT) sperr = YES else { sperr = NO parent(6) = parent(6) + 1 } } else { call gtty(parent) # get TTn: in parent parent(1) = DOLLAR # place $ in first character if (parent(4) == COLON) { parent(4) = parent(3) parent(3) = DIG0 } parent(5) = PERIOD parent(6) = DIG1 } parent(7) = EOS init = NO } if (sperr == YES) genpnm = ERR else { genpnm = OK call scopy(parent, 1, pid, 1) } return end #-h- genrun.q 436 asc 17-oct-80 17:32:02 subroutine genrun(image, pid, prio, line) character image(ARB), pid(ARB), line(ARB), prio(ARB) integer i string ins "ins " string task "/task=" string priost "/pri=" string run "./run=rem" i = 1 call stcopy(ins, 1, line, i) call stcopy(image, 1, line, i) call stcopy(task, 1, line, i) call stcopy(pid, 1, line, i) call stcopy(priost, 1, line, i) call stcopy(prio, 1, line, i) call scopy(run, 1, line, i) return end #-h- getmsg.q 465 asc 20-aug-80 12:00:32 integer function getmsg(buf) character buf(ARB), temp(FILENAMESIZE) integer unit, open, n, getlin, oldmak call getpnm(buf) if ((buf(1) == DOLLAR | buf(1) == PERIOD) & buf(2) != buf(1)) { call argfil(buf, temp) unit = open(temp, READ) if (unit == ERR) { buf(1) = BLANK n = 2 } else { n = getlin(buf, unit) call close(unit) call remove(temp) } buf(n) = EOS getmsg = n - 1 } else getmsg = oldmak(buf) return end #-h- gtty.q 252 asc 20-aug-80 12:00:33 subroutine gtty(tty) character tty(ARB) integer ids, otoc include csclun call getlun(TTYUNIT, lundat, ids) tty(1) = bbuf(1) tty(2) = bbuf(2) bbuf(4) = 0 ids = otoc(lundat(2), tty(3), 4) + 3 tty(ids) = COLON tty(ids+1) = EOS return end #-h- extpnm.q 935 asc 25-aug-80 08:38:26 subroutine extpnm(lin, task) character lin(ARB), task(PIDSIZE) integer j, i integer smatch, equal, length string tskequ "TASK=" string tskeql "task=" string run "RUN" j = 0 for (i=1; lin(i) != EOS; i=i+1) { j = smatch(lin, i, tskequ) if (j > 0) break j = smatch(lin, i, tskeql) if (j > 0) break } if (j > 0) { i = 1 for ( ; lin(j) != EOS & lin(j) != SLASH & i < PIDSIZE; j=j+1) { task(i) = lin(j) i = i + 1 } task(i) = EOS } 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 gtty(task(i)) if (i > 1) 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- smatch.q 240 asc 20-aug-80 12:00:35 integer function smatch(lin, from, pat) character lin(ARB), pat(ARB) integer from, i, j i = from for (j=1; pat(j) != EOS; j=j+1) { if (lin(i) != pat(j)) { smatch = 0 return } i = i + 1 } smatch = i return end #-h- kill.q 668 asc 20-aug-80 12:00:35 integer function kill(proces) character proces(PIDSIZE), buf(26) integer ids real task string dots "..." #IAS string dols "$$$" 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) #IAS if (ids < 0) #IAS { #IAS call concat(dols, proces, buf) #IAS call upper(buf) #IAS call irad50(6, buf, task) #IAS call abort(task, ids) #IAS } } } if (ids < 0) kill = ERR else kill = OK return end #-h- enbint.q 292 asc 20-aug-80 12:00:36 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- intsrv.q 152 asc 20-aug-80 12:00:37 subroutine intsrv integer junk integer kill include cspawn if (iffore == YES) { junk = kill(forepc) iffore = NO } return end #-h- bckspn.q 860 asc 17-oct-80 07:52:12 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, rcstdr string seed "bck" % data bspawn/6RBSPAWN/, newast/0/ % call scratf(seed, file) int = create(file, WRITE) if (int != ERR) { call putlin(image, int) call putch(NEWLINE, int) call putlin(args, int) call putch(NEWLINE, int) call close(int) i = index(file, RBRACK) + 1 call scopy(file, i, file, 1) call srda(newast, oldast) call send(bspawn, file,, ids) if (ids != 1) int = ERR else { if (rcstdr(bspawn, file) != 1) call receiv(bspawn, file,, ids) int = file(5) if (int == OK) call scopy(file, 6, pid, 1) else int = ERR } call crda(oldast) } return(int) end #-h- spawn.bld 63 asc 17-oct-80 17:37:21 pip spawn.obj@;*/nm/de rat4 spawn.r >spawn.f f4p spawn=spawn.f #-h- osprim.m 15710 asc 17-oct-80 17:37:28 #-h- closef.mac 494 asc 19-jun-80 17:03:23 .title closef ; ; subroutine to close file opened by tools openf ; ; call sequence (from fortran) ; call closef(fdb) ; where fdb is the address returned by openf when file opened ; .mcall close$ ; ; local constants ; ok=0 err=-3 ap=%5 fdb=2 ; ; start of code ; closef:: mov @fdb(ap),r0 ; FDB address in r0 close$ ; close the file bcs clserr ; if c set, error closing the file mov #ok,r0 ; return success status return clserr: mov #err,r0 ; return error status return .end #-h- ctcast.mac 313 asc 09-jun-80 21:52:41 .title ctcast .mcall astx$s .globl intsrv ctcast:: mov r0,-(sp) mov r1,-(sp) mov r2,-(sp) mov r3,-(sp) mov r4,-(sp) mov r5,-(sp) call intsrv ; call users interrupt service routine mov (sp)+,r5 mov (sp)+,r4 mov (sp)+,r3 mov (sp)+,r2 mov (sp)+,r1 mov (sp)+,r0 astx$s ; dismiss interrupt .end #-h- f11hdr.mac 872 asc 19-jun-80 15:11:45 .title f11hdr .mcall fdof$l,nbof$l,ofnb$,close$,fdop$r fdof$l nbof$l ap=%5 lun=2 dev=4 unt=6 fsw=10 fid=12 dsc=14 buf=16 ok=0 err=-3 rattbk: .word 0,attctl,0,0,0,0 attctl: .byte -9.,10. .word stblk .byte -10.,0 buffer: .word 0 .word 0 stblk: .blkw 5 f11hdr:: mov @lun(ap),r2 ; place lun in r2 for gtfdb call gtfdb tst r0 bne 5$ jmp 10$ 5$: fdop$r r0,@lun(ap) mov #stblk,f.stbk(r0) mov r0,r1 add #f.fnb,r1 tst @fsw(ap) ; see if should use fid beq 20$ mov fid(ap),r2 mov r1,r3 add #n.fid,r3 mov r3,rattbk mov (r2)+,(r3)+ mov (r2)+,(r3)+ mov (r2),(r3) mov @dev(ap),n.dvnm(r1) mov @unt(ap),n.unit(r1) br 30$ 20$: mov dsc(ap),r2 clr r3 call .parse bcs 10$ 30$: ofnb$ r0,#fo.rd!fa.shr,,,,#fd.rwm bcs 10$ mov buf(ap),buffer mov #io.rat,r1 mov #3,r2 mov #rattbk,r3 call .xqio close$ r0 mov #ok,r0 return 10$: mov #err,r0 return .end #-h- fdel.mac 366 asc 19-jun-80 15:26:31 .title fdel .globl .dlfnb .mcall fdof$l fdof$l ; define fdb offsets locally fdb=2 ap=%5 fdel:: ; entry point mov @fdb(ap),r0 ; FDB address in r0 call .dlfnb ; delete file bcs 10$ ; c set => error clr r0 ; return 0 as value of function upon success return 10$: mov f.err(r0),r0 ; put error code in r0 swab r0 ; make it negative return .end #-h- gets.mac 400 asc 09-jun-80 21:52:46 .title gets .mcall fdof$l,get$ fdof$l ; define fdb offsets locally fdb=2 buf=4 siz=6 ap=%5 gets:: ; entry point mov @fdb(ap),r0 ; FDB address in r0 get$ ,buf(ap),@siz(ap) ; get the record bcs 10$ ; c set => error mov f.nrbd(r0),r0 ; return with byte count in r0 return 10$: mov f.err(r0),r0 ; return with error code in r0 swab r0 ; swap bytes so word is negative return .end #-h- gtddir.mac 404 asc 09-jun-80 21:52:46 .title gtddir .globl gtddir, .rdfui, .ppasc ; ; implements the following fortran subroutine call ; ; call gtddir(dir) ; gtddir:: call .rdfui ; get default uic (binary) into r1 mov r1,r3 ; need it in r3 for .ppasc mov 2(r5),r2 ; address of dir in r2 mov #1,r4 ; desire separators and leading zeroes call .ppasc ; convert to [ggg,mmm] clrb (r2) ; r2 points to EOS location return .end #-h- mark.mac 240 asc 09-jun-80 21:52:48 .TITLE MARK .GLOBL .MARK MARK:: ; ENTRY POINT TST (R5)+ ; BUMP POINTER MOV @(R5)+,R0 ; FDB ADDRESS IN R0 CALL .MARK MOV R1,@(R5)+ ; STORE LBLOCK MOV R2,@(R5)+ ; STORE HBLOCK MOV R3,@(R5) ; STORE BYTE OFFSET RETURN .END #-h- maskit.mac 683 asc 09-jun-80 21:52:49 .title maskit ; ; integer*2 function maskit(type, mask, value) ; logical*1 function maskit(type, mask, value) ; ; performs an and function of mask on value and returns ; it as a 16-bit integer. type indicates the type of operands, ; with 0 indicating bytes or 1 indicating words ; ; ap=%5 ; argument pointer type=2 mask=4 value=6 maskit:: tst @type(ap) ; see if byte or word bne doword ; != 0 => words dobyte: movb @mask(ap),r1 ; place mask in r1 movb @value(ap),r0 ; place value to mask in r0 br domask doword: mov @mask(ap),r1 mov @value(ap),r0 domask: com r1 ; complement mask word bic r1,r0 ; clear all bits in r0 which are set ; in r1 return .end #-h- openf.mac 2313 asc 19-jun-80 16:44:10 .title openf .list meb ; ; ; routine to open software tools files ; ; call sequence ; status = openf(lun, dsc, typ, cc, acc, age, fdb) ; ; where: ; lun logical unit to use for file ; dsc data set descriptor for file ; typ type of file (0=character, 1=binary) ; this field is currently ignored ; cc carriage control (0=none, 1=fortran, 2=list) ; acc type of access desired ; (1=read, 2=write, 3=readwrite, 4=append) ; age age of file (-1=old, 0=unknown, 1=new) ; fdb variable to return FDB address to upon ; successful open. this address is then ; used in all other ST io primitives ; .mcall fdat$r, fdof$l, fdop$r, open$, fcsbt$, nmblk$ fdof$l fcsbt$ .globl gtfdb ; ; local constants ; ap=%5 ; argument pointer lun=2 ; offset from ap for lun info dsc=4 typ=6 cc=10 acc=12 age=14 fdb=16 read=1 ; value of READ write=2 readwr=3 append=4 err=-3 ; value of ERR charac=0 binary=1 ; ; local storage ; dfnb: nmblk$ ,,0,SY,0 ; ; start of code ; .enabl lsb openf:: mov @lun(ap),r2 ; place lun in r2 for gtfdb call gtfdb ; get a free FDB tst r0 bne 10$ ; if != 0, were successful jmp 50$ ; no more FDB's 10$: fdat$r ,#r.var,@cc(ap) ; only support sequential files fdop$r ,@lun(ap),dsc(ap),#dfnb,,#fa.enb!fa.dlk ; user lun, data-set ; descriptor and default FNB cmp #read,@acc(ap) ; see if opening at read access bne 20$ open$ ,#fo.rd!fa.shr ; open existing file at read access ; permit file to be shared bcc openok ; c clear => success jmp operr 20$: cmp #append,@acc(ap) ; see if opening at append access bne 30$ open$ ,#fo.apd bcs create ; error, go create new file br openok 30$: tst @age(ap) ; see what kind of open to do bgt create ; if > 0, then wants new file open$ ,#fo.upd ; try to open existing file bcc openok create: open$ ,#fo.wrt ; open new file at write access bcs operr openok: mov r0,@fdb(ap) ; return FDB address to user tstb f.ratt(r0) ; does file have record attributes? beq notch ; if not, then not character file cmpb f.rtyp(r0),#r.var ; is it variable length records? bne notch ; if not, then not character file mov #charac, r0 ; return character file as value return notch: mov #binary, r0 ; return binary file return operr: 50$: mov #err,r0 ; return error status return .end #-h- point.mac 276 asc 09-jun-80 21:52:52 .TITLE POINT .GLOBL .POINT POINT:: ; ENTRY POINT TST (R5)+ ; BUMP POINTER MOV @(R5)+,R0 ; FDB ADDRESS IN R0 MOV @(R5)+,R1 ; LOW ORDER BLOCK NUMBER IN R1 MOV @(R5)+,R2 ; HIGH ORDER BLOCK NUMBR IN R2 MOV @(R5),R3 ; BYTE OFFSET IN R3 CALL .POINT RETURN .END #-h- puts.mac 173 asc 09-jun-80 21:52:53 .title puts .mcall fdof$l,put$ fdof$l ; define fdb offsets locally fdb=2 buf=4 cnt=6 ap=%5 puts:: ; entry point put$ @fdb(ap),buf(ap),@cnt(ap) return .end #-h- qfile.mac 726 asc 09-jun-80 21:52:54 .TITLE QFILE .MCALL PRINT$ QFILE:: ; ENTRY POINT TST (R5)+ ; BUMP PARAMETER POINTER MOV @(R5)+,R0 ; PUT FDB ADDRESS IN R0 MOV #DISPAT,R1 ; PUT ADDRESS OF DISPATCH TABLE IN R1 MOV @(R5),R2 ; PUT FORMS QUEUE IN R2 ROL R2 ; MULTIPLY BY 2 ADD R2,R1 ; ADD OFFSET TO DISPATCH TABLE JMP @(R1) ; JUMP THROUGH DISPATCH TABLE DISPAT: .WORD QUEUE0 ; FORMS 0 QUEUE .WORD QUEUE1 ; FORMS 1 QUEUE .WORD QUEUEN ; AVAILABLE FOR EXPANSION .WORD QUEUEN .WORD QUEUEN .WORD QUEUEN .WORD QUEUE6 QUEUE0: PRINT$ ,,,,,,0,1, ; SPOOL FILE TO FORMS 0 QUEUE RETURN QUEUE1: PRINT$ ,,,,,,1,1, ; SPOOL FILE TO FORMS 1 QUEUE RETURN QUEUEN: RETURN QUEUE6: PRINT$ ,,,,,,6,1, ; spool file to forms 6 queue RETURN .END #-h- rcstdr.mac 559 asc 09-jun-80 21:52:55 .title rcstdr ; ; this routine interfaces a fortran program to the rcst$x system ; call with the following interface ; ; ids = rcstdr([task], buffer) ; .mcall rcst$s ap=%5 tsk=2 buf=4 dumtsk: .word 0,0 ; dummy task name to use if user omits it rcstdr:: mov tsk(ap),r0 ; move address of task field into r0 cmp #-1,r0 ; see if user left it blank bne 10$ ; if !=, then user supplied task name mov #dumtsk,r0 ; place null task name address into r0 10$: rcst$s r0,buf(ap) ; receive data or stop mov $dsw,r0 ; return directive status word return .end #-h- rename.mac 529 asc 09-jun-80 21:52:56 .TITLE RENAME .GLOBL .RENAM .MCALL FDOF$L FDOF$L ; DEFINE FDB OFFSETS LOCALLY RENAME:: ; entry point TST (R5)+ ; bump pointer MOV @(R5)+,R0 ; old fdb in R0 MOV @(R5),R1 ; new fdb in R1 MOV R0,-(SP) ; SAVE OLD FDB ADDRESS CALL .RENAM ; rename file MOV (SP)+,R0 ; RESTORE FDB ADDRESS TSTB F.ERR(R0) ; branch on error in rename BMI 10$ ; CLR R0 ; RETURN 0 AS VALUE OF FUNCTION UPON SUCCESS RETURN 10$: MOV F.ERR(R0),R0 ; MOVE ERROR CODE INTO R0 SWAB R0 ; MAKE VALUE OF FUNCTION NEGATIVE RETURN .END #-h- rxmrkt.mac 198 asc 09-jun-80 21:52:57 .title rxmrkt .mcall mrkt$, dir$ dpb: mrkt$ 1.,5.,2. rxmrkt:: mov #dpb,r0 tst (r5)+ mov @(r5)+,m.ktef(r0) mov @(r5)+,m.ktmg(r0) mov @(r5)+,m.ktun(r0) dir$ #dpb mov $dsw,@(r5) return .end #-h- srda.mac 953 asc 09-jun-80 21:52:58 .title srda .globl srda, crda .mcall gtsk$s, srda$s, ustp$s, astx$s ap=r5 ; arguement pointer new=2 ; offset from ap for new ast address old=4 ; same for old buf: .blkb 32. astcnt: .word 0 curast: .word 0 srda:: tst astcnt ; see if done ast yet bne 10$ ; yes we have gtsk$s #buf ; get current task name in buf mov #1,astcnt ; non-zero value implies initialization done 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 #buf ; unstop current task astx$s ; dismiss current ast .end #-h- stddir.mac 841 asc 09-jun-80 21:53:00 .title stddir .globl stddir, .ascpp, .wdfui, .wdfdr ; ; implements the following fortran subroutine call ; ; call stddir(dsc) ; ; where dsc is a descriptor pointing to the directory string ; defdir: .blkb 10. defuic: .blkw 1 ; word to hold binary value of uic stddir:: mov 2(r5),r0 ; address of descriptor in r0 mov (r0),r1 ; count in r1 mov 2(r0),r2 ; address of string in r2 mov #defdir,r3 ; destination address in r3 10$: movb (r2)+,(r3)+ ; copy byte into buffer sob r1,10$ mov (r0),r1 ; count in r1 mov #defdir,r2 ; address of string in r2 call .wdfdr ; write default directory mov 2(r5),r2 ; address of descriptor in r2 mov #defuic,r3 ; address to hold binary call .ascpp ; convert it to binary in r3 mov defuic,r1 ; binary value in r1 for .wdfui call .wdfui ; reset default uic value return .end #-h- dopen.mac 1283 asc 19-jun-80 15:26:45 .title dopen ; ; this routine implements the following fortran interface ; ; status = dopen(lun, dsc, dev, unt, fdb) ; ; where lun is the logical unit to use for this directory ; dsc is the data-set descriptor for the directory name ; dev is an integer to return the 2-char device mnemonic ; unt is an integer to return the device unit ; fdb has the fdb address returned in it for successful open ; ; status = OK if directory exists ; ERR if it does not exist ; .mcall fdop$r, fdof$l, nbof$l fdof$l nbof$l ap=%5 lun=2 dsc=4 dev=6 unt=10 fdb=12 ok=0 err=-3 dopen:: mov @lun(ap),r2 ; place lun in r2 for gtfdb call gtfdb ; get an fdb from the linked list tst r0 ; see if got one beq operr ; if == 0, no more left 10$: fdop$r ,@lun(ap) ; assign lun to this fdb mov r0,r1 ; fdb address in r1 add #f.fnb,r1 ; fnb address in r1 mov dsc(ap),r2 ; data-set descriptor address in r2 clr r3 ; no default name block call .parse ; parse the file name bcs retfdb ; if c set, then directory does not exist mov r0,@fdb(ap) ; return fdb address for future use mov n.dvnm(r1),@dev(ap) ; return the device-name mov n.unit(r1),@unt(ap) ; return the device-unit mov #ok,r0 ; return value of OK return retfdb: operr: mov #err,r0 ; return value of ERR return .end #-h- dfind.mac 1287 asc 10-jun-80 12:36:06 .title dfind ; ; this routine implements the following fortran interface ; ; status = dfind(fdb, buf, fid) ; ; where fdb is the FDB address returned by dopen ; buf is an array to hold the file name, type and version ; fid is a 3-word array to hold the file id ; ; 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 fdb=2 buf=4 fid=6 ok=0 eof=-1 dfind:: mov @fdb(ap),r0 ; FDB address in r0 mov r0,r1 ; FDB address in r1 add #f.fnb,r1 ; FNB address in r1 call .find ; find next directory entry bcs done ; if c set, no more files mov r1,r2 ; FNB address in r2 add #n.fid,r2 ; file id address in r2 mov fid(ap),r3 ; output array address in r3 mov (r2)+,(r3)+ ; copy first word mov (r2)+,(r3)+ ; copy second word mov (r2),(r3) ; copy third word mov r1,r2 ; FNB address in r2 add #n.fnam,r2 ; file name address in r2 mov buf(ap),r3 ; output array address in r3 mov (r2)+,(r3)+ ; copy first word of file name mov (r2)+,(r3)+ ; copy second word of file name mov (r2)+,(r3)+ ; copy third word of file name mov (r2)+,(r3)+ ; copy extension mov (r2),(r3) ; copy version number mov #ok,r0 ; return OK return done: mov #eof,r0 ; return EOF return .end #-h- otoc.mac 978 asc 18-jun-80 15:20:34 .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 ; ; locbuf: .blkb 8. ; local buffer to format into ; ; 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- gtfdb.mac 473 asc 19-jun-80 15:35:52 .title gtfdb d.fdb=12. ; offset from FFDB to start of FDB ; This value may have to be changed for F4P ; version 3.0 running the RMS OTS library ; ; inputs r2 lun to retrieve FDB address for ; ; outputs r0 FDB address, or 0 if invalid lun ; gtfdb:: call $fchnl ; get address of FFDB into r0 for lun in r2 bcs 10$ ; c bit set if error add #d.fdb,r0 ; add offset to have FDB address in r0 br 20$ 10$: clr r0 ; return value of 0 if error 20$: return .end #-h- cctype.mac 271 asc 26-jun-80 14:51:38 .title cctype .mcall FDOF$L FDOF$L nonctl=0 ftnctl=1 lisctl=2 cctype:: mov @2(r5),r0 bitb #ftnctl,f.ratt(r0) beq notftn mov #ftnctl,r0 br getout notftn: bitb #lisctl,f.ratt(r0) beq notlis mov #lisctl,r0 br getout notlis: mov #nonctl,r0 getout: return .end #-h- osprimm.bld 166 asc 17-oct-80 17:37:42 ar t osprim.m >mactemp ar xv osprim.m ed mactemp < # call xcopy(idate(1), 2, aux, j) call xcopy(MINUS, 1, aux, j) call xcopy(idate(3), 3, aux, j) call xcopy(MINUS, 1, aux, j) call xcopy(idate(6), 2, aux, j) call xcopy(BLANK, 1, aux, j) call xcopy(idate(8), 2, aux, j) call xcopy(COLON, 1, aux, j) call xcopy(idate(10), 2, aux, j) call xcopy(COLON, 1, aux, j) call xcopy(idate(12), 2, aux, j) call srttim(idate, date) # generate sortable date string call stcopy(" ", 1, aux, j) # # now display size of file in blocks # j = j + itocf(eof, 7, BLANK, aux(j), 8) call stcopy(" ", 1, aux, j) # # now format owner # call fmtuic(group, member, idate) call resuic(idate, idate) call scopy(idate, 1, aux, j) call fold(aux) return end #-h- decnfo.q 856 asc 12-jun-80 08:59:19 define(IDOF,1) # h.idof + 1 define(RVDT,13) # i.rvdt + 1 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 desc, fileid, 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, 13, 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- cpybyt.q 197 asc 06-may-80 16:16:11 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- xcopy.q 174 asc 06-may-80 16:16:12 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- srttim.q 871 asc 06-may-80 16:16:13 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- cwdir.q 428 asc 06-may-80 16:16:18 integer function cwdir(strng) character strng(ARB), out(FILENAMESIZE), temp(10) integer i, opendr, desc call mklocl(strng, out) if (opendr(out, desc) != ERR) # see if directory exists { call closdr(desc) i = 1 call jcopys(out, i, COLON, temp) call chddev(temp) # set default device call jcopys(out, i, RBRACK, temp) call chddir(temp) cwdir = OK } else cwdir = ERR return end #-h- mklocl.q 744 asc 13-oct-80 07:45:38 subroutine mklocl(in, out) integer i, j, type, length character in(ARB), out(ARB), temp(FILENAMESIZE) call restil(in, out) # resolve ~name stuff if (out(1) == SLASH) { j = 1 i = 1 if (type(out(2)) != DIGIT) { for (i=2; out(i) != SLASH & out(i) != EOS; i=i+1) call chcopy(out(i), temp, j) call chcopy(COLON, temp, j) } else { call gtddev(temp) j = length(temp) + 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 scopy(out, 1, temp, 1) call resdef(temp, out) return end #-h- resdef.q 612 asc 13-oct-80 10:51:54 subroutine resdef(in, out) character in(ARB), out(ARB) integer index, i, j, length i = 1 out(1) = EOS if (in(i) != EOS) { if (index(in, COLON) > 0) call jcopys(in, i, COLON, out) else call gtddev(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)) if (in(i) != EOS) { j = length(out) + 1 call scopy(in, i, out, j) } } } call fold(out) return end #-h- jcopys.q 290 asc 06-may-80 16:16:22 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- chddev.q 252 asc 06-may-80 16:16:23 subroutine chddev(dev) character dev(ARB) integer i, junk, spawn include cdrscr i = 1 call stcopy("ASN ", 1, mcrbuf, i) call stcopy(dev, 1, mcrbuf, i) call scopy("=SY0:", 1, mcrbuf, i) junk = spawn("local", mcrbuf, pid, WAIT) return end #-h- chddir.q 405 asc 06-may-80 16:16:25 subroutine chddir(dir) character dir(ARB) integer dsc(2), length, i, junk, spawn include cdrscr dsc(1) = length(dir) if (dsc(1) > 0) { call getadr(dsc(2), dir) call stddir(dsc) # reset default uic for this task i = 1 call stcopy("SET /UIC=", 1, mcrbuf, i) call scopy(dir, 1, mcrbuf, i) junk = spawn("local", mcrbuf, pid, WAIT) # do a set /uic=[,] } return end #-h- mkpath.q 564 asc 06-may-80 16:16:26 subroutine mkpath(in, out) character in(ARB), out(ARB), temp(FILENAMESIZE) integer i, j call mklocl(in, 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- resuic.q 714 asc 06-may-80 16:16:28 subroutine resuic(uic, value) character uic(ARB), value(ARB), name(FILENAMESIZE), buf(MAXLINE), defn(FILENAMESIZE) integer init, i, length, int, open, junk, getwrd, lookup, getlin data init/YES/ if (init == YES) { call adrfil(name) call tbinit # initialize instal block int = open(name, READ) if (int == ERR) call remark("cannot open user's file") else { while (getlin(buf, int) != EOF) { i = 1 junk = getwrd(buf, i, defn) junk = getwrd(buf, i, name) junk = getwrd(buf, i, name) call instal(name, defn) } call close(int) } init = NO } if (lookup(uic, value) == NO) call scopy(uic, 1, value, 1) return end #-h- itocf.q 261 asc 08-may-80 11:50:24 integer function itocf(n, w, fc, buf, size) character buf(ARB), fc integer w, size, m, itoc, i, length, n include cfmtbf 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- restil.q 1483 asc 13-oct-80 07:52:54 # resolve ~name construct in path names subroutine restil(path, out) character path(ARB), out(ARB), token(FILENAMESIZE), buf(81) integer i, junk, key, j, found, fdb, n, dsc(6) integer gtftok, equal, length, openf, gets, getwrd string bin "bin" string usr "usr" string tmp "tmp" string lpr "lpr" string mail "mail" string man "man" if (path(1) != TILDE) call scopy(path, 1, out, 1) else { 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) else { call adrfil(buf) call upper(buf) found = NO call dscbld(dsc, buf) if (openf(FREEUNIT, dsc, 0, 2, READ, -1, fdb) != ERR) { for (n=gets(fdb, buf, 80); n >= 0; n=gets(fdb, buf, 80)) { buf(n+1) = EOS j = 1 junk = getwrd(buf, j, out) if (equal(out, token) == YES) { junk = getwrd(buf, j, token) found = YES break } } call closef(fdb) } if (found == NO) token(1) = EOS } j = 1 call stcopy(token, 1, out, j) if (path(i) == SLASH) i = i + 1 call scopy(path, i, out, j) } return end #-h- dnoise.q 305 asc 13-oct-80 10:51:57 # 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- noise.q 254 asc 13-oct-80 10:51:58 # subroutine to restore white noise to filename subroutine noise(file) character file(ARB) integer index if (index(file, PERIOD) == 0) call concat(file, ".", file) if (index(file, SEMICOL) == 0) call concat(file, ";1", file) return end #-h- dirprim.bld 73 asc 17-oct-80 17:38:08 pip dirprim.obj@;*/de/nm rat4 dirprim.r >dirprim.f f4p dirprim=dirprim.f #-h- cfmtbf 80 asc 17-oct-80 17:38:09 common / cfmtbf / temp(20) character temp # temporary buffer for formatting #-h- csclun 127 asc 17-oct-80 17:38:11 common / csclun / lundat(6) character bbuf(12) integer lundat # buffer for getlun calls equivalence (lundat(1), bbuf(1)) #-h- crawtt 234 asc 17-oct-80 17:38:12 common / crawtt / ids, param(6), iosb(4) integer bcount # number of characters xferred integer ids # directive status word integer param # parameter block for qio logical*1 iosb # io status block equivalence (iosb(3), bcount) #-h- cspawn 575 asc 17-oct-80 17:38:14 common / cspawn / efn, iffore, ifback, ifbast, forepc(PIDSIZE), backpc(PIDSIZE), tasknm(PIDSIZE), priost(5) integer efn # event flag number used in spawn for foregrnd procs integer iffore # if foreground process in progress - YES/NO integer ifback # if background process in progress - YES/NO integer ifbast # if background process terminated - YES/NO character forepc # pid for foreground process in progress character backpc # pid for background process in progress character tasknm # pid for this process character priost # priority of process in ascii #-h- lib.m 8340 asc 17-oct-80 17:38:18 #-h- chcopy.mac 464 asc 18-jun-80 11:56:57 .title 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 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 .end #-h- clower.mac 557 asc 09-jun-80 10:10:39 .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 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 603 asc 09-jun-80 10:10:40 .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 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 564 asc 09-jun-80 10:10:41 .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 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- equal.mac 614 asc 09-jun-80 10:10:42 .title 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 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 .end #-h- fold.mac 676 asc 09-jun-80 10:10:43 .title 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 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 .end #-h- index.mac 684 asc 09-jun-80 10:10:44 .title 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 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 .end #-h- length.mac 455 asc 09-jun-80 10:10:46 .title 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 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 .end #-h- matchc.mac 1215 asc 09-jun-80 10:10:47 .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 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 573 asc 09-jun-80 10:10:48 .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 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- stcopy.mac 660 asc 09-jun-80 10:10:50 .title 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 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 .end #-h- upper.mac 687 asc 09-jun-80 10:10:51 .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 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- libm.bld 160 asc 17-oct-80 17:38:27 ar t lib.m >mactemp ar xv lib.m ed mactemp <