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