#-h- macsym 297 asc 08-may-80 09:18:44 ## /macsym/ - definitions for macro processor # put on a file named 'macsym' # Used only by the macro tool define(CALLSIZE,130) define(ARGSIZE,100) define(ARGFLAG,DOLLAR) define(IFTYPE,-11) define(INCTYPE,-12) define(SUBTYPE,-13) define(ARITHTYPE,-14) define(EVALSIZE,500) #-h- rat4sym 1388 asc 08-may-80 09:18:45 ## definitions for the preprocessor (hashed version from Dave Hanson) # put on a file named 'rat4sym' # Used by ratfor preprocessor, macro, and form tools define(BUFSIZE,300) #pushback buffer for ngetch and putbak define(DEFTYPE,-4) define(LEXBREAK,-8) define(LEXDIGITS,-9) define(LEXDO,-10) define(LEXELSE,-11) define(LEXFOR,-16) define(LEXIF,-12) define(LEXLITERAL,-19) define(LEXNEXT,-13) define(LEXOTHER,-14) define(LEXREPEAT,-17) define(LEXRETURN,-20) define(LEXUNTIL,-18) define(LEXWHILE,-15) define(MAXCHARS,10) # characters for outnum # (should be compatible with "putdec") define(MAXDEF,200) #max chars in a definition define(MAXFILE,6) #max files which can be open at a time define(MAXFNAMES,60) define(MAXFORSTK,200) #max space for for reinit clauses define(MAXNAME,30) #file name size in gettok define(MAXPTR,625) #number of defines in lookup define(MAXSTACK,100) #max stack depth for parser define(MAXTBL,6250) #max chars in all definitions define(MAXTOK,100) #max chars in a token define(NFILES,3) #max depth of file inclusion #(should be max nbr open files allowed - 3) define(TOGGLE,PERCENT) #literal toggle flag define(NHASHPTR,37) # number of pointer listheads (should be a prime) #-h- cdefio 279 asc 08-may-80 09:18:46 ## preprocessor common block to hold input characters # Put on a file called 'cdefio' # Used by ratfor preprocessor, macro, form, and shell tools common /cdefio/ bp, buf(BUFSIZE) integer bp # next available character; init = 0 character buf # pushed-back characters #-h- cmacro 286 asc 08-may-80 09:18:47 # -cmacro- common block # put on a file called 'cmacro' # Used only by the macro tool common /cmacro/ cp, ep, evalst(EVALSIZE) integer cp # current call stack pointer integer ep # next free position in evalst character evalst # evaluation stack #-h- macro.r 11321 asc 08-may-80 09:18:49 #-h- main 200 asc 08-may-80 09:18:22 #-------------------------------------------------------------------- ## macro -- main program # include symbols include macsym include rat4sym # call initr4 # call macro # call endr4 # end #-h- macros 4732 asc 08-may-80 09:18:23 ## macro - expand macros with arguments /*/sor/macror/macros # subroutine macro subroutine main character gtoken character defn(MAXDEF), t, token(MAXTOK) integer lookup, push integer ap, argstk(ARGSIZE), callst(CALLSIZE), nlb, plev(CALLSIZE) integer int include cmacro include cdefio # string balp '()' character balp(3) # string defnam 'define' character defnam(7) # string incnam 'incr' character incnam(5) # string subnam 'substr' character subnam(7) # string ifnam 'ifelse' character ifnam(7) # string arnam 'arith' character arnam(6) integer deftyp(2) integer inctyp(2) integer subtyp(2) integer iftyp(2) integer artyp(2) integer getarg, i, open character file(MAXLINE) # initialize keywords data balp(1) /LPAREN/, balp(2) /RPAREN/, balp(3) /EOS/ data defnam(1) /LETD/, defnam(2) /LETE/, defnam(3) /LETF/ data defnam(4) /LETI/, defnam(5) /LETN/, defnam(6) /LETE/ data defnam(7) /EOS/ data incnam(1)/LETI/,incnam(2)/LETN/,incnam(3)/LETC/,incnam(4)/LETR/ data incnam(5) /EOS/ data subnam(1) /LETS/, subnam(2) /LETU/, subnam(3) /LETB/ data subnam(4) /LETS/, subnam(5) /LETT/, subnam(6) /LETR/ data subnam(7) /EOS/ data ifnam(1) /LETI/, ifnam(2) /LETF/, ifnam(3) /LETE/ data ifnam(4) /LETL/, ifnam(5) /LETS/, ifnam(6) /LETE/ data ifnam(7) /EOS/ 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 artyp(1) /ARITHTYPE/, artyp(2) /EOS/ data arnam(1) /LETA/, arnam(2) /LETR/, arnam(3) /LETI/, arnam(4) /LETT/, arnam(5) /LETH/, arnam(6) /EOS/ data bp /0/ call tbinit # initialize lookup - instal block call instal(defnam, deftyp) call instal(incnam, inctyp) call instal(subnam, subtyp) call instal(ifnam, iftyp) call instal(arnam, artyp) for (i=1; ;i=i+1) { if (getarg(i, file, MAXLINE) == EOF) { if (i != 1) break int = STDIN } else if (file(1) == QMARK & file(2) == EOS) call error('usage: macro [file ...].') else if (file(1) == MINUS & file(2) == EOS) int = STDIN else { int = open(file, READ) if (int == ERR) call cant (file) } # initialize pointers, etc. bp = 0 cp = 0 ap = 1 ep = 1 for (t=gtoken(token, MAXTOK, int); t!= EOF; t=gtoken(token, MAXTOK, int)) { if (t == ALPHA) { if (lookup(token, defn) == NO) call puttok(token) else { # defined; put it in eval stack cp = cp + 1 if (cp > CALLSIZE) 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) call puttok(token) # stack name call putchr(EOS) ap = push(ep, argstk, ap) t = gtoken(token, MAXTOK, int) # peek at next call pbstr(token) if (t != LPAREN) # add ( ) if not present call pbstr(balp) plev(cp) = 0 } } else if (t == LBRACK) { # strip one level of [ ] nlb = 1 repeat { t = gtoken(token, MAXTOK, int) if (t == LBRACK) nlb = nlb + 1 else if (t == RBRACK) { nlb = nlb - 1 if (nlb == 0) break } else if (t == EOF) call error('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) 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) 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.') if (int != STDIN) call close(int) } return end #-h- dodef 315 asc 08-may-80 09:18:26 ## dodef - install definition in table /*/sor/macror/dodef subroutine dodef(argstk, i, j) integer a2, a3, argstk(ARGSIZE), i, j include cmacro if (j - i > 2) { a2 = argstk(i+2) a3 = argstk(i+3) call instal(evalst(a2), evalst(a3)) # subarrays } return end #-h- doif 457 asc 08-may-80 09:18:27 ## doif - select one of two (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) a4 = 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 #-h- doincr 252 asc 08-may-80 09:18:28 ## 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 = argstk(i+2) call pbnum(ctoi(evalst, k)+1) return end #-h- dosub 711 asc 08-may-80 09:18:29 ## dosub - select macro substring /*/sor/macror/dosub subroutine 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(evalst, 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))) { # subarrays k = fc + min(nc, length(evalst(fc))) - 1 for ( ; k >= fc; k = k - 1) call putbak(evalst(k)) } return end #-h- eval 1424 asc 08-may-80 09:18:30 ## eval - expand args i through j: evaluate builtin or push back defn subroutine eval(argstk, i, j) integer index, length integer argno, argstk(ARGSIZE), i, j, k, m, n, t, td include cmacro # string digits '0123456789' character digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ 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 == SUBTYPE) call dosub(argstk, 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) call 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 #-h- gtoken 590 asc 08-may-80 09:18:31 ## gtoken - get alphanumeric string or single non-alph for define character function gtoken(token, toksiz, int) character ngetc, type integer i, toksiz, int character token (toksiz) for (i=1; i= toksiz) call error ('token too long.') if (i > 1) # some alpha was seen { call putbak (token(i)) i = i - 1 gtoken = ALPHA } # else single character token token(i+1) = EOS return end #-h- pbnum 636 asc 08-may-80 09:18:32 ## pbnum - convert number to string, push back on input /*/sor/macror/pbnum subroutine pbnum(n) integer mod integer m, n, num # string digits '0123456789' character digits(11) data digits(1) /DIG0/ data digits(2) /DIG1/ data digits(3) /DIG2/ data digits(4) /DIG3/ data digits(5) /DIG4/ data digits(6) /DIG5/ data digits(7) /DIG6/ data digits(8) /DIG7/ data digits(9) /DIG8/ data digits(10) /DIG9/ data digits(11) /EOS/ num = n repeat { m = mod(num, 10) call putbak(digits(m+1)) num = num / 10 } until (num == 0) return end #-h- push 275 asc 08-may-80 09:18:32 ## 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 error('arg stack overflow.') argstk(ap) = ep push = ap + 1 return end #-h- puttok 236 asc 08-may-80 09:18:33 ## puttok-put token either on output or into eval stack /*/sor/macror/puttok subroutine puttok(str) character str(MAXTOK) integer i for (i = 1; str(i) != EOS; i = i + 1) call putchr(str(i)) return end #-h- putchr 336 asc 08-may-80 09:18:34 ## putchr - put single char on output or into eval stack /*/sor/macror/putchr 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 = ep + 1 } return end #-h- doarth 520 asc 08-may-80 09:18:34 ## doarth - do arithmetic operation subroutine doarth(argstk,i,j) integer ctoi integer argstk(ARGSIZE), i, j, k, l character op include cmacro k = argstk(i+2) l = argstk(i+4) op = evalst(argstk(i+3)) 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 == SLASH ) call pbnum(ctoi(evalst,k)/ctoi(evalst,l)) else call remark('arith error') return end