IMD 1.18: 6/11/2012 10:53:54 carousel microtools carousel toolkits version 2.0 builder toolbox files - cp/m-80 disk b 3 of 3 televideo 1983    åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   K AR M AR € M AR € M AR :N AR O AR P AR ] RATFOR AR €!"#$%&'(åå #-h- kwic.r 14_90 ascii 08/30/83 12:30:00 ## definitions for kwic and unrot tools define(FOLD,DOLLAR) #character to indicate beginning of folded line define(MAXOUT,80) #width of index #------------------------------- while(getlin(buf,int) != EOF) call putrot(buf, STDOUT) if (int != STDIN) call close(int) } if (i==1) #Read from standard input while (getlin(buf,STDIN) != EOF)  i = i + 1 } } return end ## rotate - output rotated line subroutine rotate(buf, n, outfil) character buf(ARB) integer i, n, outfil for (i=n; buf(i) != NEWLINE; i=i+1) call pRATFOR AR €)*+,-./0RATFOR AR €12345678RATFOR AR €9:;<=>?@RATFOR AR =ABCDREADME ES AR €FGHIJKLMS AR €NOPQRSTUS AR €VWXYZ[\]åå-------------------------------------- ## kwic - make keyword in context index DRIVER(kwic) character buf(MAXLINE) integer getarg, open, getlin integer i, int call query ("usage: kwic [file].") for (i=1; getarg(i,buf,MAXLINE)!=EOF;  call putrot(buf, STDOUT) DRETURN end ## putrot - create lines with keyword at front subroutine putrot (buf, outfil) character type character buf(ARB), t integer i, outfil for (i=1; buf(i) != NEWLINE; i=i+1) { utch(buf(i), outfil) call putch(FOLD, outfil) for (i=1; i 16) c = c-6 # convert to lower case n = n+1 tmp(n) = c-1 # save digit value } if (buf(i) == UNDERLINE) { # get new radix, radix radix is 10. radix =ZE), i, j, c character ngetc include cmacro if (j - i > 2) { a2 = argstk(i+2) a3 = argstk(i+3) call enter(evalst(a2), evalst(a3), st) # subarrays } if (ngetc(c) ^= NEWLINE) call putbak(c) return  integer open, getarg integer fd, i, nfiles, qflag data qflag /NO/ # default is no quoting at level 0 call query ("usage: macro [-0] [files].") call minit nfiles = 0 for (i = 1; getarg(i, arg, MAXNAME) ^= EOF; i = i + 1) lose(fd) } if (nfiles <= 0) # no args, do STDIN call domacr(STDIN, qflag) DRETURN end #-t- macro 7_93 ascii 08/30/83 12:30:00 #-h- binop 10_8 ascii 08/30/83 12:30:00 ## binop -  else result = 0 case OPNE: if (l != r) result = 1 else result = 0 case OPGT: if (l > r) result = 1 else result = 0 case OPGE: if (l >= r) result = 1 else result = binop 10_8 ascii 08/30/83 12:30:00 #-h- ctonum 7_35 ascii 08/30/83 12:30:00 # ctonum - string to number with radix control integer function ctonum(buf,i,dradix) character buf(ARB), tmp(MAXLINE) integer ctoi 0 i = i+1 radix = ctoi(buf,i) } else radix = dradix val = 0 for (j=1; j<=n; j = j+1) { c = tmp(j) if (c >= radix) call remark("number error") val = val * radix + c  end #-t- dodef 2_113 ascii 08/30/83 12:30:00 #-h- doexpr 2_121 ascii 08/30/83 12:30:00 # doexpr - evaluate infix expression subroutine doexpr(argstk, i, j) integer exptoi integer argstk(ARGSIZE), i,  if (arg(1) == MINUS & arg(2) == DIG0) qflag = YES else if (arg(1) == MINUS & arg(2) ^= EOS) call error("usage: macro [-0] [files].") else { nfiles = nfiles + 1 if (arg(1) == MINUS) fd =evaluates top 3 items on eval stack subroutine binop integer l, r, result, op include cexp r = tokst(top) op = tokst(top-1) l = tokst(top-2) top = top - 2 switch (op) { case OPOR: if (l != 0 | r != 0) result = 1  0 case OPLT: if (l < r) result = 1 else result = 0 case OPLE: if (l <= r) result = 1 else result = 0 case OPADD: result = l + r case OPSUB: result = l - r case OPNEG integer i, j, c, n, val, radix, dradix string digits "0123456789abcdefABCDEF" # while (buf(i) == BLANK | buf(i) == TAB) # i = i + 1 # skip blanks for (n=0;;i=i+1) { #collect digits c = index(digits,buf(i))  } return(val) end #-t- ctonum 7_35 ascii 08/30/83 12:30:00 #-h- dodef 2_113 ascii 08/30/83 12:30:00 # dodef - install definition in table subroutine dodef(argstk, i, j) integer a2, a3, argstk(ARGSIj, k include cmacro k = argstk(i+2) call pbnum(exptoi(evalst, k, 10)) if (evalst(k) ^= EOS) { k = argstk(i+2) call putlin(evalst(k), ERROUT) call remark(": invalid infix expression.") } return end #-t   - doexpr 2_121 ascii 08/30/83 12:30:00 #-h- doif 3_43 ascii 08/30/83 12:30:00 # doif - select one of two arguments subroutine doif(argstk, i, j) integer equal integer a2, a3, a4, a5, argstk(ARGSIZE), i, j integer k, open include cfiles include cmacro if (level + 1 > NFILES) call error("includs nested too deeply.") k = argstk(i+2) infile(level+1) = open(evalst(k), READ) if (infile(level+1) == ERR) { call putlin else call pbnum(1-ctoi(evalst,k + m)) return end #-t- doincr 2_80 ascii 08/30/83 12:30:00 #-h- dolen 1_95 ascii 08/30/83 12:30:00 # dolen - return length of argument subroutine dolen(argstker ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE) include cmacro include cdefio include cfiles string balp "()" cp = 0 ap = 1 ep = 1 bp = 0 level = 1 infile(1) = fd for (t=gettok(token, MAXTOKEN); all puttok(token) # stack name call putchr(EOS) ap = push(ep, argstk, ap) t = gettok(token, MAXTOKEN) # peek at next call pbstr(token) if (t ^= LPAREN) # add ( ) if not present EOF in string.") call puttok(token) } } else if (cp == 0) # not in a macro at all call puttok(token) else if (t == LPAREN) { if (plev(cp) > 0) call puttok(token) , j include cmacro if (j - i < 5) return a2 = argstk(i+2) a3 = argstk(i+3) a4 = argstk(i+4) a5 = argstk(i+5) if (equal(evalst(a2), evalst(a3)) == YES) # subarrays call pbstr(evalst(a4)) else call pb(evalst(k), ERROUT) call remark(": can't includ.") } else level = level + 1 return end #-t- doincl 3_89 ascii 08/30/83 12:30:00 #-h- doincr 2_80 ascii 08/30/83 12:30:00 # doincr - , i, j) integer length integer argstk(ARGSIZE), i, j, k include cmacro k = argstk(i+2) call pbnum(length(evalst(k))) return end #-t- dolen 1_95 ascii 08/30/83 12:30:00 #-h- domacr 21_t ^= EOF; t=gettok(token, MAXTOKEN)) { if (t == ALPHA) { if (lookup(token, defn, st) == NO) call puttok(token) else { # defined; put it in eval stack cp = cp + 1 if (cp > CALLSIZE call pbstr(balp) plev(cp) = 0 } } else if (t == LBRACK & (cp > 0 | qflag == YES)) { nlb = 1 # strip one level of [ ] repeat { t = gettok(token, MAXTOKEN)  plev(cp) = plev(cp) + 1 } else if (t == RPAREN) { plev(cp) = plev(cp) - 1 if (plev(cp) > 0) call puttok(token) else { # end of argument list call putchr(EOS) str(evalst(a5)) return end #-t- doif 3_43 ascii 08/30/83 12:30:00 #-h- doincl 3_89 ascii 08/30/83 12:30:00 # doincl - include named file subroutine doincl(argstk, i, j) integer argstk(ARGSIZE), iincrement argument by 1 subroutine doincr(argstk, i, j) integer ctoi, index integer argstk(ARGSIZE), i, j, k, m include cmacro k = argstk(i+2) m = index(evalst(k), MINUS) if (m == 0) call pbnum(ctoi(evalst,k) + 1) 37 ascii 08/30/83 12:30:00 # domacr - expand macros with arguments; read from fd, qflag YES do [] subroutine domacr(fd, qflag) integer fd, qflag character gettok character defn(MAXDEF), t, token(MAXTOKEN) integer lookup, push integ) call error("call stack overflow.") callst(cp) = ap ap = push(ep, argstk, ap) call puttok(defn) # stack definition call putchr(EOS) ap = push(ep, argstk, ap) c if (t == LBRACK) nlb = nlb + 1 else if (t == RBRACK) { nlb = nlb - 1 if (nlb == 0) break } else if (t == EOF) call error(" call eval(argstk, callst(cp), ap-1) ap = callst(cp) # pop eval stack ep = argstk(ap) cp = cp - 1 } } else if (t == COMMA & plev(cp) == 1) { # new arg call putchr(EOS)     ap = push(ep, argstk, ap) } else call puttok(token) # just stack it } if (cp ^= 0) call error("unexpected EOF.") return end #-t- domacr 21_37 ascii 08/30/83 12:30:00 #irst char of substring if (fc >= ap & fc < ap + length(evalst(ap))) { # subarrays k = fc + min(nc, length(evalst(fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak(evalst(k)) } return end #-t- dosub SUBTYPE) call dosub(argstk, i, j) else if (td == IFTYPE) call doif(argstk, i, j) else if (td == EXPTYPE) call doexpr(argstk, i, j) else if (td == ICLTYPE) call doincl(argstk, i, j) else if (td == LENTYPE)  else k = k - 1 # skip over $ } if (k == t) # do last character call putbak(evalst(k)) } return end #-t- eval 10_71 ascii 08/30/83 12:30:00 #-h- exptoi  return(0) } else if (kind == OP) { if (kindst(top) == OP) return(0) else if (kindst(top) == SEP) { #check for unary +,- if (kindst(top-1) == OP) { while(prec(tokst(top-1)) >= prec(tok)) call binop } -h- dosub 5_44 ascii 08/30/83 12:30:00 # dosub - select substring subroutine dosub(argstk, i, j) integer ctoi, length integer ap, argstk(ARGSIZE), fc, i, j, k, nc include cmacro if (j - i < 3) return  5_44 ascii 08/30/83 12:30:00 #-h- eval 10_71 ascii 08/30/83 12:30:00 # eval - expand args i through j: evaluate builtin or push back defn subroutine eval(argstk, i, j) integer index, length integer argno, argstk(call dolen(argstk, i, j) else { for (k = t+length(evalst(t))-1; k > t; k = k - 1) if (evalst(k-1) ^= ARGFLAG) call putbak(evalst(k)) else { argno = index(digits, evalst(k)) - 1 if (argno 24_21 ascii 08/30/83 12:30:00 ## exptoi - evalutate arithmetic expression integer function exptoi (exp, ptr, radix) integer exptok, stackx character exp(ARB) integer ptr, radix integer k, tok, kind character prec include cexp  or ! if (tok != OPADD & tok != OPSUB & tok != OPNOT) return(0) if (stackx(0, OPND) == ERR) return(0) if (tok == OP } } else # (kind == SEP) { if (tok != OPLP) #if tok == ( or tok == EOS { if (kindst(top) != OPND) return(if (j - i < 4) nc = MAXTOKEN else { k = argstk(i+4) nc = ctoi(evalst, k) # number of characters } k = argstk(i+3) # origin ap = argstk(i+2) # target string fc = ap + ctoi(evalst, k) - 1 # fARGSIZE), i, j, k, m, n, t, td include cmacro string digits "0123456789" t = argstk(i) td = evalst(t) if (td == DEFTYPE) call dodef(argstk, i, j) else if (td == INCTYPE) call doincr(argstk, i, j) else if (td ==  < 0) call putbak(evalst(k)) else if (argno < j-i) { n = i + argno + 1 m = argstk(n) call pbstr(evalst(m)) k = k - 1 # skip over $ }  k = ptr top = 1 tokst(top) = OPGO kindst(top) = SEP while (exptok(exp, k, tok, kind, radix) == YES) #loop thru legal toks { if (kind == OPND) { if (kindst(top) == OPND) ADD) tok = OPPLUS else if (tok == OPSUB) tok = OPNEG } else #kindst(top) == OPND { 0) while(prec(tokst(top-1)) > prec(tok)) { if (kindst(top-1) == OP) call binop else     return(0) # no right paren } if (prec(tokst(top-1)) == prec(tok)) { if (tok == OPDONE)  } } else #unbalanced parens return(0) } } # stack new tok, kind if (stackx(tok, kind) == Ebers integer ctonum, lookup character type character c, cn string digits "0123456789abcdefABCDEF" include cexp include cmacro c = type(exp(k)) if (radix > 10) { if (index(digits,exp(k)) > 0) c = DIGIT } if (c } else #c is symbol { cn = exp(k+1) kind = OP switch(c) { case TILDE: if (cn == EQUALS) { tok = OPNE  k = k + 1 } else tok = OPNOT case LESS: if (cn == EQUALS) { tok = OPLE  } else tok = OPERR case BAR: tok = OPOR case AMPER: tok = OPAND case PLUS: tok = OPADD case MINUS: tok = OPSUB  { ptr = k #normal return return(tokst(top)) } else #remove matcRR) return(0) } return(0) end #-t- exptoi 24_21 ascii 08/30/83 12:30:00 #-h- exptok 29_103 ascii 08/30/83 12:30:00 ## exptok - get expression token for evaluation integer function exp == DIGIT) { tok = ctonum(exp, k, radix) kind = OPND return(YES) } else if (c == LETTER) { #found stored variable name call movnam(exp, k, name, 1) k = k + length(name) k = k + 1 } else tok = OPNOT case CARET: if (cn == EQUALS) { tok = OPNE  k = k + 1 } else tok = OPLT case GREATER: if (cn == EQUALS) { tok = OPGE k case STAR: if (cn == STAR) { tok = OPEXP k = k + 1 } else tok = OPMUL casehing LPAREN { tok = tokst(top) kind = kindst(top) top = top -2 tok(exp, k, tok, kind, radix) character exp(ARB), defn(MAXTOKEN), name(MAXTOKEN) integer k #index, updated unless EOS integer tok #return value, token found integer kind #return value, kind of token integer radix #default radix for num if (lookup(name, defn, st) == YES) { i = 1 tok = ctonum(defn, i, radix) kind = OPND return(YES) } else return(NO)  k = k + 1 } else tok = OPNOT case BANG: if (cn == EQUALS) { tok = OPNE  = k + 1 } else tok = OPGT case EQUALS: if (cn == EQUALS) { tok = OPEQ k = k + 1 SLASH: tok = OPDIV case PERCENT: tok = OPMOD case LPAREN: { kind = SEP tok = OPLP } case RPAREN: {     kind = SEP tok = OPRP } case EOS: { kind = SEP tok = OPDONE }  if (gettok ^= LETTER) { token(2) = EOS return } for (i = 2; i < toksiz; i = i + 1) { # alphanumeric token gettok = type(ngetc(token(i))) if (gettok ^= LETTER & gettok ^= DIGIT & gettok ^= PERIOD & gettok) integer icltyp(2) integer lentyp(2) DS_DECL(Mem,4) include cmacro string defnam "define" string incnam "incr" string subnam "substr" string ifnam "ifelse" string expnam "expr" string iclnam "includ" st upper(defnam) call enter(defnam, deftyp, st) call enter(incnam, inctyp, st) call upper(incnam) call enter(incnam, inctyp, st) call enter(subnam, subtyp, st) call upper(subnam) call enter(subnam, subtyp, st) call enter(ifnam to out(j) until non-alphanumeric found subroutine movnam (in, i, out, j) character in(ARB), out(ARB) integer i, j, k1, k2 character type character c k1 = i k2 = j for(c=type(in(k1)); c == LETTER | c == DIGIT; c=type(in(k1))) { (getch(c, infile(level)) ^= EOF) break if (level > 1) call close(infile(level)) } buf(bp) = c } if (c ^= EOF) bp = bp - 1 ngetc = c return end #-t- ngetc  default: tok = OPERR } if (tok == OPERR) return(NO) if (tok != OPDONE) k = k + 1 return(YES) } end #-t- exptok 29_103 ascii 08/30/83 12:30:00 #-h- gettok 5_ ^= UNDERLINE) break } if (i >= toksiz) call error("token too long.") call putbak(token(i)) gettok = ALPHA token(i) = EOS return end #-t- gettok 5_26 ascii 08/30/83 12:30:00 #-h- minit ring lennam "len" data deftyp(1) /DEFTYPE/, deftyp(2) /EOS/ data inctyp(1) /INCTYPE/, inctyp(2) /EOS/ data subtyp(1) /SUBTYPE/, subtyp(2) /EOS/ data iftyp(1) /IFTYPE/, iftyp(2) /EOS/ data exptyp(1) /EXPTYPE/, exptyp(2) /EOS/ data ic, iftyp, st) call upper(ifnam) call enter(ifnam, iftyp, st) call enter(expnam, exptyp, st) call upper(expnam) call enter(expnam, exptyp, st) call enter(iclnam, icltyp, st) call upper(iclnam) call enter(iclnam, icltyp, st)  out(k2) = in(k1) k1 = k1 + 1 k2 = k2 + 1 } out(k2) = EOS return end #-t- movnam 3_6 ascii 08/30/83 12:30:00 #-h- ngetc 3_120 ascii 08/30/83 12:30:00 # ngetc - get a (poss 3_120 ascii 08/30/83 12:30:00 #-h- pbnum 1_89 ascii 08/30/83 12:30:00 # pbnum - convert number to string, push back on input subroutine pbnum(n) integer itoc character buf(MAXCHARS) integer junk junk = itoc(n,26 ascii 08/30/83 12:30:00 # gettok - get alphanumeric string or single non-alpha for define character function gettok(token, toksiz) character ngetc, type integer i, toksiz character token(toksiz) gettok = type(ngetc(token(1)))  12_59 ascii 08/30/83 12:30:00 # minit - initialize symbol table with built-in macros subroutine minit integer mktabl integer deftyp(2) integer inctyp(2) integer subtyp(2) integer iftyp(2) integer exptyp(2ltyp(1) /ICLTYPE/, icltyp(2) /EOS/ data lentyp(1) /LENTYPE/, lentyp(2) /EOS/ ifnotdef(CPM, call dsinit(MEMSIZE)) st = mktabl (CHAR_DEFN) #install both upper and lower cases call enter(defnam, deftyp, st) call call enter(lennam, lentyp, st) call upper(lennam) call enter(lennam, lentyp, st) return end #-t- minit 12_59 ascii 08/30/83 12:30:00 #-h- movnam 3_6 ascii 08/30/83 12:30:00 ## movnam - move in(i)ibly pushed back) character character function ngetc(c) character getch character c include cdefio include cfiles if (bp > 0) c = buf(bp) else { bp = 1 for (; level > 0; level = level - 1) { if  buf, MAXCHARS) call pbstr(buf) return end #-t- pbnum 1_89 ascii 08/30/83 12:30:00 #-h- pbstr 1_86 ascii 08/30/83 12:30:00 # pbstr - push string back onto input subroutine pbstr(in) character    in(MAXLINE) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end #-t- pbstr 1_86 ascii 08/30/83 12:30:00 #-h- push 1_126 ascii 08/30/83 12:3(bp > BUFSIZE) call error("too many characters pushed back.") buf(bp) = c return end #-t- putbak 1_105 ascii 08/30/83 12:30:00 #-h- putchr 2_64 ascii 08/30/83 12:30:00 # putchr - put single char  integer tok, kind include cexp if (top >= MAXSTACK) { call remark ("arith evaluation stack overflow.") return (ERR) } top = top + 1 tokst(top) = tok kindst(top) = kind return(OK) end #-t- stackx , preced(20), preced(21) / 0, 0, # EOS, start_expr 1, 1, # ( ) 2, 2, # | & 3, # ! (or ^ or ~) 4,4,4,4,4,4, # == != > >= < <= 5, 5, # + - 6, 6,  macro.rat 212_86 ascii 08/30/83 12:30:00 #-t- macro.ar 227_124 ascii 09/02/83 09:15:00 #-h- man.ar 17_87 ascii 09/02/83 09:15:00 #-h- list 0_9 ascii 08/30/83 12:30:00 man.rat #-tsage: man toolname.") for (i=1; getarg(i,buf,FILENAMESIZE)!=EOF; i=i+1) { call concat (dir, buf, file) fd = open(file, READ) if (fd == ERR) { call putlin (buf, ERROUT) call remark (": no manual entry.") next } call doman0:00 # push - push ep onto argstk, return new pointer ap integer function push(ep, argstk, ap) integer ap, argstk(ARGSIZE), ep if (ap > ARGSIZE) call error("arg stack overflow.") argstk(ap) = ep push = ap + 1 return eon output or into evaluation stack subroutine putchr(c) character c include cmacro if (cp == 0) call putc(c) else { if (ep > EVALSIZE) call error("evaluation stack overflow.") evalst(ep) = c ep = 2_82 ascii 08/30/83 12:30:00 #-h- prec 5_112 ascii 08/30/83 12:30:00 # prec - return operator precedence character function prec(opkind) integer opkind character preced(MAXOP) # precedence of respective operat # * / 8, 6, 7, 8 /# neg, mod, expon, plus return(preced(opkind)) end #-t- prec 5_112 ascii 08/30/83 12:30:00 #-h- puttok 1_99 ascii 08/30/83 12:30:00 ## puttok-put token into eval stack - list 0_9 ascii 08/30/83 12:30:00 #-h- man.rat 15_86 ascii 08/30/83 12:30:00 #-h- defns 0_26 ascii 08/30/83 12:30:00 define(MAN_DIRECTORY,"") #-t- defns 0_26 ascii 08/3 (fd) call close (fd) } if (i == 1) call remark ("usage: man toolname.") DRETURN end #-t- man 4_32 ascii 08/30/83 12:30:00 #-h- doman 8_40 ascii 08/30/83 12:30:00 ## doman - print man fnd #-t- push 1_126 ascii 08/30/83 12:30:00 #-h- putbak 1_105 ascii 08/30/83 12:30:00 # putbak - push character back onto input subroutine putbak(c) character c include cdefio bp = bp + 1 if  ep + 1 } return end #-t- putchr 2_64 ascii 08/30/83 12:30:00 #-h- stackx 2_82 ascii 08/30/83 12:30:00 ## stackx - put next expression on arith evaluation stack integer function stackx(tok, kind)ors data preced(1), preced(2), preced(3), preced(4), preced(5), preced(6), preced(7), preced(8), preced(9), preced(10), preced(11), preced(12), preced(13), preced(14), preced(15), preced(16), preced(17), preced(18), preced(19) /*/sor/macror/puttok subroutine puttok(str) character str(MAXTOKEN) integer i for (i = 1; str(i) != EOS; i = i + 1) call putchr(str(i)) return end #-t- puttok 1_99 ascii 08/30/83 12:30:00 #-t-0/83 12:30:00 #-h- man 4_32 ascii 08/30/83 12:30:00 ## man - print manual entry DRIVER(man) integer getarg, open integer i, fd character buf(FILENAMESIZE), file(FILENAMESIZE) string dir MAN_DIRECTORY call query ("uile integer function doman (fd) integer fd, nl, wait integer getlin, isatty, prompt character buf(MAXLINE), savlin(MAXLINE) string pr "Hit to continue, q to quit: " data savlin(1) /EOS/ data wait /NO/ data nl /22/ repeat    { if (wait == YES) { if (isatty (STDOUT) == YES) if (prompt (pr, buf, STDIN) == EOF) call endst (OK) if (buf(1) == LETQ | buf(1) == BIGQ) { wait = NO  return end #-t- doman 8_40 ascii 08/30/83 12:30:00 #-t- man.rat 15_86 ascii 08/30/83 12:30:00 #-t- man.ar 17_87 ascii 09/02/83 09:15:00 #-h- mcol.ar 54_1 ascii 09/02/83 0inbuf character linbuf # holds a formatted page integer linptr # points to lines #-t- cmcol 3_16 ascii 08/30/83 12:30:00 #-h- mcol.rat 47_108 ascii 08/30/83 12:30:00 #-h- mcol.r 46 linptr(i) = 0 col = 0 nextbf = 1 pagsiz = PAGESIZE # set defaults linsiz = LINESIZE ncols = COLUMNS gutsiz = GUTTER fd = ERR call query ("usage: mcol [-cn] [-ln] [-wn] [-gn] [-dn] [file].") for (i = 1; geta (fd == ERR) #read STDIN call docol (pagsiz, ncols, gutsiz, linsiz, STDIN) DRETURN end ## colarg - process flags for mcol tool subroutine colarg (arg, pagsiz, ncols, gutsiz, linsiz) integer pagsiz, ncols, gutsiz, linsiz, j  { linsiz = j if (linsiz <= 0) call error ("invalid column width.") } else if (arg(2) == LETG | arg(2) == BIGG) { gutsiz = j if (gutsiz < 0) call error ("invalid gutt savlin(1) = EOS return } } wait = YES if (savlin(1) != EOS) # put out read-ahead line { call putlin (savlin, STDOUT) j = 2 } else j = 1 for (; j<=9:15:00 #-h- list 0_17 ascii 08/30/83 12:30:00 cmcol mcol.rat #-t- list 0_17 ascii 08/30/83 12:30:00 #-h- cmcol 3_16 ascii 08/30/83 12:30:00 ## common block to hold line buffers for mc_112 ascii 08/30/83 12:30:00 # mcol - format standard input into multiple columns # include ratdef define(COLUMNS,2) # defaults define(PAGESIZE,55) define(GUTTER,8) define(LINESIZE,60) define(MAXBUF,7000) # size limits define(MAXPTrg(i, arg, MAXLINE) ^= EOF; i = i + 1) { if (arg(1) == MINUS & arg(2) ^= EOS) call colarg (arg, pagsiz, ncols, gutsiz, linsiz) else if (arg(1) == MINUS & arg(2) == EOS) call docol (pagsiz, ncols, gutsiz, linsiz, STDIN)  integer ctoi character arg(ARB) j = 3 j = ctoi(arg, j) if (arg(2) == LETC | arg(2) == BIGC) { ncols = j if (ncols <= 0) call error ("invalid column count.") } else if (arg(2) == LETL | arger width.") } else if (arg(2) == LETD | arg(2) == BIGD) { pagsiz = 23 # display defaults linsiz = 10 ncols = 7 gutsiz = 1 if (j > 0) # set column width and number of columns nl; j=j+1) { if (getlin(buf, fd) == EOF) return call putlin(buf, STDOUT) } # check for impending EOF if (getlin (savlin, fd) == EOF) wait = NO }ol tool # put on a file called 'cmcol' # used only by the mcol tool common /ccol/ col, nextbf, linbuf(MAXBUF), linptr(MAXPTR) integer col # current column number on formatted page integer nextbf # next available slot in lR,1200) DRIVER(mcol) integer pagsiz, linsiz, ncols, gutsiz, lineno, nlines, i, j, fd integer readln, ctoi, getarg, mod, max, open character arg(MAXLINE) include cmcol for (i = 1; i <= MAXPTR; i = i + 1) # clear pointer array  else { fd = open(arg, READ) if (fd == ERR) call cant(arg) call docol(pagsiz, ncols, gutsiz, linsiz, fd) call close (fd) } } if(2) == BIGL) { pagsiz = j if (pagsiz <= 0) call error ("invalid page size.") } else if ( (arg(2) == LETW | arg(2) == BIGW) | (arg(2) == LETS | arg(2) == LETS) ) #UofA convention  { linsiz = j ncols = max(1, 81/(linsiz+1)) if (ncols > 1) { gutsiz = (79 - (linsiz+1)*ncols)/(ncols - 1)+1 if (gutsi   z <= 0) ncols = ncols - 1 } } } else call remark ("ignoring invalid flag.") return end ## colerr - print error in mcol usage and stop subroutine colerr eno >= nlines) { call outbuf(pagsiz, linsiz, gutsiz) lineno = 0 } } if (lineno > 1) { pagsiz = lineno/ncols if (mod(lineno, ncols) ^= 0) pagsiz = pagsiz + 1 call outbuf(pagsiz, linsiz,n(linbuf(linptr(i))) k = linptr(i) call outlin (linbuf(k)) linptr(i) = 0 for (j = i + pagsiz; linptr(j) ^= 0; j = j + pagsiz) { # call outtab((linsiz + gutsiz)*((j - 1)/pagsiz)) call outtab((linsiz + gutsiz) * maxr(ARB) integer i for (i = 1; str(i) ^= EOS; i = i + 1) call outch(str(i)) return end # outtab - tab to column n on formatted page subroutine outtab(n) integer n include cmcol while (col < n) call outch(BLA } } if (c == EOF & i == 1) return (EOF) linbuf(nextbf) = EOS nextbf = nextbf + 1 return (i - 1) end #-t- mcol.r 46_112 ascii 08/30/83 12:30:00 #-t- mcol.rat 47_108 ascii 08/30/83  open, create, getarg if (getarg(1, file1, MAXNAME) == EOF | getarg(2, file2, MAXNAME) == EOF) call error("usage: mv file1 file2.") call gdest (file1, file2) if (amove(file1, file2) == ERR) { # cant move call remark("ca call error ("usage: mcol [-cn] [-ln] [-wn] [-gn] [-dn] [file] .") return end ## docol - process file for mcol subroutine docol (pagsiz, ncols, gutsiz, linsiz, fd) integer pagsiz, ncols, gutsiz, linsiz, fd, nlines, lineno, i integer readln  gutsiz) } return end # inject - insert pointer ptr into linptr array subroutine inject(ptr, lineno) integer ptr, lineno include cmcol if (lineno > MAXPTR) call error("insufficient buffer space.") linptr(lineno) = p((j-1)/pagsiz,1) ) # call outlin(linbuf(linptr(j))) k = linptr(j) call outlin (linbuf(k)) linptr(j) = 0 } call outch(NEWLINE) } nextbf = 1 return end # outch - output c to formatNK) return end # readln - read next line (<= linsiz) into linbuf; return location p integer function readln(p, linsiz, fd) integer p, linsiz, fd integer i character getch character c include cmcol p = nextbf for (12:30:00 #-t- mcol.ar 54_1 ascii 09/02/83 09:15:00 #-h- mv.ar 9_79 ascii 09/02/83 09:15:00 #-h- list 0_8 ascii 08/30/83 12:30:00 mv.rat #-t- list 0_8 ascii 08/30/83 n't move.") } DRETURN end subroutine gdest (src, dest) character src(ARB), dest(ARB) integer equal, ctoc, index character temp (FILENAMESIZE) integer i, j string dot "." if (equal(dest, dot) == YES) call gwdir (temp, LOCAL) elinclude cmcol nlines = pagsiz*ncols # total number of lines/page if (nlines > MAXPTR) call error ("too many lines.") for (lineno = 1; readln(i, linsiz, fd) ^= EOF; lineno = lineno + 1) { call inject(i, lineno) if (lintr return end # outbuf - dump current buffer to formatted page subroutine outbuf(pagsiz, linsiz, gutsiz) integer pagsiz, linsiz, gutsiz integer i, j, k include cmcol for (i = 1; linptr(i) ^= 0; i = i + 1) { # call outlited page subroutine outch(c) character c include cmcol call putc(c) if (c == NEWLINE) col = 0 else col = col + 1 return end # outlin - output str to formatted page subroutine outlin(str) character sti = 1; getch(c, fd) ^= EOF; i = i + 1) { if (c == NEWLINE) break if (i <= linsiz) { if (nextbf >= MAXBUF) call error("insufficient buffer space.") linbuf(nextbf) = c nextbf = nextbf + 1 12:30:00 #-h- mv.rat 7_79 ascii 08/30/83 12:30:00 #-h- mv.r 6_83 ascii 08/30/83 12:30:00 # mv - move file1 to file2, copying if necessary. DRIVER character file1(MAXNAME), file2(MAXNAME) integer amove,se call mklocl(dest,temp) i = ctoc (temp, dest, FILENAMESIZE) if (dest(i) == COLON) { call mklocl (src, temp) j = index (temp, COLON) + 1 call ctoc (temp(j), dest(i+1), FILENAMESIZE) } return end #-t- mv.r 6_83 as   cii 08/30/83 12:30:00 #-t- mv.rat 7_79 ascii 08/30/83 12:30:00 #-t- mv.ar 9_79 ascii 09/02/83 09:15:00 åard output, with line #'s DRIVER(number) character array(MAXLINE) integer getlin integer ii, jj, i, k integer work character name(FILENAMESIZE) integer ctoi integer getarg integer fd integer open integer space data space /1/ #default isNUS & name (2) == EOS) fd = STDIN else fd = open (name, READ) if (fd == ERR) call cant (name) for (i=1; getlin(array,fd)^=EOF; i=i+1) { call putdec(i,NUMBER_WIDTH) call putc(BLANK)  12_30 ascii 08/30/83 12:30:00 #-t- number.rat 14_46 ascii 08/30/83 12:30:00 #-t- number.ar 16_50 ascii 09/02/83 09:15:00 åå#-h- number.ar 16_50 ascii 09/02/83 09:15:00 #-h- list 0_12 ascii 08/30/83 12:30:00 number.rat #-t- list 0_12 ascii 08/30/83 12:30:00 #-h- number.rat 14_46 ascii 08/30/83 12:30: single spacing call query ("usage: number [-sn] [files].") work = NO ii=1 if(getarg(ii,name,FILENAMESIZE)^=ERR) { if(name(1)==MINUS & (name(2)==LETS | name(2)==BIGS)){ # space=ctoi(name(3),1) i = 1  call putlin(array,STDOUT) for(k=1; k10) space=1 ii=ii+1 } } for (jj = ii; getarg (jj, name, FILENAMESIZE) != EOF; jj = jj + 1) { work = YES if (name (1) == MIrray,STDIN)^=EOF; i=i+1) { call putdec(i,NUMBER_WIDTH) call putc(BLANK) call putlin(array,STDOUT) for(k=1; k MAXLINES) ) == BLANK | arg(j) == TAB) j = j + 1 } if (lp+1 > MAXLINES) call error ("too many numbers.") list(lp+1) = EOL call shell (list, lp) gnum = lp return end #-t- gnum 7_42 ascii 08/30/83 12:30:00 #-h- p#-h- defns 0_123 ascii 08/30/83 12:30:00 # include ratdef define(MAXBUF,3000) define(MAXLINES,200) define(EOL,-1) define(PAGESIZE,23) # default page size #-t- defns 0_123 ascii 08/30/83 12:30:00 #-h- pl flag, pagsiz) next } if (list(1) == EOL) # need some numbers lp = gnum (arg, list) # break out numbers else { if (arg(1) == MINUS & arg(2) == EOS) fd = STDIN else fd = open(arg, READ)  3_99 ascii 08/30/83 12:30:00 ## doflag - process flags for pl tool subroutine doflag (arg, pflag, pagsiz) character arg(ARB) integer pflag, pagsiz integer ctoi if (arg(2) == LETP | arg(2) == BIGP) # print pages {buf(MAXBUF) integer i character getch, c i = 1 for (m = n; m > 0; m = m - 1) { while (getch(c, fd) ^= EOF) { if (i < MAXBUF) { buf(i) = c i = i + 1 } if (c == NEWLINE)  call error ("too many numbers.") list(lp) = ctoi(arg, j) if (list(lp) <= 0) call error ("bad number.") if (arg(j) == MINUS) { # have l-u specification j = j + 1 u = ctoi(arg, j) l = list(lp) if ( u < lines 4_99 ascii 08/30/83 12:30:00 # plines - print pages from fd as specified in sorted list. subroutine plines(fd, list, pagsiz) integer fd, list(MAXLINES), pagsiz integer i, j, n, get, skip, len, junk character buf(M 9_1 ascii 08/30/83 12:30:00 # pl - print specified lines or pages of given files DRIVER character arg(MAXLINE) integer getarg, open, ctoi, addset, gnum integer fd, i, j, l, u, lp, list(MAXLINES), pagsiz, pflag, junk  if (fd == ERR) call cant(arg) if (list(1) == EOL) # need some numbers call error ("usage: pl [-pn] numbers [file].") call plines(fd, list, pagsiz) if (fd ^= STDIN) call close(fd) } } if  pflag = YES j = 3 pagsiz = ctoi(arg, j) if (pagsiz < 0 | arg(j) ^= EOS) call error("bad page size.") if (pagsiz == 0) pagsiz = PAGESIZE #default } else call remark ("ignoring invalid argumen break } if (c == EOF) break } buf(i) = EOS if (c == EOF) return(EOF) return(n) end #-t- get 4_5 ascii 08/30/83 12:30:00 #-h- gnum 7_42 ascii 0l) call error("bad range.") for (l = l + 1; l <= u; l = l + 1) { lp = lp + 1 if (lp > MAXLINES) call error ("too many numbers.") list(lp) = l } } while (arg(j) == COMMA | arg(jAXBUF) n = 0 for (i = 1; list(i) ^= EOL; ) { if (skip(pagsiz*(list(i) - n - 1), fd) == EOF) return len = get(pagsiz, buf, fd) for (j = i; list(j) == list(i); i = i + 1) call putlin(buf, STDOUT) if (   len == EOF) return n = list(j) } if (fd == STDIN) # must flush standard input junk = skip(HUGE, fd) return end #-t- plines 4_99 ascii 08/30/83 12:30:00 #-h- shell 4_82 as # v(jg) = k # } return end #-t- shell 4_82 ascii 08/30/83 12:30:00 #-h- skip 2_86 ascii 08/30/83 12:30:00 # skip - skip n lines on fd 36_42 ascii 09/02/83 09:15:00 #-h- list 0_16 ascii 08/30/83 12:30:00 cprint pr.rat #-t- list 0_16 ascii 08/30/83 12:30:00 #-h- cprint 5_124 ascii 08/30/83 12:30:00 ##ause/suppress printing of header # (default = YES) integer dotail #flag to cause/suppress printing of bottom #margin (default = YES) integer plen #page length (default = 66) #-t- cpctoi integer fd, i, j include cprint string null "" call query ("usage: pr [-ln] [file].") mar1 = MARGIN1 #set defaults mar2 = MARGIN2 bmar = BMARGIN dohead = YES plen = PAGELEN fd = ERR for (i =} else call remark ("ignoring invalid argument.") } else if (name(1) == MINUS & name(2) == EOS) { fd = STDIN call fprint(null,fd) } else { fd = open(name,READ) if (fd == ERR) call cant(name) cacii 08/30/83 12:30:00 ## 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)  integer function skip(n, fd) integer n, fd integer m character getch, c for (m = n; m > 0; m = m - 1) { while (getch(c, fd) ^= EOF) if (c == NEWLINE) break if (c == EOF) break }  common block to hold info for pr tool # put on a file called 'cprint' # used only by the pr tool common /cprint/ mar1, mar2, bmar, dohead, dotail, plen integer mar1 #distance between top of page and header rint 5_124 ascii 08/30/83 12:30:00 #-h- pr.rat 27_42 ascii 08/30/83 12:30:00 #-h- defns 0_101 ascii 08/30/83 12:30:00 # include ratdef define(MARGIN1,3) define(MARGIN2,2) define(BMARGIN,3 1; getarg(i, name, FILENAMESIZE) ^= EOF; i = i + 1) { if (name(1) == MINUS & name(2) != EOS) { #it is anticipated that more #options may be added in the future if (name(2)ll fprint(name,fd) call close(fd) } } if (fd ==ERR) # no input file specified call fprint(null, STDIN) DRETURN end #-t- print 10_7 ascii 08/30/83 12:30:00 #-h- fprint 6_32 as { jg = j + gap if (v(j) <= v(jg)) #compare break k = v(j) #exchange v(j) = v(jg)  if (c == EOF) return(EOF) return(n) end #-t- skip 2_86 ascii 08/30/83 12:30:00 #-t- pl.rat 44_121 ascii 08/30/83 12:30:00 #-t- pl.ar 46_121 ascii 09/02/83 09:15:00 #-h- pr.ar #(default = 3) integer mar2 #distance between header and text #(default = 2) integer bmar #distance between text and bottom of page #(default = 6) integer dohead #flag to c) define(PAGELEN,66) #-t- defns 0_101 ascii 08/30/83 12:30:00 #-h- print 10_7 ascii 08/30/83 12:30:00 ## print - print files with headings DRIVER character name(FILENAMESIZE) integer getarg, open,  == LETL | name(2) == BIGL) #set page length { j = 3 plen = ctoi(name, j) if ((plen-mar1-mar2-bmar-2) <= 0) call error ("page too small.") cii 08/30/83 12:30:00 # fprint - print file "name" from fd subroutine fprint(name, fd) integer line(MAXLINE), name(ARB) integer getlin integer fd, lineno, pageno include cprint pageno = 0 lineno = 0 while (    getlin(line, fd) ^= EOF) { if (lineno == 0) { pageno = pageno + 1 if (dohead == YES) { call skip(mar1) call head(name, pageno) call skip(mar2) lineno = mar1 +  for (i = 1; i <= n; i = i + 1) call putc(NEWLINE) return end #-t- skip 1_36 ascii 08/30/83 12:30:00 #-h- head 4_14 ascii 08/30/83 12:30:00 # head - print top of page header subro 4_14 ascii 08/30/83 12:30:00 #-t- pr.rat 27_42 ascii 08/30/83 12:30:00 #-t- pr.ar 36_42 ascii 09/02/83 09:15:00 #-h- pwd.ar 5_118 ascii 09/02/83 09:15:00 #-h- list 0_9 as dtype) call putlin (buf, STDOUT) call putch (NEWLINE, STDOUT) return end #-t- pwd.r 2_121 ascii 08/30/83 12:30:00 #-t- pwd.rat 3_117 ascii 08/30/83 12:30:00 #-t- pwd.ar 5_118 ascii 09/02/#-h- list 1_59 ascii 08/30/83 12:30:00 readme build.tmp rat4.lst rat41.lst rat42.lst rat43.lst cdefio cfname cfor cgoto clabel cline coutln csbuf cswtch cmacro crat4 rat4.rat rat41.rat rat42.rat rat43.rat #-t- lix=1,2,3). The corresponding .lst files are used to build the three main chunks. The "list" file is a list of all members that are needed to make rat4. a complete sequence might be: ar xv rat4.ar ar xv rat4.rat ar xv rat41.rat ar xv rat42.rat ar xv mar2 + 1 } } call putlin(line, STDOUT) lineno = lineno + 1 if (lineno + bmar >= plen) { call skip(bmar) lineno = 0 } } if (lineno > 0) { utine head(name, pageno) integer name(ARB) integer now(7), form character date(9), time(9) integer pageno string page " Page " call putlin(name, STDOUT) call putlin(page, STDOUT) call putdec(pageno, 1) formcii 08/30/83 12:30:00 pwd.rat #-t- list 0_9 ascii 08/30/83 12:30:00 #-h- pwd.rat 3_117 ascii 08/30/83 12:30:00 #-h- pwd.r 2_121 ascii 08/30/83 12:30:00 ## pwd - print name of working (curren83 09:15:00 /30/83 12:30:00 #-t- pwd.rat 3_117 ascii 08/30/83 12:30:00 #-t- pwd.ar 5_118 ascii 09/02/st 1_59 ascii 08/30/83 12:30:00 #-h- readme 6_123 ascii 08/30/83 12:30:00 The rat4 compiler is constructed from and documented in this archive. The file "build.tmp" contains a list of all primary archive members.rat43.rat ; this leaves all files extracted ; make changes desired ; then put it all back ar uv rat4.rat - 0; i = i - 1) if (lextyp(i) == LEXWHILE | lextyp(i) = 8_103 ascii 08/30/83 12:30:00 #-h- getdef 14_66 ascii 08/30/83 12:30:00 ##### define statement and symbol table ##### routines in this group are getdef, instal, lookup, hshfcn, tbinit ##### (instal, lookup, hshfct, and tbinit a call skpblk(fd) if (gtok(token, toksiz, fd) ^= ALPHA) call baderr("non-alphanumeric name.") call skpblk(fd) c = gtok(ptoken, MAXTOK, fd) if (t == BLANK) { # define name defn call pbstr(ptoken) i = 1 rep output listing call query ("usage: [-l] [-d] [files] >fortran_file.") call initkw #initialize variables ratlst = isflag (list) # Read file containing standard definitions # If this isn't desired, define(STDEFNS,"") if (isflag (nodef)for (i=1; getarg(i, buf, FILENAMESIZE) != EOF; i=i+1) { if (buf(1) == MINUS & buf(2) == EOS) infile(1) = STDIN else if (buf(1) == MINUS) #skip flags next else { infile(1) = open(buf, READ) if (infile(1) == ERR) call cant(buf) -h- rat41.rat 207_49 ascii 08/30/83 12:30:00 #-h- brknxt 8_103 ascii 08/30/83 12:30:00 ##### break and next statements # brknxt - generate code for break n and next n; n = 1 is default subroutine brknxt(s= LEXDO | lextyp(i) == LEXFOR | lextyp(i) == LEXREPEAT) { if (n > 0) { n = n - 1 next # seek proper level } else if (token == LEXBREAK) call outgo(labval(i)+1) re in the general ##### purpose library) # getdef (for no arguments) - get name and definition subroutine getdef(token, toksiz, defn, defsiz, fd) character gtok, ngetch integer defsiz, fd, i, nlpar, toksiz character c, defn(MAXDEF), toeat { c = ngetch(c, fd) if (i > defsiz) call baderr("definition too long.") defn(i) = c i = i + 1 } until (c == SHARP | c == NEWLINE | c == EOF) if (c == SHARP) call putbak(c)  == NO & defns(1) != EOS) { call scopy(defns, 1, buf, 1) ifdef(VAX_VMS, call getdir(BINDIRECTORY, buf) call concat(buf, defns, buf) ) ifdef(RSX_11M, call getdir(BINDIRECTORY,} call parse n = n + 1 if (infile(1) != STDIN) call close(infile(1)) } if (n == 1) { infile(1) = STDIN call parse } DRETURN end #-t- main 12_37 ascii 08/30/83 12:30:00 #-h- rat4 p, lextyp, labval, token) integer labval(MAXSTACK), lextyp(MAXSTACK), sp, token integer i, n, alldig, ctoi character t, ptoken(MAXTOK), gnbtok # include commonblocks include cgoto n = 0 t = gnbtok(ptoken, MAXTOK) if (alldi else call outgo(labval(i)) xfer = YES return } if (token == LEXBREAK) call synerr("illegal break.") else call synerr("illegal next.") return end #-t- brknxt ken(MAXTOK), t, ptoken(MAXTOK) call skpblk(fd) c = gtok(ptoken, MAXTOK, fd) if (c == LPAREN) t = LPAREN # define (name, defn) else { t = BLANK # define name defn call pbstr(ptoken) }  } else if (t == LPAREN) { # define (name, defn) if (c ^= COMMA) call baderr("missing comma in define.") # else got (name, nlpar = 0 for (i = 1; nlpar >= 0; i = i + 1) if (i > defsiz)      call baderr("definition too long.") else if (ngetch(defn(i), fd) == EOF) call baderr("missing right paren.") else if (defn(i) == LPAREN) nlpar = nlpar + 1 else if (defn(i) == RPAREN) nlpnclude commonblocks include cgoto string sdo "do" xfer = NO call outtab call outstr(sdo) call outch(BLANK) lab = labgen(2) if (gnbtok(lexstr, MAXTOK) == DIGIT) #check for fortran DO call outstr(lexstr) else { ca/83 12:30:00 ##### error processing - routines in this group are baderr, synerr subroutine baderr(msg) character msg(ARB) call synerr(msg) call endst end #-t- baderr 1_27 ascii 08/30/83 12:30:00 #-h- synerr es(i), ERROUT) break } call putch(COLON, ERROUT) call putch(BLANK, ERROUT) call remark (msg) return end #-t- synerr 4_84 ascii 08/30/83 12:30:00 #-h- forcod 17_86 ascii 08/30/83 12:30:00 ##### for sinit clause call pbstr(token) call outtab call eatup call outdon } if (gnbtok(token, MAXTOK) == SEMICOL) # empty condition call outcon(lab) else { # non-empty condition call pbstr(token) c } call outch(RPAREN) call outch(RPAREN) call outgo(lab+2) if (nlpar < 0) call synerr("invalid for clause.") } fordep = fordep + 1 # stack reinit clause j = 1 for (i = 1; i < fordep; i = i + 1) ar = nlpar - 1 # else normal character in defn(i) } else call baderr("getdef is confused.") defn(i-1) = EOS return end #-t- getdef 14_66 ascii 08/30/83 12:30:00 #-h- docode 4_ll pbstr(lexstr) call outnum(lab) } call outch(BLANK) call eatup call outdon return end #-t- docode 4_88 ascii 08/30/83 12:30:00 #-h- dostat 1_34 ascii 08/30/83 12:30:00 # dostat - gene 4_84 ascii 08/30/83 12:30:00 subroutine synerr(msg) character lc(MAXCHARS), msg(ARB) integer itoc integer i, junk # include commonblocks include cline string in " in " string errmsg "error at line " call putlin(errmsg, ERROUT) tatement - routines in this group are forcod, fors # forcod - beginning of for statement subroutine forcod(lab) character gettok, gnbtok character t, token(MAXTOK) integer length, labgen integer i, j, lab, nlpar # include commoall outnum(lab) call outtab call outstr(ifnot) call outch(LPAREN) nlpar = 0 while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == SEMICOL) break if (t == LPAREN) n # find end j = j + length(forstk(j)) + 1 forstk(j) = EOS # null, in case no reinit nlpar = 0 t = gnbtok(token, MAXTOK) call pbstr(token) while (nlpar >= 0) { t = gettok(token, MAXTOK) if (t == LPAREN) n88 ascii 08/30/83 12:30:00 ##### do statement - routines in this group are docode, dostat # docode - generate code for beginning of do subroutine docode(lab) integer labgen integer lab character gnbtok character lexstr(MAXTOK) # irate code for end of do statement subroutine dostat(lab) integer lab call outcon(lab) call outcon(lab+1) return end #-t- dostat 1_34 ascii 08/30/83 12:30:00 #-h- baderr 1_27 ascii 08/30 if (level >= 1) i = level else i = 1 #for EOF errors junk = itoc (linect(i), lc, MAXCHARS) call putlin(lc, ERROUT) for (i = fnamp-1; i>1; i=i-1) if (fnames(i-1) == EOS) #print file name { call putlin(in, ERROUT) call putlin(fnamnblocks include cfor string ifnot "if(.not." lab = labgen(3) call outcon(0) if (gnbtok(token, MAXTOK) ^= LPAREN) { call synerr("missing left paren.") return } if (gnbtok(token, MAXTOK) ^= SEMICOL) { # real lpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr(token) return } if (t ^= NEWLINE & t ^= UNDERLINE) call outstr(token) lpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 if (t == EOF) { call pbstr(token) break } if (nlpar >= 0 & t ^= NEWLINE & t ^= UNDERLINE) { if (j + length(token) >= MAXFORSTK)      call baderr("for clause too long.") call scopy(token, 1, forstk, j) j = j + length(token) } } lab = lab + 1 # label for next's return end #-t- forcod 17_86 ascii 08/30/83 11) fordep = fordep - 1 return end #-t- fors 3_104 ascii 08/30/83 12:30:00 #-h- balpar 6_127 ascii 08/30/83 12:30:00 ##### if statement - routines in this group are balpar, elseif, ifcode, ifgo # bEOS else if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 # else nothing special call outstr(token) } until (nlpar <= 0) if (nlpar ^= 0) call synerr("missing parentab) integer labgen integer lab # include commonblocks include cgoto xfer = NO lab = labgen(2) call ifgo(lab) return end #-t- ifcode 1_94 ascii 08/30/83 12:30:00 #-h- ifgo 2_9cal analyzer ##### routines in this group are gettok, gnbtok, gtok, lex, ngetch, ##### pbstr, putbak, relate # deftok - get token; process macro calls and invocations # this routine has been disabled to allow defines with parameters to be added #  call instal(token, defn) # } # else # call pbstr(defn) # push replacement onto input # } # deftok = t # if (deftok == ALPHA) # convert to single case # call fold(token) # return # end # gettok -2:30:00 #-h- fors 3_104 ascii 08/30/83 12:30:00 # fors - process end of for statement subroutine fors(lab) integer length integer i, j, lab # include commonblocks include cfor include cgoto xfer = NO alpar - copy balanced paren string subroutine balpar character gettok, gnbtok character t, token(MAXTOK) integer nlpar if (gnbtok(token, MAXTOK) ^= LPAREN) { call synerr("missing left paren.") return } call ohesis in condition.") return end #-t- balpar 6_127 ascii 08/30/83 12:30:00 #-h- elseif 1_31 ascii 08/30/83 12:30:00 # elseif - generate code for end of if before else subroutine elseif(lab) integer 5 ascii 08/30/83 12:30:00 # ifgo - generate "if(.not.(...))goto lab" subroutine ifgo(lab) integer lab string ifnot "if(.not." call outtab # get to column 7 call outstr(ifnot) # " if(.not. " call balpar # colsee deftok for the code for deftok # character function deftok(token, toksiz, fd) # character gtok # integer fd, toksiz # character defn(MAXDEF), t, token(MAXTOK) # integer lookup # # for (t=gtok(token, toksiz, fd); t^=EOF; t=gtok(token get token. handles file inclusion and line numbers character function gettok(token, toksiz) integer equal, open, length integer i, toksiz, f, len character t character deftok character name(MAXNAME), token(MAXTOK) # include co call outnum(lab) j = 1 for (i = 1; i < fordep; i = i + 1) j = j + length(forstk(j)) + 1 if (length(forstk(j)) > 0) { call outtab call outstr(forstk(j)) call outdon } call outgo(lab-1) call outcon(lab+utstr(token) nlpar = 1 repeat { t = gettok(token, MAXTOK) if (t==SEMICOL | t==LBRACE | t==RBRACE | t==EOF) { call pbstr(token) break } if (t == NEWLINE) # delete newlines token(1) = lab call outgo(lab+1) call outcon(lab) return end #-t- elseif 1_31 ascii 08/30/83 12:30:00 #-h- ifcode 1_94 ascii 08/30/83 12:30:00 # ifcode - generate initial code for if subroutine ifcode(llect and output condition call outch(RPAREN) # " ) " call outgo(lab) # " goto lab " return end #-t- ifgo 2_95 ascii 08/30/83 12:30:00 #-h- gettok 25_19 ascii 08/30/83 12:30:00 ##### lexi, toksiz, fd)) { # if (t ^= ALPHA) # non-alpha # break # if (lookup(token, defn) == NO) # undefined # break # if (defn(1) == DEFTYPE) { # get definition # call getdef(token, toksiz, defn, MAXDEF, fd) # mmonblocks include cline include cfname string fncn "function" string incl "include" for ( ; level > 0; level = level - 1) { f = infile(level) for (gettok = deftok(token, toksiz, f); gettok ^= EOF; gett    ok = deftok(token, toksiz, f)) { if (equal(token, fncn) == YES) { call skpblk(infile(level)) t = deftok(fcname, MAXNAME, f) call pbstr(fcname) if (t ^= ALPHA) call synerr("missinnerr("includes nested too deeply.") else { infile(level+1) = open(name, READ) linect(level+1) = 1 if (infile(level+1) == ERR) call synerr("can't open include.") else {  break } } token(1) = EOF # in case called more than once token(2) = EOS gettok = EOF return end #-t- gettok 25_19 ascii 08/30/83 12:30:00 #-h- gnbtok 2_7 ascii 08/30/83 12:30 i, b, n, toksiz, itoc character c, lexstr(MAXTOK) # include commonblocks include cline c = ngetch(lexstr(1), fd) if (c == BLANK | c == TAB) { lexstr(1) = BLANK while (c == BLANK | c == TAB) # compress many blanks toRLINE & gtok ^= PERIOD) break } call putbak(lexstr(i+1)) gtok = ALPHA } else if (gtok == DIGIT) { # digits b = c - DIG0 # in case alternate base number for (i = 1; i < toksiz -  break } call putbak(lexstr(1)) i = itoc(n, lexstr, toksiz) } else call putbak(lexstr(i+1)) gtok = DIGIT } else if (c == LBRACK) { # allow [ for { lexstr(1) = LBRACE g function name.") call putbak(BLANK) return } else if (equal(token, incl) == NO) return #process includes call skpblk(infile(level)) t = deftok(n level = level + 1 if (fnamp + i <= MAXFNAMES) { call scopy(name, 1, fnames, fnamp) fnamp = fnamp + i # push file name stack } f = infile(level) :00 # gnbtok - get nonblank token character function gnbtok(token, toksiz) integer toksiz character token(MAXTOK), gettok # include commonblocks include cline call skpblk(infile(level)) gnbtok = gettok(token, toksiz) retu one c = ngetch(c, fd) if (c == SHARP) while (ngetch(c, fd) ^= NEWLINE) # strip comments ; if (c ^= NEWLINE) call putbak(c) else lexstr(1) = NEWLINE lexstr(2) = EOS g2; i = i + 1) { if (type(ngetch(lexstr(i+1), fd)) ^= DIGIT) break b = 10*b + lexstr(i+1) - DIG0 } if (lexstr(i+1) == RADIX & b >= 2 & b <= 36) { #n%ddd... for (n = 0;; n = b*n + c - DIG0) {  gtok = LBRACE } else if (c == RBRACK) { # allow ] for } lexstr(1) = RBRACE gtok = RBRACE } # else if (c == DOLLAR) { # allow $( and $) for { and } # if (ngetch(lexstr(2), fd) == LPAREN) { # lexstrame, MAXNAME, infile(level)) if (t == SQUOTE | t == DQUOTE) { len = length(name) - 1 for (i=1; i < len; i=i+1) name(i) = name(i+1) name(i) = EOS } i = length(name) + 1 if (level >= NFILES) call sy } } } if (level > 1) { # close include and pop file name stack call close(infile(level)) for (fnamp = fnamp - 1; fnamp > 1; fnamp = fnamp - 1) if (fnames(fnamp-1) == EOS) rn end #-t- gnbtok 2_7 ascii 08/30/83 12:30:00 #-h- gtok 32_29 ascii 08/30/83 12:30:00 # gtok - get token for Ratfor character function gtok(lexstr, toksiz, fd) character ngetch, type integer fd,tok = lexstr(1) return } i = 1 gtok = type(c) if (gtok == LETTER) { # alpha for (i = 1; i < toksiz - 2; i = i + 1) { gtok = type(ngetch(lexstr(i+1), fd)) if (gtok ^= LETTER & gtok ^= DIGIT & gtok ^= UNDE c = ngetch(lexstr(1), fd) if (c >= LETA & c <= LETZ) c = c - LETA + DIG9 + 1 else if (c >= BIGA & c <= BIGZ) c = c - BIGA + DIG9 + 1 if (c < DIG0 | c >= DIG0 + b) (1) = LBRACE # gtok = LBRACE # } # else if (lexstr(2) == RPAREN) { # lexstr(1) = RBRACE # gtok = RBRACE # } # else # call putbak(lexstr(2)) # } # the above code has been disabled in o    rder to allow $( and $) to # surround strings to be copied directly to the evaluation stack within # macros. This is done by returninig dummy character values when these # digraphs are seen else if (c == DOLLAR) { if (ngetch(lexstr(2), ftr(i) = c } else call putbak(c) if (lexstr(i) == NEWLINE | i >= toksiz-1) { call synerr("missing quote.") lexstr(i) = lexstr(1) call putbak(NEWLINE) etch. This eliminates the nagging problem of incorrect # line numbers # if (lexstr(1) == NEWLINE) # linect(level) = linect(level) + 1 return end #-t- gtok 32_29 ascii 08/30/83 12:30:00 #-h- lex  string sdeflt "default" for (lex = gnbtok(lexstr, MAXTOK); lex == NEWLINE; lex = gnbtok(lexstr, MAXTOK)) ; if (lex == EOF | lex == SEMICOL | lex == LBRACE | lex == RBRACE) return if (lex == DIGIT) lex = LE(lexstr, srept) == YES) lex = LEXREPEAT else if (equal(lexstr, suntil) == YES) lex = LEXUNTIL else if (equal(lexstr, sret) == YES) lex = LEXRETURN else if (equal(lexstr, sstr) == YES) lex = LEXSTRING else if (equnblocks include cdefio include cline if (bp > 0) { c = buf(bp) bp = bp - 1 } else { c = getch(c, fd) if (ratlst == YES) call putch(c, ERROUT) } ngetch = c if (c == NEWLId) == LPAREN) { i = 2 gtok = LSTRIPC } else if (lexstr(2) == RPAREN) { i = 2 gtok = RSTRIPC } else call putbak(lexstr(2)) } else if (c == SQUOTE | c == DQUOTE) { for (ibreak } } } else if (c == SHARP) { # strip comments while (ngetch(lexstr(1), fd) ^= NEWLINE) ; gtok = NEWLINE } else if (c == GREATER | c == LESS | c == NOT | c == BANG | c == T 13_70 ascii 08/30/83 12:30:00 # lex - return lexical type of token integer function lex(lexstr) character gnbtok character lexstr(MAXTOK) integer equal # include commonblocks string sif "if" string selse "else" string swhXDIGITS else if (lex == TOGGLE) lex = LEXLITERAL else if (equal(lexstr, sif) == YES) lex = LEXIF else if (equal(lexstr, selse) == YES) lex = LEXELSE else if (equal(lexstr, swhile) == YES) lex = LEXWHILE else ial(lexstr, sswtch) == YES) lex = LEXSWITCH else if (equal(lexstr, scase) == YES) lex = LEXCASE else if (equal(lexstr, sdeflt) == YES) lex = LEXDEFAULT else lex = LEXOTHER return end #-t- lex NE) linect(level) = linect(level) + 1 return end #-t- ngetch 3_89 ascii 08/30/83 12:30:00 #-h- pbstr 1_82 ascii 08/30/83 12:30:00 # pbstr - push string back onto input subroutine pbstr(in) chara = 2; ngetch(lexstr(i), fd) ^= lexstr(1); i = i + 1) { if (lexstr(i) == UNDERLINE) if (ngetch(c, fd) == NEWLINE) { while (c == NEWLINE | c == BLANK | c == TAB) c = ngetch(c, fd) lexsILDE | c == CARET | c == EQUALS | c == AND | c == OR) call relate(lexstr, i, fd) if (i >= toksiz-1) call synerr("token too long.") lexstr(i+1) = EOS # the following lines have been disabled, since line accounting is now # done in ngile "while" string sdo "do" string sbreak "break" string snext "next" string sfor "for" string srept "repeat" string suntil "until" string sret "return" string sstr "string" string sswtch "switch" string scase "case"f (equal(lexstr, sdo) == YES) lex = LEXDO else if (equal(lexstr, sbreak) == YES) lex = LEXBREAK else if (equal(lexstr, snext) == YES) lex = LEXNEXT else if (equal(lexstr, sfor) == YES) lex = LEXFOR else if (equal 13_70 ascii 08/30/83 12:30:00 #-h- ngetch 3_89 ascii 08/30/83 12:30:00 # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd # include commocter in(ARB) integer length integer i for (i = length(in); i > 0; i = i - 1) call putbak(in(i)) return end #-t- pbstr 1_82 ascii 08/30/83 12:30:00 #-h- putbak 2_81 ascii 08/30/83 12:3    0:00 # putbak - push character back onto input subroutine putbak(c) character c # include commonblocks include cdefio include cline bp = bp + 1 if (bp > BUFSIZE) call baderr("too many characters pushed back.") buf token(3) = LETE token(4) = PERIOD token(5) = EOS token(6) = EOS # for .not. and .and. if (token(1) == GREATER) token(2) = LETG else if (token(1) == LESS) token(2) = LETL else if (token(1) == NOT | token(1) == BANG |  token(5) = PERIOD } else if (token(1) == OR) { token(2) = LETO token(3) = LETR } else # can't happen token(2) = EOS token(1) = PERIOD last = length(token) return end #-t- relate 30/83 12:30:00 #-h- deftok 22_98 ascii 08/30/83 12:30:00 ##### routines needed for full macro capability ##### routines in this group include deftok, doarth, doif, doincr, ##### dosub, valr, ifparm, bpnum, push, putchr, puttok, domacer ap, argstk(ARGSIZE), callst(CALLSIZE), # " " nlb, plev(CALLSIZE), ifl include cmacro include crat4 data balp/LPAREN, RPAREN, EOS/ cp = 0 ap = 1 ep = 1 for (t=gtok(token,toksiz,fd); t != EOF; t=gtok(token,toksiz,fd))  == IFNOTDEFTYPE)) call pbstr(defn) } else { cp = cp + 1 if (cp > CALLSIZE) call baderr("call stack overflow.") callst(cp) = ap ap = push(ep, argstk, ap) call puttok(defn) call putchr(EOS) ap =(bp) = c if (c == NEWLINE) linect(level) = linect(level) - 1 return end #-t- putbak 2_81 ascii 08/30/83 12:30:00 #-h- relate 10_20 ascii 08/30/83 12:30:00 # relate - convert relational shorthands into token(1) == CARET | token(1) == TILDE) { if (token(2) ^= EQUALS) { token(3) = LETO token(4) = LETT token(5) = PERIOD } token(2) = LETN } else if (token(1) == EQUALS) { if  10_20 ascii 08/30/83 12:30:00 #-h- litral 2_111 ascii 08/30/83 12:30:00 ##### litral - process literal ratfor line subroutine litral character ngetch # include commonblocks include coutln include cline # Finis # if macro capability is not wanted, replace this entire set # of routines with the commented-out version of deftok in # the "lex" section ## deftok - get token; process macro calls and invocations character function deftok(token, toksiz,  { if (t == ALPHA) if (lookup(token, defn, st) == NO) if (cp == 0) break else call puttok(token) else if (defn(1) == DEFTYPE) # process defines directly { call getdef(token, toksiz, defn, MAXDEF, fd) call enter( push(ep, argstk, ap) call puttok(token) call putchr(EOS) ap = push(ep, argstk, ap) t = gtok(token, toksiz, fd) call pbstr(token) if (t != LPAREN) call pbstr(balp) else if (ifparm(defn) == NO) call pbstr(balp long form subroutine relate(token, last, fd) character ngetch character token(ARB) integer length integer fd, last if (ngetch(token(2), fd) ^= EQUALS) { call putbak(token(2)) token(3) = LETT } else (token(2) ^= EQUALS) { token(2) = EOS last = 1 return } token(2) = LETE token(3) = LETQ } else if (token(1) == AND) { token(2) = LETA token(3) = LETN token(4) = LETD h off any left-over characters if (outp > 0) call outdon for(outp = 1; ngetch(outbuf(outp), infile(level)) != NEWLINE; outp = outp + 1) ; outp = outp - 1 call outdon return end #-t- litral 2_111 ascii 08/fd) character token(MAXTOK) # formal parameters integer toksiz, fd # " " character gtok # external function integer lookup, push, ifparm # " " character t, c, defn(MAXDEF), balp(3), mdefn(MAXDEF) # local integtoken, defn, st) } else if(defn(1) == IFDEFTYPE | defn(1) == IFNOTDEFTYPE) { c = defn(1) call getdef(token, toksiz, defn, MAXDEF, fd) ifl = lookup(token, mdefn, st) if ((ifl == YES & c == IFDEFTYPE) | (ifl == NO & c) plev(cp) = 0 } else if (t == LSTRIPC) { nlb= 1 repeat { t = gtok(token, toksiz, fd) if (t == LSTRIPC) nlb = nlb + 1 else if (t == RSTRIPC) { nlb = nlb - 1 if (nlb == 0) break } el    se if (t == EOF) call baderr("EOF in string.") call puttok(token) } } else if (cp == 0) break else if (t == LPAREN) { if (plev(cp) > 0) call puttok(token) plev(cp) = plev(cp) + 1 } else if (t == RPAREN) {  207_49 ascii 08/30/83 12:30:00 #-h- rat42.rat 103_71 ascii 08/30/83 12:30:00 #-h- doarth 5_65 ascii 08/30/83 12:30:00 # process macros with arguments # routines involved are doarth, domac, doif, doincr, do SLASH ) call pbnum(ctoi(evalst,k)/ctoi(evalst,l)) else call remark('arith error') return end #-t- doarth 5_65 ascii 08/30/83 12:30:00 #-h- doif 3_91 ascii 08/30/83 12:30:00 ## doif - select one of twh- doincr 2_6 ascii 08/30/83 12:30:00 ## doincr - increment macro argument by 1 /*/sor/macror/doincr subroutine doincr(argstk, i, j) integer ctoi integer argstk(ARGSIZE), i, j, k include cmacro k = argevalst, k) # number of characters } k = argstk(i+3) # origin ap = argstk(i+2) # target string fc = ap + ctoi(evalst, k) - 1 # first char of substring if (fc >= ap & fc < ap + length(evalst(ap))) { # suba '0123456789' t = argstk(i) td = evalst(t) if (td == MACTYPE) call domac(argstk, i, j) else if (td == INCTYPE) # if (td == INCTYPE) call doincr(argstk, i, j) else if (td == SUBTYPE) call dosub(argstk, plev(cp) = plev(cp) - 1 if (plev(cp) > 0) call puttok(token) else { call putchr(EOS) call evalr(argstk, callst(cp), ap-1) ap = callst(cp) ep = argstk(ap) cp = cp - 1 } } else if (t == COMMA & plesub, evalr, ifparm, # pbnum, push, putchr, puttok ## doarth - do arithmetic operation subroutine doarth(argstk,i,j) integer ctoi integer argstk(ARGSIZE), i, j, k, l character op integer ie include cmacro k = argstk(i+2) l = argstk(i+o (macro) arguments /*/sor/macror/doif subroutine doif(argstk, i, j) integer equal integer a2, a3, a4, a5, argstk(ARGSIZE), i, j include cmacro if (j - i < 5) return a2 = argstk(i+2) a3 = argstk(i+3) a4stk(i+2) call pbnum(ctoi(evalst, k)+1) return end #-t- doincr 2_6 ascii 08/30/83 12:30:00 #-h- dosub 5_95 ascii 08/30/83 12:30:00 ## dosub - select macro substring /*/sor/macror/dosub subrrays k = fc + min(nc, length(evalst(fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak(evalst(k)) } return end #-t- dosub 5_95 ascii 08/30/83 12:30:00 #-h- evalr 9_23  i, j) else if (td == IFTYPE) call doif(argstk, i, j) else if (td == ARITHTYPE) call doarth(argstk, i, j) else { for (k = t+length(evalst(t))-1; k > t; k = k - 1) if (evalst(k-1) != ARGFLAG) v(cp) == 1) { call putchr(EOS) ap = push(ep, argstk, ap) } else call puttok(token) } deftok = t if (t == ALPHA) call fold(token) return end #-t- deftok 22_98 ascii 08/30/83 12:30:00 #-t- rat41.rat 4) ie = argstk(i+3) op = evalst(ie) if (op == PLUS) call pbnum(ctoi(evalst,k)+ctoi(evalst,l)) else if (op == MINUS) call pbnum(ctoi(evalst,k)-ctoi(evalst,l)) else if (op == STAR ) call pbnum(ctoi(evalst,k)*ctoi(evalst,l)) else if (op ==  = argstk(i+4) a5 = argstk(i+5) if (equal(evalst(a2), evalst(a3)) == YES) # subarrays call pbstr(evalst(a4)) else call pbstr(evalst(a5)) return end #-t- doif 3_91 ascii 08/30/83 12:30:00 #-routine dosub(argstk, i, j) integer ctoi, length integer ap, argstk(ARGSIZE), fc, i, j, k, nc include cmacro if (j - i < 3) return if (j - i < 4) nc = MAXTOK else { k = argstk(i+4) nc = ctoi(ascii 08/30/83 12:30:00 ## evalr - expand args i through j: evaluate builtin or push back defn subroutine evalr(argstk, i, j) integer index, length integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td include cmacro string digitscall putbak(evalst(k)) else { argno = index(digits, evalst(k)) - 1 if (argno >= 0 & argno < j-i) { n = i + argno + 1 m = argstk(n) call pbstr(evalst(m))     } k = k - 1 # skip over $ } if (k == t) # do last character call putbak(evalst(k)) } return end #-t- evalr 9_23 ascii 08/30/83 12:30:00 #-h- ifparm oints at char after ARGFLAG if (type(strng(i)) == DIGIT) andif (type(strng(i+1)) != DIGIT) { ifparm = YES break } } } return end #-t- ifparm  2_30 ascii 08/30/83 12:30:00 ## push - push ep onto argstk, return new pointer ap /*/sor/macror/push integer function push(ep, argstk, ap) integer ap, argstk(ARGSIZE), ep if (ap > ARGSIZE) call baderr('arg stack overflow.')  #-h- puttok 1_97 ascii 08/30/83 12:30:00 ## puttok-put token into eval stack /*/sor/macror/puttok subroutine puttok(str) character str(MAXTOK) integer i for (i = 1; str(i) != EOS; i = i + 1) call putch-t- domac 2_99 ascii 08/30/83 12:30:00 #-h- eatup 9_62 ascii 08/30/83 12:30:00 ##### ordinary fortran statements - routines in this group are eatup, ##### labelc, otherc # eatup - process rest of statement;S | t == STAR | t == LPAREN | t == AND | t == BAR | t == BANG | t == TILDE | t == NOT | t == CARET | t == EQUALS | t == UNDERLINE) { while (gettok(ptoken, MAXTOK) == NEWLINE) ; call pbstr(ptoken)  5_61 ascii 08/30/83 12:30:00 # ifparm - determines if the defined symbol has arguments in its # definition. This effects how the macro is expanded. integer function ifparm(strng) character strng(ARB), c character type integer i,  5_61 ascii 08/30/83 12:30:00 #-h- pbnum 2_62 ascii 08/30/83 12:30:00 ## pbnum - convert number to string, push back on input subroutine pbnum(n) integer mod integer m, n, num string digits '012345678 argstk(ap) = ep push = ap + 1 return end #-t- push 2_30 ascii 08/30/83 12:30:00 #-h- putchr 2_10 ascii 08/30/83 12:30:00 ## putchr - put single char into eval stack /*/sor/macror/putchr r(str(i)) return end #-t- puttok 1_97 ascii 08/30/83 12:30:00 #-h- domac 2_99 ascii 08/30/83 12:30:00 ## domac - install macro definition in table /*/sor/macror/domac subroutine domac(argstk, i interpret continuations subroutine eatup character gettok character ptoken(MAXTOK), t, token(MAXTOK) integer nlpar nlpar = 0 repeat { t = gettok(token, MAXTOK) if (t == SEMICOL | t == NEWLINE) break  if (t == UNDERLINE) token(1) = EOS } if (t == LPAREN) nlpar = nlpar + 1 else if (t == RPAREN) nlpar = nlpar - 1 call outstr(token) } until (nlpar < 0) if (nlpar ^= 0) caindex c = strng(1) if (c == INCTYPE | c == SUBTYPE | c == IFTYPE | c == ARITHTYPE | c == MACTYPE) ifparm = YES else { ifparm = NO for (i=1; index(strng(i), ARGFLAG) > 0; ) { i = i + index(strng(i), ARGFLAG) # i p9' num = n repeat { m = mod(num, 10) call putbak(digits(m+1)) num = num / 10 } until (num == 0) return end #-t- pbnum 2_62 ascii 08/30/83 12:30:00 #-h- push  subroutine putchr(c) character c include cmacro if (ep > EVALSIZE) call baderr('evaluation stack overflow.') evalst(ep) = c ep = ep + 1 return end #-t- putchr 2_10 ascii 08/30/83 12:30:00 , j) integer a2, a3, argstk(ARGSIZE), i, j include cmacro include crat4 if (j - i > 2) { a2 = argstk(i+2) a3 = argstk(i+3) call enter(evalst(a2), evalst(a3), st) # subarrays } return end # if (t == RBRACE | t == LBRACE) { call pbstr(token) break } if (t == EOF) { call synerr("unexpected EOF.") call pbstr(token) break } if (t == COMMA | t == PLUS | t == MINUll synerr("unbalanced parentheses.") return end #-t- eatup 9_62 ascii 08/30/83 12:30:00 #-h- labelc 3_44 ascii 08/30/83 12:30:00 # labelc - output statement number subroutine labelc(lexstr) charac   ter lexstr(ARB) integer length # include commonblocks include cgoto xfer = NO # can't suppress goto's now if (length(lexstr) == 5) # warn about 23xxx labels if (lexstr(1) == DIG2 & lexstr(2) == DIG3) call synerr(scii 08/30/83 12:30:00 #-h- outch 4_1 ascii 08/30/83 12:30:00 # output routines ##### routines in this group are outch, outcon, outdon, outgo, outnum, ##### outstr, outtab, allblk # outch - put one character into output buffene outcon(n) integer n # include commonblocks include cgoto include coutln string contin "continue" xfer = NO if (n <= 0 & outp == 0) return # don't need unlabeled continues if (n > 0) call outnum 2_23 ascii 08/30/83 12:30:00 #-h- outgo 2_9 ascii 08/30/83 12:30:00 # outgo - output "goto n" subroutine outgo(n) integer n # include commonblocks include cgoto string goto "goto " if (xfer == YES) outch(MINUS) for ( ; i > 0; i = i - 1) call outch(chars(i)) return end #-t- outnum 2_119 ascii 08/30/83 12:30:00 #-h- outstr 5_57 ascii 08/30/83 12:30:00 # outstr - output string; handles quoted um(j-i) call outch(BIGH) for ( ; i < j; i = i + 1) call outch(str(i)) } } return end #-t- outstr 5_57 ascii 08/30/83 12:30:00 #-h- outtab 1_38 ascii 08/30/8"warning: possible label conflict.") call outstr(lexstr) call outtab return end #-t- labelc 3_44 ascii 08/30/83 12:30:00 #-h- otherc 1_125 ascii 08/30/83 12:30:00 # otherc - output ordinary Fortran r subroutine outch(c) character c integer i # include commonblocks include coutln if (outp >= 72) { # continuation card call outdon for (i = 1; i < 6; i = i + 1) outbuf(i) = BLANK outbuf(6) = STAR(n) call outtab call outstr(contin) call outdon return end #-t- outcon 2_125 ascii 08/30/83 12:30:00 #-h- outdon 2_23 ascii 08/30/83 12:30:00 # outdon - finish off an output line subroutine  return call outtab call outstr(goto) call outnum(n) call outdon return end #-t- outgo 2_9 ascii 08/30/83 12:30:00 #-h- outnum 2_119 ascii 08/30/83 12:30:00 # outnum - output decimal nuliterals subroutine outstr(str) character c, str(ARB) integer i, j for (i = 1; str(i) ^= EOS; i = i + 1) { c = str(i) if (c ^= SQUOTE & c ^= DQUOTE) { # produce upper case fortran, if desired 3 12:30:00 # outtab - get past column 6 subroutine outtab # include commonblocks include coutln while (outp < 6) call outch(BLANK) return end #-t- outtab 1_38 ascii 08/30/83 12:30:00 #-h- allblk statement subroutine otherc(lexstr) character lexstr(ARB) # include commonblocks include cgoto xfer = NO call outtab call outstr(lexstr) call eatup call outdon return end #-t- otherc 1_125 a outp = 6 } outp = outp + 1 outbuf(outp) = c return end #-t- outch 4_1 ascii 08/30/83 12:30:00 #-h- outcon 2_125 ascii 08/30/83 12:30:00 # outcon - output "n continue" subroutioutdon integer allblk # include commonblocks include coutln outbuf(outp+1) = NEWLINE outbuf(outp+2) = EOS if (allblk(outbuf) == NO) call putlin(outbuf, STDOUT) outp = 0 return end #-t- outdon mber subroutine outnum(n) character chars(MAXCHARS) integer i, m m = iabs(n) i = 0 repeat { i = i + 1 chars(i) = mod(m, 10) + DIG0 m = m / 10 } until (m == 0 | i >= MAXCHARS) if (n < 0) call  ifdef(UPPERC, if (c >= LETA & c <= LETZ) c = c - LETA + BIGA ) call outch(c) } else { i = i + 1 for (j = i; str(j) ^= c; j = j + 1) # find end ; call outn 3_69 ascii 08/30/83 12:30:00 # allblk - determine if line consists of all blanks # this routine is called by outdon, and is here to fix # a bug which sometimes occurs if two or more includes precede the # first line of executable code.     Could not trace down the cause integer function allblk(buf) character buf(ARB) integer i allblk = YES for (i=1; buf(i) != NEWLINE & buf(i) != EOS; i=i+1) if (buf(i) != BLANK) { allblk = NO break } return end #-t- allblk ude commonblocks include clabel include cline include crat4 integer mktabl string defnam "define" string macnam "mdefine" string incnam "incr" string subnam "substr" string ifnam "ifelse" string arnam "arith" string ifdfnm "ifdef" al(incnam, inct) call ulstal(subnam, subt) call ulstal(ifnam, ift) call ulstal(arnam, art) call ulstal(ifdfnm, ifdft) call ulstal(ifndnm, ifndt) #initialize label label = 23000 # initialize listing switch ratlst = NO return en= 0 # pushback buffer pointer fordep = 0 # for stack fcname(1) = EOS # current function name swtop = 0 # switch stack swlast = 1 return end #-t- init 4_38 ascii 08/30/83 12:30:00 #-h- parse  call ifcode(lab) else if (token == LEXDO) call docode(lab) else if (token == LEXWHILE) call whilec(lab) else if (token == LEXFOR) call forcod(lab) else if (token == LEXREPEAT) call repcod { if (lextyp(sp) == LEXIF) call elseif(labval(sp)) else call synerr("illegal else.") } else if (token == LEXLITERAL) call litral if (token == LEXIF | token == LEXELSE | toke 3_69 ascii 08/30/83 12:30:00 #-t- rat42.rat 103_71 ascii 08/30/83 12:30:00 #-h- rat43.rat 160_93 ascii 08/30/83 12:30:00 #-h- initkw 10_27 ascii 08/30/83 12:30:00 ##### parsing - routi string ifndnm "ifnotdef" data deft(1), deft(2) /DEFTYPE, EOS/ data mact(1), mact(2) /MACTYPE, EOS/ data inct(1), inct(2) /INCTYPE, EOS/ data subt(1), subt(2) /SUBTYPE, EOS/ data ift(1), ift(2) /IFTYPE, EOS/ data art(1), art(2) /ARITHTYPE, Ed #-t- initkw 10_27 ascii 08/30/83 12:30:00 #-h- init 4_38 ascii 08/30/83 12:30:00 # init - initialize for each input file subroutine init # include commonblocks include coutln include cline  21_112 ascii 08/30/83 12:30:00 # parse - parse Ratfor source program subroutine parse character lexstr(MAXTOK) integer lex integer lab, labval(MAXSTACK), lextyp(MAXSTACK), sp, token, i include cgoto include cfor include cfn(lab) else if (token == LEXSWITCH) call swcode(lab) else if (token == LEXCASE | token == LEXDEFAULT) { for (i = sp; i > 0; i = i - 1) # find for most recent switch if (lextyp(i) == LEXSWITCH) n == LEXWHILE | token == LEXFOR | token == LEXREPEAT | token == LEXSWITCH | token == LEXDO | token == LEXDIGITS | token == LBRACE) { sp = sp + 1 # beginning of statement if (sp > MAXSTACK) call badnes in this group are initkw, init, parse, unstak, ulstal ## initkw - initialize table and install keywords 'define' and 'DEFINE' subroutine initkw character deft(2), inct(2), subt(2), ift(2), art(2), ifdft(2), ifndt(2), mact(2) # inclOS/ data ifdft(1), ifdft(2) /IFDEFTYPE, EOS/ data ifndt(1), ifndt(2) /IFNOTDEFTYPE, EOS/ st = mktabl(CHAR_DEFN) #initialize hash table #install keywords 'define' and 'DEFINE' call ulstal(defnam, deft) call ulstal(macnam, mact) call ulst include cdefio include cfor include cfname include clabel include csbuf include cswtch outp = 0 # output character pointer level = 1 # file control linect(1) = 1 sbp = 1 fnamp = 2 fnames(1) = EOS bp ame include cline include csbuf include clabel include cdefio include coutln call init sp = 1 lextyp(1) = EOF for (token = lex(lexstr); token ^= EOF; token = lex(lexstr)) { if (token == LEXIF)  break if (i == 0) call synerr("illegal case or default.") else call cascod(labval(i), token) } else if (token == LEXDIGITS) call labelc(lexstr) else if (token == LEXELSE) err("stack overflow in parser.") lextyp(sp) = token # stack type and value labval(sp) = lab } else if (token ^= LEXCASE & token ^= LEXDEFAULT) { if (token == RBRACE) { if (lextyp(sp) == LBRAC   E) sp = sp - 1 else if (lextyp(sp) == LEXSWITCH) { call swend(labval(sp)) sp = sp - 1 } else call synerr("illegal right brace.") }  return end #-t- parse 21_112 ascii 08/30/83 12:30:00 #-h- unstak 6_88 ascii 08/30/83 12:30:00 # unstak - unstack at end of statement subroutine unstak(sp, lextyp, labval, token) integer labval(MAXST) == LEXWHILE) call whiles(labval(sp)) else if (lextyp(sp) == LEXFOR) call fors(labval(sp)) else if (lextyp(sp) == LEXREPEAT) call untils(labval(sp), token) } return end #-t- unstak pcod, untils # repcod - generate code for beginning of repeat subroutine repcod(lab) integer labgen integer lab call outcon(0) # in case there was a label lab = labgen(3) call outcon(lab) lab = lab + 1 # label to go ab-1) call outcon(lab+1) return end #-t- untils 3_23 ascii 08/30/83 12:30:00 #-h- retcod 4_70 ascii 08/30/83 12:30:00 ##### return statement # retcod - generate code for return subroutine retc 4_70 ascii 08/30/83 12:30:00 #-h- strdcl 20_21 ascii 08/30/83 12:30:00 ##### string declaration # strdcl - generate code for string declaration subroutine strdcl character t, token(MAXTOK), gnbtok in else if (token == LEXOTHER) call otherc(lexstr) else if (token == LEXBREAK | token == LEXNEXT) call brknxt(sp, lextyp, labval, token) else if (token == LEXRETURN) call retcod else if ACK), lextyp(MAXSTACK), sp, token for ( ; sp > 1; sp = sp - 1) { if (lextyp(sp) == LBRACE | lextyp(sp) == LEXSWITCH) break if (lextyp(sp) == LEXIF & token == LEXELSE) break if (lextyp(sp) == LEXIF)  6_88 ascii 08/30/83 12:30:00 #-h- ulstal 1_106 ascii 08/30/83 12:30:00 ## install both lower and upper case versions of name subroutine ulstal(name, defn) character name(ARB), defn(ARB) include crat4 call enter(nameon next's return end #-t- repcod 2_84 ascii 08/30/83 12:30:00 #-h- untils 3_23 ascii 08/30/83 12:30:00 # untils - generate code for until or end of repeat subroutine untils(lab, token) character ptod character token(MAXTOK), gnbtok, t # include commonblocks include cfname include cgoto string sret "return" t = gnbtok(token, MAXTOK) if (t ^= NEWLINE & t ^= SEMICOL & t ^= RBRACE) { call pbstr(token) call outteger i, j, k, n, len integer length, ctoi, lex character dchar(MAXTOK) include csbuf string char "character/" string dat "data " string eoss "EOS/" t = gnbtok(token, MAXTOK) if (t ^= ALPHA) call synerr("missing str(token == LEXSTRING) call strdcl token = lex(lexstr) # peek at next token call pbstr(lexstr) call unstak(sp, lextyp, labval, token) } } if (sp ^= 1) call synerr("unexpected EOF.") call outcon(labval(sp)) else if (lextyp(sp) == LEXELSE) { if (sp > 2) sp = sp - 1 call outcon(labval(sp)+1) } else if (lextyp(sp) == LEXDO) call dostat(labval(sp)) else if (lextyp(sp, defn, st) call upper(name) call enter(name, defn, st) return end #-t- ulstal 1_106 ascii 08/30/83 12:30:00 #-h- repcod 2_84 ascii 08/30/83 12:30:00 ##### repeat statement - routines in this group are reoken(MAXTOK) integer lex integer junk, lab, token # include commonblocks include cgoto xfer = NO call outnum(lab) if (token == LEXUNTIL) { junk = lex(ptoken) call ifgo(lab-1) } else call outgo(ltab call outstr(fcname) call outch(EQUALS) call eatup call outdon } else if (t == RBRACE) call pbstr(token) call outtab call outstr(sret) call outdon xfer = YES return end #-t- retcod ing token.") call outtab call pbstr(char) #use defined meaning of "character" repeat { t = gnbtok(dchar, MAXTOK) if (t == SLASH) break call outstr (dchar) } call outch(BLANK) # separator in declaration call outstr(   token) call addstr(token, sbuf, sbp, SBUFSIZE) # save for later call addchr(EOS, sbuf, sbp, SBUFSIZE) if (gnbtok(token, MAXTOK) ^= LPAREN) { # make size same as initial value len = length(token) + 1 if (token(1) == SQUOTE | token(UOTE) { len = length(token) token(len) = EOS call addstr(token(2), sbuf, sbp, SBUFSIZE) } else call addstr(token, sbuf, sbp, SBUFSIZE) call addchr(EOS, sbuf, sbp, SBUFSIZE) t = lex(token) # peek at next toke break n = sbuf(j) call outnum (n) call outch(SLASH) k = k + 1 } call pbstr(eoss) # use defined meaning of EOS repeat { t = gnbtok(token, MAXTOK)  if (bp > maxsiz) call baderr("buffer overflow.") buf(bp) = c bp = bp + 1 return end #-t- addchr 2_110 ascii 08/30/83 12:30:00 #-h- alldig 2_62 ascii 08/30/83 12:30:00 # alldig - return YES  integer n # include commonblocks include clabel labgen = label label = label + n return end #-t- labgen 1_88 ascii 08/30/83 12:30:00 #-h- skpblk 1_101 ascii 08/30/83 12:30:00 # skpblkd(lab, token) integer lab, token integer t, l, lb, ub, i, j character tok(MAXTOK) character gnbtok integer caslab, labgen include cswtch include cgoto if (swtop <= 0) { call synerr("illegal case or default.") 1) == DQUOTE) len = len - 2 } else { # form is string name(size) init t = gnbtok(token, MAXTOK) i = 1 len = ctoi(token, i) if (token(i) ^= EOS) call synerr("invalid string size.") if (gnbtokn call pbstr(token) if (t ^= LEXSTRING) { # dump accumulated data statements for (i = 1; i < sbp; i = j + 1) { call outtab call outstr(dat) k = 1 for (j = i + length(sbuf(i)) + 1; ; j = j + 1) {  call outstr(token) } until (t == SLASH) call outdon } sbp = 1 } return end #-t- strdcl 20_21 ascii 08/30/83 12:30:00 #-h- addchr 2_110 ascii 08/30/83 12:30:00 if str is all digits integer function alldig(str) character type character str(ARB) integer i alldig = NO if (str(1) == EOS) return for (i = 1; str(i) ^= EOS; i = i + 1) if (type(str(i)) ^= DIGIT) retu - skip blanks and tabs in file fd subroutine skpblk(fd) integer fd character c, ngetch for (c = ngetch(c, fd); c == BLANK | c == TAB; c = ngetch(c, fd)) ; call putbak(c) return end #-t- skpblk 1_10 return } call outgo(lab+1) # terminate previous case xfer = YES l = labgen(1) if (token == LEXCASE) { # case n[,n]... : ... while (caslab(lb, t) ^= EOF) { ub = lb if (t == MINUS) junk = caslab(token, MAXTOK) ^= RPAREN) call synerr("missing right paren.") else t = gnbtok(token, MAXTOK) } call outch(LPAREN) call outnum(len) call outch(RPAREN) call outdon if (token(1) == SQUOTE | token(1) == DQ if (k > 1) call outch(COMMA) call outstr(sbuf(i)) call outch(LPAREN) call outnum(k) call outch(RPAREN) call outch(SLASH) if (sbuf(j) == EOS) ##### miscellaneous routines ##### routines in this group are addchr, addstr, alldig, labgen, skpblk # addchr - put c in buf(bp) if it fits, increment bp subroutine addchr(c, buf, bp, maxsiz) integer bp, maxsiz character c, buf(ARB) rn alldig = YES return end #-t- alldig 2_62 ascii 08/30/83 12:30:00 #-h- labgen 1_88 ascii 08/30/83 12:30:00 # labgen - generate n consecutive labels, return first one integer function labgen(n) 1 ascii 08/30/83 12:30:00 #-h- cascod 15_80 ascii 08/30/83 12:30:00 ##### switch statement - routines involved are cascod, caslab, swcode, ##### swend, swvar # cascod - generate code for case or default label subroutine casco(ub, t) if (lb > ub) { call synerr("illegal range in case label.") ub = lb } if (swlast + 3 > MAXSWITCH) call baderr("switch table overflow.") for (i = swtop + 3; i < swlast;    i = i + 3) if (lb <= swstak(i)) break else if (lb <= swstak(i+1)) call synerr("duplicate case label.") if (i < swlast & ub >= swstak(i)) call synerr("duplicate case label.") ll error("multiple defaults in switch statement.") else swstak(swtop+2) = l } if (t == EOF) call synerr("unexpected EOF.") else if (t ^= COLON) call error("missing colon in case or default label.") xfer = N (t == MINUS | t == PLUS) t = gnbtok(tok, MAXTOK) if (t ^= DIGIT) { call synerr("invalid case label.") n = 0 } else { i = 1 n = s*ctoi(tok, i) } t = gnbtok(tok, MAXTOK) while (t == NEWLINE) tak(swlast+1) = 0 swstak(swlast+2) = 0 swtop = swlast swlast = swlast + 3 xfer = NO call outtab # Innn=(e) call swvar(lab) call outch(EQUALS) call balpar call outdon call outgo(lab) # goto L xfer = YES while ".lt.1.or." string sgt ".gt." string sgoto "goto(" string seq ".eq." string sge ".ge." string sle ".le." string sand ".and." lb = swstak(swtop+3) ub = swstak(swlast-2) n = swstak(swtop+1) call outgo(lab+1) # termif(Innn.lt.1.or.Innn.gt.ub-lb+1)goto default call outstr(sif) call swvar(lab) call outstr(slt) call swvar(lab) call outstr(sgt) call outnum(ub - lb + 1) call outch(RPAREN) call outgo(swstak(swtop+2))  for (j = swlast; j > i; j = j - 1) # insert new entry swstak(j+2) = swstak(j-1) swstak(i) = lb swstak(i+1) = ub swstak(i+2) = l swstak(swtop+1) = swstak(swtop+1) + 1 swlast = swlastO call outcon(l) return end #-t- cascod 15_80 ascii 08/30/83 12:30:00 #-h- caslab 5_13 ascii 08/30/83 12:30:00 # caslab - get one case label integer function caslab(n, t) integer n, t charac t = gnbtok(tok, MAXTOK) return end #-t- caslab 5_13 ascii 08/30/83 12:30:00 #-h- swcode 6_10 ascii 08/30/83 12:30:00 # swcode - generate code for beginning of switch statement subroutine swcode(l(gnbtok(tok, MAXTOK) == NEWLINE) ; if (tok(1) != LBRACE) { call synerr("missing left brace in switch statement.") call pbstr(tok) } return end #-t- swcode 6_10 ascii 08/30/83 12:30:00 #-h- swendnate last case if (swstak(swtop+2) == 0) swstak(swtop+2) = lab + 1 # default default label xfer = NO call outcon(lab) # L continue if (n >= CUTOFF & ub - lb + 1 < DENSITY*n) { # output branch table if (lb ^= 1) { # L Inn call outtab # goto (....),Innn call outstr(sgoto) j = lb for (i = swtop + 3; i < swlast; i = i + 3) { for ( ; j < swstak(i); j = j + 1) { # fill in vacancies call outnum(swstak(swtop+2)) call + 3 if (t == COLON) break else if (t ^= COMMA) call synerr("illegal case syntax.") } } else { # default : ... t = gnbtok(tok, MAXTOK) if (swstak(swtop+2) ^= 0) cater tok(MAXTOK) integer i, s character gnbtok integer ctoi t = gnbtok(tok, MAXTOK) while (t == NEWLINE) t = gnbtok(tok, MAXTOK) if (t == EOF) return (t) if (t == MINUS) s = -1 else s = +1 ifab) integer lab character tok(MAXTOK) character gnbtok integer labgen include cswtch include cgoto lab = labgen(2) if (swlast + 3 > MAXSWITCH) call baderr("switch table overflow.") swstak(swlast) = swtop sws 21_25 ascii 08/30/83 12:30:00 # swend - finish off switch statement; generate dispatch code subroutine swend(lab) integer lab integer lb, ub, n, i, j include cswtch include cgoto string sif "if(" string sltn=Innn-lb+1 call outtab call swvar(lab) call outch(EQUALS) call swvar(lab) if (lb < 1) call outch(PLUS) call outnum(-lb + 1) call outdon } call outtab # i outch(COMMA) } for (j = swstak(i+1) - swstak(i); j >= 0; j = j - 1) call outnum(swstak(i+2)) # fill in range j = swstak(i+1) + 1 if (i < swlast - 3) call outch(COMMA) }    call outch(RPAREN) call outch(COMMA) call swvar(lab) call outdon } else if (n > 0) { # output linear search form for (i = swtop + 3; i < swlast; i = i + 3) { call outtab # if(Innn call outstr(sif if (lab + 1 ^= swstak(swtop+2)) call outgo(swstak(swtop+2)) } call outcon(lab+1) # L+1 continue swlast = swtop # pop switch stack swtop = swstak(swtop) return end #-t- swend 21_25 ascii 08/30/83abgen integer lab call outcon(0) # unlabeled continue, in case there was a label lab = labgen(2) call outnum(lab) call ifgo(lab+1) return end #-t- whilec 2_75 ascii 08/30/83 12:30:00 #-h- whiles ), fflag(4) call scopy (flag, 1, fflag, 1) call fold (fflag) for (i=1; getarg(i,buf,4) != EOF; i=i+1) { call fold (buf) if (equal(fflag,buf) == YES) return(YES) } return(NO) end #-t- isflag 3_12 ascii 08/30/83 Disk 3 of 3 for the Carousel MicroTools Builder ToolBook (V2.0) Files on this diskette are copyrighted (c) 1983 by Carousel MicroTools, Inc., and may be used only in accordance with a duly executed software license from Carousel MicroTools, Inc. å) call swvar(lab) if (swstak(i) == swstak(i+1)) { call outstr(seq) # .eq.... call outnum(swstak(i)) } else { call outstr(sge) # .ge.lb.and.Innn.le.ub call ou 12:30:00 #-h- swvar 1_33 ascii 08/30/83 12:30:00 # swvar - output switch variable Innn, where nnn = lab subroutine swvar(lab) integer lab call outch(BIGI) call outnum(lab) return end #-t- swvar  1_23 ascii 08/30/83 12:30:00 # whiles - generate code for end of while subroutine whiles(lab) integer lab call outgo(lab) call outcon(lab+1) return end #-t- whiles 1_23 ascii 08/30/83 12:30:0012:30:00 #-t- rat43.rat 160_93 ascii 08/30/83 12:30:00 d (buf) if (equal(fflag,buf) == YES) return(YES) } return(NO) end #-t- isflag 3_12 ascii 08/30/83 ååtnum(swstak(i)) call outstr(sand) call swvar(lab) call outstr(sle) call outnum(swstak(i+1)) } call outch(RPAREN) # ) goto ... call outgo(swstak(i+2)) }  1_33 ascii 08/30/83 12:30:00 #-h- whilec 2_75 ascii 08/30/83 12:30:00 ##### while statement - routines involved are whilec, whiles # whilec - generate code for beginning of while subroutine whilec(lab) integer l #-h- isflag 3_12 ascii 08/30/83 12:30:00 ## isflag - looks for flag on command line # temporary version -- should be made more general integer function isflag(flag) character flag(ARB) integer getarg, equal, i character buf(4ååå   å 12:30:00 ## common block for csedit tool # put on a file called 'csedit' # (used only by csedit) common /csedit/ aq, iq, buf(MAXBUF), lastbf, nlines, line1, line2, pat(MAXPAT), prevc, nflag integer aq # end of append queue intege #-h- sedit.rat 198_73 ascii 08/30/83 12:30:00 #-h- defns 19_113 ascii 08/30/83 12:30:00 # include ratdef define(NLINES,0) # number of line numbers define(NEXT,1) # index of next command define(LINE1, read command define(SUBSTCOM,LETS) # substitute command # define(SUBSTGFLAG,COMMAND+1) # YES for global replacement define(SUBSTGFLAG,5) # define(SUBSTPFLAG,COMMAND+2) # YES for print define(SUBSTPFLAG,6) # define(SUBSTPAT,COMMAND+3) # index of e(LASTLINE,DOLLAR) define(OKYES,YES) # to be compatible with addset/addstr define(GLOBAL,LETG) # for getrhs define(PRINT,LETP) # for ckp define(DITTO,(-3)) # define(APPENDLIST,LIST+1) # location of list of appends define(APPENDLIST,ntain zeroes. # On CP/M EOS is also zero. Thus these pattern arrays could not be # properly moved around. # # Thus sedit had to undergo considerable alterations to make it # work on CP/M. The code now is not pretty, and should be reworked # for cår iq # end of insert queue integer buf # buf for commands integer lastbf # next available character in buf integer nlines # number of line number expressions integer line1 # line number 1 or index to pattern integer line2 # li2) # line number 1 or index of pattern define(LINE2,3) # line number 2 or index of pattern define(COMMAND,4) # command define(LIST,5) # next command on insert/append list define(TEXT,6) # text for insert/append opattern define(SUBSTPAT,7) # define(SUBSTNEW,COMMAND+4) # index of replacement define(SUBSTNEW,8) define(WRITECOM,LETW) # write command # define(WRITEFD,COMMAND+1) # file descriptor for opened file or 0 define(WRITEFD,5) define(EQUALCOM,EQUAL6) define(NOFILE,ERR) define(PATEND,-77) # EOS marker for patterns (which may contain # zeroes) # ------------------------------------------------------------------------ # # NOTE: The version of sedit distributed by the Software Tools Users # larity, but at least it works... # # --------------------------------------------------------------------- #-t- defns 19_113 ascii 08/30/83 12:30:00 #-h- sedit 22_111 ascii 08/30/83 12:30:00 # sedit - stream edito#-h- sedit.ar 207_8 ascii 09/02/83 09:15:00 #-h- list 0_19 ascii 08/30/83 12:30:00 csedit sedit.rat #-t- list 0_19 ascii 08/30/83 12:30:00 #-h- csedit 5_56 ascii 08/30/83ne number 2 or index to pattern character pat # current pattern during compilation integer prevc # index of previous command integer nflag # YES to print result of "p" commands only #-t- csedit 5_56 ascii 08/30/83 12:30:00 r file name for read define(APPENDCOM,LETA) # append command define(CHANGECOM,LETC) # change command define(DELETECOM,LETD) # delete command define(INSERTCOM,LETI) # insert command define(PRINTCOM,LETP) # print command define(READCOM,LETR) #S) # print line number command define(INSERTLIST,1) # location of list of inserts # define(FIRSTFREE,APPENDLIST+TEXT) # first free location in buf define(FIRSTFREE,12) define(COMMANDLIST,1) define(MAXBUF,5000) # size of command buffer defingroup had some peculiarities -- it stored characters and integers # in the same arrays. On CP/M this limited these integers to 8 bits, # which was not enough. Also, regular expressions, which are coded # by 'getpat' into special pattern arrays, may cor DRIVER(sedit) character arg(MAXLINE), linbuf(MAXLINE) integer i, j, nfiles, fd, k integer length, getarg, open, getlin include csedit call query ("usage: sedit [-n] [[-e script | -f sfiles] | script] [files].") prevc = COMMANDL   IST # initialize lists # buf(COMMANDLIST+NEXT) = 0 k = COMMANDLIST + NEXT buf(k) = 0 lastbf = FIRSTFREE nflag = NO nfiles = 0 i = 1 if (getarg (i, arg, MAXLINE) == EOF | arg(i) == QMARK & arg(2) == EOS) call u } else if (arg(1) == MINUS & (arg(2)==LETE | arg(2)==BIGE)) { # -e script if (getarg(i + 1, arg, MAXLINE) == EOF) call usage j = length(arg) arg(j+1) = NEWLINE arg(j+2) = EOS call coS) fd = STDIN else fd = open(arg, READ) if (fd == ERR) call cant(arg) call sed(linbuf, lineno, fd) if (fd ^= STDIN) call close(fd) nfiles = nfiles + 1 } if (nfiles == 0)  { if (buf(i+NLINES) == 2) buf(i+NLINES) = 1 # insures changed text is output if (buf(i+NLINES) == 3 & (buf(i+LINE2) > 0 | -buf(i+LINE2) >= lineno)) buf(i+LINE2) = -lineno  == DITTO) for (j = from; j < to; j = j + 1) junk = addset(lin(j), new, k, maxnew) else junk = addset(sub(i), new, k, maxnew) return end #-t- catsub 3_114 ascii 08/30/83 12:3030/83 12:30:00 #-h- compil 25_78 ascii 08/30/83 12:30:00 # compil - "compile" command in lin(i) from file fd, increment i subroutine compil(lin, fd) character lin(MAXLINE) integer fd character file(MAXNAME), sub(MAXPAT)sage if (arg(1) == MINUS & (arg(2) == LETN | arg(2) == BIGN)) { nflag = YES i = i + 1 } for (; getarg(i, arg, MAXLINE) ^= EOF; i = i + 2) if (arg(1) == MINUS & (arg(2) == LETF | arg(2) == BIGF)) { # -f filename mpil(arg, NOFILE) } else # no flags break if (lastbf == FIRSTFREE) { # use argument as script if (getarg(i, arg, MAXLINE) == EOF) call usage j = length(arg) arg(j+1) = NEWLINE arg call sed(linbuf, lineno, STDIN) if (linbuf(1) ^= EOS) { # set last line number and do last line lineno = lineno + 1 # for (i = buf(COMMANDLIST+NEXT); i > 0; i = buf(i+NEXT)) { k = COMMANDLIST + NEXT for (i = buf(k } } call docmds(linbuf, lineno) } DRETURN end #-t- sedit 22_111 ascii 08/30/83 12:30:00 #-h- catsub 3_114 ascii 08/30/83 12:30:00 ## catsub - add replacement text to end of:00 #-h- ckp 3_15 ascii 08/30/83 12:30:00 # ckp - check for "p" after command integer function ckp(lin, i, pflag, status) character lin(MAXLINE) integer i, j, pflag, status character clower j = i if (clow, c integer i, gflag, pflag, status, fdw, j integer addi, addis, create, getrhs, getfn, ckp, optpat, dotext, getlst, patlen integer addpat character clower include csedit status = ERR i = 1 if (getlst(lin, i, status if (getarg(i + 1, arg, MAXLINE) == EOF) call usage fd = open(arg, READ) if (fd == ERR) call cant(arg) while (getlin(arg, fd) ^= EOF) call compil(arg, fd) call close(fd) (j+2) = EOS call compil(arg, NOFILE) i = i + 1 } linbuf(1) = EOS lineno = 0 call docmds(linbuf, 0) # do line 0 commands for (; getarg(i, arg, MAXLINE) ^= EOF; i = i + 1) { if (arg(1) == MINUS & arg(2) == EO); i > 0; i = buf(i+NEXT)) { if (buf(i+LINE1) == -HUGE) buf(i+LINE1) = -lineno if (buf(i+LINE2) == -HUGE) buf(i+LINE2) = -lineno if (buf(i+COMMAND) == CHANGECOM) #clean unsatisfied c commands  new. subroutine catsub(lin, from, to, sub, new, k, maxnew) integer addset integer from, i, j, junk, k, maxnew, to character lin(MAXLINE), new(maxnew), sub(MAXPAT) for (i = 1; sub(i) != EOS; i = i + 1) if (sub(i)er(lin(j)) == PRINT) { j = j + 1 pflag = YES } else pflag = NO if (lin(j) == NEWLINE) status = OKYES else status = ERR ckp = status return end #-t- ckp 3_15 ascii 08/) == ERR) { call putlin(lin, ERROUT) call error("bad line numbers.") } call skipbl(lin, i) buf(prevc+NEXT) = lastbf # link in new command prevc = lastbf status = addi(nlines, buf, lastbf, MAXBUF) status = addi(0   , buf, lastbf, MAXBUF) status = addi(line1, buf, lastbf, MAXBUF) status = addi(line2, buf, lastbf, MAXBUF) #fold commands to lower case c = clower(lin(i)) j = c status = addi (j, buf, lastbf, MAXBUF)uf, lastbf, MAXBUF) status = dotext(fd) } else if (clower(lin(i)) == PRINTCOM & lin(i+1) == NEWLINE) status = OKYES else if (clower(lin(i)) == READCOM) { status = addi(0, buf, lastbf, MAXBUF) status = getfn(lin, ius = addi(lastbf + 2, buf, lastbf, MAXBUF) status = addi(lastbf + patlen(pat) + 2, buf, lastbf, MAXBUF) # status = addis(pat, buf, lastbf, MAXBUF) # status = addi(EOS, buf, lastbf, MAXBUF) # insert pattern (special problem lin(i+1) == NEWLINE) status = OKYES else status = ERR if (status ^= OKYES) { call putlin(lin, ERROUT) if (lastbf > MAXBUF) call error("too many commands.") else call error("invalid command.") j = COMMANDLIST + NEXT for (i = buf(j); i ^= 0; i = buf(i+NEXT)) { nlines = buf(i+NLINES) line1 = buf(i+LINE1) line2 = buf(i+LINE2) if (nlines == 0) call docom(i, linbuf, lineno) else if (nlines == 1) {  } else if (line1 > 0) # andif (match(linbuf, buf(line1)) > 0) { { call gpat (buf(line1), 1, temp, 1) if (match(linbuf, temp) > 0) { buf(i+NLINES) = 3 call docom(i, linbuf, if (clower(lin(i)) == APPENDCOM & lin(i+1) == NEWLINE & fd ^= NOFILE) { status = addi(0, buf, lastbf, MAXBUF) status = dotext(fd) } else if (clower(lin(i)) == CHANGECOM & lin(i+1) == NEWLINE & fd ^= NOFILE) { status = a, file) if (status == OKYES) { status = addis(file, buf, lastbf, MAXBUF) status = addi(EOS, buf, lastbf, MAXBUF) } } else if (clower(lin(i)) == SUBSTCOM) { i = i + 1 if (optpat(lin, i) == OKYES) # with the EOS marker) status = addpat(pat, buf, lastbf, MAXBUF) status = addis(sub, buf, lastbf, MAXBUF) status = addi(EOS, buf, lastbf, MAXBUF) } } else if (clower(lin(i)) == WRITECOM) { stat } return end #-t- compil 25_78 ascii 08/30/83 12:30:00 #-h- docmds 22_13 ascii 08/30/83 12:30:00 # docmds-execute commands in buf on linbuf, which contains line lineno subroutine docmds(linbuf, lin if (-line1 == lineno) call docom(i, linbuf, lineno) else if (line1 > 0) { # andif (match(linbuf, buf(line1)) > 0) call gpat (buf(line1), 1, temp, 1) if (match(linbuf, temp) > 0) cal lineno) } } } else if (nlines == 3) { # 2 line numbers, searching for line2 if (line2 <= 0) { if (lineno >= -line2) buf(i+NLINES) = 2 # found it, change state ddi(0, buf, lastbf, MAXBUF) status = dotext(fd) } else if (clower(lin(i)) == DELETECOM & lin(i+1) == NEWLINE) status = OKYES else if (clower(lin(i)) == INSERTCOM & lin(i+1) == NEWLINE & fd ^= NOFILE) { status = addi(0, b andif (getrhs(lin, i, sub, gflag) == OKYES) status = ckp(lin, i + 1, pflag, status) if (status == OKYES) { status = addi(gflag, buf, lastbf, MAXBUF) status = addi(pflag, buf, lastbf, MAXBUF) status = getfn(lin, i, file) if (status == OKYES) { fdw = create(file, WRITE) if (fdw == ERR) call cant(file) } status = addi(fdw, buf, lastbf, MAXBUF) } else if (clower(lin(i)) == EQUALCOM & eno) character linbuf(MAXLINE), temp(MAXPAT) integer lineno integer i, n, j integer match include csedit aq = APPENDLIST # initialize append and insert queues buf(aq+LIST) = 0 iq = INSERTLIST buf(iq+LIST) = 0 l docom(i, linbuf, lineno) } } else if (nlines == 2) { # 2 line numbers, searching for line1 if (-line1 == lineno) { buf(i+NLINES) = 3 # found it, change state call docom(i, linbuf, lineno)  if (lineno <= -line2) call docom(i, linbuf, lineno) } else if (line2 > 0) { # if (match(linbuf, buf(line2)) > 0) call gpat (buf(line2), 1, temp, 1) if (match(linbuf, temp   ) > 0) buf(i+NLINES) = 2 call docom(i, linbuf, lineno) } } else call error("in docmds: can't happen.") if (linbuf(1) == EOS & lineno > 0) break } o r command else # call putlin(buf(i+TEXT), STDOUT) { call icopys (buf(i+TEXT), 1, temp, 1) call putlin (temp, STDOUT) } return end #-t- docmds 22_13 ascii 08/30/83 12:30:00 #-h- docom  buf(aq+LIST) = i aq = i buf(i+LIST) = 0 } } else if (cmd == DELETECOM) linbuf(1) = EOS else if (cmd == INSERTCOM) { buf(iq+LIST) = i iq = i buf(i+LIST) = 0 } elseWRITEFD) ^= 0) call putlin(linbuf, buf(i+WRITEFD)) } else if (cmd == EQUALCOM) { call putdec(lineno, 1) call putc(NEWLINE) } # else ignore command return end #-t- docom 11_52 ascii ii 08/30/83 12:30:00 #-h- getfn 3_99 ascii 08/30/83 12:30:00 # getfn - get file name from lin(i)... integer function getfn(lin, i, file) character lin(MAXLINE), file(MAXLINE) integer i, j, k getfn = ERR if (lineger function getlst(lin, i, status) character lin(MAXLINE) integer i integer status # ignored integer num integer getone include csedit nlines = 0 if (getone(lin, i, num) == EOF) return(OKYES) line1 = num  # output inserts j = INSERTLIST + LIST for (i = buf(j); i > 0; i = buf(i+LIST)) # call putlin(buf(i+TEXT), STDOUT) { call icopys (buf(i+TEXT), 1, temp, 1) call putlin (temp, STDOUT) } if (nflag == NO 11_52 ascii 08/30/83 12:30:00 # docom - execute a single command at buf(i) on linbuf and lineno subroutine docom(i, linbuf, lineno) character linbuf(MAXLINE) character temp1(MAXLINE), temp2(MAXLINE) integer i, lineno character cmd  if (cmd == PRINTCOM) call putlin(linbuf, STDOUT) else if (cmd == READCOM) { buf(aq+LIST) = i aq = i buf(i+LIST) = 0 } else if (cmd == SUBSTCOM) { k1 = buf(i+SUBSTPAT) k2 = buf(i+SUBSTNEW) call gpa08/30/83 12:30:00 #-h- dotext 3_7 ascii 08/30/83 12:30:00 # dotext - append text in file fd onto buf integer function dotext(fd) integer fd integer getlin, addi, addis character lin(MAXLINE) include csedit w(i + 1) == BLANK | lin(i + 1) == TAB) { j = i + 2 # get new file name call skipbl(lin, j) for (k = 1; lin(j) ^= NEWLINE; k = k + 1) { file(k) = lin(j) j = j + 1 } file(k) = EOS if (k > 1 nlines = nlines + 1 if (lin(i) ^= COMMA) return(OKYES) i = i + 1 if (getone(lin, i, num) ^= OKYES) return(ERR) line2 = num nlines = nlines + 1 return(OKYES) end #-t- getlst 4_28 ascii 08/30/) call putlin(linbuf, STDOUT) # output appends j = APPENDLIST + LIST for (i = buf(j); i > 0; i = buf(i+LIST)) if (buf(i+COMMAND) == READCOM) call fcopy(buf(i+TEXT), STDOUT) # d integer k1, k2, junk include csedit cmd = buf(i+COMMAND) if (cmd == APPENDCOM) { buf(aq+LIST) = i aq = i buf(i+LIST) = 0 } else if (cmd == CHANGECOM) { linbuf(1) = EOS if (buf(i+NLINES) <= 2) { t (buf(k1), 1, temp1, 1) call icopys (buf(k2), 1, temp2, 1) call subst (linbuf, temp1, temp2, # call subst(linbuf, buf(k1), buf(k2), buf(i+SUBSTGFLAG), buf(i+SUBSTPFLAG)) } else if (cmd == WRITECOM) { if (buf(i+hile (getlin(lin, fd) ^= EOF) { if (lin(1) == PERIOD & lin(2) == NEWLINE) break junk = addis(lin, buf, lastbf, MAXBUF) } dotext = addi(EOS, buf, lastbf, MAXBUF) return end #-t- dotext 3_7 asc) getfn = OKYES } return end #-t- getfn 3_99 ascii 08/30/83 12:30:00 #-h- getlst 4_28 ascii 08/30/83 12:30:00 # getlst - get a list of line numbers starting at lin(i), increment i int83 12:30:00 #-h- getone 9_21 ascii 08/30/83 12:30:00 # getone - evaluate one line number expression, increment i integer function getone(lin, i, num) character lin(MAXLINE) integer i, istart, num integer addpat, ctoi,    optpat include csedit getone = OKYES call skipbl(lin, i) istart = i if (lin(i) >= DIG0 & lin(i) <= DIG9) { num = ctoi(lin, i) i = i - 1 # move back; to be advanced at the end if (num < 0) getone = ERRse getone = EOF if (getone == OKYES) i = i + 1 # point at next character to be examined call skipbl(lin, i) if (i <= istart) getone = EOF else getone = OKYES return end #-t- getone  i + 1 gflag = YES } else gflag = NO getrhs = OKYES return end #-t- getrhs 4_9 ascii 08/30/83 12:30:00 #-h- optpat 5_73 ascii 08/30/83 12:30:00 # optpat - make pattern if spec), pat) } if (pat(1) == EOS) i = ERR if (i == ERR) { pat(1) = EOS optpat = ERR } else optpat = OKYES return end #-t- optpat 5_73 ascii 08/30/83 12:30:00 #-h- maksub # missing delimiter maksub = ERR else if (addset(EOS, sub, j, MAXPAT) == NO) # no room maksub = ERR else maksub = i return end #-t- maksub 5_16 ascii 08/30/83 12:30:00 #-h- sed  { # buf1 contains last line call scopy(buf1, 1, linbuf, 1) break } lineno = lineno + 1 call docmds(buf1, lineno) if (getlin(buf1, fd) == EOF) { # buf2 contains last line call scopy(buf2, 1 num = -num } else if (lin(i) == LASTLINE) num = -HUGE else if (lin(i) == SLASH) { if (optpat(lin, i) == ERR) # build the pattern getone = ERR else if (lin(i) == SLASH) { num = lastbf # 9_21 ascii 08/30/83 12:30:00 #-h- getrhs 4_9 ascii 08/30/83 12:30:00 # getrhs - get substitution string for "s" command integer function getrhs(lin, i, sub, gflag) character lin(MAXLINE), sub(MAXPAT) integer maksub chified at lin(i) integer function optpat(lin, i) character lin(MAXLINE) integer makpat integer i include csedit if (lin(i) == EOS) i = ERR else if (lin(i + 1) == EOS) i = ERR else if (lin(i + 1) == lin(i))  5_16 ascii 08/30/83 12:30:00 ## maksub - make substitution string in sub integer function maksub(arg, from, delim, sub) character esc character arg(MAXARG), delim, sub(MAXPAT) integer addset integer from, i, j, junk  6_80 ascii 08/30/83 12:30:00 # sed-execute all commands for file fd, use linbuf and increment lineno subroutine sed(linbuf, lineno, fd) character linbuf(MAXLINE) integer lineno, fd character buf1(MAXLINE), buf2(MAXLINE), linbuf, 1) break } lineno = lineno + 1 call docmds(buf2, lineno) } return end #-t- sed 6_80 ascii 08/30/83 12:30:00 #-h- subst 8_14 ascii 08/30/83 12:30:00 #  junk = addis(pat, buf, lastbf, MAXBUF) # if (addi(EOS, buf, lastbf, MAXBUF) == NO) # insert pattern (special # problem with EOS marker) if (addpat(pat, buf, lastbf, MAXBUF) == NO) getone = ERR } } elaracter clower integer gflag, i getrhs = ERR if (lin(i) == EOS) return if (lin(i + 1) == EOS) return i = maksub(lin, i + 1, lin(i), sub) if (i == ERR) return if (clower(lin(i + 1)) == GLOBAL) { i =# repeated delimiter i = i + 1 # leave existing pattern alone else { # Patterns with closures (*) can't # be terminated with EOS if EOS is >= 0 for (j=1; j <= MAXPAT; j=j+1) pat(j) = PATEND i = makpat(lin, i + 1, lin(i 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 junk = addset(esc(arg, i), sub, j, MAXPAT) if (arg(i) != delim)  integer getlin include csedit if (getlin(buf1, fd) == EOF) return if (lineno > 0) { # do previous last line lineno = lineno + 1 call docmds(linbuf, lineno) } repeat { if (getlin(buf2, fd) == EOF)subst - substitute sub for occurrences of pat in txt subroutine subst(txt, pat, sub, gflag, pflag) character txt(MAXLINE), pat(ARB), sub(ARB) integer gflag, pflag character new(MAXLINE) integer addset, amatch integer j, junk, k, las   tm, m, subbed j = 1 subbed = NO lastm = 0 for (k = 1; txt(k) ^= EOS; ) { if (gflag == YES | subbed == NO) m = amatch(txt, k, pat) else m = 0 if (m > 0 & lastm ^= m) { # replace matched text rn end #-t- subst 8_14 ascii 08/30/83 12:30:00 #-h- usage 1_29 ascii 08/30/83 12:30:00 # usage - print usage message subroutine usage call error(_ "usage: sedit [-n] [[-e script | -f sfiles] | scaddis 2_68 ascii 08/30/83 12:30:00 ## addis - add character string to integer array(j); increment j integer function addis(s, str, j, maxsiz) character s(ARB) integer str(ARB) integer j, maxsiz integer i for OS return end #-t- icopys 2_26 ascii 08/30/83 12:30:00 #-h- gpat 3_64 ascii 08/30/83 12:30:00 ## gpat - copy pattern out of integer array (terminated by PATEND marker) # The endoding of patterns may inclu special PATEND marker) integer function addpat (pat, buf, j, maxsiz) character pat(ARB) integer buf(ARB), j, maxsiz integer i, lc # assume pattern array was initially filled # with PATEND markers. Thus first non-PATEND # chapatlen = 0; pat(patlen+1) != PATEND; patlen=patlen+1) ; return end #-t- patlen 1_45 ascii 08/30/83 12:30:00 #-t- sedit.rat 198_73 ascii 08/30/83 12:30:00 #-t- sedit.ar 207_8 ascii 09/02/83 09:15: subbed = YES call catsub(txt, k, m, sub, new, j, MAXLINE) lastm = m } if (m == 0 | m == k) { # no match or null match junk = addset(txt(k), new, j, MAXLINE) k = k + 1 } else ript] [files].") return end #-t- usage 1_29 ascii 08/30/83 12:30:00 #-h- addi 2_28 ascii 08/30/83 12:30:00 ## addi - put i in set(j) if it fits; increment j # similar to 'addset' only works with inte(i = 1; s(i) ^= EOS; i = i + 1) { if (j > maxsiz) return (NO) str(j) = s(i) j = j + 1 } return (YES) end #-t- addis 2_68 ascii 08/30/83 12:30:00 #-h- icopys 2_26 ascii 08/30/83 12:30:00 ## icode zero, which is often the EOS marker. # Thus a special routine is needed for moving patterns around. subroutine gpat (from, i, to, j) integer from(ARB), i, j character to(ARB) integer k1, k2 k2 = j for (k1 = i; from(k1) != PATEND; k1 = k1racter is end of pattern. for (lc = MAXPAT; lc > 0; lc = lc -1) { if (pat(lc) != PATEND) break } if ( (j+lc) > maxsiz) return (NO) # copy characters; terminate with PATEND for (i = 1; i <= lc+1; i=i+1) { buf(j) = pat(i) j =00 #-h- set.ar 37_53 ascii 09/02/83 09:15:00 #-h- list 0_9 ascii 08/30/83 12:30:00 set.rat #-t- list 0_9 ascii 08/30/83 12:30:00 #-h- set.rat 35_52 ascii 08/30/83 12:30 # skip matched text k = m } if (subbed == YES) { if (addset(EOS, new, j, MAXLINE) == NO) return call scopy(new, 1, txt, 1) if (pflag == YES) call putlin(txt, STDOUT) } retugers rather than characters integer function addi (i, set, j, maxsiz) integer i, set(maxsiz), j, maxsiz if (j > maxsiz) return (NO) set(j) = i j = j + 1 return (YES) end #-t- addi 2_28 ascii 08/30/83 12:30:00 #-h- pys - copy integer string to character string subroutine icopys (from, i, to, j) integer from(ARB), i, j character to(ARB) integer k1, k2 k2 = j for (k1 = i; from(k1) != EOS; k1 = k1 + 1) { to(k2) = from(k1) k2 = k2 + 1 } to(k2) = E + 1) { to(k2) = from(k1) k2 = k2 + 1 } to(k2) = EOS return end #-t- gpat 3_64 ascii 08/30/83 12:30:00 #-h- addpat 4_86 ascii 08/30/83 12:30:00 ## addpat - add pattern string to integer array (use j + 1 } return (YES) end #-t- addpat 4_86 ascii 08/30/83 12:30:00 #-h- patlen 1_45 ascii 08/30/83 12:30:00 ## patlen - get length of pattern integer function patlen (pat) character pat(ARB) for (:00 #-h- set.r 34_56 ascii 08/30/83 12:30:00 ## set - set an item in the environment file DRIVER(set) character line(MAXLINE) character value(MAXLINE) integer getarg, i integer delete, verbos string usage "usage: set [-v] [-d] i   tem value(s)" data delete /NO/ data verbos /NO/ call query (usage) if (getarg (1, line, MAXLINE) == EOF) call error (usage) if (line(1) == MINUS) { if (line(2) == LETV | line(2) == BIGV) verbos = YES else if (line(2) == LETD | line(2)te, verbos, i, ctoi, ctoc, getwrd, equal string equals " = " string on "ON" string off "OFF" string err "invalid item name: " string items "PATH TEMP MAXDEV DATE TAB HOME EXT LIST VERBOSE TTCOLS TTROWS ATEND CTRLC" # PATH TEMP MAXDEV DATE TAB MAXLINE) } ) define(do_int, {if (delete == YES) $1 = 0 else if (verbos == YES) {call putlin (name, STDOUT) call putlin(equals,STDOUT) i = $1 call putint (i, 1, STDOUT) call putch (NEWLINE, STDOUT)} else {i = 1; $1 = ctoi(value,i)} } ) define call putlin (name, STDOUT) call putlin (equals, STDOUT) call putch (maxdev, STDOUT) call newlin (STDOUT) } else if (value(1) < BIGA | value(1) > BIGP) { call remark ("illegal maxdev value.") return } else maxdev racter line (MAXLINE) include "cshstuff" fd = open (envfil, READ) if (fd == ERR) call cant (envfil) while (getlin(line, fd) != EOF) call putlin (line, STDOUT) call close (fd) return end ## evchar - change/print character item in environme# switch (j) # { # case 1: path(1) = E0S # case 2: tmpdef(1) = EOS # case 3: maxdev(1) = EOS # case 6: homedr(1) = EOS # case 7: extn(1) = EOS # case 12: atend(1) = EOS # } # } #else if (verbos == YES) #{call putlin (name, STDOUT) #call == BIGD) delete = YES for (i=2; getarg (i, line, MAXLINE) != EOF; i=i+1) call doit (line, EOS, delete, verbos) if (i == 2 & verbos == YES) call prtenv } else { call delarg (1) call getcl (value, MAXLINE) call doit (line, value, NHOME EXT LIST VERBOSE TTCOLS TTROWS ATEND CTRLC # 1 2 3 4 5 6 7 8 9 10 11 12 13 # c c c i b c c b b b b c b # path tmpdef maxdev ddate tabsiz homedr ex(do_onoff, {if (verbos == NO) {if (equal(value, on) == YES) value(1) = DIG1 else if (equal(value, off) == YES) value(1) = DIG0 else {call remark ("invalid value."); return} value(2) = EOS} do_int($1) } ) include config include cntrlc call= value(1) } case 4: call remark ("use 'date' tool to set and show date.") case 5: do_int(tabsiz) case 6: do_char(homedr) case 7: do_char(extn) case 8: do_onoff(list) case 9: do_onoff(vbose) case 10: do_int(ttcols) case 11: do_int(ttrowsnt #subroutine evchar (name, j, value, delete, verbos) #character name(ARB) # #integer j # index of item ## PATH TEMP MAXDEV DATE TAB HOME EXT LIST VERBOSE TTCOLS TTROWS ATEND ## 1 2 3 4 5 6 7 8 9 10 putlin (" = ", STDOUT) #call putlin ($1, STDOUT) #call putch (NEWLINE, STDOUT)} #else #i=ctoc(value,$1,MAXLINE) ) # #-t- set.r 34_56 ascii 08/30/83 12:30:00 #-t- set.rat 35_52 ascii 08/30/83 12:30:00 #-t- set.O, NO) } if (verbos == NO) # there were some changes made call setenv DRETURN end ## doit - perform operation on environment file subroutine doit (name, value, delete, verbos) character name(ARB), value(ARB) character buf(MAXLINE) integer deletn list vbose ttcols ttrows atend ctrlc define(do_char, {if (delete == YES) $1(1) = EOS else if (verbos == YES) {call putlin (name, STDOUT) call putlin(equals,STDOUT) call putlin ($1, STDOUT) call putch (NEWLINE, STDOUT)} else i=ctoc(value,$1, upper (name) call upper (value) i = 1 for (j=1; getwrd (items, i, buf) != 0; j=j+1) { if (equal (buf, name) == YES) # found it break } switch (j) { case 1: do_char(path) case 2: do_char(tmpdev) case 3: { if (verbos == YES) { ) case 12: do_char(atend) case 13: do_onoff(ctrlc) default: call putlin (err, ERROUT) call putlin (name, ERROUT) call putch (NEWLINE, ERROUT) } return end ## prtenv - print environment file subroutine prtenv integer open, fd, getlin cha 11 12 ## c c c i b c c b b b b c ## path tmpdef maxdev ddate tabsiz homedr extn list vbose ttcols ttrows atend # #character value(ARB) #integer delete, verbos # #if (delete == YES) # { ar 37_53 ascii 09/02/83 09:15:00 #-h- show.ar 16_102 ascii 09/02/83 09:15:00 #-h- list 0_10 ascii 08/30/83 12:30:00 show.rat #-t- list 0_10 ascii 08/30/83 12:30:00 #-h- sh   ow.rat 14_100 ascii 08/30/83 12:30:00 #-h- defns 0_52 ascii 08/30/83 12:30:00 # include standard symbols # include ratdef #-t- defns 0_52 ascii 08/30/83 12:30:00 #-h- show  #process flags { call remark ('ignoring invalid argument.') next } else { int = open(buf, READ) if (int == ERR) n't # work if you have subverted this convention subroutine showc (int) character c, getch integer int while (getch(c, int) ^= EOF) { if (c ^= NEWLINE & c < BLANK) { call putc(CARET) c = c + ATSIGN }  2_37 ascii 08/30/83 12:30:00 ## common block used to hold list of files from command line # Put on a file called 'flist' # Used by the tools: sort, format, lpr (VMS version), ls(VMS version) #flist - common block commo runs to date; init a(i)=1 for i=1...TAPENO-1 # a(TAPENO)=0 integer d # number of runs to add to tape; init d(i)=1 for i=1...TAPENO-1 # d(TAPENO)=0 integer level # Fibonacci level; init level=1 integer unit # rat4 unit for tap integer linptr # pointers to beginning of line in linbuf integer blanks # whether to skip leading blanks in compar; init=NO integer dict # whether to sort in dictionary order ; init=NO integer fold # whether to fold all characters to lcase  7_119 ascii 08/30/83 12:30:00 ## show - show what's in a file, displaying control characters DRIVER character buf(MAXLINE) integer getarg, open integer i, files data files /NO/ for (i=1; getarg(i, buf, MAXLINE) != EOF; i=i+1)  call cant(buf) } call showc (int) files = YES if (int != STDIN) call close(int) } if (files == NO) call showc (STDIN) #no files specified; read  if (c == NEWLINE) call putc(DOLLAR) call putc(c) } return end #-t- showc 3_69 ascii 08/30/83 12:30:00 #-t- show.rat 14_100 ascii 08/30/83 12:30:00 #-t- show.ar 16_102 asn /flist/ flevel, ffiles(FILENAMESIZE, FLMAX) integer flevel character ffiles #-t- flist 2_37 ascii 08/30/83 12:30:00 #-h- select 5_27 ascii 08/30/83 12:30:00 # select common block - used by sorter # pue integer t # array for mapping actual units to virtual units character file # names of temporary files #-t- select 5_27 ascii 08/30/83 12:30:00 #-h- sortcom 8_25 ascii 08/30/83 12:30:00 # sortcom common block; init=NO integer noprt # whether to ignore non-printing characs ; init=NO integer merg # whether is a merge only ; init=NO integer revers # whether to reverse comparisons ; init=NO integer subf # whether sort is on a subfield ; init=N { if (buf(1) == QMARK & buf(2) == EOS) #user needs help call error ("usage: show [file].") else if (buf(1) == MINUS & buf(2) == EOS) #read from STDIN int = STDIN else if (buf(1) == MINUS) from STDIN DRETURN end #-t- show 7_119 ascii 08/30/83 12:30:00 #-h- showc 3_69 ascii 08/30/83 12:30:00 ## showc - display all characters in file 'int' # This routine assumes all characters are ASCII--it wocii 09/02/83 09:15:00 #-h- sort.ar 150_10 ascii 09/02/83 09:15:00 #-h- list 0_34 ascii 08/30/83 12:30:00 flist select sortcom sort.rat #-t- list 0_34 ascii 08/30/83 12:30:00 #-h- flist t on a file called 'select' # used only by the sorter common / select / tape, a(TAPENO), d(TAPENO), level, unit(TAPENO), t(TAPENO), file(FILENAMESIZE, TAPENO) integer tape # current tape to write run to; init tape=1 integer a # number of - holds information about sort flags # put on a file called 'sortcom' # used only by the sorter common / sortcm / linptr(MAXPTR), blanks, dict, fold, noprt, merg, revers, subf, cofset, ifout, ofile(FILENAMESIZE), linbuf(MAXTEXT) O integer cofset # starting column of subfield ; init=0 integer ifout # if output file specified in command line; init=NO character ofile # file name of +ooutfile specified ; init=EOS character linbuf # buffer to hold lines for internal sort    #-t- sortcom 8_25 ascii 08/30/83 12:30:00 #-h- sort.rat 129_35 ascii 08/30/83 12:30:00 #-h- defns 1_94 ascii 08/30/83 12:30:00 # include ratdef # definitions for sort tool # used only by thes, makrun, sunit, nruns character buf(MAXLINE) include select include sortcom call srtint status = OK nruns = 0 repeat { if (status == OK) # haven't reached EOI yet { status = makrun(nlines)  # set up temporary files } else nlines = 0 if (sum(d, TAPENO-1) > 0 | nlines > 0) { call stape if (a(tape) > 1) call puteor(unit(tape)) call putrun(linptr, nlines, linbufl = t(TAPENO) if (level == 1) { sunit = unit(outfil) # save scratch unit # call redout # redirect STDOUT if necessary unit(outfil) = STDOUT # copy sorted file directly to STDOU if (unit(i) == ERR) call cant(file(1,i)) call close(unit(j)) unit(j) = open(file(1,j), READ) if (unit(j) == ERR) call cant(file(1,j)) t(TAPENO) = i t(ieof) = j level = level - 1 } until (level == 0 NO for (i=1; getarg(i, temp, FILENAMESIZE) != EOF; i=i+1) { if (temp(1) == QMARK & temp(2) == EOS) call error('usage: sort [-bdfimr] [+sn] [files].') else if (temp(1) == MINUS & temp(2) != EOS) { if (index(temp sort tool define(LOGPTR,20) define(MAXPTR,750) define(MAXTEXT,12000) define(TAPENO,6) define(CTRLD,4) define(FLMAX,25) define(EOI,ERR) #-t- defns 1_94 ascii 08/30/83 12:30:00 #-h- sorts 22_89 asc # make a run nruns = nruns + 1 # update number of runs if (merg == NO) call quick(linptr, nlines, linbuf) # sort run if (nruns == 1) if (status == EOI) # internal sort on, unit(tape)) } } until (sum(d, TAPENO-1) == 0 & status == EOI) # open files for merge for (i=1; i < TAPENO; i=i+1) { t(i) = i call close(unit(i)) #change from WRITE to READ access unit(i) = open(filT } repeat { call mrgrun(ieof) if (ieof == 0) call puteor(unit(outfil)) } until(ieof > 0) # one of the units terminated on EOF if (level == 1) { unit(out) # sorted results on t(ieof) # eliminate temporary files call cleans return end #-t- sorts 22_89 ascii 08/30/83 12:30:00 #-h- srtint 11_33 ascii 08/30/83 12:30:00 subroutine srtint , LETB) != 0 | index(temp, BIGB) != 0) blanks = YES if (index(temp, LETD) != 0 | index(temp, BIGD) != 0) dict = YES if (index(temp, LETF) != 0 | index(temp, BIGF) != 0) fold = YES if (index(ii 08/30/83 12:30:00 DRIVER # (dummy routine necessary for proper returning from main # sort driver) call sorts DRETURN end subroutine sorts integer nlines, sum, i, n, getlin, eor, open, outfil, ieof, j filedes create integer statuly { # call redout # redirect STDOUT if necessary call putrun(linptr, nlines, linbuf, STDOUT) return } else call fsetup e(1,i), READ) if (unit(i) == ERR) call cant(file(1,i)) } unit(TAPENO) = create(file(1,TAPENO), WRITE) if (unit(TAPENO) == ERR) call cant(file(1,TAPENO)) t(TAPENO) = TAPENO # now merge runs repeat { outfifil) = sunit # restore scratch unit break # stop loop, sorted file already on STDOUT } i = t(ieof) j = t(TAPENO) call close(unit(i)) #change file accesses unit(i) = open(file(1,i), WRITE)  character temp(FILENAMESIZE), clower integer i, n, getarg, index, ctoi include select include sortcom include flist flevel = 0 blanks = NO dict = NO fold = NO noprt = NO merg = NO revers = NO subf = NO cofset = 0 # ifout =temp, LETI) != 0 | index(temp, BIGI) != 0) noprt = YES if (index(temp, LETM) != 0 | index(temp, BIGM) != 0) merg = YES if (index(temp, LETR) != 0 | index(temp, BIGR) != 0) revers = YES }     else if (temp(1) == PLUS & clower(temp(2)) == LETS) { subf = YES n = 3 cofset = ctoi(temp, n) - 1 if (cofset < 0) cofset = 0 } # else if (temp(1) == PLUS & clower(temp(2)) == LETO)  call error ("too many arguments.") flevel = flevel + 1 for (i=1; iarg(i) != EOS; i=i+1) ffiles(i,flevel) = iarg(i) ffiles(i,flevel) = EOS return end #-t- fstack 3_52 ascii 08/30/83 12:30:00 #-h- mTR) break } } if (len == EOI) makrun = EOI else makrun = OK return end #-t- makrun 4_63 ascii 08/30/83 12:30:00 #-h- putrun 1_121 ascii 08/30/83 12:30:00 subroutine p bump one Fibonacci level { level = level + 1 z = a(1) for (i=1; i < TAPENO; i=i+1) { d(i) = z + a(i+1) - a(i) a(i) = z + a(i+1) } } tape = 1 } d(t call putch(NEWLINE, int) return end #-t- puteor 0_112 ascii 08/30/83 12:30:00 #-h- sum 1_14 ascii 08/30/83 12:30:00 integer function sum(array, n) integer array(ARB), n, i sum = 0 for (i=1; i<= 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 = linptr(j) # pivot line # { # ifout = YES # call scopy(temp, 3, ofile, 1) # } else call fstack(temp) } return end #-t- srtint 11_33 ascii 08/30/83 12:30:00 #-h- fstack 3_52 ascii 08/30/83 12akrun 4_63 ascii 08/30/83 12:30:00 integer function makrun(nlines) integer nlines, lbp, len, gsrtln include sortcom nlines = 0 lbp = 1 repeat { len = gsrtln(linbuf(lbp)) if (len == EOI) break utrun(linptr, nlines, linbuf, outfil) character linbuf(MAXTEXT) integer i, j, linptr(MAXPTR), nlines, outfil for (i=1; i <= nlines; i=i+1) { j = linptr(i) call putlin(linbuf(j), outfil) } return end #-t- putrun ape) = d(tape) - 1 return end #-t- stape 3_59 ascii 08/30/83 12:30:00 #-h- eor 1_33 ascii 08/30/83 12:30:00 integer function eor(buffer) character buffer(ARB) if (buffer(1) == CTRLD & buffer(2) ==n; i=i+1) sum = sum + array(i) return end #-t- sum 1_14 ascii 08/30/83 12:30:00 #-h- quick 11_62 ascii 08/30/83 12:30:00 #--------------------------------------------------------------------  while (i < j) { for (i=i+1; compar(linptr(i), pivlin, linbuf) < 0; i=i+1) ; for (j = j - 1; j > i; j = j - 1) if (compar(linptr(j), pivlin, linbuf) <= 0) break :30:00 #------------------------------------------------------------ ## fstack - generate stack of input files subroutine fstack (iarg) integer i character iarg(FILENAMESIZE) include flist if (flevel >= FLMAX)  if (len == EOF & merg == YES) break if (len != EOF) { nlines = nlines + 1 linptr(nlines) = lbp lbp = lbp + len + 1 # "1" is room for EOS if (lbp >= MAXTEXT - MAXLINE | nlines >= MAXP 1_121 ascii 08/30/83 12:30:00 #-h- stape 3_59 ascii 08/30/83 12:30:00 subroutine stape integer i, z include select if (d(tape) < d(tape+1)) tape = tape + 1 else { if (d(tape) == 0) # NEWLINE) eor = YES else eor = NO return end #-t- eor 1_33 ascii 08/30/83 12:30:00 #-h- puteor 0_112 ascii 08/30/83 12:30:00 subroutine puteor(int) integer int call putch(CTRLD, int)  ## quick - quicksort for character lines subroutine quick(linptr, nlines, linbuf) character linbuf(ARB) integer compar integer i, j, linptr(ARB), lv(LOGPTR), nlines, p, pivlin, uv(LOGPTR) lv(1) = 1 uv(1) = nlines  if (i < j) # out of order pair call exchan(linptr(i), linptr(j), linbuf) } j = uv(p) # move pivot to position i call exchan(linptr(i), linptr(j), linbuf) 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) c1,c2 character clower include sortcom i = lp1 j = lp2 if (blanks == YES) # ignore leading blanks { while (lin(i) == BLANK) i = i + 1 while (lin(j) == BLANK) j = j + 1 } else i(j) > 0 & lin(j) < 32) | lin(j) == 127) j = j + 1 } if (dict == YES) #dictionary order--only letters & digits & blanks { repeat { ct = type (lin(i)) i if (c1 != c2) break i = i + 1 j = j + 1 } if (c1 < c2 ) compar = -1 else compar = +1 if (revers == YES) compar = -compar return end #-t- compar 2:30:00 # merges one run from unit(t(i)),...,unit(t(TAPENO-1)) onto # unit(t(TAPENO)) # returns a value of 0 if all files terminate on EOR # returns index of file which terminated on EOF (1...TAPENO-1) subroutine mrgrun(ieofnf > 0) { lbp = linptr(1) call putlin(linbuf(lbp), unit(outfil)) # write top line of heap i = lbp / MAXLINE + 1 # compute index of file k = t(i) n = getlin(linbuf(lbp), unit(k)) if (n == EOF | e= i - 1 } p = p + 1 # push onto stack } return end #-t- quick 11_62 ascii 08/30/83 12:30:00 #-h- compar 15_119 ascii 08/30/83 12:30:00 #-----------------f (subf == YES) { while (lin(i) != EOS) i = i + 1 while (lin(j) != EOS) j = j + 1 if (i > lp1 + cofset) i = lp1 + cofset if (j > lp2 + cofset) j = lp2 + cofset } repeat { if (lin(i) == EOf (ct == LETTER | ct == DIGIT | ct== BLANK | ct == EOS) break i = i + 1 } repeat { ct = type (lin(j)) if (ct == LETTER | ct == DIGIT | ct == BLANK | ct == EOS) break  15_119 ascii 08/30/83 12:30:00 #-h- exchan 2_46 ascii 08/30/83 12:30:00 #-------------------------------------------------------------------- ## exchan - exchange linbuf(lp1) with linbuf(lp2) subroutine exchan(lp1, lp2) integer outfil, lbp, nf, i, k, n, getlin, eor, ieof include select include sortcom outfil = t(TAPENO) lbp = 1 nf = 0 ieof = 0 for (i=1; i < TAPENO; i=i+1) { k = t(i) n = getlin(linbuf(lbp), unit(k)) if (n != EOF or(linbuf(lbp)) == YES) { linptr(1) = linptr(nf) nf = nf - 1 if (n == EOF) ieof = i } call reheap(linptr, nf, linbuf) } return end #-t- mrgrun 9_69 ascii 08/30/8------------------------------------------------ ## compar - compare lin(lp1) with lin(lp2) integer function compar(lp1, lp2, lin) character lin(ARB) integer i, j, lp1, lp2 character type character ct character S) { compar = 0 return } if (noprt == YES) #ignore non-printing characters { while ((lin(i) > 0 & lin(i) < 32) | lin(i) == 127) i = i + 1 while ((lin j = j + 1 } } if (fold == YES) { c1 = clower (lin(i)) c2 = clower(lin(j)) } else { c1 = lin(i) c2 = lin(j) } , linbuf) character linbuf(ARB) integer k, lp1, lp2 k = lp1 lp1 = lp2 lp2 = k return end #-t- exchan 2_46 ascii 08/30/83 12:30:00 #-h- mrgrun 9_69 ascii 08/30/83 1& eor(linbuf(lbp)) != YES) { nf = nf + 1 linptr(nf) = lbp } else if (n == EOF) ieof = i lbp = lbp + MAXLINE } call quick(linptr, nf, linbuf) # now have initial heap while (3 12:30:00 #-h- reheap 5_35 ascii 08/30/83 12:30:00 #-------------------------------------------------------------------- ## reheap - propagate linbuf(linptr(1)) to proper place in heap subroutine reheap(linptr, nf, lin   buf) character linbuf(MAXTEXT) integer compar integer i, j, nf, linptr(ARB) for (i = 1; 2 * i <= nf; i = j) { j = 2 * i if (j < nf) # find smaller child if (compar(linptr(j), linptr(j+1), linbu 1_8 ascii 08/30/83 12:30:00 #-h- gsrtln 7_21 ascii 08/30/83 12:30:00 integer function gsrtln(buf) character buf(MAXLINE) integer getlin, init, level, fopen, open, infile include flist data init/0/  call cant(ffiles(1, level)) } } gsrtln = getlin(buf, infile) if (gsrtln == EOF) { fopen = NO if (infile != STDIN) call close(infile) } } return end call cant(file(1,i)) } else unit(i) = 0 } d(TAPENO) = 0 a(TAPENO) = 0 return end #-t- fsetup 3_127 ascii 08/30/83 12:30:00 #-h- redout 1_106 ascii 08/30/83 12:30:00 # subrascii 08/30/83 12:30:00 split.rat #-t- list 0_11 ascii 08/30/83 12:30:00 #-h- split.rat 38_78 ascii 08/30/83 12:30:00 #-h- defns 1_77 ascii 08/30/83 12:30:00 # include standard symbol definitpyl integer fn, fin, fout, nl, i, ccase string x "x" nl = NLINES call scopy(x, 1, prefix, 1) fin = STDIN ccase = 1 i = 1 if (getarg(i, line, MAXLINE) ^= EOF) { if (line(1) == QMARK & line(2) == EOS) #user nf) > 0) j = j + 1 if (compar(linptr(i), linptr(j), linbuf) <= 0) break # proper position found call exchan(linptr(i), linptr(j), linbuf) # percolate } return end #-t- reheap if (init == 0) { level = 0 if (flevel == 0) { flevel = 1 call scopy('-', 1, ffiles(1,1), 1) } init = 1 fopen = NO } if (fopen == NO & level == flevel) gsrtln = EOI else {  #-t- gsrtln 7_21 ascii 08/30/83 12:30:00 #-h- fsetup 3_127 ascii 08/30/83 12:30:00 subroutine fsetup character temp(4) integer i, n, itoc filedes create include select tape = 1 level = 1 for (outine redout # # integer assign # # include sortcom # # if (ifout == YES) # if (assign(ofile, STDOUT, WRITE) == ERR) # call remark("Cannot redirect standard output to +o file.") # # return # end #-t- redout ions # include ratdef define(NLINES,100) # default lines/file define(MAXFILES,676) # maximum number of files; 676 = aa...zz define(NAMESIZE,FILENAMESIZE) #-t- defns 1_77 ascii 08/30/83 12:30:00 #-h- split eeds help call error ("usage: split [-n or +from [-to]] [file [out]].") else if (line(1) == MINUS & line(2) ^= EOS) { i = 2 nl = ctoi(line, i) if (nl <= 0 | line(i) ^= EOS) { call remark("bad arg 5_35 ascii 08/30/83 12:30:00 #-h- cleans 1_8 ascii 08/30/83 12:30:00 subroutine cleans integer i include select for (i=1; i <= TAPENO; i=i+1) call remove(file(1,i)) return end #-t- cleans if (fopen == NO) { fopen = YES level = level + 1 if (ffiles(1, level) == MINUS) infile = STDIN else { infile = open(ffiles(1, level), READ) if (infile == ERR) i=1; i <= TAPENO; i=i+1) { a(i) = 1 d(i) = 1 temp(1) = LETS n = itoc(i, temp(2), 3) call mkuniq(temp, file(1,i)) if (i < TAPENO) { unit(i) = create(file(1,i), WRITE) if (unit(i) == ERR)  1_106 ascii 08/30/83 12:30:00 #-t- sort.rat 129_35 ascii 08/30/83 12:30:00 #-t- sort.ar 150_10 ascii 09/02/83 09:15:00 #-h- split.ar 40_81 ascii 09/02/83 09:15:00 #-h- list 0_11  22_111 ascii 08/30/83 12:30:00 # split - split file into n-line pieces or at specified patterns DRIVER(split) character line(MAXLINE), prefix(NAMESIZE), from(MAXPAT), to(MAXPAT) integer getarg, open, maknam, getlin, ctoi, getpat, copyp, coument.") call error("usage: split [-n | +from [-to]] [file [name]].") } i = 2 } else if (line(1) == PLUS) { ccase = 2 if (getpat(line(2), from) == ERR) call error("illega   l from pattern.") i = 2 if (getarg(i, line, MAXLINE) ^= EOF) if (line(1) == MINUS & line(2) ^= EOS) { ccase = 3 if (getpat(line(2), to) == ERR) call error("illegal to patte) call putlin(line, fout) if (fn >= MAXFILES) # copy everything if last file call fcopy(fin, fout) else if (copyl(fin, fout, nl-1) == EOF) break call close(fout) } } e fout = maknam(prefix, fn - 1) call putlin(line, fout) if (fn >= MAXFILES) call fcopy(fin, fout) else if (copyp(fin, fout, line, to) ^= EOF) call putlin(line, fout) call turn(EOF) else call putlin(line, fdo) return(i-1) end #-t- copyl 2_62 ascii 08/30/83 12:30:00 #-h- copyp 3_47 ascii 08/30/83 12:30:00 # copyp - copy lines from fdi to fdo until line matc- create file n using prefix integer function maknam(prefix, n) character prefix(ARB) integer n character name(NAMESIZE) integer length, mod, create call scopy(prefix, 1, name, 1) i = length(name) name(i+1) = n/26 + LETA årn.") i = 3 } } if (getarg(i, line, MAXLINE) ^= EOF) { if (line(1) == MINUS & line(2) == EOS) fin = STDIN else fin = open(line, READ) if (fin == ERR) call cantlse if (ccase == 2) { # split +from [file [name]] nl = copyp(fin, -1, line, from) for (fn = 1; nl ^= EOF; fn = fn + 1) { fout = maknam(prefix, fn - 1) call putlin(line, fout) if (fn >= MAXFILES) close(fout) } } else call error("split: can't happen.") if (fin ^= STDIN) call close(fin) DRETURN end #-t- split 22_111 ascii 08/30/83 12:30:00 #-h- copyl 2_62 ascii 0hing pat is found integer function copyp(fdi, fdo, buf, pat) integer fdi, fdo character buf(MAXLINE), pat(MAXPAT) integer n, match, getlin for (n = 0; getlin(buf, fdi) ^= EOF; n = n + 1) if (match(buf, pat) == YES) re # add aa, ab, etc. name(i+2) = mod(n, 26) + LETA name(i+3) = EOS maknam = create(name, WRITE) if (maknam == ERR) call cant(name) return end #-t- maknam 3_57 ascii 08/30/83 12:30:00 #-t- split.rat å(line) } } if (getarg(i+1, line, MAXLINE) ^= EOF) call scopy(line, 1, prefix, 1) if (ccase == 1) { # split [-n] [file [name]] for (fn = 1; getlin(line, fin) ^= EOF; fn = fn + 1) { fout = maknam(prefix, fn - 1 call fcopy(fin, fout) nl = copyp(fin, fout, line, from) call close(fout) } } else if (ccase == 3) { # split +from -to [file [name]] for (fn = 1; copyp(fin, -1, line, from) ^= EOF; fn = fn + 1) { 8/30/83 12:30:00 # copyl - copy n lines from fdi to fdo integer function copyl(fdi, fdo, n) integer fdi, fdo, n, i character line(MAXLINE) integer getlin for (i = 1; i <= n; i = i + 1) if (getlin(line, fdi) == EOF) return (n) else if (fdo >= 0) # fdo < 0 causes skips call putlin(buf, fdo) return (EOF) end #-t- copyp 3_47 ascii 08/30/83 12:30:00 #-h- maknam 3_57 ascii 08/30/83 12:30:00 # maknam  38_78 ascii 08/30/83 12:30:00 #-t- split.ar 40_81 ascii 09/02/83 09:15:00 ERR) call cant(name) return end #-t- maknam 3_57 ascii 08/30/83 12:30:00 #-t- split.rat å   #-h- tail.ar 33_2 ascii 09/02/83 09:15:00 #-h- list 0_10 ascii 08/30/83 12:30:00 tail.rat #-t- list 0_10 ascii 08/30/83 12:30:00 #-h- tail.rat 31_0 ascii 08/30/83 12:30:00 for (i=1; getarg(i, arg, MAXLINE) != EOF; i=i+1) { if (arg(1) == QMARK & arg(2) == EOS) call error ("usage: tail [-n] [files].") else if (arg(1) == MINUS & arg(2) != EOS) { j = } } if (fd == ERR) #no files specified, read STDIN call ptail (n, STDIN) DRETURN end #-t- tail 8_44 ascii 08/30/83 12:30:00 #-h- ptail 12_59 ascii 08/30/83 1 (i == 0) # i = MAXBUF # if (buf(i) == NEWLINE) { # n = n - 1 # if (n < 0) { # i = mod(i, MAXBUF) + 1 # break # } # } # } # for (head = i; head ^= tail; head =head; ) { i = i - 1 if (i == 0) i = MAXBUF if (buf(i) == NEWLINE) { n = n - 1 if (n < 0) { i = i+1 if (i == MAXBUF) i = 1 break } } } for (head = i; head ^= tail; head = head + 1) { if (head == MAXB return end subroutine addil$ (pos,delta) integer pos(2), delta integer i,j,isign,iabs i = iabs(delta) j = i / 128 i = i & 127 i = pos(1) + isign(i,delta) j = pos(2) + isign(j,delta) while (i < 0) { i = i+128 j = j-1 } while (i > 127)  #-h- defns 1_37 ascii 08/30/83 12:30:00 # include standard symbol definitions # include ratdef define(MAXBUF,3000) # line buffer size define(DEFAULT,23) # default if no argument #-t- defns  2 n = ctoi(arg, j) if (n <= 0) call error ("invalid size.") } else if (arg(1) == MINUS & arg(2) == EOS) { fd = STDIN ca2:30:00 ## ptail - print last 'n' lines of file 'fd' # original version, see below for CP/M version. # subroutine ptail (nlins, fd) # integer n, fd, nlins # character buf(MAXBUF) # character getch # integer head, tail, i # # head = 1 # mod(head, MAXBUF) + 1) # call putch(buf(head), STDOUT) # # return # end # # CP/M version subroutine ptail (nlins, fd) integer n, fd, nlins character buf(MAXBUF) character getch integer head, tail, i head = 1 tail = 1 UF) head = 1 call putch(buf(head), STDOUT) } return end #-t- ptail 12_59 ascii 08/30/83 12:30:00 #-h- rseek 5_4 ascii 08/30/83 12:30:00 ## rseek - relative seek in file subroutine rseek(delta,from,fd { i = i-128 j = j+1 } pos(1) = i pos(2) = j return end #-t- rseek 5_4 ascii 08/30/83 12:30:00 #-t- tail.rat 31_0 ascii 08/30/83 12:30:00 #-t- tail.ar 33_2 ascii 09/02/83 09:15:00 #- 1_37 ascii 08/30/83 12:30:00 #-h- tail 8_44 ascii 08/30/83 12:30:00 # tail - print tail portion of a file DRIVER character arg(MAXLINE) integer n, i, fd integer ctoi, getarg, open n = DEFAULT fd = ERR ll ptail (n, fd) } else { fd = open(arg, READ) if (fd == ERR) call cant(arg) call ptail (n, fd) call close(fd)  tail = 1 # n = nlins # while (getch(buf(tail), fd) ^= EOF) { # tail = mod(tail, MAXBUF) + 1 # if (tail == head) # head = mod(head, MAXBUF) + 1 # } # for (i = tail; i ^= head; ) { # i = i - 1 # if n = nlins call rseek (-(n+MAXBUF),2,fd) while (getch(buf(tail), fd) ^= EOF) { tail = tail + 1 if (tail == MAXBUF) tail = 1 if (tail == head) { head = head + 1 if (head == MAXBUF) head = 1 } } for (i = tail; i ^= ) integer delta, from, fd integer pos(2) if (from == 0) call seek(BEGINNING_OF_FILE,fd) else if (from == 2) call seek(END_OF_FILE,fd) call note(pos,fd) call addil$ (pos,delta) if (pos(2) < 0) { pos(1) = 0 pos(2) = 0 } call seek(pos,fd) h- tee.ar 10_23 ascii 09/02/83 09:15:00 #-h- list 0_9 ascii 08/30/83 12:30:00 tee.rat #-t- list 0_9 ascii 08/30/83 12:30:00 #-h- tee.rat 8_22 ascii 08/30/83 12:30:00 #   -h- defns 0_70 ascii 08/30/83 12:30:00 # include ratdef define(MAXFILES,16) define(MAXNAME,FILENAMESIZE) #-t- defns 0_70 ascii 08/30/83 12:30:00 #-h- tee 5_88 ascii 08/30/83 12:30:00 #hile (getc(c) ^= EOF) { for (i = 1; i <= nfiles; i = i + 1) call putch(c, fdo(i)) call putc(c) } for (i = 1; i <= nfiles; i = i + 1) call close(fdo(i)) DRETURN end #-t- tee 5_88 asciefns 0_43 ascii 08/30/83 12:30:00 #-h- tr 11_22 ascii 08/30/83 12:30:00 ## tr - transliterate characters on a file DRIVER character getc character arg(MAXLINE), c, from(MAXSET), to(MAXSET) AXLINE) == EOF) to(1) = EOS else if (makset(arg, 1, to, MAXSET) == NO) call error('to: too large.') lastto = length(to) if (length(from) > lastto | allbut == YES) collap = YES else collap = NO N end #-t- tr 11_22 ascii 08/30/83 12:30:00 #-h- makset 2_57 ascii 08/30/83 12:30:00 ## makset - make set from array(k) in set integer function makset(array, k, set, size) integer addset  EOF) xindex = 0 else if (allbut == NO) xindex = index(array, c) else if (index(array, c) > 0) xindex = 0 else xindex = lastto + 1 return end #-t- xindex 3_11 ascii 08/30/83 12:3 tee - copy standard input to named files and to standard output DRIVER character c, getc, name(MAXNAME) integer getarg, create, fdo(MAXFILES), i, nfiles for (i = 1; getarg(i, name, MAXNAME) ^= EOF; i = i + 1) { if (name(1) == QMARK &i 08/30/83 12:30:00 #-t- tee.rat 8_22 ascii 08/30/83 12:30:00 #-t- tee.ar 10_23 ascii 09/02/83 09:15:00 #-h- tr.ar 22_117 ascii 09/02/83 09:15:00 #-h- list 0_8 ascii 08/30/integer getarg, length, makset, xindex integer allbut, collap, i, lastto call query ("usage: tr from to.") if (getarg(1, arg, MAXLINE) == EOF) call error('usage: tr from to.') else if (arg(1) == NOT) { allbut = YES repeat { i = xindex(from, getc(c), allbut, lastto) if (collap == YES & i >= lastto & lastto > 0) { # collapse call putc(to(lastto)) repeat i = xindex(from, getc(c), allbut, lastto) until (i integer i, j, k, size character array(ARB), set(size) i = k j = 1 call filset(EOS, array, i, set, j, size) makset = addset(EOS, set, j, size) return end #-t- makset 2_57 ascii 08/30/83 12:30:00 #0:00 #-t- tr.rat 20_117 ascii 08/30/83 12:30:00 #-t- tr.ar 22_117 ascii 09/02/83 09:15:00 #-h- tsort.ar 59_50 ascii 09/02/83 09:15:00 #-h- list 0_11 ascii 08/30/83 12:30:00 ts name(2) == EOS) call error ("usage: tee files .") if (i > MAXFILES) call error("too many files.") fdo(i) = create(name, WRITE) if (fdo(i) == ERR) call cant(name) } nfiles = i - 1 w83 12:30:00 tr.rat #-t- list 0_8 ascii 08/30/83 12:30:00 #-h- tr.rat 20_117 ascii 08/30/83 12:30:00 #-h- defns 0_43 ascii 08/30/83 12:30:00 # include ratdef define(MAXSET,100) #-t- d if (makset(arg, 2, from, MAXSET) == NO) call error('from: too large.') } else { allbut = NO if (makset(arg, 1, from, MAXSET) == NO) call error('from: too large.') } if (getarg(2, arg, M < lastto) } if (c == EOF) break if (i > 0 & lastto > 0) # translate call putc(to(i)) else if (i == 0) # copy call putc(c) # else delete } DRETUR-h- xindex 3_11 ascii 08/30/83 12:30:00 ## xindex - invert condition returned by index integer function xindex(array, c, allbut, lastto) character array(ARB), c integer index integer allbut, lastto if (c ==ort.rat #-t- list 0_11 ascii 08/30/83 12:30:00 #-h- tsort.rat 57_47 ascii 08/30/83 12:30:00 #-h- tsort.r 10_40 ascii 08/30/83 12:30:00 define(MAXBUF,5000) # storage array define(MAXSYMBOL,120   ) # maximum symbol size # symbol table entries define(NEXT,0) # pointer to next entry define(SYMBOL,1) # pointer to symbol structure define(CHARS,2) # characters in symbol # node structure define(LINK,0) # pointer t if (arg(1) == QMARK & arg(2) == EOS) call usage else if (arg(1) == MINUS & arg(2) == EOS) fd = STDIN else { fd = open(arg, READ) if (fd == ERR) er getwrd, getlin, looks integer hash # hash table headers integer nxtsym # next symbol structure integer nxtfre # next free word at bottom of buf integer buf # free storage common /ctsort/ hash(128), nxtsym, nxtfre, buf(MAXBUF) n0 if (buf(i+COUNT) == 0) f = i for (r = f; i < nxtsym; i = i + SYMSIZE) # find rest of 0 counts if (buf(i+COUNT) == 0) { buf(r+COUNT) = i r = i } n = nxtsym # will be 0 if non-circular SIZE } if (n > 1) call error("circular.") return end #-t- tpsort 13_105 ascii 08/30/83 12:30:00 #-h- entprc 3_105 ascii 08/30/83 12:30:00 # entprc - enter the relation a < b subroutine e 7_34 ascii 08/30/83 12:30:00 ## looks - lookup symbol s, insert if necessary integer function looks(s) character s(MAXSYMBOL), lin(MAXSYMBOL) integer j integer i integer length, nalloc, equal, symalc integer haso next node define(SUCC,1) # pointer to successor symbol structure define(NODESIZE,2) # size of node structure # symbol structure define(NAME,0) # symbol structure; pointer to name define(COUNT,1) # successor count defi call cant(arg) } call tpsort (fd) if (fd != STDIN) call close(fd) } if (i == 1) #read STDIN call tpsort (STDIN) DRETURN end #-t- tsort.r xtsym = 1 # initialize nxtfre = MAXBUF for (i = 1; i <= 128; i = i + 1) hash(i) = 0 while (getlin(linbuf, fd) ^= EOF) { i = 1 if (getwrd(linbuf, i, symbuf) <= 0) # ignore blank lines next j = looks( for (; f > 0; f = buf(f+COUNT)) { # print in topological order # call putlin(buf(buf(f+NAME)), STDOUT) call icopys (buf, buf(f+NAME), linbuf, 1) call putlin(linbuf, STDOUT) call putch(NEWLINE, STDOUT) for (i = buf(f+ntprc(a, b) integer a, b integer p integer nalloc integer hash # hash table headers integer nxtsym # next symbol structure integer nxtfre # next free word at bottom of buf integer buf # free storage common /ctsort/ hash(128)h # hash table headers integer nxtsym # next symbol structure integer nxtfre # next free word at bottom of buf integer buf # free storage common /ctsort/ hash(128), nxtsym, nxtfre, buf(MAXBUF) j = s(1) + 1 for (i = hash(j); i > 0;ne(TOP,2) # beginning of successor list define(SYMSIZE,3) # size of symbol structure DRIVER integer getarg, open integer i, fd character arg(FILENAMESIZE) for (i=1; getarg(i, arg, FILENAMESIZE) != EOF; i=i+1) {  10_40 ascii 08/30/83 12:30:00 #-h- tpsort 13_105 ascii 08/30/83 12:30:00 ## tpsort - topological sort file 'fd' subroutine tpsort (fd) character linbuf(MAXLINE), symbuf(MAXSYMBOL) integer i, j, f, r, n, fd integsymbuf) while (getwrd(linbuf, i, symbuf) > 0) call entprc(j, looks(symbuf)) # insert a relation } f = 0 # build list of symbols with 0 counts for (i = 1; i < nxtsym & f == 0; i = i + SYMSIZE) # find first TOP); i > 0; i = buf(i+LINK)) { j = buf(i+SUCC) buf(j+COUNT) = buf(j+COUNT) - 1 if (buf(j+COUNT) == 0) { # add more onto list buf(r+COUNT) = j r = j } } n = n - SYM, nxtsym, nxtfre, buf(MAXBUF) buf(b+COUNT) = buf(b+COUNT) + 1 p = nalloc(NODESIZE) buf(p+LINK) = buf(a+TOP) buf(p+SUCC) = b buf(a+TOP) = p return end #-t- entprc 3_105 ascii 08/30/83 12:30:00 #-h- looks  i = buf(i+NEXT)) { call icopys (buf, i+CHARS, lin, 1) # convert from int to char if (equal(s, lin) == YES) # got it return (buf(i+SYMBOL)) } i = nalloc(CHARS + 1 + length(s) + 1) # must make    new entry j = s(1) + 1 buf(i+NEXT) = hash(j) # add onto proper hash chain hash(j) = i buf(i+SYMBOL) = symalc(i+CHARS) call scopyi(s, 1, buf, i + CHARS) return (buf(i+SYMBOL)) end #-t- looks 7_34 ascii 08nd #-t- nalloc 3_53 ascii 08/30/83 12:30:00 #-h- symalc 4_16 ascii 08/30/83 12:30:00 # symalc - allocate a symbol structure for symbol s integer function symalc(s) integer s integer p integer hash 3 12:30:00 subroutine usage call error ("usage: tsort [files].") return end #-t- usage 0_77 ascii 08/30/83 12:30:00 #-h- icopys 2_84 ascii 08/30/83 12:30:00 ## icopys - copy integer string at from(i)m, i, to, j) character from(ARB) integer 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 #-t- scopyåå/30/83 12:30:00 #-h- nalloc 3_53 ascii 08/30/83 12:30:00 # nalloc - allocate n words in top part of buf integer function nalloc(n) integer n integer hash # hash table headers integer nxtsym # next symbol structure  # hash table headers integer nxtsym # next symbol structure integer nxtfre # next free word at bottom of buf integer buf # free storage common /ctsort/ hash(128), nxtsym, nxtfre, buf(MAXBUF) p = nxtsym nxtsym = nxtsym + SYMSIZE  to char string at to(j) subroutine icopys(from, i, to, j) integer from(ARB) character 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 }i 2_81 ascii 08/30/83 12:30:00 #-t- tsort.rat 57_47 ascii 08/30/83 12:30:00 #-t- tsort.ar 59_50 ascii 09/02/83 09:15:00 åå integer nxtfre # next free word at bottom of buf integer buf # free storage common /ctsort/ hash(128), nxtsym, nxtfre, buf(MAXBUF) nxtfre = nxtfre - n if (nxtfre < nxtsym) call error("out of storage.") return (nxtfre + 1) e if (nxtsym > nxtfre) call error("out of storage.") buf(p+NAME) = s buf(p+COUNT) = 0 buf(p+TOP) = 0 return (p) end #-t- symalc 4_16 ascii 08/30/83 12:30:00 #-h- usage 0_77 ascii 08/30/8 to(k2) = EOS return end #-t- icopys 2_84 ascii 08/30/83 12:30:00 #-h- scopyi 2_81 ascii 08/30/83 12:30:00 ## scopyi - copy char string at from(i) to integer string to(j) subroutine scopyi(froååå   #-h- uniq.ar 19_74 ascii 09/02/83 09:15:00 #-h- list 0_10 ascii 08/30/83 12:30:00 uniq.rat #-t- list 0_10 ascii 08/30/83 12:30:00 #-h- uniq.rat 17_72 ascii 08/30/83 12:30:00t } else if (buf(1) == MINUS & buf(2) == EOS) int = STDIN else { int = open(buf,READ) if (int == ERR) call cant(buf)  t = getlin(buf1, int) while (t != EOF) { k = 1 for (t=getlin(buf2,int); t!= EOF; t=getlin(buf2,int)) { if (equal(buf1, buf2) == NO) break k = k + call putdec(k, 5) call putc(BLANK) } call putlin(buf2, STDOUT) } return end #-t- unik 8_49 ascii 08/30/83 12:30:00 #-t- uniq.rat 17_72 ascii 08/30/83 12fine(MAXOUT,80) #width of index #--------------------------------------------------------------------- ## unrot - unrotate lines rotated by kwic DRIVER(unrot) character buf(MAXLINE) integer work integer getarg, open, ctoi integer i, in(buf, READ) if (int == ERR) call cant(buf) } call nrot (int, width) work = YES if (int != STDIN) call close(int) } if (work == NO)  #-h- uniq 7_31 ascii 08/30/83 12:30:00 ## uniq -strip adjacent duplicate lines DRIVER character buf(MAXLINE) integer open, getarg integer i, int, count data count /NO/ for (i=1; getarg(i, buf, MAXLINE) != EOF; i=i+1 } call unik (int, count) if (int != STDIN) call close(int) } if (i == 1 | (i == 2 & count == YES)) #read from STDIN call unik (STDIN, count) DRETURN end #-t- uniq 7 1 } if (count == YES) { call putdec(k, 5) call putc(BLANK) } call putlin(buf1, STDOUT) if (t == EOF) break k = 1 :30:00 #-t- uniq.ar 19_74 ascii 09/02/83 09:15:00 #-h- unrot.ar 29_123 ascii 09/02/83 09:15:00 #-h- list 0_11 ascii 08/30/83 12:30:00 unrot.rat #-t- list 0_11 ascii 08/30/83nt, width, j, n data width /MAXOUT/ data work /NO/ call query ("usage: unrot [-n] [file].") for (i=1; getarg(i,buf,MAXLINE)!=EOF; i=i+1) { if (buf(1) == MINUS & buf(2) != EOS) { j = 2  call nrot (STDIN, width) DRETURN end ## nrot - unrotate lines from file -int- subroutine nrot(int, width) character inbuf(MAXLINE), outbuf(MAXLINE) integer getlin, index integer int, i, j, width, middle middle = max(width/2, 1) while) { if (buf(1) == QMARK & buf(2) == EOS) call error ('usage: uniq [-c] [file].') else if (buf(1) == MINUS & (buf(2) == LETC | buf(2) == BIGC)) { count = YES nex_31 ascii 08/30/83 12:30:00 #-h- unik 8_49 ascii 08/30/83 12:30:00 ## unik - locate duplicate lines in file int subroutine unik (int, count) integer equal, getlin integer t, count, k character buf1(MAXLINE), buf2(MAXLINE) for (t=getlin(buf1,int); t!= EOF; t=getlin(buf1,int)) { if (equal(buf1,buf2) == NO) break k = k + 1 } if (count == YES) {  12:30:00 #-h- unrot.rat 27_120 ascii 08/30/83 12:30:00 #-h- unrot.r 26_124 ascii 08/30/83 12:30:00 ## definitions for kwic and unrot tools define(FOLD,DOLLAR) #character to indicate beginning of folded line de n = ctoi(buf,j) if (n > 0) width = n next } else if (buf(1) == MINUS) int = STDIN else { int = ope (getlin(inbuf, int) != EOF) { for (i=1; i1 & inbuf(i-1) == BLANK) if (nextj(+1,inbuf,i,j) >= width - 1) j = 1 if (j >= width - 1)  if (nextj(-1,inbuf,i,j) <= 0) j = width - 2 if (j <= 0) j = width - 2 outbuf(j) = inbuf(i) }  = j for (k=i; k>0; k = k + incmnt) { if (buf(k) == BLANK | buf(k) == FOLD | buf(k) == NEWLINE) break nextj = nextj + incmnt } return enåå#-h- defns 0_19 ascii 08/30/83 12:30:00 # include ratdef #-t- defns 0_19 ascii 08/30/83 12:30:00 #-h- wc 13_7 ascii 08/30/83 12:30:00 # wc - count lines, words, and characters in named  j = 1 outbuf(j) = inbuf(i) } if (inbuf(i) == FOLD) #copy second half { j = middle #working backwards for } for (i=width-2; i > 0; i=i-1) if (outbuf(i) != BLANK) #delete trailing blanks break outbuf(i+1) = NEWLINE #terminate line properly outbuf(i+2)d #-t- unrot.r 26_124 ascii 08/30/83 12:30:00 #-t- unrot.rat 27_120 ascii 08/30/83 12:30:00 #-t- unrot.ar 29_123 ascii 09/02/83 09:15:00 ååfiles or STDIN DRIVER character arg(MAXLINE) integer open, getarg integer fd, i, j, words, lines, chars, nfiles integer nl, nw, nc, tl, tw, tc string total "total" data words /YES/, lines /YES/, chars /YES/ # -lwc is default  (i=index(inbuf,NEWLINE)-1; i>0; i=i-1) { if (inbuf(i) == FOLD) break j = j -1 if (inbuf(i+1) == BLANK)  = EOS call putlin(outbuf, STDOUT) } return end ## nextj - see if enough space for another word integer function nextj(incmnt,buf,i,j) character buf(ARB) integer incmnt, i, j, k nextjåå#-h- wc.ar 26_29 ascii 09/02/83 09:15:00 #-h- list 0_8 ascii 08/30/83 12:30:00 wc.rat #-t- list 0_8 ascii 08/30/83 12:30:00 #-h- wc.rat 24_29 ascii 08/30/83 12:30:00 data tl /0/, tw /0/, tc /0/ call query ("usage: wc [-lwc] [files].") nfiles = 0 for (i = 1; getarg(i, arg, MAXNAME) ^= EOF; i = i + 1) if (arg(1) == MINUS & arg(2) ^= EOS) { lines = NO words = NO chars =    NO for (j = 2; arg(j) ^= EOS; j = j + 1) if (arg(j) == LETL | arg(j) == BIGL) lines = YES else if (arg(j) == LETW | arg(j) == BIGW) words = YES else if (arg(j) == LETC | arg(j if (fd ^= STDIN) call close(fd) } } if (nfiles == 0) { # no args, do STDIN call dowc(STDIN, nl, nw, nc) call printc(EOS, nl, nw, nc, lines, words, chars) } else if (nfiles > nl = nl + 1 if (c == BLANK | c == NEWLINE | c == TAB) inword = NO else if (inword == NO) { inword = YES nw = nw + 1 } } return end #-t- dowc 3_125 ascii 08/30/83_22 ascii 08/30/83 12:30:00 #-t- wc.rat 24_29 ascii 08/30/83 12:30:00 #-t- wc.ar 26_29 ascii 09/02/83 09:15:00 #-h- which.ar 11_37 ascii 09/02/83 09:15:00 #-h- list 0_11 asci= EOF) break buf(j) = EOS call which (buf) } } else if (buf(1) == QMARK & buf(2) == EOS) call error ('usage: which [file ] .') else call which (buf) } DRETURN #-t- which 2_126 ascii 08/30/83 12:30:00 #-t- which.rat 9_34 ascii 08/30/83 12:30:00 #-t- which.ar 11_37 ascii 09/02/83 09:15:00 ) == BIGC) chars = YES else call error("usage: wc [-lwc] files.") } else { nfiles = nfiles + 1 if (arg(1) == MINUS) fd = STDIN else fd = o 1) call printc(total, tl, tw, tc, lines, words, chars) DRETURN end #-t- wc 13_7 ascii 08/30/83 12:30:00 #-h- dowc 3_125 ascii 08/30/83 12:30:00 # dowc - count lines, words, and characters in f 12:30:00 #-h- printc 3_22 ascii 08/30/83 12:30:00 # printc - print count statistics for arg subroutine printc(arg, nl, nw, nc, lines, words, chars) character arg(ARB) integer nl, nw, nc, lines, words, chars if (lines i 08/30/83 12:30:00 which.rat #-t- list 0_11 ascii 08/30/83 12:30:00 #-h- which.rat 9_34 ascii 08/30/83 12:30:00 #-h- which.r 4_44 ascii 08/30/83 12:30:00 ## which - report full path of comman end #-t- which.r 4_44 ascii 08/30/83 12:30:00 #-h- which 2_126 ascii 08/30/83 12:30:00 ## which - print path subroutine which (cmd) character cmd(ARB) character fullnm(FILENAMESIZE) integer loccom strinåpen(arg, READ) if (fd == ERR) call cant (arg) else { call dowc(fd, nl, nw, nc) call printc(arg, nl, nw, nc, lines, words, chars) tl = tl + nl tw = tw + nw tc = tc + nc d subroutine dowc(fd, nl, nw, nc) integer fd, nl, nw, nc character getch character c integer inword nl = 0 nw = 0 nc = 0 inword = NO while (getch(c, fd) ^= EOF) { nc = nc + 1 if (c == NEWLINE) == YES) call putdec(nl, 8) if (words == YES) call putdec(nw, 8) if (chars == YES) call putdec(nc, 8) call putc(BLANK) call putlin(arg, STDOUT) call putc(NEWLINE) return end #-t- printc 3d DRIVER character buf(MAXLINE) integer getarg, getlin integer i, j for (i=1; getarg(i, buf, MAXLINE) != EOF; i=i+1) { if (buf(1) == MINUS & buf(2) == EOS) { repeat { j = getlin(buf,STDIN) if (j =g notfnd " *** not found ***" if (loccom(cmd,fullnm) == ERR) { call putlin (cmd, STDOUT) call putlin (notfnd, STDOUT) call putch (NEWLINE, STDOUT) } else { call putlin (fullnm, STDOUT) call putch (NEWLINE, STDOUT) } return end å   å2:30:00 ## common block for xref tool # put on a file called "cxref" # (Used only by 'xref') common /cxref/ buf(MAXBUF), nextbf integer buf # holds trees and linked lists integer nextbf # next free element in buf, init = 1 #-tth(name) + 1 # layout of linked list nodes define(LINENUM,0) # line number define(LINK,1) # pointer to next line number define(LNODESIZE,2) #define(MAXBUF,12000) define(MAXBUF,6000) define(LINESIZE,80) # length of output lines (see pentry)  data nfiles /0/ call query ("usage: xref [-f] [files].") for (i = 1; getarg(i, arg, FILENAMESIZE) ^= EOF; i = i + 1) { if (arg(1) == MINUS & (arg(2) == LETF | arg(2) == BIGF)) fflag = YES else if (arg(1) == MINUS & arg7_29 ascii 08/30/83 12:30:00 #-h- balloc 1_118 ascii 08/30/83 12:30:00 # balloc - allocate n words in storage array buf; return index integer function balloc(n) integer n include cxref nextbf = nextbf + n if (next MAXTOKEN, fd) if (t == EOF) break if (t == LETTER) { if (fflag == YES) call fold(token) call instl(token, lineno, root) } else if (t == NEWLINE) lineno = lineno + 1 å- cxref 1_116 ascii 08/30/83 12:30:00 #-h- xref.rat 63_68 ascii 08/30/83 12:30:00 #-h- defns 6_16 ascii 08/30/83 12:30:00 # include ratdef # layout of tree nodes define(LLINK,0) # pointer define(MAXTOKEN,15) # maximum token size (see pentry) define(MAXNUM,5) # size of line number entry (see pentry) # avoid conflict with CP/M rtn of same name ifdef(CPM, define(gettok,gxtok) ) #-t- defns 6_16 ascii 08/30/83 12:30(2) != EOS) call error ("usage: xref [-f] [files].") else { if (arg(1) == MINUS) fd = STDIN else fd = open(arg, READ) if (fd == ERR) call cant(arg) call putlinbf > MAXBUF) call error("out of storage.") return(nextbf - n) end #-t- balloc 1_118 ascii 08/30/83 12:30:00 #-h- doxref 4_95 ascii 08/30/83 12:30:00 # doxref-generate cross reference list for file fd } call tprint(root) return end #-t- doxref 4_95 ascii 08/30/83 12:30:00 #-h- gettok 8_34 ascii 08/30/83 12:30:00 # gettok - get text token from file fd character function gettok(token, size, fd) #-h- xref.ar 68_61 ascii 09/02/83 09:15:00 #-h- list 0_17 ascii 08/30/83 12:30:00 cxref xref.rat #-t- list 0_17 ascii 08/30/83 12:30:00 #-h- cxref 1_116 ascii 08/30/83 1to left subtree define(RLINK,1) # pointer to right subtree define(LNLIST,2) # pointer to list of references define(LAST,3) # pointer to last reference entered define(ENTRY,4) # name (string) define(TNODESIZE,5)# size of node = TNODESIZE + leng:00 #-h- xref 7_29 ascii 08/30/83 12:30:00 # xref - make cross reference list of named files DRIVER(xref) character name(MAXTOKEN), arg(FILENAMESIZE) integer fd, fflag, nfiles integer open, getarg data fflag /NO/ (arg, STDOUT) call putc(COLON) call putc(NEWLINE) call doxref(fd, fflag) nfiles = nfiles + 1 } } if (nfiles == 0) call doxref(STDIN, fflag) DRETURN end #-t- xref ; fold if fflag = YES subroutine doxref(fd, fflag) integer fd, fflag integer t, root, lineno character gettok character token(MAXTOKEN) include cxref root = 0 nextbf = 1 lineno = 1 repeat { t = gettok(token, character token(ARB) integer size, fd character getch, type integer i character c, peek data peek /EOS/ if (peek == EOS) # check for lookahead c = getch(c, fd) else { c = peek peek = EOS }     for (; c ^= EOF; c = getch(c, fd)) { gettok = type(c) if (gettok == LETTER) { # start of name token(1) = c for (i = 2; getch(c, fd) ^= EOF; i = i + 1) if (type(c) == LETTER | type(c) == DIGIT) { 2:30:00 #-h- instl 8_113 ascii 08/30/83 12:30:00 # instl - install name in tree with reference on lineno; update tree subroutine instl(name, lineno, tree) character name(ARB), temp(MAXNAME) integer lineno, tree integer q = p + LLINK else q = p + RLINK } p = balloc(TNODESIZE+length(name)+1) # allocate and fill in new node buf(p+LLINK) = 0 buf(p+RLINK) = 0 call scopyi(name, 1, buf, p+ENTRY) if (q == 0) tree = p elame, j, STDOUT) # call putstr(name, -MAXTOKEN - 1, STDOUT) len = MAXTOKEN + 1 for (i = list; i ^= 0; i = buf(i+LINK)) { if (len > LINESIZE - MAXNUM) { call putc(NEWLINE) j = (-MAXTOKEN - 1) call putstr (EOS, aracter temp(MAXNAME) include cxref sp = 0 p = tree repeat { while (p ^= 0) if (buf(p+LLINK) ^= 0) { q = buf(p+LLINK) buf(p+LLINK) = sp sp = p p = q } t from(i) to char string at to(j) subroutine icopys(from, i, to, j) integer from(ARB) character 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  if (i < size) token(i) = c } else break peek = c # went one too far if (i <= size) token(i) = EOS else token(size) = EOS  cond, p, q, itmp integer balloc, strcmp, length include cxref p = tree for (q = 0; p ^= 0; p = buf(q)) { call icopys (buf, p+ENTRY, temp, 1) #convert from int to char cond = strcmp(name, temp) if (cond == 0) { se buf(q) = p q = balloc(LNODESIZE) # insert first reference buf(q+LINENUM) = lineno buf(q+LINK) = 0 buf(p+LNLIST) = q buf(p+LAST) = q return end #-t- instl 8_113 ascii 08/30/83 12:30:00 #-h- pentrj, STDOUT) # call putstr(EOS, -MAXTOKEN - 1, STDOUT) len = MAXTOKEN + 1 } call putint(buf(i+LINENUM), MAXNUM, STDOUT) len = len + MAXNUM } if (len <= LINESIZE) call putc(NEWLINE) return e else { call icopys (buf, p+ENTRY, temp, 1) call pentry(temp, buf(p+LNLIST)) p = buf(p+RLINK) } if (sp == 0) return call icopys (buf, sp+ENTRY, temp, 1) call pentry(temp } to(k2) = EOS return end #-t- icopys 2_84 ascii 08/30/83 12:30:00 #-h- scopyi 2_81 ascii 08/30/83 12:30:00 ## scopyi - copy char string at from(i) to integer string to(j) subroutine s return(LETTER) } else if (gettok == NEWLINE) { # newline must be returned peek = EOS return(NEWLINE) } } peek = EOS return(EOF) end #-t- gettok 8_34 ascii 08/30/83 1 q = balloc(LNODESIZE) # add a new element onto list buf(q+LINENUM) = lineno buf(q+LINK) = 0 itmp = buf(p+LAST) buf(itmp+LINK) = q buf(p+LAST) = q return } else if (cond < 0) y 5_80 ascii 08/30/83 12:30:00 # pentry - print name and list of references subroutine pentry(name, list) character name(ARB) integer list integer i, len, j include cxref j = (-MAXTOKEN - 1) call putstr (nnd #-t- pentry 5_80 ascii 08/30/83 12:30:00 #-h- tprint 5_98 ascii 08/30/83 12:30:00 # tprint - destructively print tree, left subtree first subroutine tprint(tree) integer tree integer p, q, sp ch, buf(sp+LNLIST)) p = buf(sp+RLINK) sp = buf(sp+LLINK) } return end #-t- tprint 5_98 ascii 08/30/83 12:30:00 #-h- icopys 2_84 ascii 08/30/83 12:30:00 ## icopys - copy integer string acopyi(from, i, to, j) character from(ARB) integer 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 #   -t- scopyi 2_81 ascii 08/30/83 12:30:00 #-t- xref.rat 63_68 ascii 08/30/83 12:30:00 #-t- xref.ar 68_61 ascii 09/02/83 09:15:00 ååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå   åååååååååååååååååå    åååååååååååååååååå    åååååååååååååååååå!   åååååååååååååååååå!   åååååååååååååååååå"   åååååååååååååååååå"   åååååååååååååååååå#   åååååååååååååååååå#   åååååååååååååååååå$   åååååååååååååååååå$   åååååååååååååååååå%   åååååååååååååååååå%   åååååååååååååååååå&   åååååååååååååååååå&   åååååååååååååååååå'   åååååååååååååååååå'   åååååååååååååååååå