home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / fortran / watfiv.lbr / WATFIV.SQC / WATFIV.SRC
Text File  |  1984-06-30  |  25KB  |  1,128 lines
  1. PROGRAM watfiv1;
  2. {modified from U of W version supplied Nov 82}
  3. CONST
  4.   STACKFLAG='stack overflow';
  5.   error2='More then 19 continuation cards for read statement';
  6.   error4='invalid use of while(..)do,';
  7.   error41=' or c-card following complete if(..)then do';
  8.   gotos='GO TO ';
  9.   CONTINUES='CONTINUE';
  10. TYPE
  11.   STRING1=STRING[1];
  12. VAR
  13.   RESULT:INTEGER;
  14.   FILENAME:STRING;
  15.   INFILE,OUTFILE:TEXT;
  16.   I,PLENGTH{packed l},CARDLENGTH,WORDCOUNT:INTEGER;
  17.   STACKSIZE,EXITCASE,LEVEL:INTEGER;
  18.   NTOP,RTOP,REMBLK,LNO,LABLE,LINC:INTEGER;
  19.   CODE,PRVCODE,RDEND,BCOL,BCARD:INTEGER;
  20.   PCOL,CCOL:INTEGER;
  21.   FOUND,HOLLERITH,EOS,EOC,ERRORSW:BOOLEAN;
  22.   BUFFNO,RTYPE,TOP:INTEGER;
  23.   LABLE1,LABLE2,TYPO:ARRAY[1..50]OF INTEGER;
  24.   BLKNAM:STRING;
  25.   BLANK:STRING1;
  26.   BNAME:ARRAY[1..50]OF STRING[8];
  27.   BUFFIN:ARRAY[1..2]OF STRING[20];
  28.   LBLIST:ARRAY[1..7]OF INTEGER;
  29.   CARD:STRING;
  30.   PACK:STRING;
  31.   FMT1:STRING;
  32.   STRTNO:ARRAY[1..2,1..50]OF INTEGER;
  33.   RETRNS:ARRAY[1..2,1..150]OF INTEGER;
  34.   FORMAT0:STRING;
  35.   CGOTO1,STNO,BUFLIN1:STRING;
  36.   RTRNSW,VFMT,ENDFILE:BOOLEAN;
  37.   AGOTO1,BLK:STRING;
  38.   CH:STRING1;
  39.   
  40. EXTERNAL FUNCTION @BDOS(FUNC:INTEGER;PARM:INTEGER):INTEGER;
  41. PROCEDURE ITOS(I:INTEGER;VAR S:STRING);FORWARD;
  42. PROCEDURE ERROR(LN:INTEGER;S:STRING);FORWARD;
  43. FUNCTION EQUAL(A:STRING;I:INTEGER;B:STRING;J:INTEGER;K:INTEGER):BOOLEAN;
  44. FORWARD;  
  45. FUNCTION OTHER(B:BOOLEAN):BOOLEAN;FORWARD;
  46. FUNCTION NORMAL(CARD:STRING):BOOLEAN;FORWARD;
  47. PROCEDURE FCONCAT(VAR S1:STRING;N1:INTEGER;S2:STRING;
  48.   MODE:INTEGER;N2:INTEGER);FORWARD;
  49. FUNCTION KOMPAR(S:STRING):BOOLEAN;FORWARD;
  50. PROCEDURE FINDCHAR(I:INTEGER;VAR CH:STRING1);FORWARD;
  51. FUNCTION ISDIGIT(C:STRING1):BOOLEAN;FORWARD;
  52. FUNCTION ISBLANK(C:STRING1):BOOLEAN;FORWARD;
  53. FUNCTION ISLETTER(C:STRING1):BOOLEAN;FORWARD;
  54. FUNCTION KOMPCH(S1:STRING;N1:INTEGER;S2:STRING;N2:INTEGER;N:INTEGER):
  55.   INTEGER;FORWARD;
  56. PROCEDURE PACKIT;FORWARD;
  57. FUNCTION FTNOPT(CARD:STRING):BOOLEAN;FORWARD;
  58. PROCEDURE BLANKCOM(VAR S:STRING);FORWARD;
  59. PROCEDURE UPPERC(VAR S:STRING);FORWARD;
  60. PROCEDURE GETCODE;FORWARD;
  61.  
  62.  
  63. PROCEDURE ABORT;
  64. VAR I:INTEGER;
  65. BEGIN
  66.   CLOSE(INFILE,RESULT);
  67.   CLOSE(OUTFILE,RESULT);
  68.   I:=@BDOS(0,0)
  69. END;
  70.  
  71.  
  72. PROCEDURE ITOS;
  73. VAR NEGFLAG:BOOLEAN;
  74.     K:INTEGER;
  75. BEGIN
  76.   NEGFLAG:=(I<0);S:='     ';
  77.   FOR K:=1 TO 5 DO BEGIN
  78.     S[6-K]:=CHR((I MOD 10)+ORD('0'));
  79.     I:=I DIV 10
  80.   END;
  81.   IF NEGFLAG THEN S:=CONCAT('-',S)
  82. END;
  83. PROCEDURE ERROR;
  84. VAR STR:STRING;
  85. BEGIN
  86.   ITOS(LN,STR);
  87.   WRITELN(STR,'  ',S);
  88.   ERRORSW:=TRUE;
  89. END;
  90.  
  91.  
  92. PROCEDURE FCONCAT;
  93. {mode 1:append the first n2 characters of s2 at position n1 of s1}
  94. {     3:insert the first n2 characters of s2 at n1 of s1 and kill rest}
  95. {     4:insert the first n2 characters of s2 at position n1 of s1}
  96. VAR S:STRING;
  97. BEGIN
  98.   S:=COPY(S2,1,N2);
  99.   IF(N1>LENGTH(S1))THEN S1:=CONCAT(S1,S)
  100.   ELSE IF MODE=3 THEN BEGIN
  101.     DELETE(S1,N1,LENGTH(S1)-N1+1);
  102.     S1:=CONCAT(S1,S)
  103.   END
  104.   ELSE IF (MODE=1)THEN BEGIN
  105.     DELETE(S1,N1,N2);
  106.     INSERT(S,S1,N1)
  107.   END
  108.   ELSE IF MODE=4 THEN BEGIN
  109.     INSERT(S,S1,N1)
  110.   END
  111. END;
  112.  
  113. FUNCTION ISDIGIT;
  114. BEGIN
  115.   IF (C[1] IN ['0'..'9'])THEN ISDIGIT:=TRUE
  116.   ELSE ISDIGIT:=FALSE
  117. END;
  118.  
  119. FUNCTION ISBLANK;
  120. BEGIN
  121.   IF C[1]=' ' THEN ISBLANK:=TRUE
  122.   ELSE ISBLANK:=FALSE
  123. END;
  124.  
  125. FUNCTION ISLETTER;
  126. BEGIN
  127.   IF (C[1]IN['A'..'Z']) THEN ISLETTER:=TRUE
  128.   ELSE ISLETTER:=FALSE
  129. END;
  130.  
  131. FUNCTION KOMPCH;
  132. VAR I,K:INTEGER;
  133. BEGIN
  134.   IF (LENGTH(S1)<(N+N1-1))THEN BEGIN
  135.     KOMPCH:=0; EXIT
  136.   END;
  137.   IF (LENGTH(S2)<(N+N2-1))THEN BEGIN
  138.     KOMPCH:=0; EXIT
  139.   END;
  140.   K:=0;
  141.   FOR I:=1 TO N DO BEGIN
  142.     IF(K=I-1)AND(S1[N1+I-1]=S2[N2+I-1])THEN K:=I
  143.     ELSE K:=0
  144.     
  145.   END;
  146.   KOMPCH:=K
  147. END;
  148.  
  149. PROCEDURE FINDCHAR;
  150. BEGIN
  151.   IF(I>LENGTH(CARD))THEN BEGIN
  152.     CH[1]:=CHR(255); EOC:=TRUE;EXIT
  153.   END
  154.   ELSE CH[1]:=CARD[I]
  155. END;
  156.  
  157. PROCEDURE PACKIT;
  158. BEGIN
  159.   CCOL:=7;
  160.   PCOL:=7;
  161.   PACK:='      ';
  162.   EOC:=FALSE;
  163.   FINDCHAR(CCOL,CH);
  164.   WHILE(CH[1]  IN [' ','A'..'Z'])AND(NOT EOC)DO BEGIN
  165.     IF (CH[1]  IN ['A'..'Z'])THEN BEGIN
  166.       PACK:=CONCAT(PACK,CH);
  167.       PCOL:=PCOL+1
  168.     END;
  169.     CCOL:=CCOL+1;
  170.     IF(CCOL>CARDLENGTH)THEN EOC:=TRUE
  171.     ELSE FINDCHAR(CCOL,CH)
  172.   END;
  173.   PRVCODE:=CODE;
  174.   CODE:=0;
  175.   PLENGTH:=PCOL-7
  176. END;
  177.  
  178.   
  179. FUNCTION KOMPAR;
  180. BEGIN
  181.   KOMPAR:=(KOMPCH(PACK,7,S,1,LENGTH(S))<>0)
  182. END;
  183.  
  184. FUNCTION EQUAL;
  185. BEGIN
  186.   EQUAL:=KOMPCH(A,I,B,J,K)<>0
  187. END;
  188.  
  189. FUNCTION NORMAL;
  190. BEGIN
  191.   NORMAL:=(EQUAL(CARD,6,BLANK,1,1))
  192.           OR (EQUAL(CARD,6,'0',1,1))
  193.           OR (EQUAL(CARD,1,'C',1,1))
  194.           OR (EQUAL(CARD,1,'*',1,1))
  195. END;
  196.  
  197. FUNCTION FTNOPT;
  198. BEGIN
  199.   FTNOPT:=(EQUAL(CARD,1,'*! ',1,3))
  200.           OR (EQUAL(CARD,1,'C! ',1,3))
  201.           OR (EQUAL(CARD,1,'c! ',1,3))
  202. END;
  203.   
  204. PROCEDURE BLANKCOM;
  205. BEGIN
  206.   IF (LENGTH(S)>0)THEN EXIT
  207.   ELSE S:='C'
  208. END;
  209. FUNCTION OTHER;
  210. BEGIN
  211.   IF (B=TRUE)THEN OTHER:=FALSE ELSE
  212.     OTHER:=TRUE
  213. END;
  214.  
  215. PROCEDURE UPPERC;
  216. VAR STRFLAG:BOOLEAN;
  217.     I:INTEGER;
  218. BEGIN
  219.   STRFLAG:=FALSE;
  220.   FOR I:=1 TO LENGTH(S) DO BEGIN
  221.     IF (S[I]='''') THEN STRFLAG:=OTHER(STRFLAG)
  222.     ELSE IF ((S[I]IN ['a'..'z']) AND (NOT STRFLAG)) THEN S[I]:=CHR(ORD(S[I])
  223.     -ORD('a')+ORD('A'))
  224.   END
  225. END;
  226.  
  227. PROCEDURE GETCODE;
  228. VAR N:INTEGER;
  229. BEGIN
  230.   IF(PLENGTH=2)THEN 
  231.     IF(KOMPAR('IF')AND EQUAL('(',1,CH,1,1)) THEN CODE:=13;
  232.   IF(PLENGTH=3)THEN
  233.     IF(KOMPAR('END')AND EOC)THEN CODE:=-1;
  234.   IF(PLENGTH=4) THEN BEGIN 
  235.     IF KOMPAR('READ')THEN BEGIN
  236.       RDEND:=CCOL;
  237.       IF EQUAL(',',1,CH,1,1)THEN CODE:=15
  238.       ELSE IF EQUAL('(',1,CH,1,1)THEN CODE:=16
  239.       ELSE IF ISDIGIT(CH) THEN CODE:=18
  240.     END
  241.     ELSE IF KOMPAR('STOP')AND EOC THEN CODE:=-2
  242.   END;
  243.   IF(PLENGTH=5)THEN BEGIN
  244.     IF KOMPAR('ENDIF')AND EOC THEN CODE:=2
  245.     ELSE IF KOMPAR('WHILE')AND EQUAL('(',1,CH,1,1) THEN CODE:=14
  246.     ELSE IF KOMPAR('PRINT')THEN CODE:=19
  247.   END;
  248.   IF(PLENGTH=6)THEN
  249.     IF (KOMPAR('ELSEDO')AND EOC)THEN CODE:=1;
  250.   IF(PLENGTH=7)THEN
  251.     IF EOC THEN BEGIN
  252.       IF KOMPAR('ATENDDO')THEN CODE:=12
  253.       ELSE IF KOMPAR('ENDCASE')THEN CODE:=8
  254.   END;
  255.   IF(PLENGTH=8)THEN BEGIN
  256.     IF EOC THEN BEGIN
  257.       IF KOMPAR('ENDWHILE') THEN CODE:=3
  258.       ELSE BEGIN
  259.         IF KOMPAR('ENDATEND')THEN CODE:=4
  260.         ELSE IF KOMPAR('IFNONEDO')THEN CODE:=7
  261.       END
  262.     END
  263.   END;
  264.   IF (CODE=0) THEN BEGIN
  265.     IF KOMPAR('DOCASE')THEN CODE:=5
  266.     ELSE BEGIN
  267.       IF KOMPAR('CASE')THEN CODE:=6
  268.       ELSE BEGIN
  269.         IF (KOMPAR('READ')AND EQUAL(',',1,CH,1,1))THEN BEGIN
  270.           CODE:=17;
  271.           RDEND:=CCOL;
  272.           FMT1:=COPY(PACK,11,PCOL-11);
  273.           
  274.         END
  275.         ELSE BEGIN
  276.           IF KOMPAR('EXECUTE') THEN CODE:=9
  277.           ELSE IF KOMPAR('REMOTEBLOCK')THEN CODE:=10
  278.           ELSE IF KOMPAR('ENDBLOCK')THEN CODE:=11
  279.         END
  280.       END
  281.     END
  282.   END
  283. END;
  284.       
  285.   
  286. PROCEDURE LNFMT;
  287. BEGIN
  288.   LNO:=LNO+LINC;
  289.   IF (NOT ((FTNOPT(CARD))OR(NORMAL(CARD))))THEN
  290.     CARD:=CONCAT('     &',CARD)
  291. END;
  292.     
  293.   
  294. PROCEDURE GETLINE;
  295. BEGIN
  296.   READLN(INFILE,CARD);
  297.   IF(EOF(INFILE))THEN BEGIN
  298.     WRITELN('Done');ABORT
  299.   END;
  300.   BLANKCOM(CARD);
  301.   LNFMT;
  302.   UPPERC(CARD)
  303. END;
  304.  
  305. {see WATFIV.DOC for details of use}
  306. PROCEDURE WAT;
  307. VAR OUTFORMAT:STRING;
  308. BUFIN:ARRAY[1..20]OF STRING;
  309.  
  310. PROCEDURE INITIALIZE;
  311. VAR I:INTEGER;
  312. BEGIN
  313.   OUTFORMAT:='READ';
  314.   CARDLENGTH:=80;
  315.   WORDCOUNT:=20;
  316.   STACKSIZE:=50;
  317.   FOR I:=1 TO 50 DO LABLE1[I]:=0;
  318.   FOR I:=1 TO 50 DO LABLE2[I]:=0;
  319.   FOR I:=1 TO 50 DO TYPO[I]:=0;
  320.   CH:=' ';
  321.   NTOP:=0;
  322.   RTOP:=0;
  323.   BUFFNO:=0;
  324.   REMBLK:=0;
  325.   BLK:='                                     ';
  326.   BLK:=CONCAT(BLK,BLK);
  327.   BLANK:=' ';
  328.   LNO:=0;
  329.   LINC:=1;
  330.   EOC:=FALSE;
  331.   LABLE:=30000;
  332.   PRVCODE:=0;
  333.   CODE:=0;
  334.   ERRORSW:=FALSE;
  335.   TOP:=1;
  336.   RTRNSW:=FALSE;
  337.   VFMT:=FALSE;
  338.   EOS:=FALSE;
  339.   ENDFILE:=FALSE;
  340. END;
  341.  
  342. PROCEDURE GETLABEL;
  343. BEGIN
  344.   LABLE:=LABLE+1
  345. END;
  346. PROCEDURE GETTOP;
  347. BEGIN
  348.   TOP:=TOP+1;
  349.   IF (TOP>STACKSIZE)THEN ERROR(LNO,STACKFLAG)
  350. END;
  351.  
  352.  
  353. PROCEDURE CONVERT(S:STRING;VAR T,FORMAT:STRING);
  354. {converts the string s to t and format according to fortran rules}
  355. {assigns 20 spaces each, takes no account of brackets}
  356. VAR PRINTFCOMMA,PRINTCOMMA,NEWTOKEN,ASCII:BOOLEAN;
  357.   I:INTEGER;
  358.   S1:STRING[1];
  359. BEGIN
  360.   NEWTOKEN:=TRUE;
  361.   S1:=' ';
  362.   ASCII:=FALSE;
  363.   I:=1;
  364.   PRINTCOMMA:=FALSE;
  365.   PRINTFCOMMA:=FALSE;
  366.   WHILE (I<=LENGTH(S))DO BEGIN
  367.     S1[1]:=S[I];
  368.     IF (S1='''')THEN BEGIN
  369.       IF PRINTFCOMMA THEN BEGIN
  370.         FORMAT:=CONCAT(FORMAT,',');
  371.         PRINTCOMMA:=FALSE
  372.       END;
  373.       FORMAT:=CONCAT(FORMAT,S1);
  374.       ASCII:=NOT ASCII
  375.     END
  376.     ELSE BEGIN{not '}
  377.       IF (ASCII=FALSE)THEN BEGIN
  378.         IF (S1=',')THEN BEGIN
  379.           NEWTOKEN:=TRUE;
  380.           PRINTCOMMA:=TRUE;
  381.           PRINTFCOMMA:=TRUE
  382.         END
  383.         ELSE BEGIN{not ',ascii,comma}
  384.           IF PRINTFCOMMA THEN BEGIN
  385.             FORMAT:=CONCAT(FORMAT,',');
  386.             PRINTFCOMMA:=FALSE
  387.           END;
  388.           IF NEWTOKEN=TRUE THEN BEGIN
  389.             IF(S1[1] IN ['A'..'H','a'..'h','O'..'Z','o'..'z'])THEN
  390.               FORMAT:=CONCAT(FORMAT,'E20.8')
  391.             ELSE FORMAT:=CONCAT(FORMAT,'I20')
  392.           end;
  393.           IF PRINTCOMMA THEN BEGIN
  394.             T:=CONCAT(T,',');
  395.             PRINTCOMMA:=FALSE
  396.           END;
  397.           T:=CONCAT(T,S1);
  398.           NEWTOKEN:=FALSE
  399.         END;
  400.       END
  401.       ELSE BEGIN
  402.         FORMAT:=CONCAT(FORMAT,S1);
  403.         PRINTFCOMMA:=FALSE
  404.       END
  405.     END;
  406.     I:=I+1
  407.   END
  408. END;
  409.  
  410. PROCEDURE OUTCON(I:INTEGER);
  411. BEGIN
  412.   WRITELN(OUTFILE,I:5,' ',CONTINUES)
  413. END;
  414.  
  415. PROCEDURE OUTGO(I:INTEGER);
  416. BEGIN
  417.   WRITELN(OUTFILE,'      ',GOTOS,I:5)
  418. END;
  419.  
  420. PROCEDURE WRRD1;FORWARD;
  421. PROCEDURE PUTLINE;FORWARD;
  422. PROCEDURE WRRD2;FORWARD;
  423. PROCEDURE RD2;FORWARD;
  424. PROCEDURE NPACK;FORWARD;
  425. PROCEDURE ENDWH;FORWARD;
  426. PROCEDURE ENDIF;FORWARD;
  427. PROCEDURE EXEC;FORWARD;
  428.  
  429. PROCEDURE CASES;
  430. VAR MATCH,II,J,N:INTEGER;
  431. BEGIN
  432.   IF (CODE>12)AND(CODE<15)THEN BEGIN
  433.     IF (CODE=14)THEN BEGIN
  434.       GETLABEL;
  435.       OUTCON(LABLE);
  436.       N:=CCOL-1;
  437.       FCONCAT(CARD,7,'IF',1,2);
  438.       FCONCAT(CARD,9,BLK,1,N-8)
  439.     END;
  440.     CCOL:=CCOL+1;
  441.     LEVEL:=0;
  442.     HOLLERITH:=FALSE;
  443.     WHILE((NOT EQUAL(CARD,CCOL,')',1,1))
  444.            OR(LEVEL<>0)
  445.            OR(HOLLERITH))DO BEGIN
  446.       IF(EQUAL(CARD,CCOL,'''',1,1))THEN HOLLERITH:=OTHER(HOLLERITH)
  447.       ELSE BEGIN
  448.         IF (NOT HOLLERITH)THEN BEGIN
  449.           IF EQUAL(CARD,CCOL,'(',1,1)THEN LEVEL:=LEVEL+1
  450.           ELSE BEGIN
  451.             IF EQUAL(CARD,CCOL,')',1,1)THEN LEVEL:=LEVEL-1
  452.           END
  453.         END
  454.       END;
  455.       CCOL:=CCOL+1;
  456.       IF(CCOL>CARDLENGTH)THEN BEGIN
  457.         WRRD2;
  458.         IF(RTRNSW) THEN ABORT;
  459.         CCOL:=7
  460.       END
  461.     END;
  462.     FCONCAT(CARD,CCOL,BLANK,1,1);
  463.     J:=CCOL;
  464.     WHILE (EQUAL(CARD,CCOL,BLANK,1,1)
  465.       AND(CCOL<=CARDLENGTH))DO CCOL:=CCOL+1;
  466.     FCONCAT(CARD,J,')',1,1);
  467.     J:=J+1;
  468.     IF(CCOL>CARDLENGTH)THEN BEGIN
  469.       WRRD2;
  470.       IF(RTRNSW)THEN ABORT;
  471.       J:=7;
  472.       CCOL:=7
  473.     END;
  474.     PACK:='      ';
  475.     PCOL:=7;
  476.     EOC:=FALSE;
  477.     FINDCHAR(CCOL,CH);
  478.     NPACK;
  479.     MATCH:=0;
  480.     IF(KOMPAR('EXECUTE'))THEN MATCH:=2
  481.     ELSE BEGIN
  482.       IF(CODE=14)THEN BEGIN
  483.         IF(KOMPAR('DO')AND(EOC))THEN MATCH:=1
  484.         ELSE BEGIN
  485.           ERROR(LNO,'''do'' missing from while-do');
  486.           ABORT
  487.         END
  488.       END
  489.       ELSE BEGIN
  490.         IF (KOMPAR('THENDO')AND(EOC))THEN MATCH:=1
  491.       END
  492.     END;
  493.     IF(MATCH=0)THEN WRRD1
  494.     ELSE BEGIN
  495.       GETLABEL;
  496.       ITOS(LABLE,FMT1);
  497.       CCOL:=J;
  498.       IF (CCOL>64)THEN BEGIN
  499.         FCONCAT(CARD,CCOL,BLK,1,CARDLENGTH+1-CCOL);
  500.         PUTLINE;
  501.         CARD:='     &GOTO';
  502.         CCOL:=11
  503.       END
  504.       ELSE BEGIN
  505.         FCONCAT(CARD,CCOL,'GOTO',3,4);
  506.         CCOL:=CCOL+3
  507.       END;
  508.       FCONCAT(CARD,CCOL+1,FMT1,1,5);
  509.       PUTLINE;
  510.       GETLABEL;
  511.       OUTGO(LABLE);
  512.       OUTCON(LABLE-1);
  513.       GETTOP;
  514.       LABLE1[TOP]:=LABLE;
  515.       TYPO[TOP]:=CODE;
  516.       IF(CODE=14)THEN LABLE2[TOP]:=LABLE-2;
  517.       IF(MATCH=2)THEN BEGIN
  518.         EXEC;
  519.         IF(CODE=14)THEN ENDWH
  520.         ELSE ENDIF
  521.       END;
  522.       RD2;
  523.       IF(NOT NORMAL(CARD))THEN BEGIN
  524.         ERROR(LNO,CONCAT(ERROR4,ERROR41));
  525.         ABORT
  526.       END
  527.     END
  528.   END
  529. END;
  530.  
  531.  
  532.  
  533. PROCEDURE PUTCLN;
  534. VAR INDEX:INTEGER;
  535. BEGIN
  536.   WRITELN(OUTFILE,CARD)
  537. END;
  538.  
  539. PROCEDURE DUMPBUF;
  540. VAR I:INTEGER;
  541. BEGIN
  542.   I:=1;
  543.   WHILE(I<=BUFFNO)DO BEGIN
  544.     WRITELN(OUTFILE,BUFIN[I]);
  545.     I:=I+1
  546.   END;
  547.   BUFFNO:=0;
  548. END;
  549.  
  550. PROCEDURE PUTLINE;
  551. BEGIN
  552.   PUTCLN
  553. END;
  554.  
  555. PROCEDURE RD1;
  556. BEGIN
  557.   GETLINE;
  558.   IF EOF THEN BEGIN
  559.     EOS:=TRUE;
  560.     ENDFILE:=TRUE
  561.   END;
  562.   IF (NORMAL(CARD))THEN EOS:=TRUE
  563. END;
  564.  
  565. PROCEDURE RD2;
  566. BEGIN
  567.   GETLINE;
  568.   IF EOF THEN BEGIN
  569.     ENDFILE:=TRUE;
  570.     FCONCAT(CARD,6,BLK,1,1)
  571.   END
  572. END;
  573.  
  574. PROCEDURE WRRD1;
  575. BEGIN
  576.   EOS:=FALSE;
  577.   WHILE (NOT EOS)DO BEGIN
  578.     PUTLINE;
  579.     RD1
  580.   END
  581. END;
  582.  
  583. PROCEDURE WRRD2;
  584. BEGIN
  585.   PUTLINE;
  586.   RD2;
  587.   IF(NORMAL(CARD)) THEN BEGIN
  588.     ERROR(LNO,'Expecting continuation line.');
  589.     RTRNSW:=TRUE
  590.   END
  591. END;
  592.  
  593. PROCEDURE NPACK;
  594. BEGIN
  595.   IF (NOT EOC) THEN BEGIN
  596.     WHILE(ISDIGIT(CH)
  597.     OR ISLETTER(CH) 
  598.     OR ISBLANK(CH))AND(NOT EOC) DO BEGIN
  599.       IF (NOT ISBLANK(CH)) THEN BEGIN
  600.         FCONCAT(PACK,PCOL,CH,4,1);
  601.         PCOL:=PCOL+1
  602.       END;
  603.       CCOL:=CCOL+1;
  604.       IF(CCOL>CARDLENGTH)THEN EOC:=TRUE
  605.       ELSE FINDCHAR(CCOL,CH)
  606.     END
  607.   END
  608. END;
  609.       
  610.   PROCEDURE SKIPCOMMENT;
  611. BEGIN
  612.   IF FTNOPT(CARD) THEN PUTCLN;
  613.   GETLINE
  614. END;
  615.  
  616. PROCEDURE NMSRCH;
  617. BEGIN
  618.   BNAME[NTOP+1]:=BLKNAM;
  619.   I:=1;
  620.   WHILE (NOT EQUAL(BNAME[I],1,BLKNAM,1,8))DO I:=I+1
  621. END;
  622.  
  623. PROCEDURE XITCAS;
  624. BEGIN
  625.   I:=TOP;
  626.   FOUND:=FALSE;
  627.   WHILE (NOT FOUND) DO BEGIN
  628.     IF(TYPO[I]=5)THEN FOUND:=TRUE;
  629.     I:=I-1
  630.   END;
  631.   OUTGO(LABLE1[I])
  632. END;
  633.  
  634. PROCEDURE EXEC;
  635. BEGIN
  636.   IF(NOT EOC)THEN ERROR(LNO,'Invalid name for execute block')
  637.   ELSE BEGIN
  638.     PLENGTH:=PCOL-14;
  639.     IF(PLENGTH<8)THEN FCONCAT(PACK,PCOL,BLK,1,8);
  640.     BLKNAM:=COPY(PACK,14,8);
  641.     NMSRCH;
  642.     IF(I>NTOP) THEN BEGIN
  643.       NTOP:=I;
  644.       GETLABEL;
  645.       STRTNO[1,I]:=LABLE;
  646.       STRTNO[2,I]:=RTOP+1
  647.     END;
  648.     GETLABEL;
  649.     RTOP:=RTOP+1;
  650.     RETRNS[1,RTOP]:=LABLE;
  651.     IF(STRTNO[2,I]=RTOP)THEN RETRNS[2,RTOP]:=0
  652.     ELSE BEGIN
  653.       RETRNS[2,RTOP]:=STRTNO[2,I];
  654.       STRTNO[2,I]:=RTOP
  655.     END;
  656.     IF (NOT EQUAL(CARD,1,BLK,1,5))AND(CODE=9) THEN BEGIN
  657.       CARD:=COPY(CARD,1,5); WRITELN(OUTFILE,CARD:5,' ',CONTINUES)
  658.     END;
  659.     CARD:=' ';
  660.     WRITELN(OUTFILE,'      ','ASSIGN ',LABLE,' TO ',BLKNAM);
  661.     IF(STRTNO[1,I]=0) THEN
  662.       ERROR(LNO,'Execute stmt. must precede its execute block.');
  663.     OUTGO(STRTNO[1,I]);
  664.     OUTCON(LABLE)
  665.   END
  666. END;
  667.   
  668. PROCEDURE ENDATEND;
  669. BEGIN
  670.   IF(TYPO[TOP]<>12)THEN
  671.     ERROR(LNO,'Mismatch of END AT END')
  672.   ELSE BEGIN
  673.     OUTCON(LABLE1[TOP]);
  674.     TOP:=TOP-1
  675.   END
  676. END;
  677.  
  678. PROCEDURE DOCASEVNAME;
  679. BEGIN
  680.   NPACK;
  681.   IF(NOT EOC) THEN
  682.     ERROR(LNO,'A variable name is expected after ''DO CASE''')
  683.   ELSE BEGIN
  684.     PLENGTH:=PCOL-13;
  685.     IF(PLENGTH<8)THEN FCONCAT(PACK,PCOL,BLK,1,21-PCOL);
  686.     IF(NOT EQUAL(CARD,1,BLK,1,5))THEN BEGIN
  687.       FCONCAT(CARD,6,' CONTINUE',3,9);
  688.       PUTLINE
  689.     END;
  690.     GETTOP;
  691.     GETLABEL;
  692.     LABLE1[TOP]:=LABLE;
  693.     LABLE2[TOP]:=ORD(PACK[13]);
  694.     TYPO[TOP]:=ORD(PACK[13]);
  695.     GETLABEL;
  696.     GETTOP;
  697.     LABLE1[TOP]:=LABLE;
  698.     OUTGO(LABLE);
  699.     GETLABEL;
  700.     LABLE2[TOP]:=LABLE;
  701.     TYPO[TOP]:=5;
  702.     OUTCON(LABLE)
  703.   END
  704. END;
  705.  
  706. PROCEDURE ENDIF;
  707. BEGIN
  708.   IF (TYPO[TOP]<>13) AND (TYPO[TOP]<>1)THEN
  709.     ERROR(LNO,'''end if'' only follows ''if(..'' or ''else do..''.')
  710.   ELSE BEGIN
  711.     OUTCON(LABLE1[TOP]);
  712.     TOP:=TOP-1
  713.   END
  714. END;
  715.  
  716. PROCEDURE ELSEDO;
  717. BEGIN
  718.   IF(TYPO[TOP]<>13)THEN 
  719.     ERROR(LNO,'''elsedo'' follows after ''if-then''.')
  720.   ELSE BEGIN
  721.     GETLABEL;
  722.     IF(PRVCODE<>-2) THEN OUTGO(LABLE);
  723.     OUTCON(LABLE1[TOP]);
  724.     LABLE1[TOP]:=LABLE;
  725.     TYPO[TOP]:=1
  726.   END
  727. END;
  728.  
  729. PROCEDURE ENDWH;
  730. BEGIN
  731.   IF (TYPO[TOP]<>14)THEN
  732.     ERROR(LNO,'Mismatch of ''end while''.')
  733.   ELSE BEGIN
  734.     OUTGO(LABLE2[TOP]);
  735.     OUTCON(LABLE1[TOP]);
  736.     TOP:=TOP-1
  737.   END
  738. END;
  739.  
  740. PROCEDURE CASEDOT;
  741. BEGIN
  742.   IF ((TYPO[TOP]<>5)AND(TYPO[TOP]<>6))THEN
  743.     ERROR(LNO,'Illegal ''case'' usage.')
  744.   ELSE BEGIN
  745.     IF(PRVCODE<>5)THEN BEGIN
  746.       XITCAS;
  747.       GETLABEL;
  748.       OUTCON(LABLE);
  749.       GETTOP;
  750.       LABLE1[TOP]:=LABLE;
  751.       TYPO[TOP]:=6
  752.     END
  753.   END
  754. END;
  755.  
  756. PROCEDURE CGOTO;
  757. VAR NOLBLS,N,J,NN,K:INTEGER;
  758.     STR:STRING;
  759.     S1,S2:STRING1;
  760. PROCEDURE MAKESTRING(I:INTEGER;VAR S:STRING1);
  761. BEGIN
  762.   S:=' ';
  763.   S[1]:=CHR(I)
  764. END;
  765. BEGIN
  766.   CARD:=' ';
  767.   I:=I+1;
  768.   IF(CODE=7)THEN BEGIN
  769.     MAKESTRING(LABLE2[I-1],S1);
  770.     WRITELN(OUTFILE,LABLE1[I]:5,' ','IF(',S1,'.LT.1.OR.',S1,
  771.       '.GT.',TOP-I+1,')GOTO ',LABLE)
  772.   END
  773.   ELSE BEGIN
  774.     MAKESTRING(LABLE2[I-1],S1);
  775.     WRITELN(OUTFILE,LABLE1[I]:5,' ','IF(',S1,'.LT.1.OR.',
  776.     S1,'.GT.',TOP-I+1,')GOTO ',LABLE1[I-1])
  777.   END;
  778.   ITOS(LABLE2[I],CARD);
  779.   CARD:=CONCAT('      GOTO(',CARD);
  780.   NOLBLS:=TOP-I;
  781.   N:=0;
  782.   J:=I+1;
  783.   {walk through the stack getting end case entry labels}
  784.   WHILE (NOLBLS>0)DO BEGIN
  785.     IF(NOLBLS<=8)THEN BEGIN
  786.       N:=NOLBLS;
  787.       NOLBLS:=0
  788.     END ELSE BEGIN
  789.       N:=8;
  790.       NOLBLS:=NOLBLS-8
  791.     END;
  792.     NN:=J+N-1;
  793.     FOR K:=J TO NN DO BEGIN
  794.       ITOS(LABLE1[K],STR);
  795.       CARD:=CONCAT(CARD,',',STR)
  796.     END;
  797.     J:=NN+1;
  798.     IF(NOLBLS<>0)THEN BEGIN
  799.       PUTLINE;
  800.       CARD:='      &'
  801.     END
  802.   END;{while}
  803.   CCOL:=N*6+17;
  804.   FCONCAT(CARD,CCOL,'),',1,2);
  805.   MAKESTRING(LABLE2[I-1],S1);
  806.   FCONCAT(CARD,CCOL+2,S1,1,1);
  807.   PUTLINE;
  808.   I:=I-1
  809. END;
  810.  
  811.     
  812.   
  813. PROCEDURE EXECUTE;
  814. BEGIN
  815.   NPACK;
  816.   EXEC
  817. END;
  818.  
  819. PROCEDURE IFNONEDO;
  820. BEGIN IF(TYPO[TOP]<>5)AND(TYPO[TOP]<>6) THEN
  821.     ERROR(LNO,'Illegal ''if none do'' usage.')
  822.   ELSE BEGIN
  823.     XITCAS;
  824.     GETLABEL;
  825.     CGOTO;
  826.     OUTCON(LABLE);
  827.     GETTOP;
  828.     TYPO[TOP]:=7;
  829.     LABLE1[TOP]:=I
  830.   END
  831. END;
  832.  
  833. PROCEDURE ENDCASE; BEGIN IF(TYPO[TOP]<5)OR(TYPO[TOP]>7)THEN
  834.     ERROR(LNO,'Mismatch of ''end case''.')
  835.   ELSE BEGIN
  836.     XITCAS;
  837.     IF(TYPO[TOP]=7)THEN I:=LABLE1[TOP]
  838.     ELSE CGOTO;
  839.     OUTCON(LABLE1[I]);
  840.     TOP:=I-1
  841.   END
  842. END;
  843.  
  844. PROCEDURE REMOTEBLOCK; BEGIN NPACK;
  845.   IF (NOT EOC) THEN ERROR(LNO,'Invalid remote block name.')
  846.   ELSE BEGIN
  847.     PLENGTH:=PCOL-18;
  848.     IF(PLENGTH<8)THEN FCONCAT(PACK,PCOL,BLK,1,8);
  849.     BLKNAM:=COPY(PACK,18,8);
  850.     NMSRCH;
  851.     IF(I>NTOP) OR (STRTNO[1,I]=0)THEN BEGIN
  852.       ERROR(LNO,BLKNAM);WRITELN('not found.')
  853.     END
  854.     ELSE BEGIN
  855.       REMBLK:=I;
  856.       OUTCON(STRTNO[1,I]);
  857.       STRTNO[1,I]:=0
  858.     END
  859.   END
  860. END;
  861.  
  862. PROCEDURE ENDBLOCK;
  863. VAR J,K:INTEGER;
  864.     STR:STRING;
  865.  
  866. BEGIN 
  867.   IF(REMBLK=0)THEN ERROR(LNO,'Mismatch of ''end block''.')
  868.   ELSE BEGIN
  869.     I:=STRTNO[2,REMBLK];
  870.     ITOS(RETRNS[1,I],CARD);
  871.     CARD:=CONCAT('       ',GOTOS,BNAME[REMBLK],',(',CARD);
  872.     CCOL:=27;
  873.     J:=0;
  874.     WHILE(RETRNS[2,I]<>0)DO BEGIN
  875.       J:=0;
  876.       WHILE(J<7)AND(RETRNS[2,I]<>0)DO BEGIN
  877.         J:=J+1;
  878.         I:=RETRNS[2,I];
  879.         LBLIST[J]:=RETRNS[1,I]
  880.       END;
  881.       FOR K:=1 TO J DO BEGIN
  882.         ITOS(LBLIST[K],STR);
  883.         CARD:=CONCAT(CARD,',',STR)
  884.       END;
  885.       CCOL:=CCOL+6*J;
  886.       IF(RETRNS[2,I]<>0)THEN BEGIN
  887.         PUTLINE;
  888.         CARD:='     &';
  889.         CCOL:=27
  890.       END
  891.     END;
  892.     CARD:=CONCAT(CARD,')');
  893.     PUTLINE;
  894.     REMBLK:=0
  895.   END
  896. END;
  897. PROCEDURE UNFORMAT;
  898. VAR STR,T,F,LABSTR:STRING;
  899. BEGIN
  900.   {read,.../at end do}
  901.   CARD:='     ';
  902.   STR:=BUFIN[1];
  903.   FCONCAT(CARD,1,STR,1,5);
  904.   BCOL:=RDEND+1;
  905.   STR:=COPY(STR,BCOL,LENGTH(STR)+1-BCOL);
  906.   T:='';
  907.   F:='';
  908.   CONVERT(STR,T,F);
  909.   GETLABEL;
  910.   ITOS(LABLE,LABSTR);
  911.   CARD:=CONCAT(CARD,' ',OUTFORMAT,'(1,',LABSTR,')',T);
  912.   PUTLINE;
  913.   CARD:=CONCAT(LABSTR,' FORMAT(',F,')');
  914.   BUFFNO:=0
  915. END;
  916. PROCEDURE ATENDDO;
  917. VAR II:INTEGER;
  918.     STR:STRING;
  919. PROCEDURE AR2;
  920. BEGIN
  921.   STR:=BUFIN[1];
  922.   CARD:=' ';
  923.   FCONCAT(CARD,1,STR,3,RDEND);
  924.   LEVEL:=0;
  925.   I:=RDEND+1;
  926.   WHILE (I<=LENGTH(BUFIN[1]))AND(LEVEL>=0)DO BEGIN
  927.     IF(EQUAL(BUFIN[1],I,'(',1,1))THEN LEVEL:=LEVEL+1
  928.     ELSE IF(EQUAL(BUFIN[1],I,')',1,1))THEN LEVEL:=LEVEL-1;
  929.     STR:=' ';
  930.     STR[1]:=BUFIN[1,I];
  931.     CARD:=CONCAT(CARD,STR);
  932.     I:=I+1
  933.   END;
  934.   DELETE(CARD,LENGTH(CARD),1);
  935.   GETLABEL;
  936.   ITOS(LABLE,STR);
  937.   BCOL:=I;
  938.   CARD:=CONCAT(CARD,',END=',STR,')');
  939.   I:=I+12
  940. END;
  941. PROCEDURE AR3;
  942. BEGIN
  943.   GETLABEL;
  944.   CARD:='     ';
  945.   STR:=BUFIN[1];
  946.   FCONCAT(CARD,1,STR,1,5);
  947.   ITOS(LABLE,STR);
  948.   CARD:=CONCAT(CARD,' ',OUTFORMAT,'(',FMT1,',END=',STR,')');
  949.   BCOL:=RDEND+1;
  950.   I:=36
  951. END;
  952.  
  953. BEGIN IF(PRVCODE<15)THEN 
  954.     ERROR(LNO,'Previous  statement must be a read.')
  955.   ELSE BEGIN
  956.     RTYPE:=PRVCODE-14;
  957.     IF RTYPE=1 THEN ERROR(LNO,'Does not support unformatted read')
  958.     ELSE IF RTYPE=2 THEN AR2
  959.     ELSE IF RTYPE=3 THEN AR3;
  960.     STR:=BUFIN[1];
  961.     STR:=COPY(STR,BCOL,LENGTH(STR)-BCOL+1);
  962.     CARD:=CONCAT(CARD,STR);
  963.     PUTLINE;
  964.     IF(BUFFNO>1)THEN
  965.       FOR II:=2 TO BUFFNO DO WRITELN(OUTFILE,BUFIN[II]);
  966.     BUFFNO:=0;
  967.     GETLABEL;
  968.     OUTGO(LABLE);
  969.     OUTCON(LABLE-1);
  970.     GETTOP;
  971.     LABLE1[TOP]:=LABLE;
  972.     TYPO[TOP]:=12
  973.   END
  974. END;
  975.  
  976. PROCEDURE CASE12;
  977. BEGIN
  978.   IF CODE=1 THEN ELSEDO
  979.   ELSE IF CODE=2 THEN ENDIF
  980.   ELSE IF CODE=3 THEN ENDWH
  981.   ELSE IF CODE=4 THEN ENDATEND
  982.   ELSE IF CODE=5 THEN DOCASEVNAME
  983.   ELSE IF CODE=6 THEN CASEDOT
  984.   ELSE IF CODE=7 THEN IFNONEDO
  985.   ELSE IF CODE=8 THEN ENDCASE
  986.   ELSE IF CODE=9 THEN EXECUTE
  987.   ELSE IF CODE=10 THEN REMOTEBLOCK
  988.   ELSE IF CODE=11 THEN ENDBLOCK
  989.   ELSE IF CODE=12 THEN ATENDDO;
  990.   RD2;
  991.   IF(NOT NORMAL(CARD))THEN
  992.     ERROR(LNO,'Unexpected continuation card');
  993.   IF ERRORSW THEN BEGIN
  994.     ERROR(LNO,'Translator terminated. Fix error and re-try.');
  995.     ABORT
  996.   END
  997. END;
  998.     
  999. PROCEDURE CASE16; BEGIN 
  1000.   IF(CODE=18)THEN BEGIN
  1001.     FMT1:='';
  1002.     PACK:=' ';
  1003.     PCOL:=1;
  1004.     CODE:=17;
  1005.     FINDCHAR(CCOL,CH);
  1006.     WHILE (CH<>',')DO BEGIN
  1007.       IF (NOT ISBLANK(CH))THEN BEGIN
  1008.         IF (NOT (ISDIGIT(CH))OR(ISLETTER(CH)))THEN 
  1009.           ERROR(LNO,'Unexpected non-alphabetic characters.')
  1010.         ELSE BEGIN
  1011.           FCONCAT(PACK,PCOL,CH,4,1);
  1012.           PCOL:=PCOL+1
  1013.         END
  1014.       END;
  1015.       CCOL:=CCOL+1;
  1016.       IF(CCOL>CARDLENGTH)THEN BEGIN
  1017.         WRITELN('Statement must be complete on one card.');
  1018.         ABORT
  1019.       END;
  1020.       FINDCHAR(CCOL,CH)
  1021.     END;
  1022.     IF(PCOL>6)THEN BEGIN
  1023.       ERROR(LNO,'Invalid read statement');
  1024.       ABORT
  1025.     END;
  1026.     FCONCAT(FMT1,1,PACK,1,PCOL-1);
  1027.     RDEND:=CCOL
  1028.   END{if};
  1029.   IF(LENGTH(FMT1)=0)THEN BEGIN FMT1:='1,29999';VFMT:=TRUE END
  1030.   ELSE BEGIN
  1031.     CH:=COPY(FMT1,1,1);
  1032.     IF ISDIGIT(CH)THEN FMT1:=CONCAT('1,',FMT1)
  1033.   END;
  1034.   I:=1;
  1035.   EOS:=FALSE;
  1036.   WHILE (NOT EOS) DO BEGIN
  1037.     BUFIN[I]:=CARD;
  1038.     RD1;
  1039.     I:=I+1;
  1040.     IF(I>21)THEN BEGIN
  1041.       ERROR(LNO,ERROR2);
  1042.       ABORT
  1043.     END
  1044.   END;
  1045.   BUFFNO:=I-1;
  1046. END;
  1047.       
  1048. PROCEDURE PARSE;
  1049. BEGIN
  1050.   GETLINE;
  1051.   WHILE NOT EOF DO BEGIN
  1052.     WHILE(EQUAL(CARD,1,'C',1,1))OR(EQUAL(CARD,1,'*',1,1))DO
  1053.      SKIPCOMMENT;
  1054.     PACKIT;
  1055.     GETCODE;
  1056.     IF (PRVCODE>=15)AND(CODE<>12)THEN DUMPBUF;
  1057.     IF (CODE<=0)THEN BEGIN
  1058.       IF (CODE=-1)THEN BEGIN
  1059.         IF (VFMT) THEN WRITELN(OUTFILE,'29999 FORMAT(E20.8)');
  1060.         WRITELN(OUTFILE,'C Structured Fortran, version 3.07A, Nov 82');
  1061.       END;
  1062.       WRRD1;
  1063.       IF(CODE=-1)THEN BEGIN
  1064.         IF (TOP>1) THEN ERROR(LNO,'Missing ''END..'' control.')
  1065.         ELSE BEGIN
  1066.           WHILE (NTOP>0)AND(NOT ERRORSW)DO BEGIN
  1067.             IF(STRTNO[1,NTOP]<>0)THEN ERROR(LNO,
  1068.               'Execute undefined remote block name');
  1069.             NTOP:=NTOP-1
  1070.           END;
  1071.           NTOP:=0;
  1072.           RTOP:=0;
  1073.           LABLE:=30000
  1074.         END
  1075.       END
  1076.     END
  1077.     ELSE IF (CODE<=12)THEN CASE12
  1078.     ELSE IF (CODE=19)THEN BEGIN
  1079.       OUTFORMAT:='WRITE';
  1080.       RDEND:=CCOL;
  1081.       BUFIN[1]:=CARD;
  1082.       BUFFNO:=0;
  1083.       UNFORMAT
  1084.     END
  1085.     ELSE IF (CODE=15)THEN BEGIN
  1086.       OUTFORMAT:='READ';
  1087.       RDEND:=CCOL;
  1088.       BUFIN[1]:=CARD;
  1089.       BUFFNO:=0;
  1090.       UNFORMAT
  1091.     END
  1092.     ELSE IF (CODE IN [16..18])THEN BEGIN
  1093.       OUTFORMAT:='READ';
  1094.       CASE16
  1095.     END
  1096.     ELSE CASES;
  1097.       {wrapup}
  1098.     IF ERRORSW THEN BEGIN
  1099.       ERROR(LNO,'Error ***.');ABORT 
  1100.     END
  1101.   END{while not eof};
  1102.   IF(CODE>15)THEN DUMPBUF;
  1103.   IF (TOP>1)THEN ERROR(LNO,'Missing ''END-BLOCK'' control statement')
  1104.   ELSE WRITELN(LNO,'Translation complete')
  1105.     
  1106.     
  1107. END;
  1108.  
  1109. BEGIN{program}
  1110.   INITIALIZE;
  1111.   WRITELN('INPUT FILE?');
  1112.   READLN(FILENAME);
  1113.   ASSIGN(INFILE,FILENAME);
  1114.   RESET(INFILE);
  1115.   WRITELN('OUTPUTFILE?');
  1116.   READLN(FILENAME);
  1117.   ASSIGN(OUTFILE,FILENAME);
  1118.   REWRITE(OUTFILE);
  1119.   PARSE;
  1120.   PUTLINE;
  1121.   ABORT
  1122. END;
  1123. BEGIN
  1124.   WAT
  1125. END.
  1126.   
  1127.   
  1128.