home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / net / prep.2 < prev    next >
Internet Message Format  |  1986-12-17  |  55KB
  1. From prove@batcomputer.tn.cornell.edu Tue Dec 16 13:57:45 1986
  2. Path: beno!seismo!rochester!cornell!batcomputer!prove
  3. From: prove@batcomputer.tn.cornell.edu (Roger Ove)
  4. Newsgroups: net.sources
  5. Subject: PREP: fortran preprocessor, part 2/2
  6. Keywords: fortran, preprocessor, cray
  7. Message-ID: <1841@batcomputer.tn.cornell.edu>
  8. Date: 16 Dec 86 18:57:45 GMT
  9. Organization: Theory Center, Cornell U., Ithaca NY
  10. Lines: 2223
  11.  
  12.  
  13.  
  14. # This is a shell archive.  Remove anything before this line,
  15. # then unpack it by saving it in a file and typing "sh file".
  16. #
  17. # Wrapped by newton!ove on Mon Dec 15 21:11:16 CST 1986
  18. # Contents:  flow.c misc.c fix.h macro.h prep.h prepdf.h prepmac.h string.h
  19. #    vecdem.h demo.p sieve.p vecdem.p vecdemo.p
  20.  
  21. echo x - flow.c
  22. sed 's/^@//' > "flow.c" <<'@//E*O*F flow.c//'
  23. /* Flow control extensions and related routines */
  24.  
  25. #include "prep.h"
  26.  
  27.  
  28.  
  29. /* Function AGAIN_PROC
  30.  *
  31.  * Process again statements.
  32.  * 3/2/86
  33.  */
  34.  
  35. again_proc()     
  36. {                  
  37.  
  38. /* on missing begin statement, abort */
  39. if ( begin_count <= 0 ) {
  40.     sprintf( errline, "Again: no matching begin: %s", in_buff ) ;
  41.     abort( errline ) ;
  42. }
  43.  
  44. /* construct the goto statement back to begin */
  45. sprintf( out_buff, "      goto %s", blabel[begin_count] ) ;
  46. dump( out_buff ) ;
  47.  
  48. /* construct label statement */
  49. sprintf( out_buff, "%s continue", alabel[begin_count] ) ;
  50. dump( out_buff ) ;
  51.  
  52. begin_count-- ;
  53. IN_BUFF_DONE
  54. }
  55.  
  56.  
  57.  
  58.  
  59. /* Function BEGIN_PROC.C
  60.  *
  61.  * Process begin statements.  Construct a label for the
  62.  * while, until, and again statements to branch to.  The
  63.  * label for again is created here as well.
  64.  *
  65.  * P. R. OVE  3/2/86
  66.  */
  67.  
  68. begin_proc() 
  69. {
  70. int    count ;
  71.                       
  72. /* keep track of the nesting */
  73. begin_count++ ;
  74. if ( begin_count >= NESTING ) {
  75.     sprintf( errline, "Begin: nesting too deep: %s", in_buff ) ;
  76.     abort( errline ) ;
  77. }
  78.  
  79. /* make up a label (for begin) and store it in blabel[begin_count] */
  80. count = 17500 + blabel_count ;
  81. blabel_count++ ;
  82. if ( count > 19999 ) {
  83.     sprintf( errline, "Begin: too many labels: %s", in_buff ) ;
  84.     abort( errline ) ;
  85. }
  86. sprintf( blabel[begin_count], "%d", count ) ;
  87.  
  88. /* make up a label (for again) and store it in alabel[begin_count] */
  89. count = 15000 + alabel_count ;
  90. alabel_count++ ;
  91. if ( count > 17499 ) {
  92.     sprintf( errline, "Begin: too many labels: %s", in_buff ) ;
  93.     abort( errline ) ;
  94. }
  95. sprintf( alabel[begin_count], "%d", count ) ;
  96.  
  97. /* construct and dump the output record */
  98. sprintf( out_buff, "%s continue", blabel[begin_count] ) ;
  99. dump( out_buff ) ;
  100.  
  101. IN_BUFF_DONE
  102. }                            
  103.  
  104.  
  105.  
  106.  
  107. /* Function CASE_PROC
  108.  *
  109.  * Process again statements.
  110.  * 11/9/85
  111.  */
  112.  
  113. case_proc()     
  114. {                  
  115. int    n, count ;
  116. char    *open_parens, *close_parens ;
  117.  
  118. /* get the comparison expression */
  119. open_parens = line_end( first_nonblank + name_length ) ;
  120. close_parens = mat_del( open_parens ) ;
  121.  
  122. /* if char after case is not a blank, tab, or delimeter assume a */
  123. /* variable name beginning with case                             */
  124. if ((close_parens == NULL) & (open_parens == first_nonblank + name_length))
  125.     return ;
  126.  
  127. /* keep track of the nesting */
  128. case_count++ ;
  129. if ( case_count >= NESTING ) {
  130.     sprintf( errline, "Case: nesting too deep: %s", in_buff ) ;
  131.     abort( errline ) ;
  132. }
  133.  
  134. /* get logical expression, set to NULL if it is missing */
  135. if ( open_parens == NULL ) { 
  136.     case_exp[ case_count ][0] = NULL ;
  137. }
  138. else {  
  139.     if ( close_parens == NULL ) {
  140.         sprintf( errline, "Case: missing delimeter: %s", in_buff ) ;
  141.         abort( errline ) ;
  142.     }
  143.     n = close_parens - open_parens - 1 ;
  144.     GET_MEM( case_exp[case_count], n+5 ) ;
  145.     case_exp[case_count][0] = '(' ;
  146.     strncpy( case_exp[case_count] + 1, open_parens + 1, n ) ;
  147.     case_exp[case_count][n+1] = ')' ;
  148.     case_exp[case_count][n+2] = NULL ;
  149. }                              
  150.  
  151.  
  152. /* make label for continue to return to, store it in clabel[case_count] */
  153. count = 20000 + clabel_count ;
  154. clabel_count++ ;
  155. if ( count > 22499 ) {
  156.     sprintf( errline, "Case: too many labels: %s", in_buff ) ;
  157.     abort( errline ) ;
  158. }
  159. sprintf( clabel[case_count], "%d", count ) ;
  160.  
  161. /* construct and dump the output record */
  162. sprintf( out_buff, "%s continue", clabel[case_count] ) ;
  163. dump( out_buff ) ;
  164.  
  165.  
  166. /* signal that in_buff is empty */
  167. IN_BUFF_DONE
  168. }
  169.  
  170.  
  171.  
  172.  
  173. /* Function CONTINUE_CASE_PROC
  174.  *
  175.  * Process continue_case statements (part of case construct).
  176.  *
  177.  * P. R. OVE  10/10/86
  178.  */
  179.  
  180. continue_case_proc()     
  181. {                  
  182. int    n, count ;
  183. char    *pntr, *open_parens, *close_parens ;
  184.  
  185. /* get the comparison expression */
  186. open_parens = line_end( first_nonblank + name_length ) ;
  187. close_parens = mat_del( open_parens ) ;
  188.                                            
  189. /* if there is stuff on the line (open_parens != NULL) and no open
  190.  * parens (close_parens == NULL) assume variable name */
  191. if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
  192.  
  193. /* on missing case statement, abort */
  194. if ( case_count <= 0 ) {
  195.     sprintf( errline, "CONTINUE_CASE: no matching CASE: %s", in_buff ) ;
  196.     abort( errline ) ;
  197. }
  198.                                    
  199. /* get the logical expression if there is one */
  200. if (open_parens != NULL) {
  201.     n = close_parens - open_parens - 1 ;
  202.     GET_MEM( exp, n+5 ) ;
  203.     exp[0] = '(' ;
  204.     strncpy( exp + 1, open_parens + 1, n ) ;
  205.     exp[n+1] = ')' ;
  206.     exp[n+2] = NULL ;
  207. }
  208.  
  209. /* construct and dump the jump back to the case statement */
  210. if (open_parens != NULL) {
  211.     strcpy( out_buff, "      if " ) ;
  212.     strcat( out_buff, exp ) ;
  213.     strcat( out_buff, " goto " ) ;
  214.     strcat( out_buff, clabel[case_count] ) ;
  215.     free( exp ) ;
  216. }
  217. else {
  218.     strcpy( out_buff, "      goto " ) ;
  219.     strcat( out_buff, clabel[case_count] ) ;
  220. }
  221.  
  222. dump( out_buff ) ;
  223.  
  224. IN_BUFF_DONE
  225. }
  226.  
  227.  
  228.  
  229.  
  230. /* Function CONTINUE_DO_PROC
  231.  *
  232.  * Process continue_do statements (part of do/end_do construct).
  233.  *
  234.  * P. R. OVE  11/13/86
  235.  */
  236.  
  237. continue_do_proc()     
  238. {                  
  239. int    n, count ;
  240. char    *pntr, *open_parens, *close_parens ;
  241.  
  242. /* get the comparison expression */
  243. open_parens = line_end( first_nonblank + name_length ) ;
  244. close_parens = mat_del( open_parens ) ;
  245.                                            
  246. /* if there is stuff on the line (open_parens != NULL) and no open
  247.  * parens (close_parens == NULL) assume variable name like CONTINUE_DOit */
  248. if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
  249.  
  250. /* on missing do statement, abort */
  251. if ( do_count <= 0 ) {
  252.     sprintf( errline, "CONTINUE_DO: not in do/end_do loop: %s", in_buff ) ;
  253.     abort( errline ) ;
  254. }
  255.                                     
  256. /* get the logical expression if there is one */
  257. if (open_parens != NULL) {
  258.     n = close_parens - open_parens - 1 ;
  259.     GET_MEM( exp, n+5 ) ;
  260.     exp[0] = '(' ;
  261.     strncpy( exp + 1, open_parens + 1, n ) ;
  262.     exp[n+1] = ')' ;
  263.     exp[n+2] = NULL ;
  264. }
  265.  
  266. /* construct and dump the jump to the end_do label */
  267. if (open_parens != NULL) {
  268.     strcpy( out_buff, "      if " ) ;
  269.     strcat( out_buff, exp ) ;
  270.     strcat( out_buff, " goto " ) ;
  271.     strcat( out_buff, dlabel[do_count] ) ;
  272.     free( exp ) ;
  273. }
  274. else {
  275.     strcpy( out_buff, "      goto " ) ;
  276.     strcat( out_buff, dlabel[do_count] ) ;
  277. }
  278.  
  279. dump( out_buff ) ;
  280.  
  281. IN_BUFF_DONE
  282. }
  283.  
  284.  
  285.  
  286.  
  287. /* Function CONTINUE_PROC
  288.  *
  289.  * Process continue statements (part of begin construct).
  290.  *
  291.  * P. R. OVE  10/10/86
  292.  */
  293.  
  294. continue_proc()     
  295. {                  
  296. int    n, count ;
  297. char    *pntr, *open_parens, *close_parens ;
  298.  
  299. /* get the comparison expression */
  300. open_parens = line_end( first_nonblank + name_length ) ;
  301. close_parens = mat_del( open_parens ) ;
  302.                                            
  303. /* if there is stuff on the line (open_parens != NULL) and no open
  304.  * parens (close_parens == NULL) assume variable name like CONTINUEit */
  305. if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
  306.  
  307. /* on missing begin statement, abort */
  308. if ( begin_count <= 0 ) {
  309.     sprintf( errline, "CONTINUE: no matching BEGIN: %s", in_buff ) ;
  310.     abort( errline ) ;
  311. }
  312.                                    
  313. /* get the logical expression if there is one */
  314. if (open_parens != NULL) {
  315.     n = close_parens - open_parens - 1 ;
  316.     GET_MEM( exp, n+5 ) ;
  317.     exp[0] = '(' ;
  318.     strncpy( exp + 1, open_parens + 1, n ) ;
  319.     exp[n+1] = ')' ;
  320.     exp[n+2] = NULL ;
  321. }
  322.  
  323. /* construct and dump the back to the begin statement */
  324. if (open_parens != NULL) {
  325.     strcpy( out_buff, "      if " ) ;
  326.     strcat( out_buff, exp ) ;
  327.     strcat( out_buff, " goto " ) ;
  328.     strcat( out_buff, blabel[begin_count] ) ;
  329.     free( exp ) ;
  330. }
  331. else {
  332.     strcpy( out_buff, "      goto " ) ;
  333.     strcat( out_buff, blabel[begin_count] ) ;
  334. }
  335.  
  336. dump( out_buff ) ;
  337.  
  338. IN_BUFF_DONE
  339. }
  340.  
  341.  
  342.  
  343.  
  344. /* Function DEFAULT_PROC
  345.  *
  346.  * Process default statements.
  347.  *
  348.  * P. R. OVE  11/9/85
  349.  */
  350.  
  351. default_proc()     
  352. {                  
  353. char    *pntr ;
  354.  
  355. if ( case_count <= 0 ) {
  356.     sprintf( errline, "DEFAULT: no matching CASE: %s", in_buff ) ;
  357.     abort( errline ) ;
  358. }
  359.  
  360. dump( "      else" ) ;
  361.  
  362. /* eliminate "default" from the input buffer */
  363. pntr = line_end( first_nonblank + name_length ) ;
  364. if ( pntr != NULL ) {
  365.     strcpy( in_buff, "\t" ) ;
  366.     strcat( in_buff, pntr ) ;
  367. }
  368. else { IN_BUFF_DONE }
  369.  
  370. }
  371.  
  372.  
  373.  
  374.  
  375. /* Function DO_PROC
  376.  *
  377.  * Process do statements.  If there is a label (ala
  378.  * fortran) just dump it to the output.  If no label
  379.  * exists make one up in anticipation of an eventual
  380.  * end_do statement.
  381.  *
  382.  * P. R. OVE  11/9/85
  383.  */
  384.  
  385. do_proc() 
  386. {
  387. char    *after_do, *pntr ;
  388. int    count ;
  389.                       
  390. /* return without processing if the first nonblank char after DO is a label
  391.    or if there is no blank/tab after the DO */
  392. pntr = first_nonblank + name_length ;
  393. after_do = line_end( pntr ) ;
  394. if ( ( strchr( "0123456789", *after_do ) != NULL ) | 
  395.      ( after_do == pntr )                            ) return ;
  396.                       
  397. /* keep track of the nesting */
  398. do_count++ ;
  399. if ( do_count >= NESTING ) {
  400.     sprintf( errline, "DO: nesting too deep: %s", in_buff ) ;
  401.     abort( errline ) ;
  402. }
  403.  
  404. /* make up a label and store it in dlabel[do_count] */
  405. count = 12500 + dlabel_count ;
  406. dlabel_count++ ;
  407. if ( count > 14999 ) {
  408.     sprintf( errline, "DO: too many labels: %s", in_buff ) ;
  409.     abort( errline ) ;
  410. }
  411. sprintf( dlabel[do_count], "%d", count ) ;
  412.  
  413. /* make label for leave_do to jump to and store it in elabel[do_count] */
  414. count = 22500 + elabel_count ;
  415. elabel_count++ ;
  416. if ( count > 24999 ) {
  417.     sprintf( errline, "DO: too many labels: %s", in_buff ) ;
  418.     abort( errline ) ;
  419. }
  420. sprintf( elabel[do_count], "%d", count ) ;
  421.  
  422. /* construct and dump the output record */
  423. sprintf( out_buff, "      do %s %s", dlabel[do_count], after_do ) ;
  424. dump( out_buff ) ;
  425.  
  426. IN_BUFF_DONE
  427. }                            
  428.  
  429.  
  430.  
  431. /* Function END_CASE_PROC
  432.  *
  433.  * Process end_case statements.
  434.  *
  435.  * P. R. OVE  11/9/85
  436.  */
  437.  
  438. end_case_proc()
  439. {                  
  440.     of_count[ case_count ] = 0 ;
  441.     free( case_exp[ case_count ] ) ;
  442.     case_count-- ;
  443.     IN_BUFF_DONE
  444.  
  445.     if ( case_count < 0 ) { 
  446.         case_count = 0 ;
  447.         return ; }        
  448.         
  449.     dump( "      end if" ) ;
  450. }
  451.  
  452.  
  453.  
  454.  
  455. /* Function END_DO_PROC
  456.  *
  457.  * Process end_do statements.  Use the label indexed
  458.  * by the current value of do_count (the do nesting
  459.  * index).
  460.  *
  461.  * P. R. OVE  11/9/85
  462.  */
  463.  
  464. end_do_proc() 
  465. {
  466.                       
  467. /* signal error if no matching do has been found */
  468. if ( do_count <= 0 )  {
  469.     sprintf( errline, "END_DO: no matching do: %s", in_buff ) ;
  470.     abort( errline ) ;
  471. }
  472.  
  473. /* construct and dump the normal do loop continue statement */
  474. sprintf( out_buff, "%s continue", dlabel[do_count] ) ;
  475. dump( out_buff ) ;
  476.  
  477. /* construct and dump the leave_do label if needed */
  478. if ( leave_do_flag[do_count] == TRUE ) {
  479.     sprintf( out_buff, "%s continue", elabel[do_count] ) ;
  480.     dump( out_buff ) ;
  481.     leave_do_flag[do_count] = FALSE ;
  482. }
  483.  
  484. do_count -= 1 ;
  485. IN_BUFF_DONE
  486. }                            
  487.  
  488.  
  489.  
  490.  
  491. /* Function LEAVE_DO_PROC
  492.  *
  493.  * Process leave_do statements.
  494.  *
  495.  * P. R. OVE  3/2/86
  496.  */
  497.  
  498. leave_do_proc()     
  499. {                  
  500. int    n, count ;
  501. char    *pntr, *open_parens, *close_parens ;
  502.  
  503. /* get the comparison expression */
  504. open_parens = line_end( first_nonblank + name_length ) ;
  505. close_parens = mat_del( open_parens ) ;
  506.                                            
  507. /* if there is stuff on the line (open_parens != NULL) and no              */
  508. /* open parens (close_parens == NULL) assume variable name like LEAVE_DOit */
  509. if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
  510.  
  511. /* on missing do statement, abort */
  512. if ( do_count <= 0 ) {
  513.     sprintf( errline, "LEAVE_DO: not in do/end_do loop: %s", in_buff ) ;
  514.     abort( errline ) ;
  515. }
  516.                                     
  517. /* get the logical expression if there is one */
  518. if (open_parens != NULL) {
  519.     n = close_parens - open_parens - 1 ;
  520.     GET_MEM( exp, n+5 ) ;
  521.     exp[0] = '(' ;
  522.     strncpy( exp + 1, open_parens + 1, n ) ;
  523.     exp[n+1] = ')' ;
  524.     exp[n+2] = NULL ;
  525. }
  526.  
  527. /* construct and dump the jump out of the loop */
  528. if (open_parens != NULL) {
  529.     strcpy( out_buff, "      if " ) ;
  530.     strcat( out_buff, exp ) ;
  531.     strcat( out_buff, " goto " ) ;
  532.     strcat( out_buff, elabel[do_count] ) ;
  533.     free( exp ) ;
  534. }
  535. else {
  536.     strcpy( out_buff, "      goto " ) ;
  537.     strcat( out_buff, elabel[do_count] ) ;
  538. }
  539.  
  540. leave_do_flag[do_count] = TRUE ;
  541.  
  542. dump( out_buff ) ;
  543.  
  544. IN_BUFF_DONE
  545. }
  546.  
  547.  
  548.  
  549.  
  550. /* Function LEAVE_PROC
  551.  *
  552.  * Process leave statements.
  553.  *
  554.  * P. R. OVE  3/2/86
  555.  */
  556.  
  557. leave_proc()     
  558. {                  
  559. int    n, count ;
  560. char    *pntr, *open_parens, *close_parens ;
  561.  
  562. /* get the comparison expression */
  563. open_parens = line_end( first_nonblank + name_length ) ;
  564. close_parens = mat_del( open_parens ) ;
  565.                                            
  566. /* if there is stuff on the line (open_parens != NULL) and no           */
  567. /* open parens (close_parens == NULL) assume variable name like LEAVEit */
  568. if ( (open_parens != NULL) & (close_parens == NULL) ) return ;
  569.  
  570. /* on missing begin statement, abort */
  571. if ( begin_count <= 0 ) {
  572.     sprintf( errline, "LEAVE: no matching begin: %s", in_buff ) ;
  573.     abort( errline ) ;
  574. }
  575.                                     
  576. /* get the logical expression if there is one */
  577. if (open_parens != NULL) {
  578.     n = close_parens - open_parens - 1 ;
  579.     GET_MEM( exp, n+5 ) ;
  580.     exp[0] = '(' ;
  581.     strncpy( exp + 1, open_parens + 1, n ) ;
  582.     exp[n+1] = ')' ;
  583.     exp[n+2] = NULL ;
  584. }
  585.  
  586. /* construct and dump the jump to again */
  587. if (open_parens != NULL) {
  588.     strcpy( out_buff, "      if " ) ;
  589.     strcat( out_buff, exp ) ;
  590.     strcat( out_buff, " goto " ) ;
  591.     strcat( out_buff, alabel[begin_count] ) ;
  592.     free( exp ) ;
  593. }
  594. else {
  595.     strcpy( out_buff, "      goto " ) ;
  596.     strcat( out_buff, alabel[begin_count] ) ;
  597. }
  598.  
  599. dump( out_buff ) ;
  600.  
  601. IN_BUFF_DONE
  602. }
  603.  
  604.  
  605.  
  606. /* Function OF_PROC
  607.  *
  608.  * Process of statements.
  609.  *
  610.  * P. R. OVE  11/9/85
  611.  */
  612.  
  613. of_proc()     
  614. {                  
  615. int    n ;
  616. char    *pntr, *open_parens, *close_parens ;
  617.  
  618. /* get the comparison expression */
  619. open_parens = line_end( first_nonblank + name_length) ;
  620. close_parens = mat_del( open_parens ) ;
  621.                                            
  622. /* if no open parens assume variable name like OFile */
  623. /* (no open parens <==> close_parens will be NULL)   */
  624. if ( close_parens == NULL ) return ;
  625.  
  626. /* abort on missing case statement */
  627. if ( case_count <= 0 ) {
  628.     sprintf( errline, "OF: missing CASE statement: %s", in_buff ) ;
  629.     abort( errline ) ;
  630. }
  631.  
  632. /* keep track of "of's" for each case level */
  633. of_count[ case_count ] += 1 ;
  634.  
  635. /* get the logical expression */
  636. n = close_parens - open_parens - 1 ;
  637. GET_MEM( exp, n+5 ) ;
  638. exp[0] = '(' ;
  639. strncpy( exp + 1, open_parens + 1, n ) ;
  640. exp[n+1] = ')' ;
  641. exp[n+2] = NULL ;
  642.  
  643. /* construct the "if" or "if else" statement.  If there is a case */
  644. /* logical expression us .eq. to determine the result             */
  645. if ( case_exp[ case_count ][0] == NULL ) {
  646.     if ( of_count[ case_count ] != 1 ) {
  647.         strcpy( out_buff, "      else if " ) ; }
  648.          else {
  649.         strcpy( out_buff, "      if " )      ; }
  650.     strcat( out_buff, exp ) ;
  651.     strcat( out_buff, " then " ) ; }
  652. else {
  653.     if ( of_count[ case_count ] != 1 ) {
  654.         strcpy( out_buff, "      else if (" ) ; }
  655.          else {
  656.         strcpy( out_buff, "      if (" )      ; }
  657.     strcat( out_buff, case_exp[ case_count ] ) ;
  658.     strcat( out_buff, ".eq." ) ;
  659.     strcat( out_buff, exp ) ;
  660.     strcat( out_buff, ") then " ) ; }
  661.                                    
  662. dump( out_buff ) ;
  663.  
  664. /* eliminate "of stuff" from the input buffer */
  665. pntr = line_end( close_parens + 1 ) ;
  666. if ( pntr != NULL ) {
  667.     strcpy( in_buff, "\t" ) ;
  668.     strcat( in_buff, pntr ) ;
  669. }
  670. else { IN_BUFF_DONE }
  671.  
  672. free( exp ) ;
  673. }
  674.  
  675.  
  676.  
  677.  
  678. /* Function UNTIL_PROC
  679.  *
  680.  * Process until statements.
  681.  *
  682.  * P. R. OVE  3/2/86
  683.  */
  684.  
  685. until_proc()     
  686. {                  
  687. int    n, count ;
  688. char    *pntr, *open_parens, *close_parens ;
  689.  
  690. /* get the comparison expression */
  691. open_parens = line_end( first_nonblank + name_length ) ;
  692. close_parens = mat_del( open_parens ) ;
  693.                                            
  694. /* if no open parens assume variable name like UNTILon */
  695. /* (no open parens <==> close_parens will be NULL)   */
  696. if ( close_parens == NULL ) return ;
  697.  
  698. /* on missing begin statement, abort */
  699. if ( begin_count <= 0 ) {
  700.     sprintf( errline, "UNTIL: no matching begin: %s", in_buff ) ;
  701.     abort( errline ) ;
  702. }
  703.                                     
  704. /* get the logical expression */
  705. n = close_parens - open_parens - 1 ;
  706. GET_MEM( exp, n+5 ) ;
  707. exp[0] = '(' ;
  708. strncpy( exp + 1, open_parens + 1, n ) ;
  709. exp[n+1] = ')' ;
  710. exp[n+2] = NULL ;
  711.  
  712. /* construct and dump the conditional jump to begin */
  713. sprintf( out_buff, "      if (.not.%s) goto %s",
  714.     exp, blabel[begin_count] ) ;
  715. dump( out_buff ) ;
  716.  
  717. /* construct a label statement (for leave to jump to) */
  718. sprintf( out_buff, "%s continue", alabel[begin_count] ) ;
  719. dump( out_buff ) ;
  720.  
  721. begin_count-- ;
  722. free( exp ) ;
  723. IN_BUFF_DONE
  724. }
  725.  
  726.  
  727.  
  728.  
  729. /* Function WHILE_PROC
  730.  *
  731.  * Process while statements.
  732.  *
  733.  * P. R. OVE  3/2/86
  734.  */
  735.  
  736. while_proc()     
  737. {                  
  738. int    n, count ;
  739. char    *pntr, *open_parens, *close_parens ;
  740.  
  741. /* get the comparison expression */
  742. open_parens = line_end( first_nonblank + name_length ) ;
  743. close_parens = mat_del( open_parens ) ;
  744.                                            
  745. /* if no open parens assume variable name like WHILEon */
  746. /* (no open parens <==> close_parens will be NULL)   */
  747. if ( close_parens == NULL ) return ;
  748.  
  749. /* on missing begin statement, abort */
  750. if ( begin_count <= 0 ) {
  751.     sprintf( errline, "WHILE: no matching begin: %s", in_buff ) ;
  752.     abort( errline ) ;
  753. }
  754.  
  755. /* get the logical expression */
  756. n = close_parens - open_parens - 1 ;
  757. GET_MEM( exp, n+5 ) ;
  758. exp[0] = '(' ;
  759. strncpy( exp + 1, open_parens + 1, n ) ;
  760. exp[n+1] = ')' ;
  761. exp[n+2] = NULL ;
  762.  
  763. /* construct and dump the output record */
  764. strcpy( out_buff, "      if (.not." ) ;
  765. strcat( out_buff, exp ) ;
  766. strcat( out_buff, ") goto " ) ;
  767. strcat( out_buff, alabel[begin_count] ) ;
  768. dump( out_buff ) ;
  769.  
  770. free( exp ) ;
  771. IN_BUFF_DONE
  772. }
  773. @//E*O*F flow.c//
  774. chmod u=rw,g=r,o=r flow.c
  775.  
  776. echo x - misc.c
  777. sed 's/^@//' > "misc.c" <<'@//E*O*F misc.c//'
  778. /* misc routines */
  779.  
  780. #include "prep.h"
  781.  
  782.  
  783.  
  784.  
  785. /* Function DUMP.C
  786.  *
  787.  *   Send a string to the output stream.  The string is a
  788.  * fortran record constructed by PREP, which may be
  789.  * longer than 72 characters after processing.  It is
  790.  * broken up into pieces before output.  The string
  791.  * must be null terminated.  The string is not affected
  792.  * by this routine, so it is safe to do
  793.  *       dump( "explicit text" ) ;
  794.  *
  795.  *   If inside a vector loop (vec_flag==TRUE) the record is
  796.  * not broken up and is sent to mem_store rather than a file.
  797.  *
  798.  * P. R. OVE  11/9/85
  799.  */
  800.  
  801. dump( string ) 
  802. char     *string ;
  803.  
  804. {
  805. char    record[73], *pntr ;
  806. int    i_str, i_rec = 0, i, i_tab, quote_flag = 0 ;
  807.  
  808. /* ignore empty lines sent here */
  809. if ( NULL == line_end( string ) ) return ;
  810.  
  811. /* if in a vector loop write the string to mem_store */
  812. if ( vec_flag ) {
  813.     push( string ) ;
  814.     return ;
  815. }
  816.  
  817. /* loop until end of record */
  818. for ( i_str = 0;; i_str++ ) {
  819.  
  820.     /* wrap up on end of line */
  821.     if ( line_end( &string[i_str] ) == NULL ) {
  822.                record[i_rec] = NULL ;
  823.         put_string( record ) ;
  824.         break ; }
  825.  
  826.     /* break string if necessary */
  827.     if ( i_rec >= 72 ) {                
  828.         record[i_rec] = NULL ;
  829.         put_string( record ) ;
  830.         strcpy( record, "     *" ) ;
  831.         i_str-- ;
  832.         i_rec = 6 ;
  833.         continue ;
  834.     }
  835.  
  836.     /* toggle quote flag on quotes */
  837.     if ( string[i_str] == '\'' ) quote_flag = ! quote_flag ;
  838.         
  839.     /* underline filtering */
  840.     if ( (string[i_str]=='_') & (!underline_keep) & (!quote_flag) )
  841.         continue ;
  842.  
  843.     /* tab handling */
  844.     if ( string[i_str] == TAB ) {
  845.         if (    i_rec >= 70 - tab_size ) {
  846.             record[i_rec] = NULL ;
  847.             put_string( record ) ;
  848.             strcpy( record, "     *" ) ;
  849.             i_rec = 6 ; }
  850.  
  851.         else {  /* replace tab by blanks */
  852.             i_tab = ( ( i_rec + 1 )/tab_size ) 
  853.                   * tab_size - i_rec + tab_size - 1 ;
  854.             for ( i = 0; i < i_tab; i++ ) {
  855.                 record[i_rec] = BLANK ;
  856.                         i_rec++ ; }
  857.         }
  858.         continue ;
  859.     }
  860.  
  861.             
  862.     /* default action */
  863.     record[i_rec] = string[i_str] ;
  864.     i_rec++ ;
  865.  
  866. }                       
  867. }                          
  868.  
  869.  
  870.  
  871.  
  872. /* GET_RECORD
  873.  *
  874.  * Get a record from the input stream, making sure that the buffer
  875.  * does not overflow by increasing its size as necessary.  The 
  876.  * string in_buff will contain the record on return.  In_buff will
  877.  * always contain about ten percent of its default length in trailing 
  878.  * blanks to play with.  Out_buff will have space allocated for it
  879.  * as well, 4 times that of in_buff.  Returns a pointer to the 
  880.  * terminating NULL character.  On EOF the previous input file
  881.  * (assuming the present one was an include file) will be restored as
  882.  * the input file.  If the filestack is empty return NULL.
  883.  */
  884.  
  885. char    *get_rec()
  886. {
  887. int    i, j ;
  888. char    *pntr, *area ;
  889.  
  890. /* fill the in_put buffer, enlarging it when nearly full in 
  891.  * increments of DEF_BUFFSIZE.  On end of file the previous file
  892.  * handle is popped from the include stack (if present).
  893.  */
  894. pntr = in_buff ;
  895. i = 0 ;
  896. while(1) {
  897.  
  898.     for (; i < allocation - DEF_BUFFSIZE/10 ; i++, pntr++ ) {
  899.         *pntr = getc(in) ;
  900.         if ( *pntr == EOF ) {
  901.             fclose(in) ;
  902.             if ( NULL == popfile(&in) ) return( NULL ) ;
  903.             pntr = in_buff-1 ;
  904.             i = -1 ;
  905.             continue ;
  906.         }
  907.         if ( *pntr == '\n' ) {
  908.             *pntr = NULL ;
  909.             return( pntr ) ;
  910.         }
  911.     }
  912.  
  913.  
  914.     /* if control falls through to here, increase buffer sizes. */
  915.     allocation += DEF_BUFFSIZE ;
  916.     if ( NULL == realloc( in_buff, allocation ) )
  917.         abort( "Reallocation failed" ) ;
  918.     if ( NULL == realloc( out_buff, 4*allocation ) )
  919.         abort( "Reallocation failed" ) ;
  920. }
  921.  
  922. }
  923.  
  924.  
  925.  
  926. /* Include_proc
  927.  *
  928.  * Handle file inclusion
  929.  *
  930.  * P. R. OVE  11/9/85
  931.  */
  932.  
  933. include_proc()     
  934. {                  
  935. char    *pntr, *open_parens, *close_parens, *name ;
  936.  
  937. /* get the file name */
  938. open_parens = line_end( first_nonblank + name_length ) ;
  939. if ( NULL == ( close_parens = mat_del( open_parens ) ) ) {
  940.     sprintf( errline, "INCLUDE: syntax: %s", in_buff ) ;
  941.     abort( errline ) ;
  942. }
  943. name = open_parens+1 ;
  944. *close_parens = NULL ;
  945.  
  946. /* push the old input file handle onto the filestack */
  947. if ( NULL == pushfile(&in) ) {
  948.     sprintf( errline, "INCLUDE: nesting too deep: %s", in_buff ) ;
  949.     abort( errline ) ;
  950. }
  951.  
  952. /* open the new file */
  953. if ( NULL == ( in = fopen( name, "r" ) ) ) {
  954.     sprintf( errline, "INCLUDE: can't open file: %s", name ) ;
  955.     abort( errline ) ;
  956. }
  957.  
  958. IN_BUFF_DONE ;
  959. }
  960.  
  961.  
  962. /* push a file handle onto the filestack.  return NULL on error. */
  963. int    pushfile(handleaddress)
  964. FILE    *(*handleaddress) ;
  965. {
  966.     if ( include_count >= NESTING ) return(NULL) ;
  967.     filestack[include_count] = *handleaddress ;
  968.     include_count++ ;
  969.     return(1) ;
  970. }
  971.  
  972.  
  973. /* pop a file handle from the filestack.  return NULL on error */
  974. int    popfile(handleaddress)
  975. FILE    *(*handleaddress) ;
  976. {
  977.     if ( include_count <= 0 ) return(NULL) ;
  978.     include_count-- ;
  979.     *handleaddress = filestack[include_count] ;
  980.     return(1) ;
  981. }
  982.  
  983.  
  984.  
  985.  
  986. /* Function LINE_END
  987.  *
  988.  * Return a NULL pointer if the string contains only
  989.  * blanks and tabs or if it is a NULL string.  Else
  990.  * return a pointer to the first offending character.
  991.  *
  992.  * P. R. OVE  11/9/85
  993.  */
  994.  
  995. char    *line_end( string ) 
  996. char     *string ;
  997.  
  998. {
  999.     for (; *string != NULL; string++ )
  1000.         if ( (*string != BLANK) && (*string != TAB) ) return(string) ;
  1001.  
  1002.     return( NULL ) ;
  1003. }
  1004.  
  1005.  
  1006.  
  1007.  
  1008. /* Function MAT_DEL
  1009.  *
  1010.  * Given pointer to a delimeter this routine finds its
  1011.  * partner and returns a pointer to it.  On failure a
  1012.  * NULL pointer is returned.  The supported delimeters
  1013.  * are:
  1014.  *
  1015.  *   '  "  ( )  [ ]  { }  < >
  1016.  *
  1017.  * ' and " are supported only in the forward direction
  1018.  * and no nesting is detected.
  1019.  * In all cases the search is limited to the current
  1020.  * line (bounded by NULLs).
  1021.  *
  1022.  * P. R. OVE  11/9/85
  1023.  */
  1024.  
  1025.  
  1026. char *mat_del( pntr )
  1027. char    *pntr ;
  1028.  
  1029. {
  1030. int    nest_count = 0, i, direction ;
  1031. char    target ;
  1032.  
  1033. if ( pntr == NULL ) return( NULL ) ;
  1034.  
  1035. /* get the target character and direction of search */
  1036.     switch( *pntr ) {
  1037.  
  1038.         case '(' :    { target = ')' ;
  1039.                   direction = 1 ;
  1040.                   break ;          }
  1041.  
  1042.         case ')' :    { target = '(' ;
  1043.                   direction = -1 ;
  1044.                   break ;          }
  1045.  
  1046.         case '[' :    { target = ']' ;
  1047.                   direction = 1 ;
  1048.                   break ;          }
  1049.  
  1050.         case ']' :    { target = '[' ;
  1051.                   direction = -1 ;
  1052.                   break ;          }
  1053.  
  1054.         case '{' :    { target = '}' ;
  1055.                   direction = 1 ;
  1056.                   break ;          }
  1057.  
  1058.         case '}' :    { target = '{' ;
  1059.                   direction = -1 ;
  1060.                   break ;          }
  1061.  
  1062.         case '<' :    { target = '>' ;
  1063.                   direction = 1 ;
  1064.                   break ;          }
  1065.  
  1066.         case '>' :    { target = '<' ;
  1067.                   direction = -1 ;
  1068.                   break ;          }
  1069.  
  1070.         case '\'':    { target = '\'' ;
  1071.                   direction = 1 ;
  1072.                   break ;          }
  1073.  
  1074.         case '\"':    { target = '\"' ;
  1075.                   direction = 1 ;
  1076.                   break ;          }
  1077.  
  1078.         default:      return( NULL ) ;
  1079.                 
  1080.     }
  1081.  
  1082. /* find the match */
  1083.     for ( i = direction; pntr[i] != NULL; i += direction ) {
  1084.         
  1085.         if ( pntr[i] == target ) {
  1086.  
  1087.             if ( nest_count == 0 ) {
  1088.                 break ;    }
  1089.             else {
  1090.                 nest_count-- ;
  1091.                 continue ; }
  1092.                 }
  1093.         
  1094.         if ( pntr[i] == pntr[0] ) nest_count++ ;
  1095.     }
  1096.  
  1097.     if ( &pntr[i] == NULL ) return( NULL ) ;
  1098.     return( &pntr[i] ) ;
  1099. }
  1100.  
  1101.  
  1102.  
  1103.  
  1104. /* PARMER
  1105.  *
  1106.  * Processes the command line parameters.
  1107.  */
  1108.  
  1109. int parmer ( argc, argv )
  1110. int    argc ;
  1111. char    *argv[] ;
  1112. {
  1113. int    i ;
  1114.     
  1115. /* default io streams */
  1116. in = stdin ;
  1117. out = stdout ;
  1118.  
  1119. /* use in_buff to hold file inclusion command if found */
  1120. IN_BUFF_DONE ;         /* clear the buffer */
  1121.  
  1122. for ( i = 1; i < argc; i++ ) {
  1123.  
  1124.     /* assume data file name if not a switch */
  1125.     if ( argv[i][0] != '-' ) {
  1126.         sprintf( dataf, "%s.p", argv[i] ) ;
  1127.         if ( NULL != ( in = fopen( dataf, "r" ) ) ) {
  1128.             sprintf( dataf, "%s.f", argv[i] ) ;
  1129.             out = fopen( dataf, "w" ) ;
  1130.         }
  1131.         else in = stdin ;
  1132.     }
  1133.     
  1134.     else {
  1135.     /* switches */
  1136.         switch ( argv[i][1] ) {
  1137.  
  1138.         case 'c' :    com_keep = TRUE ;    break ;
  1139.  
  1140.         case 'u' :    underline_keep = TRUE ;    break ;
  1141.  
  1142.         case 'U' :    i++ ;
  1143.                 if ( i < argc ) {
  1144.                 if ( argv[i][0] == '-' ||
  1145.                      NULL==sscanf(argv[i],"%d",&unroll_depth) ){
  1146.                     unroll_depth = DEF_UNROLL_DEPTH ;
  1147.                     i-- ;
  1148.                     break ;
  1149.                 }}
  1150.                 else    unroll_depth = DEF_UNROLL_DEPTH ;
  1151.                 break ;
  1152.  
  1153.         case 'L' :    i++ ;
  1154.                 if ( i < argc ) {
  1155.                 if ( argv[i][0] == '-' ||
  1156.                      NULL==sscanf(argv[i],"%d",&line_limit) ){
  1157.                     line_limit = DEF_LINE_LIMIT ;
  1158.                     i-- ;
  1159.                     break;
  1160.                 }}
  1161.                 else    line_limit = DEF_LINE_LIMIT ;
  1162.                 break ;
  1163.  
  1164.         case 'm' :    macro_only = TRUE ;
  1165.                 underline_keep = TRUE ;
  1166.                 com_keep = TRUE ;
  1167.                 break ;
  1168.         
  1169.         case 'i' :    i++ ;
  1170.                 if ( i < argc ) {
  1171.                     sprintf(in_buff,"#include \"%s\"", argv[i] ) ;
  1172.                     break ;
  1173.                 }
  1174.         
  1175.     
  1176. default :    fprintf( stderr, "\nUnrecognized switch: %s\n", argv[i]);
  1177.         fprintf( stderr, "\nAllowed switches:\n\n%s\n%s\n%s\n%s\n%s\n%s",
  1178.         " -c        keep comments",
  1179.         " -u        keep underline characters",
  1180.         " -m        expand macros only",
  1181.         " -i <file>    include <file> before processing",
  1182.         " -U n        unroll vector loops to depth n",
  1183.         " -L n        unroll loops with n or fewer lines only"
  1184.         ) ;
  1185.         abort( "\n" ) ;
  1186.         }
  1187.     }
  1188. }
  1189.  
  1190. /* process the file include statement if present */
  1191. if ( IN_BUFF_FULL ) preproc( rec_type(0) ) ;
  1192. return(1) ;
  1193. }
  1194.  
  1195.  
  1196.  
  1197.  
  1198. /* Function PREPROCESS.C
  1199.  *
  1200.  * The guts of the preprocessor PREP.  Variable tipe
  1201.  * contains the type of record code:
  1202.  *
  1203.  *  BEGIN statement
  1204.  *  AGAIN statement
  1205.  *  WHILE statement
  1206.  *  UNTIL statement
  1207.  *  CONTINUE statement
  1208.  *  LEAVE statement
  1209.  *
  1210.  *  CASE statement
  1211.  *  OF statement
  1212.  *  DEFAULT statement
  1213.  *  CONTINUE_CASE statement
  1214.  *  END_CASE statement
  1215.  *  DO_LIMITS statement
  1216.  *  UNROLL statement
  1217.  *
  1218.  *  DO statement
  1219.  *  LEAVE_DO statement
  1220.  *  CONTINUE_DO statement
  1221.  *  END_DO statement
  1222.  *
  1223.  *  [  (start of clustered vector arithmetic)
  1224.  *  ]  (  end  "     "        "       "     )
  1225.  *  #  vectored arithmetic statement
  1226.  *  normal (normal fortran statement)
  1227.  *
  1228.  *  INCLUDE files
  1229.  *  MACRO expansion
  1230.  *
  1231.  * P. R. OVE  11/9/85
  1232.  */
  1233.  
  1234. preproc(tipe)
  1235. int tipe ;
  1236. {
  1237.  
  1238. switch ( tipe ) {
  1239.  
  1240.     case unknown :        break ;
  1241.     case normal :        strcpy( out_buff, in_buff ) ;
  1242.                 dump( out_buff ) ;
  1243.                 in_buff[0] = NULL ;
  1244.                 break ;
  1245.     case type_begin :    begin_proc() ; break ;
  1246.     case type_again :    again_proc() ; break ;
  1247.     case type_while :    while_proc() ; break ;
  1248.     case type_until :    until_proc() ; break ;
  1249.     case type_continue :    continue_proc() ; break ;
  1250.     case type_leave :    leave_proc() ; break ;
  1251.     case type_case :    case_proc() ; break ;
  1252.     case type_of :        of_proc() ; break ;
  1253.     case type_default :    default_proc() ; break ;
  1254.     case type_continue_case:continue_case_proc() ; break ;
  1255.     case type_end_case :    end_case_proc() ; break ;
  1256.     case type_do_limits :    do_limits_proc() ; break ;
  1257.     case type_unroll :    unroll_proc() ; break ;
  1258.     case type_do :        do_proc() ; break ;
  1259.     case type_end_do :    end_do_proc() ; break ;
  1260.     case type_leave_do :    leave_do_proc() ; break ;
  1261.     case type_continue_do :    continue_do_proc() ; break ;
  1262.     case type_osqb :    osqb_proc() ; break ;
  1263.     case type_vec :     vec_proc() ; break ;
  1264.     case type_csqb :    csqb_proc() ; break ;
  1265.     case type_include :    include_proc() ; break ;
  1266.                       
  1267. }
  1268. }
  1269.  
  1270.  
  1271.  
  1272.  
  1273. /* PUSH
  1274.  *
  1275.  * Push a string onto the MEM_STORE.  Space is allocated for it and
  1276.  * a pointer kept in the array mem_store (array of pointers).  The
  1277.  * index to mem_store at which the current string is stored is returned.
  1278.  * If the input string is a NULL pointer the last entry is removed.
  1279.  * Global variable mem_count keeps track of the total number of pointers
  1280.  * in use.
  1281.  */
  1282.  
  1283. int push( string )
  1284. char    *string ;
  1285. {
  1286. int    i ;
  1287.  
  1288. if ( string != NULL ) {
  1289.     if ( mem_count >= STORE_SIZE - 1 ) {
  1290.         sprintf( errline, "PUSH out of memory pointers: %s", in_buff ) ;
  1291.         abort( errline ) ;
  1292.     }
  1293.     GET_MEM( mem_store[ mem_count ], strlen( string ) ) ;
  1294.     strcpy( mem_store[ mem_count ], string ) ;
  1295.     mem_count++ ;
  1296.     return( mem_count - 1 ) ;
  1297. }
  1298.  
  1299. if ( mem_count > 0 ) {
  1300.     mem_count-- ;
  1301.     free( mem_store[ mem_count ] ) ;
  1302.     return( mem_count - 1 ) ;
  1303. }
  1304. }
  1305.  
  1306.  
  1307.  
  1308. /* Function REC_TYPE.C
  1309.  *
  1310.  * Determine the type of a record.
  1311.  *
  1312.  * P. R. OVE  11/9/85
  1313.  */
  1314.  
  1315. char    *strchrq() ;
  1316.  
  1317. int    rec_type( group )
  1318. int    group ;
  1319. {                  
  1320. char    combuff[16], *string ;
  1321. int    i ;
  1322.  
  1323. if (in_buff[0] == NULL) return(unknown) ;
  1324. string = in_buff ;
  1325.  
  1326. /* go to first nonblank character, save a pointer to it */
  1327. while ( *string != NULL ) {
  1328.     if ( *string != TAB & *string != BLANK ) {    
  1329.         first_nonblank = string ;
  1330.         break ;
  1331.     }
  1332.     string++ ;
  1333. }
  1334.  
  1335. /* copy the initial characters into combuff */
  1336. for ( i = 0; (i < 15) & (*string != NULL); i++ ) {
  1337.     combuff[i] = string[i] ;
  1338. }
  1339. combuff[15] = NULL ;
  1340.  
  1341. strupr( combuff ) ;  /* convert to upper case */
  1342.  
  1343.  
  1344.      
  1345. /* check for commands by group */
  1346. switch ( group ) {
  1347.  
  1348.  
  1349. /* group 0 commands: file includes */
  1350. case 0 : {
  1351.     if ( MATCH( "#INCLUDE" ) ) return(type_include) ;
  1352.                            return(unknown) ;
  1353. }
  1354.  
  1355.  
  1356. /* group 1 commands: case's OF and DEFAULT commands are done first so
  1357.    that it is legal to have:  of ( 'a' ) leave_do, for instance.
  1358. */
  1359. case 1 : {
  1360.     if ( MATCH( "OF" ) )        return(type_of) ;
  1361.     if ( MATCH( "DEFAULT" ) )   return(type_default) ;
  1362.                         return(unknown) ;
  1363. }
  1364.  
  1365.  
  1366. /* group 2 commands: flow control extensions and parameter changes */
  1367. case 2 : {
  1368.     if ( MATCH( "DO_LIMITS" ) ) return(type_do_limits) ;
  1369.     if ( MATCH( "DO LIMITS" ) ) return(type_do_limits) ;
  1370.  
  1371.     if ( MATCH( "DO" ) )        return(type_do) ;
  1372.     if ( MATCH( "END_DO" ) )    return(type_end_do) ;
  1373.     if ( MATCH( "END DO" ) )    return(type_end_do) ;
  1374.     if ( MATCH( "LEAVE_DO" ) )  return(type_leave_do) ;
  1375.     if ( MATCH( "LEAVE DO" ) )  return(type_leave_do) ;
  1376.     if ( MATCH( "CONTINUE_DO")) return(type_continue_do) ;
  1377.     if ( MATCH( "CONTINUE DO")) return(type_continue_do) ;
  1378.  
  1379.     if ( MATCH( "CASE" ) )      return(type_case) ;
  1380.     if ( MATCH( "END_CASE" ) )  return(type_end_case) ;
  1381.     if ( MATCH( "END CASE" ) )  return(type_end_case) ;
  1382.     if (MATCH("CONTINUE_CASE")) return(type_continue_case) ;
  1383.     if (MATCH("CONTINUE CASE")) return(type_continue_case) ;
  1384.  
  1385.     if ( MATCH( "BEGIN" ) )     return(type_begin) ;
  1386.     if ( MATCH( "AGAIN" ) )     return(type_again) ;
  1387.     if ( MATCH( "WHILE" ) )     return(type_while) ;
  1388.     if ( MATCH( "UNTIL" ) )     return(type_until) ;
  1389.     if ( MATCH( "LEAVE" ) )     return(type_leave) ;
  1390.     if ( MATCH( "CONTINUE" ) )  return(type_continue) ;
  1391.  
  1392.     if ( MATCH( "UNROLL" ) )    return(type_unroll) ;
  1393.                     return(unknown) ;
  1394. }
  1395.  
  1396.  
  1397. /* group 3 commands: vector processing */
  1398. case 3: {
  1399.     if ( MATCH( "[" )    )                      return(type_osqb) ;
  1400.     if ( strchrq( string, ']' ) != NULL )           return(type_csqb) ;
  1401.     if ( strchrq( string, '#' ) != NULL )            return(type_vec) ;
  1402.                                return(normal) ;
  1403. }
  1404.  
  1405.  
  1406. } /* end switch case */
  1407. }
  1408.  
  1409.  
  1410.  
  1411. /* Look for unquoted character in string, where ' is the fortran quote char.
  1412.  * Returns a pointer to the character, or a NULL pointer if not present.
  1413.  */
  1414.  
  1415. char    *strchrq( string, c )
  1416. char    *string, c ;
  1417. {
  1418. int    i, quote=1 ;
  1419.  
  1420. for ( i = 0; string[i] != NULL; i++ ) {
  1421.     if ( string[i] == '\'' ) {
  1422.         quote = -quote ;
  1423.         continue ;
  1424.     }
  1425.     if ( string[i] == c && quote == 1 ) return( &string[i] ) ;
  1426. }
  1427.  
  1428. return( NULL ) ;    /* not found */
  1429. }
  1430.  
  1431.  
  1432.  
  1433.  
  1434.  
  1435. /* strmatch:  find the first occurrence of string2 in string1, return pointer
  1436.  * to the first character of the match.  Returns NULL pointer if no match.
  1437.  */
  1438. #define NULL    0
  1439.  
  1440. char    *strmatch( string1, string2 )
  1441. char    *string1, *string2 ;
  1442. {
  1443. char    *pntr1, *pntr2 ;
  1444.  
  1445.      for ( pntr1 = string1, pntr2 = string2 ; *pntr1 != NULL; pntr1++ ) {
  1446.         if ( *pntr1 == *pntr2 ) {
  1447.             pntr2++ ;
  1448.             if ( *pntr2 == NULL ) return( pntr1 - strlen(string2) + 1 ) ;
  1449.         }
  1450.         else pntr2 = string2 ;
  1451.     }
  1452.  
  1453.     /* failure if control reaches this point */
  1454.     return( NULL ) ;
  1455. }
  1456.  
  1457.  
  1458.  
  1459.  
  1460. /* function STRTOKP
  1461.  
  1462.    Like Strtok, except that the original string is preserved (strtok
  1463.    puts null in there to terminate the substrings).  This routine
  1464.    uses mallocs to allow storage for the token.  The memory is
  1465.    reallocated for each new string.  Use just like strtok:
  1466.    
  1467.    Successively returns the tokens in string1, using the delimeters
  1468.    defined by string2.  If string1 is NULL (a NULL pointer) the 
  1469.    routine returns the next token in the string from the previous call.
  1470.    Otherwise the first token is returned.  A NULL pointer is returned
  1471.    on failure (no more tokens in the current string).
  1472. */
  1473.  
  1474. char *strtokp( string1, string2 )
  1475. char    *string1, *string2 ;
  1476. {
  1477. static char    *spntr, *tpntr, *token ;
  1478. static int    called = NULL ;        /* called=NULL ==> initialize */
  1479. int    i ;
  1480.  
  1481. /* initialize on first call */
  1482.     if ( called == NULL ) {
  1483.         called = 1 ;
  1484.         GET_MEM( token, strlen(string1) ) ;
  1485.     }
  1486.  
  1487. /* if string1 is not NULL reset the routine */
  1488.     if ( string1 != NULL ) {
  1489.         spntr = string1 ;
  1490.         if ( NULL == ( token = realloc( token, strlen(string1)+1 )))
  1491.             abort("STRTOKP: reallocation error") ;
  1492.     }
  1493.     if ( *spntr == NULL ) return( NULL ) ;    /* end of original string */
  1494.  
  1495. /* skip    initial delimeter characters */
  1496.     for (; NULL != strchr( string2, *spntr ); spntr++ ) ;
  1497.  
  1498. /* copy characters to token until the next delimeter */
  1499.     tpntr = &token[0] ;
  1500.     for (; *spntr != NULL; spntr++ ) {
  1501.         if ( NULL != strchr( string2, *spntr ) ) break ;
  1502.         *tpntr = *spntr ;
  1503.         tpntr++ ;
  1504.     }
  1505.     *tpntr = NULL ;
  1506.  
  1507. /* return result to caller */
  1508.     if ( token[0] == NULL ) return( NULL ) ;
  1509.     return( &token[0] ) ;
  1510. }
  1511.  
  1512.  
  1513.  
  1514.  
  1515. /* strupr: convert a string to upper case.
  1516.  */
  1517.  
  1518. char    *strupr( string )
  1519. char    *string ;
  1520. {
  1521. int    i ;
  1522.  
  1523.     for ( i=0; i<strlen( string ); i++ )
  1524.         if ( string[i] > 96 & string[i] < 123 ) string[i] -= 32 ;
  1525.  
  1526.     return( string ) ;
  1527. }
  1528.  
  1529.  
  1530.  
  1531.  
  1532. /* Tokenize
  1533.  *
  1534.  * Break out arguments from a string.  Pntr is the argument string
  1535.  * and tokens is an array of pointers which will be assigned memory and have
  1536.  * the arguments returned.  The function returns the number of arguments
  1537.  * found.  Pairwise characters are monitored to ensure that expressions
  1538.  * are sexually balanced.  Unused parm pointers are returned NULL.
  1539.  * MAX_TOKENS determines the dimension of the array of pointers.
  1540.  * Commas are the only delimiters allowed to distinquish tokens.
  1541.  */
  1542.  
  1543. int    tokenize( pntr, tokens )
  1544. char    *pntr, *tokens[] ;
  1545. {
  1546. int    square = 0, curl = 0, parens = 0, apost = 1, quote = 1 ;
  1547. int    i, j, quit ;
  1548. char    *text, *txt ;
  1549.  
  1550. /* clear the pointers and make a copy of the string */
  1551. for ( i=0; i<MAX_TOKENS; i++ ) tokens[i] = NULL ;
  1552. GET_MEM( text, strlen(pntr) ) ;
  1553. strcpy( text, pntr ) ;
  1554.  
  1555. for ( i=0, j=0, quit=FALSE, txt=text; quit==FALSE; j++ ) {
  1556.  
  1557.     switch( text[j] ) {
  1558.  
  1559.     case '['  :    square += 1 ;    break ;
  1560.     case ']'  :    square -= 1 ;    break ;
  1561.     case '{'  :    curl   += 1 ;    break ;
  1562.     case '}'  :    curl   -= 1 ;    break ;
  1563.     case '('  :    parens += 1 ;    break ;
  1564.     case ')'  :    parens -= 1 ;    break ;
  1565.     case '\'' :    apost = -apost;    break ;
  1566.     case '\"' :    quote = -quote;    break ;
  1567.     case NULL :    
  1568.             GET_MEM( tokens[i], strlen(txt) ) ;
  1569.             strcpy( tokens[i], txt ) ;
  1570.             quit = TRUE ;
  1571.             break ;
  1572.     case ','  :    if (!square && !curl && !parens &&(apost==1)&&(quote==1)){
  1573.                 text[j] = NULL ;
  1574.                 GET_MEM( tokens[i], strlen(txt) ) ;
  1575.                 strcpy( tokens[i], txt ) ;
  1576.                 i += 1 ;
  1577.                 txt = &text[j+1] ;
  1578.             }
  1579.     }
  1580. }
  1581.  
  1582. free( text ) ;
  1583. return( i+1 ) ;
  1584. }
  1585. @//E*O*F misc.c//
  1586. chmod u=rw,g=r,o=r misc.c
  1587.  
  1588. echo x - fix.h
  1589. sed 's/^@//' > "fix.h" <<'@//E*O*F fix.h//'
  1590. : .eq.        ==;    file for imbedding a few macros in a fortran program
  1591. : .ge.        >=;
  1592. : .gt.        >;    to use do:  prep -m -i fix.h <file >output
  1593. : .lt.        <;
  1594. : .le.        <=;
  1595. : .ne.        !=;
  1596. : **        ^;
  1597. : .and.        &;
  1598. : .or.        |;
  1599. : .not.        !;
  1600. : .true.    TRUE;
  1601. : .false.    FALSE;
  1602.  
  1603. @//E*O*F fix.h//
  1604. chmod u=rw,g=r,o=r fix.h
  1605.  
  1606. echo x - macro.h
  1607. sed 's/^@//' > "macro.h" <<'@//E*O*F macro.h//'
  1608. /* macro related stuff */
  1609.  
  1610. #include "prep.h"
  1611.  
  1612. #define    MAX_MACROS        1000
  1613. #define MAX_CALLS        100    /* if exceeded, assume recursive */
  1614.  
  1615.  
  1616. /* macro structure */
  1617. struct mac {
  1618.     char    *name ;
  1619.     char    *text ;
  1620.     int    parmcount ;
  1621.     int    callcount ;
  1622. } macro[MAX_MACROS], *macrop ;
  1623.  
  1624. int    defined_macros = 0 ;    /* number of defined macros */
  1625.  
  1626.  
  1627. /* function types */
  1628. char    *expand_macros(), *mac_expand(), *strmatch() ;
  1629. int    define_macro() ;
  1630.  
  1631. @//E*O*F macro.h//
  1632. chmod u=rw,g=r,o=r macro.h
  1633.  
  1634. echo x - prep.h
  1635. sed 's/^@//' > "prep.h" <<'@//E*O*F prep.h//'
  1636. #ifdef    MAIN
  1637. /*
  1638.     Included stuff for main routine of program PREP
  1639. */
  1640.  
  1641. #include "stdio.h"
  1642. #include "string.h"
  1643. #include "prepdf.h"
  1644.  
  1645. /* global pointers & storage */
  1646. char    *in_buff, *out_buff ;        /* text buffer pointers */
  1647. char    *phys_ibuff ;            /* physical input buffer */
  1648. char    *phys_obuff ;            /* physical output buffer */
  1649. char    *mem_store[STORE_SIZE] ;    /* pointers to malloc areas */
  1650. char    *initial_name[NESTING] ;    /* do loop initial values */
  1651. char    *limit_name[NESTING] ;        /* do loop limits */
  1652. char    *increment_name[NESTING] ;    /* do loop increments */
  1653. char    *case_exp[NESTING] ;        /* case expression storage */
  1654. char    *exp ;                /* general expression storage pointer */
  1655. char    *first_nonblank ;        /* first nb char in in_buff */
  1656. char    label[NESTING][6] ;        /* label storage (vector loops) */
  1657. char    alabel[NESTING][6] ;        /* again label storage */
  1658. char    blabel[NESTING][6] ;        /* begin label storage */
  1659. char    clabel[NESTING][6] ;        /* case label storage */
  1660. char    dlabel[NESTING][6] ;        /* do/end_do label storage */
  1661. char    elabel[NESTING][6] ;        /* leave_do label storage */
  1662. char    var_name[NESTING][6] ;        /* do counter names */
  1663. char    dataf[DEF_BUFFSIZE] ;        /* data file name */
  1664. char    errline[2*DEF_BUFFSIZE] ;    /* error message line */
  1665.  
  1666. long    allocation ;          /* current size of in_buff */
  1667. int    of_count[NESTING] ;   /* counters for of statements */
  1668. int    leave_do_flag[NESTING] ;   /* marks if leave_do in current loop */
  1669. int    var_count = 0 ;       /* number of variables used in do loops */
  1670. int    label_count = 0 ;     /* label = label_count + 10000 */
  1671. int    alabel_count = 0 ;    /* alabel = alabel_count + 15000 */
  1672. int    blabel_count = 0 ;    /* blabel = blabel_count + 17500 */
  1673. int    clabel_count = 0 ;    /* clabel = clabel_count + 20000 */
  1674. int    dlabel_count = 0 ;    /* dlabel = dlabel_count + 12500 */
  1675. int    elabel_count = 0 ;    /* elabel = elabel_count + 22500 */
  1676. int    do_count = 0 ;        /* nesting counter for do/end_do */
  1677. int    begin_count = 0 ;     /* nesting counter for begin ... loops */
  1678. int    case_count = 0 ;      /* case nesting level */
  1679. int    tab_size = 7 ;        /* size of the tab in blanks */
  1680. int    unroll_depth = 0 ;    /* do loop unroll depth, 0 for no unrolling */
  1681. int    line_limit = 1000 ;   /* unroll loops if # lines <= line_limit */
  1682. int    mem_count = 0 ;       /* mem_store external counter */
  1683. int    include_count = 0 ;   /* index of filestack (for includes) */
  1684. int    name_length = 0 ;     /* current command name length */
  1685. int    vec_flag = FALSE ;    /* TRUE if in vector loop */
  1686. int    com_keep = FALSE ;    /* TRUE to keep comments */
  1687. int    underline_keep=FALSE; /* TRUE to keep underline characters */
  1688. int    macro_only = FALSE ;  /* TRUE to do only macro expansion */
  1689.  
  1690. FILE    *in, *out, *filestack[NESTING] ;
  1691.  
  1692. /* function declarations */
  1693. char    *get_rec(), *mac_proc(), *malloc(), *realloc() ;
  1694.  
  1695.  
  1696. #else
  1697.  
  1698. /* Header file for the functions of program PREP */
  1699.  
  1700. #include "stdio.h"
  1701. #include "string.h"
  1702. #include "prepdf.h"
  1703.  
  1704. /* global pointers & storage */
  1705. extern char    *in_buff, *out_buff, *phys_ibuff, *phys_obuff,
  1706.         *mem_store[],
  1707.         *initial_name[], *limit_name[], *increment_name[],
  1708.         *case_exp[], *exp, *first_nonblank,
  1709.         label[][6],
  1710.         alabel[][6], blabel[][6], clabel[][6], dlabel[][6], elabel[][6],
  1711.         var_name[][6],
  1712.         dataf[], errline[] ;
  1713.  
  1714. extern int    var_count, tab_size, unroll_depth, line_limit,
  1715.         com_keep, vec_flag, label_count,
  1716.         alabel_count, blabel_count, clabel_count,
  1717.         dlabel_count, elabel_count,
  1718.         case_count, of_count[], do_count, begin_count,
  1719.         mem_count, underline_keep, include_count, macro_only,
  1720.         name_length, leave_do_flag[] ;
  1721.  
  1722. extern long    allocation ;
  1723.  
  1724. extern    FILE    *in, *out, *filestack[] ;
  1725.  
  1726. /* function type declarations */
  1727. char        *mat_del(), *line_end(), *get_rec(), get_a_char(),
  1728.         *malloc(), *calloc(), *realloc(), *strtokp(),
  1729.         *mac_proc(), *strupr() ;
  1730.  
  1731. #endif
  1732.  
  1733. @//E*O*F prep.h//
  1734. chmod u=rw,g=r,o=r prep.h
  1735.  
  1736. echo x - prepdf.h
  1737. sed 's/^@//' > "prepdf.h" <<'@//E*O*F prepdf.h//'
  1738. /* #define CRAY            1 */
  1739.  
  1740. #define BLANK            ' '
  1741. #define TAB            '\t'
  1742. #define TRUE            1
  1743. #define FALSE            0
  1744. #define    NOT            !
  1745. #define    DEF_UNROLL_DEPTH    8
  1746. #define    DEF_LINE_LIMIT        1
  1747. #define DEF_BUFFSIZE        200
  1748. #define PHYS_IBUFF_SIZE        10000
  1749. #define PHYS_OBUFF_SIZE        0    /* not used, uses sys output buffer */
  1750. #define    STORE_SIZE        1000
  1751. #define    NESTING            10
  1752. #define    MAX_TOKENS        2*NESTING    /* tokens and macro args */
  1753. #define exp            expression    /* used exp as a variable */
  1754.  
  1755. #define    IN_BUFF_DONE        in_buff[0] = NULL ;
  1756.  
  1757. #define IN_BUFF_FULL        line_end( in_buff ) != NULL
  1758.  
  1759. #define    UNROLLING        ( ( unroll_depth >  1          ) && \
  1760.                   ( mem_count    <= line_limit ) && \
  1761.                   ( var_count    >  1          ) )
  1762.  
  1763. #define    GET_MEM(S,A)\
  1764. if ( NULL == (S = malloc(A+1)) ) {\
  1765.     abort( "Memory allocation failed") ; }
  1766.  
  1767. #define MATCH(S)    ( strncmp( combuff, S, (name_length=strlen(S)) ) == 0 )
  1768.  
  1769. #define put_string(s)    fputs( s, out ) ; putc( '\n', out ) ;
  1770.  
  1771.  
  1772. /* enumeration of command types, by hand because of svs c enum bug */
  1773. #define    type_begin     0
  1774. #define    type_again     1
  1775. #define    type_while     2
  1776. #define    type_until     3
  1777. #define    type_leave     4
  1778. #define    type_case     5
  1779. #define    type_of         6
  1780. #define    type_default     7
  1781. #define    type_end_case     8
  1782. #define    type_do_limits     9
  1783. #define    type_do         10
  1784. #define    type_end_do     11
  1785. #define    type_osqb     12
  1786. #define    type_csqb     13
  1787. #define    type_vec     14
  1788. #define    type_unroll     15
  1789. #define    type_continue     16
  1790. #define    type_leave_do     17
  1791. #define    type_continue_do 18
  1792. #define type_continue_case 19
  1793. #define    normal         20
  1794. #define type_include     21
  1795. #define    unknown         22 
  1796.  
  1797.  
  1798.  
  1799. #ifdef CRAY
  1800.  
  1801. /* the cray considers characters to be unsigned */
  1802. #undef    EOF
  1803. #define EOF    255
  1804.  
  1805. /* a few macros to adapt to cray namelength limitations */
  1806. #define continue_proc        cont_proc
  1807. #define continue_do_proc    cont_do_proc
  1808. #define leave_do_proc        le_do_proc
  1809. #define include_proc        inc_proc
  1810.  
  1811. #endif
  1812. @//E*O*F prepdf.h//
  1813. chmod u=rw,g=r,o=r prepdf.h
  1814.  
  1815. echo x - prepmac.h
  1816. sed 's/^@//' > "prepmac.h" <<'@//E*O*F prepmac.h//'
  1817. c Some standard macros for prep.
  1818.  
  1819. c logical stuff
  1820. : ==    .eq. ;
  1821. : >=    .ge. ;
  1822. : >    .gt. ;
  1823. : <    .lt. ;
  1824. : <=    .le. ;
  1825. : !=    .ne. ;
  1826. : <>    .ne. ;
  1827. : !    .not. ;
  1828. : |    .or. ;
  1829. : &    .and. ;
  1830. : TRUE    .true. ;
  1831. : FALSE    .false. ;
  1832. : ^    ** ;
  1833.  
  1834. c flow control redefinitions
  1835. : enddo        end_do ;
  1836. : ->begin    continue ;
  1837. : ->case    continue_case ;
  1838. : ->do        continue_do ;
  1839. @//E*O*F prepmac.h//
  1840. chmod u=rw,g=r,o=r prepmac.h
  1841.  
  1842. echo x - string.h
  1843. sed 's/^@//' > "string.h" <<'@//E*O*F string.h//'
  1844. /*    @(#)strings.h 1.1 85/12/18 SMI; from UCB 4.1 83/05/26    */
  1845.  
  1846. /*
  1847.  * External function definitions
  1848.  * for routines described in string(3).
  1849.  */
  1850. char    *strcat();
  1851. char    *strncat();
  1852. int    strcmp();
  1853. int    strncmp();
  1854. char    *strcpy();
  1855. char    *strncpy();
  1856. int    strlen();
  1857. char    *index();
  1858. char    *rindex();
  1859. char    *strchr();
  1860. int    strspn();
  1861. int    strcspn();
  1862. @//E*O*F string.h//
  1863. chmod u=rw,g=r,o=r string.h
  1864.  
  1865. echo x - vecdem.h
  1866. sed 's/^@//' > "vecdem.h" <<'@//E*O*F vecdem.h//'
  1867. c macros defs for vec demo
  1868.  
  1869. #include "prepmac.h"
  1870.  
  1871. : XLIM        81 ;        hard dimensions of arrays are from 0 --> ?lim
  1872. : YLIM        81 ;
  1873.  
  1874. : SCRNX        320 ;        geodesic drawing screen dimensions
  1875. : SCRNY        200 ;
  1876. : PHOTONS    64 ;        number of photons
  1877.  
  1878. : SMALL        1.e-20 ;
  1879. : BIG        1.e+20 ;
  1880.  
  1881. : include(x)    use x ;        cray specific file include
  1882. : PERIODIC(x)    call periodic( mx, my, x ) ;
  1883.  
  1884. c default do limits
  1885. do_limits = [ (XLIM-1), (YLIM-1) ]
  1886. @//E*O*F vecdem.h//
  1887. chmod u=rw,g=r,o=r vecdem.h
  1888.  
  1889. echo x - demo.p
  1890. sed 's/^@//' > "demo.p" <<'@//E*O*F demo.p//'
  1891. c Demo code segment to illustrate some PREP facilities.  This is
  1892. c just a preprocessor demo and will not compile without adding
  1893. c a lot of variable declarations.
  1894.  
  1895.  
  1896. #include "prepmac.h"
  1897.  
  1898. c flag to call alternate window filler if window size = array size
  1899. : PIXIE_FLAG    (((xpix1-xpix0+1) == nrows) & ((ypix1-ypix0+1) == ncols))) ;
  1900.  
  1901.       include 'tencomn'
  1902.  
  1903. c open the input data file and initialize the device
  1904.       call init
  1905.  
  1906. c skip over skip0 data sets
  1907.       call skipdat( skip0 )
  1908.       if (eoflag) call exodus
  1909.  
  1910. c enter the menu
  1911.       call menu
  1912.  
  1913. c read data tables from the input file and plot until empty
  1914.       begin
  1915.          
  1916. c clear the record numbers
  1917.          do j = 1, 10
  1918.             record( j ) = 0
  1919.          end_do
  1920.  
  1921.          do j = 1, 10
  1922.  
  1923.             icount = j
  1924.             call getdat
  1925.             record( icount ) = first_record
  1926.             leave_do (eoflag)
  1927.  
  1928. c on first dataset of a group reset background
  1929.             if ( icount .eq. 1 ) then
  1930.                call vsbcol(dev, backcol)
  1931.                call vclrwk(dev)
  1932.             end if
  1933.  
  1934. c weed the data to make it fit in the window
  1935.             call compact
  1936.  
  1937. c clear a window and label it
  1938.             call windower
  1939.  
  1940. c Plot the data table , 1st arg is absolute first dim of buffer
  1941.             if ( PIXIE_FLAG ) then
  1942.                call pixie( HARD_X_DIM, nrows, ncols,
  1943.      *                     xpix0, PHYS_HEIGHT - 1 - ypix1,
  1944.      *                     buffer )
  1945.             else
  1946.                call winfill( HARD_X_DIM, nrows, ncols,
  1947.      *                       xpix0, xpix1,
  1948.      *                       PHYS_HEIGHT - 1 - ypix1,
  1949.      *                       PHYS_HEIGHT - 1 - ypix0,
  1950.      *                       buffer )
  1951.             end if
  1952.  
  1953. c see if the user is tired and wants to quit
  1954.             status = vsmstr( dev, ten, zero, echoxy, dummy)
  1955.             if ( status .gt. 0 ) then
  1956.                case [ upper( dummy(1:1) ) ]
  1957.                   of ( 'Q' )   call exodus
  1958.                   of ( 'R' )   leave_do
  1959.                   of ( 'B' )   leave_do
  1960.                end_case
  1961.             end if
  1962.  
  1963.          end_do
  1964.  
  1965. c skip over skip data sets
  1966.          call skipdat( skip )
  1967.  
  1968. c Delay and wait for keystroke.  Quit on Q,q; continue on cr; enlarge
  1969. c on keys 1,2,3,...9,0 (0 --> 10); make a dump file on D, d.
  1970. c If in movie mode, skip this input section, make a dump, and continue
  1971.          if ( movie_mode ) then
  1972.             if (eoflag) call exodus
  1973.             call dump
  1974.  
  1975.          else
  1976. c stay in this loop if end of file has been reached.
  1977.             begin
  1978.  
  1979.                case ( last_key )
  1980.                last_key = key(dev)
  1981.  
  1982.                   of ( 'D' )   call dump
  1983.                                continue_case
  1984.                   of ( 'Q' )   call exodus
  1985.                   of ( 'R' )   call restart
  1986.                   of ( 'B' )   call pop( recn )
  1987.                                recn = max0( recn, 1 )
  1988.                                eoflag = .false.
  1989.                   default      call push( max0( record(1), 1 ) )
  1990.  
  1991.                                call enlarger
  1992.                end_case
  1993.  
  1994.             while ( eoflag )
  1995.             again
  1996.  
  1997.          end if
  1998.  
  1999.       again
  2000.  
  2001. c Restore the video mode and turn off the device
  2002.       call exodus
  2003.       end
  2004. @//E*O*F demo.p//
  2005. chmod u=rw,g=r,o=r demo.p
  2006.  
  2007. echo x - sieve.p
  2008. sed 's/^@//' > "sieve.p" <<'@//E*O*F sieve.p//'
  2009. c sieve benchmark in fortran
  2010.  
  2011. #include "prepmac.h"
  2012. : S        8190 ;
  2013. : WHILE(l)    begin
  2014.         while (l) ;
  2015.  
  2016. do limits [ (0, S) ]
  2017.  
  2018.     integer f(S+1), i, p, k, c, n
  2019.  
  2020.     do n = 1, 10
  2021.        c = 0
  2022.        f(#) = 1
  2023. [       if ( f(#) != 0 ) then
  2024.           p = # + # + 3
  2025.           k = # + p
  2026.           WHILE ( k <= S )
  2027.              f(k) = 0
  2028.              k = k + p
  2029.           again
  2030.           c = c + 1
  2031.        end if
  2032. ]
  2033.     enddo
  2034.  
  2035.     write(*,*) c, ' primes'
  2036.  
  2037.     stop
  2038.     end
  2039. @//E*O*F sieve.p//
  2040. chmod u=rw,g=r,o=r sieve.p
  2041.  
  2042. echo x - vecdem.p
  2043. sed 's/^@//' > "vecdem.p" <<'@//E*O*F vecdem.p//'
  2044. c Demo to demonstrate some PREP facilities.  This program is a demo
  2045. c only and will not compile without a lot of variable definitions.
  2046.  
  2047. #include "vecdem.h"
  2048.  
  2049.         subroutine w_accel_l(psi, lin_fac, source, omega)
  2050.         include "ellipdim"
  2051.  
  2052.         if (w_bypass) return
  2053.         w_error = FALSE
  2054.  
  2055. c Set up the basis consisting of past iterates
  2056. [    basis(#,#,1) = psi(#,#)
  2057.     basis(#,#,2) = psi(#,#) - psi_alt(#,#,1)
  2058.     basis(#,#,3) = psi(#,#) - 2*psi_alt(#,#,1) + psi_alt(#,#,2)
  2059.     basis(#,#,4) = 1      ]
  2060.     PERIODIC( basis1 )
  2061.     PERIODIC( basis2 )
  2062.     PERIODIC( basis3 )
  2063.     PERIODIC( basis4 )
  2064.  
  2065. c Calculate the matrix and the source vector
  2066.         do i = 1, w_dim
  2067.     ii = i
  2068.     do j = i, w_dim
  2069.     jj = j
  2070.            call make_mat_l(psi, lin_fac, source, omega, i, j)
  2071.         end_do
  2072.     end_do
  2073.  
  2074.     do i = 1, w_dim
  2075.            w_source(i) = 0
  2076.            w_source(i) = source(#,#)*basis(#,#,i) + w_source(i)
  2077.         end_do
  2078.  
  2079. c invert the symmetric matrix
  2080.         call linsys(w_matrix, w_dim, w_dim, w_source, w_coeff, ising, lfirst,
  2081.      *              lprint, work)
  2082.         if (ising == 1) then
  2083.            write(*,*) ' WARNING:  W_matrix is singular '
  2084.            w_error = TRUE
  2085.            return
  2086.         endif
  2087.  
  2088. c calculate the improved solution
  2089.         psi(#,#) = 0
  2090.         do i = 1, w_dim
  2091.            psi(#,#) = psi(#,#) + w_coeff(i)*basis(#,#,i)
  2092.         end_do
  2093.  
  2094. c output section for error checking
  2095.         do i = 1, w_dim
  2096.            write(*,100) i, .5*w_matrix(i,i) - w_source(i),
  2097.      *                  i, w_coeff(i)
  2098.         end_do
  2099.  
  2100.     do_limits = { w_dim }
  2101.         action = 0
  2102.         do i = 1, w_dim
  2103.            action = action + w_matrix(i,#)*w_coeff(i)*w_coeff(#)
  2104.         end_do
  2105.         action = action/2
  2106.         action = action - w_source(#)*w_coeff(#)
  2107.         write(*,*) ' new action = ',action
  2108.  
  2109.         return
  2110.  
  2111.  
  2112. 100     format(' action(',i1')= ',g16.9,'    w_coeff(',i1,')= ', g16.9)
  2113.  
  2114.         end
  2115. @//E*O*F vecdem.p//
  2116. chmod u=rw,g=r,o=r vecdem.p
  2117.  
  2118. echo x - vecdemo.p
  2119. sed 's/^@//' > "vecdemo.p" <<'@//E*O*F vecdemo.p//'
  2120.  
  2121. c***********************************************************************
  2122. c                                                                      *
  2123. c                    subroutine W_ACCEL_LIN                            *
  2124. c                                                                      *
  2125. c Do the Wachspress accelleration.                                     *
  2126. c   The solution is expressed as a linear combination of the previous  *
  2127. c iterate and the lowest order fourier modes and the coefficients      *
  2128. c are found so as to minimize the error.                               *
  2129. c                                                                      *
  2130. c P.R.OVE  7/6/85                                                      *
  2131. c***********************************************************************
  2132.  
  2133.         subroutine w_accel_l(psi, lin_fac, source, omega)
  2134.         use ellipdim
  2135.         do_limits = { mx, my }
  2136.  
  2137.         if (w_bypass) return
  2138.         w_error = FALSE
  2139.  
  2140. c**********************************************************************
  2141. c Set up the basis consisting of past iterates                        *
  2142. c**********************************************************************
  2143. [    basis(#,#,1) = psi(#,#)
  2144.     basis(#,#,2) = psi(#,#) - psi_alt(#,#,1)
  2145.     basis(#,#,3) = psi(#,#) - 2*psi_alt(#,#,1) + psi_alt(#,#,2)
  2146.     basis(#,#,4) = 1      ]
  2147.     call periodic( mx, my, basis1 )
  2148.     call periodic( mx, my, basis2 )
  2149.     call periodic( mx, my, basis3 )
  2150.     call periodic( mx, my, basis4 )
  2151.  
  2152. c**********************************************************************
  2153. c Calculate the Wachspress matrix and the source vector               *
  2154. c**********************************************************************
  2155.         do i = 1, w_dim
  2156.     ii = i
  2157.     do j = i, w_dim
  2158.        jj = j
  2159.            call make_mat_l(psi, lin_fac, source, omega, i, j)
  2160.         end_do
  2161.     end_do
  2162.  
  2163.     do i = 1, w_dim
  2164.            w_source(i) = 0
  2165.            w_source(i) = source(#,#)*basis(#,#,i) + w_source(i)
  2166.         end_do
  2167.  
  2168. c**********************************************************************
  2169. c invert the symmetric matrix and improve the solution psi.           *
  2170. c**********************************************************************
  2171.         call linsys(w_matrix, w_dim, w_dim, w_source, w_coeff,
  2172.      *              ising, lfirst, lprint, work)
  2173.         if (ising == 1) then
  2174. c          write(*,*) ' WARNING:  W_matrix is singular '
  2175.            w_error = TRUE
  2176.            goto 99
  2177.         endif
  2178.  
  2179. c calculate the improved solution
  2180.         psi(#,#) = 0
  2181.         do i = 1, w_dim
  2182.            psi(#,#) = psi(#,#) + w_coeff(i)*basis(#,#,i)
  2183.         end_do
  2184.  
  2185. c**********************************************************************
  2186. c output section for error checking  (optional)                       *
  2187. c**********************************************************************
  2188.     go to 99
  2189.         do i = 1, w_dim
  2190.            write(*,100) i, .5*w_matrix(i,i) - w_source(i),
  2191.      *                  i, w_coeff(i)
  2192. 100        format(' action(',i1')= ',g16.9,'    w_coeff(',i1,')= ',
  2193.      *               g16.9)
  2194.         end_do
  2195.  
  2196.     do_limits = { w_dim }
  2197.         action = 0
  2198.         do i = 1, w_dim
  2199.            action = action + w_matrix(i,#)*w_coeff(i)*w_coeff(#)
  2200.         end_do
  2201.         action = action/2
  2202.         action = action - w_source(#)*w_coeff(#)
  2203.         write(*,*) ' new action = ',action
  2204.  
  2205. 99      return
  2206.         end
  2207. @//E*O*F vecdemo.p//
  2208. chmod u=rw,g=r,o=r vecdemo.p
  2209.  
  2210. echo Inspecting for damage in transit...
  2211. temp=/tmp/shar$$; dtemp=/tmp/.shar$$
  2212. trap "rm -f $temp $dtemp; exit" 0 1 2 3 15
  2213. cat > $temp <<\!!!
  2214.      750    2967   17527 flow.c
  2215.      807    3353   18498 misc.c
  2216.       13      55     243 fix.h
  2217.       23      65     414 macro.h
  2218.       97     566    3740 prep.h
  2219.       74     268    1826 prepdf.h
  2220.       22      81     326 prepmac.h
  2221.       18      46     326 string.h
  2222.       19      80     408 vecdem.h
  2223.      113     441    3190 demo.p
  2224.       30      91     402 sieve.p
  2225.       71     241    1870 vecdem.p
  2226.       87     316    3336 vecdemo.p
  2227.     2124    8570   52106 total
  2228. !!!
  2229. wc  flow.c misc.c fix.h macro.h prep.h prepdf.h prepmac.h string.h vecdem.h demo.p sieve.p vecdem.p vecdemo.p | sed 's=[^ ]*/==' | diff -b $temp - >$dtemp
  2230. if [ -s $dtemp ]
  2231. then echo "Ouch [diff of wc output]:" ; cat $dtemp
  2232. else echo "No problems found."
  2233. fi
  2234. exit 0
  2235.  
  2236.  
  2237.