home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG049.ARK / RATFOR.RAT < prev    next >
Text File  |  1984-04-29  |  25KB  |  953 lines
  1.  #symbolic constants greater than 10000 have been changed to
  2.  #negative numbers which fit in bytes.  If they are enclosed in
  3.  #parentheses in relational expressions, they should be accepted by all FORTRAN.
  4. define(alpha,-100)
  5. define(amper,38) #ampersand
  6. define(arb,100)
  7. define(atsign,64)
  8. define(backslash,92)
  9. define(backspace,8)
  10. define(bang,33)#exclamation point
  11. define(bar,124)#synonym for .or.
  12. define(biga,65)
  13. define(bigb,66)
  14. define(bigc,67)
  15. define(bigd,68)
  16. define(bige,69)
  17. define(bigf,70)
  18. define(bigg,71)
  19. define(bigh,72)
  20. define(bigi,73)
  21. define(bigj,74)
  22. define(bigk,75)
  23. define(bigl,76)
  24. define(bigm,77)
  25. define(bign,78)
  26. define(bigo,79)
  27. define(bigp,80)
  28. define(bigq,81)
  29. define(bigr,82)
  30. define(bigs,83)
  31. define(bigt,84)
  32. define(bigu,85)
  33. define(bigv,86)
  34. define(bigw,87)
  35. define(bigx,88)
  36. define(bigy,89)
  37. define(bigz,90)
  38. define(blank,32)
  39. define(bufsize,300)#pushback buffer for ngetch, putbak
  40. define(caret,94)#alternate not, converted to !
  41. define(colon,58)
  42. define(comma,44)
  43. define(deftype,-10)
  44. define(dig0,48)
  45. define(dig1,49)
  46. define(dig2,50)
  47. define(dig3,51)
  48. define(dig4,52)
  49. define(dig5,53)
  50. define(dig6,54)
  51. define(dig7,55)
  52. define(dig8,56)
  53. define(dig9,57)
  54. define(digit,2)
  55. define(dollar,36)
  56. define(dquote,34)
  57. define(eof,-3)
  58. define(eos,-2)
  59. define(equals,61)
  60. #define(err,-1) not used, conflicts with err=
  61. define(kons,3)
  62. define(errout,kons)#error message to console
  63. define(greater,62)
  64. define(kb,3)
  65. define(lbrace,123)
  66. define(lbrack,91)
  67. define(less,60)
  68. define(leta,97)
  69. define(letb,98)
  70. define(letc,99)
  71. define(letd,100)
  72. define(lete,101)
  73. define(letf,102)
  74. define(letg,103)
  75. define(leth,104)
  76. define(leti,105)
  77. define(letj,106)
  78. define(letk,107)
  79. define(letl,108)
  80. define(letm,109)
  81. define(letn,110)
  82. define(leto,111)
  83. define(letp,112)
  84. define(letq,113)
  85. define(letr,114)
  86. define(lets,115)
  87. define(lett,116)
  88. define(letter,1)
  89. define(letu,117)
  90. define(letv,118)
  91. define(letw,119)
  92. define(letx,120)
  93. define(lety,121)
  94. define(letz,122)
  95. define(lexbreak,-64)
  96. define(lexdigits,-60)
  97. define(lexdo,-66)
  98. define(lexelse,-62)
  99. define(lexfor,-68)
  100. define(lexif,-61)
  101. define(lexnext,-65)
  102. define(lexother,-67)
  103. define(lexrepeat,-69)
  104. define(lexuntil,-70)
  105. define(lexwhile,-63)
  106. define(lparen,40)
  107. define(maxcard,80)#input record size
  108. define(maxchars,10)#chars in ascii integer incl - and eos
  109. define(maxdef,200)#max chars in defn
  110. define(maxforstk,200)#space for reinit clauses
  111. define(maxline,81)#maxcard+1
  112. define(maxname,30)#include file name length
  113. define(maxptr,200)#number of defines
  114. define(maxstack,100)#parser stack depth
  115. define(maxtbl,1500)#size of definition table
  116. define(maxtok,200)#token size
  117. define(minus,45)
  118. #define(nchars,33)
  119. define(newline,10)#lf
  120. define(nfiles,5)#max open files
  121. define(no,.false.)
  122. define(not,bang)#use !
  123. define(percent,37)
  124. define(period,46)
  125. define(plus,43)
  126. define(qmark,63)
  127. define(rbrace,125)
  128. define(rbrack,93)
  129. #define(readonly,0)#not used by Microsoft
  130. define(rparen,41)
  131. define(semicol,59)
  132. define(sharp,35)
  133. define(slash,47)
  134. define(squote,39)
  135. define(star,42)
  136. define(stdin,7)#input unit
  137. define(stdout,6)
  138. define(tab,9)
  139. define(tilde,126)
  140. define(underline,95)
  141. define(yes,.true.)
  142. define(character,byte)
  143. define(abs,iabs)
  144. program ratfor#main program
  145. character name(8),namer(11),namef(11)
  146. data namer(9),namer(10),namer(11)/'R','A','T'/
  147. data namef(9),namef(10),namef(11)/'F','O','R'/
  148. 9 format('Addison-Wesley Ratfor adapted for FORTRAN-80 August',
  149. '1979 by Tim Prince, 1 EastLakeView Apt 17, Cincinnati 45237')
  150. write(kons,1,err=3)
  151. 1 format(1x,'Input file name ?')
  152. 3 read(kb,2,err=4)name
  153. 2 format(8a1)
  154. 4 do i=1,8
  155. {namer(i)=name(i);namef(i)=name(i)}
  156. call open(stdin,namer,0)
  157. call open(stdout,namef,0)
  158. call parse
  159. endfile stdout
  160. stop
  161. end
  162. block data initl
  163. include RATCOMNS
  164. data outp/0/#output character pointer
  165. #file control
  166. data level/1/,linect(1)/1/,infile(1)/stdin/
  167. data bp/0/#pushback buffer pointer
  168. data fordep/0/#for stack depth
  169. #table lookup pointers
  170. data lastp/0/,lastt/0/
  171. #keywords:
  172. data sdo/letd,leto,eos/,vdo/lexdo,eos/
  173. data sif/leti,letf,eos/,vif/lexif,eos/
  174. data selse/lete,letl,lets,lete,eos/
  175. data velse/lexelse,eos/
  176. data swhile/letw,leth,leti,letl,lete,eos/
  177. data vwhile/lexwhile,eos/
  178. data sbreak/letb,letr,lete,leta,letk,eos/
  179. data vbreak/lexbreak,eos/
  180. data snext/letn,lete,letx,lett,eos/
  181. data vnext/lexnext,eos/
  182. data sfor/letf,leto,letr,eos/,vfor/lexfor,eos/
  183. data srept/letr,lete,letp,lete,leta,lett,eos/
  184. data vrept/lexrepeat,eos/
  185. data suntil/letu,letn,lett,leti,letl,eos/
  186. data vuntil/lexuntil,eos/
  187. #if a transliteration table is required, insert it here
  188. end
  189. logical function alldig(str)#yes if str is all digits
  190. #called by lex
  191. character type,str(arb)
  192. alldig=no
  193. if(str(1)==eos)return
  194. for(i=1;str(i)!=eos;i=i+1)if(type(str(i))!=digit)return
  195. alldig=yes
  196. return
  197. end
  198. subroutine balpar #copy balanced paren string
  199. #called by ifgo
  200. character gettok,t,token(maxtok)
  201. integer*1 nlpar
  202. if(gettok(token,maxtok)!=lparen)
  203.   {call synerr("missing left paren.")
  204.   return}
  205. call outstr(token)
  206. nlpar=1
  207. repeat{
  208.   t=gettok(token,maxtok)
  209.   if(t==semicol | t==lbrace | t==rbrace | t==eof)
  210.     {call pbstr(token)
  211.     break}
  212.   if(t==newline)token(1)=eos # delete lf
  213.   else if (t==lparen)nlpar=nlpar+1
  214.   else if (t==rparen)nlpar=nlpar-1
  215.   call outstr(token)
  216.   }until(nlpar<=0)
  217. if(nlpar!=0)call synerr("missing parenthesis in condition.")
  218. return
  219. end
  220. subroutine brknxt(sp,lextyp,labval,token)#break & next
  221. #called by parse
  222. integer i,labval(maxstack),sp
  223. character lextyp(maxstack),token
  224. for(i=sp;i>0;i=i-1)
  225.   if(lextyp(i)==lexwhile | lextyp(i)==lexdo
  226.     | lextyp(i)==lexfor | lextyp(i)==lexrepeat)
  227.     {labout=labval(i)
  228.     if(token==lexbreak)labout=labout+1
  229.     call outgo(labout)
  230.     return}
  231. if(token==lexbreak)call synerr("illegal break.")
  232. else call synerr("illegal next.")
  233. return
  234. end
  235. subroutine closei(fd)#file close
  236. #called by gettok
  237. integer fd
  238. endfile fd
  239. return
  240. end
  241. character function deftok(token,toksiz,fd)
  242. #called by gettok
  243. integer fd,toksiz
  244. character gtok,defn(maxdef),t,token(toksiz)
  245. logical lookup
  246. for(t=gtok(token,toksiz,fd);t!=eof;t=gtok(token,toksiz,fd))
  247.   {if(t!=alpha)break #non-alpha
  248.   if(! lookup(token,defn))break #undefined
  249.   if(defn(1)==deftype) #get definition
  250.   {call getdef(token,toksiz,defn,maxdef,fd)
  251.   call instal(token,defn)}
  252.   else call pbstr(defn)} #push replacement onto input
  253. deftok=t
  254. if(deftok==alpha) call fold(token) #convert to lower case
  255. return
  256. end
  257. subroutine fold(token)
  258. #called by deftok
  259. character token(arb)
  260. # internal numeric equivalence of letters must be sequential
  261. # within each case.
  262. integer*1 lwrmup
  263. lwrmup=leta-biga
  264. for(i=1;token(i)!=eos;i=i+1)
  265.   if(token(i)>=biga & token(i)<=bigz)
  266.     token(i)=token(i)+lwrmup
  267. return
  268. end
  269. subroutine docode(lab) #generate do
  270. #called by parse
  271. character dostr(4)
  272. data dostr/letd,leto,blank,eos/
  273. call outtab
  274. call outstr(dostr)
  275. lab=labgen(2)
  276. call outnum(lab)
  277. call eatup
  278. call outdon
  279. return
  280. end
  281. subroutine dostat(lab) #generate end do
  282. #called by unstak
  283. call outcon(lab)
  284. call outcon(lab+1)
  285. return
  286. end
  287. subroutine eatup #proc rest of statement incl continuations
  288. #called by docode,forcod,otherc
  289. character gettok,ptoken(maxtok),t,token(maxtok)
  290. integer*1 nlpar
  291. nlpar=0
  292. repeat{
  293.   t=gettok(token,maxtok)
  294.   if(t==semicol | t==newline)break
  295.   if(t==rbrace){call pbstr(token);break}
  296.   if(t==lbrace | t==eof){
  297.     call synerr("unexpected brace or eof.")
  298.     call pbstr(token)
  299.     break}
  300.   if(t==comma | t==underline){
  301.     if(gettok(ptoken,maxtok)!=newline)call pbstr(ptoken)
  302.     if(t==underline)token(1)=eos}
  303.   else if(t==lparen)nlpar=nlpar+1
  304.   else if(t==rparen)nlpar=nlpar-1
  305.   call outstr(token)
  306.   }until(nlpar<0)
  307. if(nlpar!=0)call synerr("unbalanced parentheses.")
  308. return
  309. end
  310. subroutine elseif(lab) #generate else code
  311. #called by parse
  312. call outgo(lab+1)
  313. call outcon(lab)
  314. return
  315. end
  316. logical function equal(str1,str2) #? strings equal
  317. #called by gettok,lex
  318. character str1(arb),str2(arb)
  319. for(i=1;str1(i)==str2(i);i=i+1)
  320.   if(str1(i)==eos){equal=yes;return}
  321. equal=no
  322. return
  323. end
  324. subroutine error(buf)#fatal error msg; die
  325. #called by getdef,parse,putbak
  326. character buf(arb)
  327. call remark(buf)
  328. endfile stdout
  329. stop
  330. end
  331. subroutine forcod(lab)#begin for
  332. #called by parse
  333. character gettok,t,token(maxtok),ifnot(9)
  334. integer*1 i,nlpar
  335. include RATCOMNS
  336. data ifnot/leti,letf,lparen,period,letn,leto,lett,period,eos/
  337. lab=labgen(3)
  338. call outcon(0)
  339. if(gettok(token,maxtok)!=lparen){
  340.   call synerr("missing left paren.")
  341.   return}
  342. if(gettok(token,maxtok)!=semicol)#real init clause
  343.   {call pbstr(token)
  344.   call outtab
  345.   call eatup
  346.   call outdon}
  347. if(gettok(token,maxtok)==semicol)#empty condition
  348.   call outcon(lab)
  349. else{ #non-empty condition
  350.   call pbstr(token)
  351.   call outnum(lab)
  352.   call outtab
  353.   call outstr(ifnot)
  354.   call outch(lparen)
  355.   nlpar=0
  356.   while(nlpar>=0){
  357.     t=gettok(token,maxtok)
  358.     if(t==semicol)break
  359.     if(t==lparen)nlpar=nlpar+1
  360.     else if(t==rparen)nlpar=nlpar-1
  361.     if(t!=newline & t!=underline)call outstr(token)}
  362.   call outch(rparen)
  363.   call outch(rparen)
  364.   call outgo(lab+2)
  365.   if(nlpar<0)call synerr("invalid for clause.")}
  366. fordep=fordep+1 #stack reinit clause
  367. j=1
  368. for(i=1;i<fordep;i=i+1)#find end
  369.   j=j+length(forstk(j))+1
  370. forstk(j)=eos #null, in case no reinit
  371. nlpar=0
  372. while(nlpar>=0){
  373.   t=gettok(token,maxtok)
  374.   if(t==lparen)nlpar=nlpar+1
  375.   else if(t==rparen)nlpar=nlpar-1
  376.   if(nlpar>=0 & t!=newline & t!=underline){
  377.     call scopy(token,1,forstk,j)
  378.     j=j+length(token)}}
  379. lab=lab+1 #label for NEXTs
  380. return
  381. end
  382. subroutine fors(lab)#process end of for
  383. #called by unstak
  384. integer*1 i
  385. include RATCOMNS
  386. call outnum(lab)
  387. j=1
  388. for(i=1;i<fordep;i=i+1)
  389.   j=j+length(forstk(j))+1
  390. if(length(forstk(j))>0){
  391.   call outtab
  392.   call outstr(forstk(j))
  393.   call outdon}
  394. call outgo(lab-1)
  395. call outcon(lab+1)
  396. fordep=fordep-1
  397. return
  398. end
  399. character function getch(c,f)#get character from file
  400. #called by ngetch
  401. character buf(maxline),c
  402. integer f
  403. data lastc/maxline/,buf(maxline)/newline/
  404. #note: maxline=maxcard+1
  405. if(buf(lastc)==newline | lastc>=maxline){
  406.   read(f,1,err=5,end=10)(buf(i),i=1,maxcard)
  407.     1 format(maxcard a1)#use r1 format if available
  408.   #now transliterate into ascii and shift right if needed
  409.   for(i=maxcard;i>0;i=i-1)
  410.   if(buf(i)!=blank)break
  411.   buf(i+1)=newline
  412.   go to 7
  413.   5 buf(1)=qmark
  414.   buf(2)=newline
  415.   7 if(buf(1)==newline)lastc=1
  416.   else lastc=0
  417.   }#Microsoft leaves newline in front; skip it
  418. lastc=lastc+1
  419. c=buf(lastc)
  420. getch=c
  421. return
  422. 10 c=eof
  423. getch=eof
  424. return
  425. end
  426. subroutine getdef(token,toksiz,defn,defsiz,fd)
  427. #called by deftok
  428. integer defsiz,fd,toksiz
  429. character gtok,ngetch,c,defn(defsiz),token(toksiz)
  430. integer*1 nlpar
  431. if(ngetch(c,fd)!=lparen)call remark("missing left paren.")
  432. if(gtok(token,toksiz,fd)!=alpha)
  433.   call remark("non-alphanumeric name.")
  434. else if(ngetch(c,fd)!=comma)
  435.   call remark("missing comma in define.")
  436. nlpar=0
  437. for(i=1;nlpar>=0;i=i+1)
  438.   if(i>defsiz)call error("definition too long.")
  439.   else if(ngetch(defn(i),fd)==eof)
  440.     call error("missing right paren.")
  441.   else if(defn(i)==lparen)nlpar=nlpar+1
  442.   else if(defn(i)==rparen)nlpar=nlpar-1
  443. defn(i-1)=eos
  444. return
  445. end
  446. character function gettok(token,toksiz)
  447. #called by balpar,eatup,forcod,lex
  448. logical equal
  449. integer openi,toksiz
  450. character junk
  451. character deftok,name(maxname),token(toksiz),incl(8)
  452. include RATCOMNS
  453. data incl/leti,letn,letc,letl,letu,letd,lete,eos/
  454. for(;level>0;level=level-1){
  455.   for(gettok=deftok(token,toksiz,infile(level));gettok!=eof;
  456.     gettok=deftok(token,toksiz,infile(level))){
  457.     if(! equal(token,incl))return
  458.     junk=deftok(name,maxname,infile(level))
  459.     if(level>=nfiles)
  460.       call synerr("includes nested too deeply.")
  461.     else{
  462.       infile(level+1)=openi(name,level+1)
  463.       linect(level+1)=1
  464. #open error not flagged by FORT-80;must change name anyway
  465. #      if(infile(level+1)==err)
  466. #    call synerr("can't open include.")
  467. #      else 
  468.       level=level+1}}
  469.   if(level>1)call closei(infile(level))}
  470. gettok=eof
  471. return
  472. end
  473. character function gtok(lexstr,toksiz,fd)
  474. #called by deftok,getdef
  475. integer toksiz,fd
  476. character ngetch,type,c,lexstr(toksiz)
  477. include RATCOMNS
  478. while(ngetch(c,fd)!=eof)if(c!=blank&c!=tab)break
  479. call putbak(c)
  480. for(i=1;i<toksiz-1;i=i+1){
  481.   gtok=type(ngetch(lexstr(i),fd))
  482.   if(gtok!=letter>ok!=digit)break}
  483. if(i>=toksiz-1)call synerr("token too long.")
  484. if(i>1){ #some alpha seen
  485.   call putbak(lexstr(i))#insert eos before lexstr(i)
  486.   lexstr(i)=eos
  487.   gtok=alpha}
  488. else if(lexstr(1)==dollar){#process $( & $)
  489.   if(ngetch(lexstr(2),fd)==lparen){
  490.     lexstr(1)=lbrace
  491.     gtok=lbrace}
  492.   else if(lexstr(2)==rparen){
  493.     lexstr(1)=rbrace
  494.     gtok=rbrace}
  495.   else call putbak(lexstr(2))}
  496. else if(lexstr(1)==squote | lexstr(1)==dquote){
  497.   for(i=2;ngetch(lexstr(i),fd)!=lexstr(1);i=i+1)
  498.     if(lexstr(i)==newline | i>=toksiz-1){
  499.       call synerr("missing quote.")
  500.       lexstr(i)=lexstr(1)
  501.       call putbak(newline)
  502.       break}}
  503. else if(lexstr(1)==sharp){ #strip comment
  504.   while(ngetch(lexstr(1),fd)!=newline);
  505.   gtok=newline}
  506. else{
  507.   if(lexstr(1)==tilde | lexstr(1)==caret)lexstr(1)=not
  508.  if(lexstr(1)==greater|lexstr(1)==less|lexstr(1)==not
  509.   |lexstr(1)==equals|lexstr(1)==amper|lexstr(1)==bar)
  510.   call relate(lexstr,i,fd)}
  511. lexstr(i+1)=eos
  512. if(lexstr(1)==newline)linect(level)=linect(level)+1
  513. return
  514. end
  515. subroutine ifcode(lab)#initial if code
  516. #called by parse
  517. lab=labgen(2)
  518. call ifgo(lab)
  519. return
  520. end
  521. subroutine ifgo(lab)
  522. #called by ifcode,unstak,whilec
  523. character ifnot(9)
  524. data ifnot/leti,letf,lparen,period,letn,leto,lett,period,eos/
  525. call outtab #get to column 7
  526. call outstr(ifnot)
  527. call balpar #collect & output condition
  528. call outch(rparen)
  529. call outgo(lab) #"goto lab"
  530. return
  531. end
  532. subroutine initkw #install "define" in definition table
  533. #called by parse
  534. #note "define"must be all lower case unless further provided.
  535. character defnam(7),deftyp(2)
  536. data defnam/letd,lete,letf,leti,letn,lete,eos/
  537. data deftyp/deftype,eos/
  538. call instal(defnam,deftyp)
  539. return
  540. end
  541. subroutine instal(name,defn)#add to definition table
  542. #called by deftok,initkw
  543. character defn(maxtok),name(maxdef)
  544. integer dlen
  545. include RATCOMNS
  546. nlen=length(name)+1
  547. dlen=length(defn)+1
  548. if(lastt+nlen+dlen>maxtbl | lastp>=maxptr){
  549.   call putlin(name,errout)
  550.   call remark(": too many definitions.")}
  551. lastp=lastp+1
  552. namptr(lastp)=lastt+1
  553. call scopy(name,1,table,lastt+1)
  554. call scopy(defn,1,table,lastt+nlen+1)
  555. lastt=lastt+nlen+dlen
  556. return
  557. end
  558. function itoc(int,str,size)#convert int to str
  559. #called by outnum,synerr
  560. integer size
  561. character k,str(size)
  562. intval=abs(int)
  563. str(1)=eos
  564. i=1
  565. repeat{
  566.   i=i+1
  567.   str(i)=mod(intval,10)+dig0
  568.   intval=intval/10
  569.   }until(intval==0 | i>=size)
  570. if(int<0 & i<size){ #check sign
  571.   i=i+1
  572.   str(i)=minus}
  573. itoc=i-1
  574. for(j=1;j<i;j=j+1)  #reverse
  575.   {k=str(i)
  576.   str(i)=str(j)
  577.   str(j)=k
  578.   i=i-1}
  579. return
  580. end
  581. subroutine labelc(lexstr)#output label
  582. #called by parse
  583. character lexstr(arb)
  584. if(length(lexstr)==5) #warn about 23xxx labels
  585.   if(lexstr(1)==dig2 & lexstr(2)==dig3)
  586.     call synerr("warning:  possible label conflict.")
  587. call outstr(lexstr)
  588. call outtab
  589. return
  590. end
  591. function labgen(n)#generate n labels, return first one
  592. #called by docode,forcod,ifcode,repcod,whilec
  593. data label/23000/
  594. labgen=label
  595. label=label+n
  596. return
  597. end
  598. function length(str)
  599. #called by fors,labelc,pbstr
  600. character str(arb)
  601. for(length=0;str(length+1)!=eos;length=length+1);
  602. return
  603. end
  604. character function lex(lexstr)
  605. #called by parse,unstak
  606. character gettok,lexstr(maxtok)
  607. logical alldig,equal
  608. include RATCOMNS
  609. while(gettok(lexstr,maxtok)==newline);
  610. lex=lexstr(1)
  611. if(lex==eof | lex==semicol | lex==lbrace | lex==rbrace)return
  612. if(alldig(lexstr))lex=lexdigits
  613. else if(equal(lexstr,sif))lex=vif(1)
  614. else if(equal(lexstr,selse))lex=velse(1)
  615. else if(equal(lexstr,swhile))lex=vwhile(1)
  616. else if(equal(lexstr,sdo))lex=vdo(1)
  617. else if(equal(lexstr,sbreak))lex=vbreak(1)
  618. else if(equal(lexstr,snext))lex=vnext(1)
  619. else if(equal(lexstr,sfor))lex=vfor(1)
  620. else if(equal(lexstr,srept))lex=vrept(1)
  621. else if(equal(lexstr,suntil))lex=vuntil(1)
  622. else lex=lexother
  623. return
  624. end
  625. logical function lookup(name,defn)
  626. #called by deftok
  627. character defn(maxdef),name(maxtok)
  628. include RATCOMNS
  629. for(i=lastp;i>0;i=i-1) #note last defn checked first
  630.   {j=namptr(i)
  631.   for(k=1;name(k)==table(j)&name(k)!=eos;k=k+1)
  632.     j=j+1
  633.   if(name(k)==table(j)){ #found defn
  634.     call scopy(table,j+1,defn,1)
  635.     lookup=yes
  636.     return}}
  637. lookup=no
  638. return
  639. end
  640. character function ngetch(c,fd)#get char (possibly pushed back)
  641. #called by getdef,gtok,type,relate
  642. character getch,c
  643. integer fd
  644. include RATCOMNS
  645. if(bp>0)c=buf(bp)
  646. else{bp=1;buf(1)=getch(c,fd)}
  647. bp=bp-1
  648. ngetch=c
  649. return
  650. end
  651. integer function openi(name,level)
  652. #called by gettok
  653. character name(maxname),namer(11)
  654. data namer(9),namer(10),namer(11)/'R','A','T'/
  655. openi=level+6#use units 8,9,10 according to include level
  656. for(i=1;i<=8&name(i)!=eos;i=i+1)
  657. {if(name(i)>underline)name(i)=name(i)-blank
  658. namer(i)=name(i)} #strip lc bit
  659. if(name(i)!=eos)i=i+1 #don't blank unless eos
  660. while(i<=8){namer(i)=blank;i=i+1}
  661. call open(openi,namer,0)#current disk
  662. return
  663. end
  664. subroutine otherc(lexstr)#put out ordinary FORTRAN
  665. #called by parse
  666. character lexstr(arb)
  667. call outtab
  668. call outstr(lexstr)
  669. call eatup
  670. call outdon
  671. return
  672. end
  673. subroutine outch(c)#output by characters
  674. #called by forcod,ifgo,outnum,outstr,outtab
  675. character c
  676. include RATCOMNS
  677. if(outp>=72){#make continuation card
  678.   call outdon
  679.   do i=1,5
  680.     outbuf(i)=blank
  681.   outbuf(6)=amper#ampersand in col 6 (may want *)
  682.   outp=6}
  683. outp=outp+1
  684. outbuf(outp)=c
  685. return
  686. end
  687. subroutine outcon(n)#put out "n continue"
  688. #called by dostat,elseif,forcod,fors,repcod,unstak,whilec,whiles
  689. character contin(9)
  690. data contin/letc,leto,letn,lett,leti,letn,letu,lete,eos/
  691. if(n>0)call outnum(n)
  692. call outtab
  693. call outstr(contin)
  694. call outdon
  695. return
  696. end
  697. subroutine outdon #terminate output line
  698. #called by docode,forcod,fors,otherc,outch,outcon,outgo
  699. include RATCOMNS
  700. outbuf(outp+1)=newline
  701. outbuf(outp+2)=eos
  702. call putlin(outbuf,stdout)
  703. outp=0
  704. return
  705. end
  706. subroutine outgo(n)#put out "goto n"
  707. #called by brknxt,elseif,forcod,fors,ifgo,unstak,whiles
  708. character goto(6)
  709. data goto/letg,leto,lett,leto,blank,eos/
  710. call outtab
  711. call outstr(goto)
  712. call outnum(n)
  713. call outdon
  714. return
  715. end
  716. subroutine outnum(n)#put out decimal number
  717. #called by docode,forcod,fors,outcon,outgo,outstr,whilec
  718. character chars(maxchars)
  719. len=itoc(n,chars,maxchars)
  720. do i=1,len
  721. call outch(chars(i))
  722. return
  723. end
  724. subroutine outstr(str)#put out string
  725. #called by balpar,docode,eatup,forcod,fors,ifgo,labelc,otherc,
  726. #outcon,outgo
  727. character c,str(arb)
  728. for(i=1;str(i)!=eos;i=i+1){
  729.   c=str(i)
  730.   if(c!=squote & c!=dquote)call outch(c)
  731.   else{
  732.     i=i+1
  733.     for(j=i;str(j)!=c;j=j+1);#count Hollerith string
  734.     call outnum(j-i)
  735.     call outch(leth)
  736.     for(;i<j;i=i+1)call outch(str(i))}}
  737. return
  738. end
  739. subroutine outtab#tab to column 7
  740. #called by docode,forcod,fors,ifgo,labelc,otherc,outcon,outgo
  741. include RATCOMNS
  742. while(outp<6)call outch(blank)
  743. return
  744. end
  745. subroutine parse#parse ratfor source
  746. #called by ratfor
  747. character lexstr(maxtok),lex,lextyp(maxstack),token
  748. integer labval(maxstack),sp
  749. call initkw #install initial definitions
  750. sp=1
  751. lextyp(1)=eof
  752. for(token=lex(lexstr);token!=eof;token=lex(lexstr)){
  753.   if(token==lexif)call ifcode(lab)
  754.   else if(token==lexdo)call docode(lab)
  755.   else if(token==lexwhile)call whilec(lab)
  756.   else if(token==lexfor)call forcod(lab)
  757.   else if(token==lexrepeat)call repcod(lab)
  758.   else if(token==lexdigits)call labelc(lexstr)
  759.   else if(token==lexelse){
  760.     if(lextyp(sp)==lexif)call elseif(labval(sp))
  761.     else call synerr("illegal else.")}
  762.   if(token==lexif | token==lexelse | token==lexwhile
  763.     | token==lexfor | token==lexrepeat
  764.     | token==lexdo | token==lexdigits | token==lbrace){
  765.     sp=sp+1 #begin statement
  766.     if(sp>maxstack)call error("stack overflow in parser.")
  767.     lextyp(sp)=token #stack type and value
  768.     labval(sp)=lab}
  769.   else{ #end of statement - prepare to unstack
  770.     if(token==rbrace){
  771.       if(lextyp(sp)==lbrace)sp=sp-1
  772.       else call synerr("illegal right brace.")}
  773.     else if(token==lexother)call otherc(lexstr)
  774.     else if(token==lexbreak | token==lexnext)
  775.       call brknxt(sp,lextyp,labval,token)
  776.     token=lex(lexstr) #peek at next token
  777.     call pbstr(lexstr)
  778.     call unstak(sp,lextyp,labval,token)}}
  779. if(sp!=1)call synerr("unexpected eof.")
  780. return
  781. end
  782. subroutine pbstr(in)#push string back on input
  783. #called by balpar,deftok,eatup,forcod,parse
  784. character in(arb)
  785. for(i=length(in);i>0;i=i-1)call putbak(in(i))
  786. return
  787. end
  788. subroutine putbak(c)#push character back on input
  789. #called by gtok,pbstr,relate
  790. character c
  791. include RATCOMNS
  792. bp=bp+1
  793. if(bp>bufsize)call error("too many characters pushed back.")
  794. buf(bp)=c
  795. return
  796. end
  797. subroutine putch(c,f)
  798. #called by putlin,synerr
  799. character buf(maxline),c,c1,q1
  800. integer f
  801. data c1/'C'/,q1/'?'/
  802. data lastc/0/
  803. if(lastc>=maxline | c==newline){
  804.   if(lastc>0){
  805.     write(f,1,err=5)(buf(i),i=1,lastc)
  806.     goto 4
  807.     5 write(errout,1)c1,q1
  808.     4 continue
  809.     1 format(1x,maxcard a1)}# r1 where appropriate
  810.   lastc=0}
  811. if(c!=newline){lastc=lastc+1
  812.   c=c&127 #strip sign
  813.   if(c<27)c=c+33 #map bomb chars into visible zone
  814.   buf(lastc)=c}
  815. return
  816. end
  817. subroutine putlin(b,f)#put out line via putch
  818. #called by instal,outdon,synerr
  819. character b(arb)
  820. integer f
  821. for(i=1;b(i)!=eos;i=i+1)call putch(b(i),f)
  822. return
  823. end
  824. subroutine relate(token,last,fd)
  825. #called by gtok
  826. #called by error,getdef,instal,synerr
  827. character ngetch,token(arb),dotge(5),dotgt(5),dotle(5),
  828. dotne(5),dotnot(6),doteq(5),dotand(6),dotor(5),dotlt(5)
  829. integer fd
  830. data dotge/period,letg,lete,period,eos/,
  831. dotgt/period,letg,lett,period,eos/,
  832. dotle/period,letl,lete,period,eos/,
  833. dotlt/period,letl,lett,period,eos/,
  834. dotne/period,letn,lete,period,eos/,
  835. doteq/period,lete,letq,period,eos/,
  836. dotor/period,leto,letr,period,eos/,
  837. dotand/period,leta,letn,letd,period,eos/,
  838. dotnot/period,letn,leto,lett,period,eos/
  839. if(ngetch(token(2),fd)!=equals)call putbak(token(2))
  840. if(token(1)==greater){
  841.   if(token(2)==equals)call scopy(dotge,1,token,1)
  842.   else call scopy(dotgt,1,token,1)}
  843. else if(token(1)==less){
  844.   if(token(2)==equals)call scopy(dotle,1,token,1)
  845.   else call scopy(dotlt,1,token,1)}
  846. else if(token(1)==not){
  847.   if(token(2)==equals)call scopy(dotne,1,token,1)
  848.   else call scopy(dotnot,1,token,1)}
  849. else if(token(1)==equals){
  850.   if(token(2)==equals)call scopy(doteq,1,token,1)
  851.   else token(2)=eos}
  852. else if(token(1)==amper)call scopy(dotand,1,token,1)
  853. else if(token(1)==bar)call scopy(dotor,1,token,1)
  854. else token(2)=eos#not recognized
  855. last=length(token)
  856. return
  857. end
  858. subroutine remark(buf)#warning message
  859. #called by error,getdef,instal,synerr
  860. character buf(arb),pct
  861. data pct/'%'/
  862. for(j=1;j<63&buf(j)!=period;j=j+1){
  863.   buf(j)=buf(j)&127
  864.   if(buf(j)<27)buf(j)=buf(j)+33}
  865. write(errout,10,err=5)(buf(i),i=1,j)
  866. 10 format(1x,63a1)
  867. return
  868. 5 write(errout,10)pct
  869. return
  870. end
  871. subroutine repcod(lab)#begin repeat
  872. #called by parse
  873. call outcon(0)#in case there was a label
  874. lab=labgen(3)
  875. call outcon(lab)
  876. lab=lab+1 #label for NEXTs
  877. return
  878. end
  879. subroutine scopy(from,i,to,j)
  880. #called by forcod,instal,lookup,relate
  881. character from(arb),to(arb)
  882. k2=j
  883. for(k1=i;from(k1)!=eos;k1=k1+1){
  884. to(k2)=from(k1)
  885. k2=k2+1}
  886. to(k2)=eos
  887. return
  888. end
  889. subroutine synerr(msg)#report syntax error
  890. #called by balpar,brknxt,eatup,forcod,gettok,gtok,labelc,parse
  891. character lc(maxline),msg(maxline)
  892. include RATCOMNS
  893. call remark("error at line.")
  894. do i=1,level
  895.   {call putch(blank,errout)
  896.   junk=itoc(linect(i),lc,maxline)
  897.   call putlin(lc,errout)}
  898. call putch(colon,errout)
  899. call putch(newline,errout)
  900. call remark(msg)
  901. return
  902. end
  903. character function type(c)#based on ascii
  904. #called by alldig,gtok
  905. character c
  906. if(c>=dig0 & c<=dig9)type=digit
  907. else if((c>=leta & c<=letz)|(c>=biga&c<=bigz))type=letter
  908. else type=c
  909. return
  910. end
  911. subroutine unstak(sp,lextyp,labval,token)#at statement end
  912. #called by parse
  913. integer labval(maxstack),sp
  914. character lextyp(maxstack),token
  915. for(;sp>1;sp=sp-1){
  916.   if(lextyp(sp)==lbrace|(lextyp(sp)==lexif&token==lexelse))
  917.     break
  918.   if(lextyp(sp)==lexif)call outcon(labval(sp))
  919.   else if(lextyp(sp)==lexelse){
  920.     if(sp>2)sp=sp-1
  921.     call outcon(labval(sp)+1)}
  922.   else if(lextyp(sp)==lexdo)call dostat(labval(sp))
  923.   else if(lextyp(sp)==lexwhile)call whiles(labval(sp))
  924.   else if(lextyp(sp)==lexfor)call fors(labval(sp))
  925.   else if(lextyp(sp)==lexrepeat)call untils(labval(sp),token)}
  926. return
  927. end
  928. subroutine untils(lab,token)#generate end of repeat
  929. #called by unstak
  930. character ptoken(maxtok),token,junk,lex
  931. call outnum(lab)
  932. if(token==lexuntil){
  933.   junk=lex(ptoken)
  934.   call ifgo(lab-1)}
  935. else call outgo(lab-1)
  936. call outcon(lab+1)
  937. return
  938. end
  939. subroutine whilec(lab)#begin while
  940. #called by parse
  941. call outcon(0) #in case there was a label
  942. lab=labgen(2)
  943. call outnum(lab)
  944. call ifgo(lab+1)
  945. return
  946. end
  947. subroutine whiles(lab)#end of while
  948. #called by unstak
  949. call outgo(lab)
  950. call outcon(lab+1)
  951. return
  952. end
  953.