home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume43 / pf77 / part01 / ifprob.c < prev    next >
C/C++ Source or Header  |  1994-06-10  |  30KB  |  928 lines
  1. /*************************************************************************
  2.    i f p r o b    i n s t r u m e n t a t i o n   r o u t i n e s
  3.  ************************************************************************
  4. Copyright (c) 1990, Kevin Dowd.
  5. You are free to use this software in any manner you choose.  It is requested,
  6. but not required, that you include the above copyright notice in any derived
  7. works.  The author make no claims as to the fitness or correctness of
  8. this software for any use whatsoever, and it is provided as is. Any use
  9. of this software is at the user's own risk.
  10.  
  11.    This file contains routines that insert instrumenting code into 
  12.    fortran source.  They are called from routines found in ft.c.
  13.    Subroutine ifprob_body2 may be called recursively untill all fortran
  14.    constructs have been instrumented.
  15. */
  16.  
  17. #include <stdio.h>
  18. #include "def.h"
  19. #include "ext.h"
  20.  
  21. /* Data structures for ifprobbing:
  22.  
  23.    The first is a stack for keeping track of the termination labels for
  24.    loops. A certain amount of transformation has to be done to correctly
  25.    instrument the termination point.
  26. */
  27. int loopstack[MAXLSTACK];
  28. int lstackptr = -1;
  29.  
  30. /* Specifically for ifprobbing:
  31. */
  32.  
  33. struct probnode *probstart = NULL;      /* Profiling info is kept     */
  34. struct probnode    *probptr, *probfree;    /* in a linked list           */
  35. FILE *outifprobfp   = stdout;           /* fp for profiling output    */
  36. int ifprob          = TRUE;             /* Is ifprobbing turned on?   */
  37. char *root          = {ROOT};           /* Variable root name         */
  38. int ifpcount        = 0;                /* Ifprobbing counter.        */
  39.  
  40. /* Labels are given new values as encountered.
  41. */
  42.  
  43. struct lablnode *lstart, *lptr, *lfree;
  44. int label_num = 10000;              /* initial label number              */
  45. char ws[2000];                    /* some general scratch space        */
  46. char *wsptr;                      /* a pointer into ws for incr_output */
  47. int  wsindent;
  48. int  executable_statement;
  49.  
  50. static int body_first_time;
  51. static int preamble_dumped;
  52. static int progtype;
  53.  
  54. /* These rules are first a handling the parameters that appear in
  55.    I/O statements.
  56. */
  57.  
  58. static RULE arglst  = { "$B`,`6[,$X7]",                       ARGLST,   NULL};
  59. static RULE iolst   = { "$LC4$X3",                            IOLST,    NULL};
  60. static RULE xeqx    = { "$B`=`4!=$X5",                        XEQX,     NULL};
  61.  
  62. /* This one is for computed gotos.
  63. */
  64. static RULE lbllst  = { "$N6[,$X7]",                          ARGLST,   NULL};
  65.  
  66. /*************************************************************************
  67.  i f p r o b _ i n i t
  68.  ************************************************************************/
  69. int ifprob_init()
  70. {
  71. /* For ifprobbing: probnodes are allocated as needed. However, when
  72.    instrumenting more than one program module nodes already allocated
  73.    can be reused.
  74. */
  75.     struct probnode *getprobnode();
  76.     struct lablnode *getlablnode();
  77.  
  78.     if (probstart == (struct probnode *) NULL) 
  79.         probptr = probstart = getprobnode();
  80.     else {
  81.         probptr  = probstart;
  82.         probfree = probstart->next;
  83.         probstart->next = (struct probnode *) NULL;
  84.     }
  85.  
  86. /* The same thing goes for new label nodes. These are used for generating
  87.    new label numbers in lieu of the ones in the source.
  88. */
  89.  
  90.     if (lstart != (struct lablnode *) NULL) {
  91.         lfree = lstart;
  92.         lstart = (struct lablnode *) NULL;
  93.     }
  94.  
  95. /* Reset first time through flags so that stuff will be prepended to the
  96.    instrumented program body.
  97. */
  98.     body_first_time = TRUE;
  99.     preamble_dumped = FALSE;
  100.  
  101. /* Initialize the symbol table
  102. */
  103.     initsymtab();
  104.  
  105. /* Initialize list of implicit types.
  106. */
  107.     initimpllist();
  108. }
  109.  
  110. /*************************************************************************
  111.  i f p r o b _ p r o g
  112.  ************************************************************************/
  113. int ifprob_prog (s, args)
  114. int s;
  115. struct arg *args[];
  116. {
  117.  
  118. /* This routine is specific for processing the program statement 
  119.    of a FORTRAN routine which is being 'ifprobbed'.
  120.  
  121.    Inputs:   s - an int telling what type of statement this is.
  122.                  (i.e. IFTHEN, GOTO...)
  123.              args - argument pointers.
  124.  
  125.    Modifies: ismain, modulename
  126.  
  127.    Outputs:  nothing
  128. */
  129.  
  130. /* If there was no program statement.
  131. */
  132.     if (s == NOMATCH) {
  133.         ismain = TRUE;
  134.         strcpy (modulename, "MAIN");
  135.     }
  136.  
  137.     else {
  138.  
  139.     switch (s) {
  140.  
  141. /* If there is a program statement, get it's name.
  142. */
  143.         case PROGRAM:
  144.             ismain = TRUE;
  145.             break;
  146.  
  147. /* Block data. Get the name.
  148. */
  149.         case BLOCKDATA:
  150.             ismain = FALSE;
  151.             break;
  152.  
  153. /* A function may be typed and may have an argument list. Record the module
  154.    name and add it to the symbol table. Do whatever may be necessary with
  155.    the input argument list.
  156. */
  157.          case FUNCTION:
  158.             ismain = FALSE;
  159.             break;
  160.  
  161.         case SUBROUTINE:
  162.             ismain = FALSE;
  163.             break;
  164.  
  165. /* Record the module name. Output the input line.
  166. */
  167.         }
  168.     emitf77 (NULL,"%s", input_buffer);
  169.     strcpy (modulename, args[0]->text);
  170.     }
  171.  
  172. /* Record that we are inside a program module. Premature EOF will be an
  173.    error.
  174. */
  175.     inside_module = TRUE;
  176.  
  177. /* Record the program type so that we won't output any instrumention
  178.    preamble if this is a blockdata. 
  179. */
  180.     progtype = s;    
  181.  
  182. /* Record the symbol. Functions are typed. All others are typeless.
  183.    add: symbol,type,size,dim,use. This is the unofficial version
  184.    of the rules we are working with:
  185.  
  186.    "PROGRAM$A0",                               PROGRAM
  187.    "BLOCKDATA$A0",                             BLOCKDATA
  188.    "[$LA1[*$LB2]]FUNCTION$A0[*$LB2][([$X3])]", FUNCTION
  189.    "[$LF1[*$N2]]FUNCTION$A0[*$N2][([$X3])]",   FUNCTION
  190.    "SUBROUTINE$A0[($X3!)]",                    SUBROUTINE
  191.  
  192. */
  193.     if (s == FUNCTION) 
  194.         addsymtab (modulename, (args[1] != NULL ? args[1]->value : DEFAULT),
  195.                       (args[2] != NULL ? atoi (args[2]->text) : DEFAULT),
  196.                       SCALAR, DEFINITION, GLOBAL);
  197.     else
  198.         addsymtab (modulename, TYPELESS, UNDEFINED, UNDEFINED, DEFINITION, 
  199.            GLOBAL);
  200.  
  201. /* Dissect the input argument list. This, unlike most other expressions
  202.    we'll encounter, cannot contain subexpressions.
  203. */
  204.     if (args[3] != (struct arg *) NULL)
  205.         dissectdmmy (args[3]->text);
  206.  
  207. #ifdef NEVER
  208.     fprintf (stderr,"program_statement: module=%s\n", modulename);
  209. #endif
  210. }
  211.       
  212. /*************************************************************************
  213.  i f p r o b _ d e c l
  214.  ************************************************************************/
  215. int ifprob_decl (label, s, args)
  216. char *label;
  217. int s;
  218. struct arg *args[];
  219. {
  220. /* This routine is specific for processing the decls
  221.    of a FORTRAN routine which is being 'ifprobbed'.
  222.  
  223.    Inputs:   s - an int telling what type of statement this is.
  224.              args - argument pointers.
  225.  
  226.    Modifies: nothing
  227.  
  228.    Outputs:  nothing
  229. */
  230.  
  231. /* If the your fortran compiler doesn't care where an implicit statement
  232.    occurs, then I don't either.
  233. */
  234.     switch (s) {
  235.  
  236.     case IMPL:
  237.         dissectimpl (args[0]->value, 
  238.             (args[1] == NULL ? DEFAULT : args[1]->value), args[2]->text);
  239.         break;
  240.  
  241.     case EXTER:
  242.     case INTRINS:
  243.  
  244. /* Add externals to the symbol table. First module and then the rest.
  245. */
  246.         dissectnames (args[0]->text);
  247.         if (args[1] != (struct arg *) NULL)
  248.             dissectnames (args[1]->text);
  249.         break;
  250.  
  251.     case COMPLX:
  252.     case INTEGER:
  253.     case REAL:
  254.     case LOGICAL:
  255.     case CHR:
  256.  
  257. /* The pass the type and possibly the length (if known).
  258. */
  259.         dissectdecl (s, args[0]->text, 
  260.              (args[1] == NULL ? DEFAULT : args[1]->value));
  261.         break;
  262.     
  263.     case DP:
  264.         dissectdecl (s, args[0]->text, 8);
  265.         break;
  266.  
  267.     case DC:
  268.         dissectdecl (s, args[0]->text, 16);
  269.         break;
  270.  
  271. /* Dimension statements take previously specified or default type.
  272. */
  273.     case DIM:
  274.  
  275.         dissectdecl (DEFAULT, args[0]->text, DEFAULT);
  276.     break;
  277.  
  278. /* Common statements can contain first references to variables and arrays.
  279. */
  280.     case COMMON:
  281.     case NAMELIST:
  282.  
  283. /* If this is a named common, make a reference to it.
  284. */
  285.         if (args[0] != (struct arg *) NULL)
  286.             addsymtab (args[0]->text, TYPELESS, UNDEFINED, UNDEFINED, 
  287.                 DEFINITION, GLOBAL);
  288.  
  289. /* Catalog the variables in the common.
  290. */
  291.         dissectdecl (DEFAULT, args[1]->text, DEFAULT);
  292.     break;
  293.  
  294.     default:
  295.  
  296.         if (preamble_dumped == FALSE)
  297.             ifprob_preamble();
  298.         preamble_dumped = TRUE;
  299.     }
  300.     emitf77 (label,"%s", input_buffer);
  301. }
  302.  
  303. /*************************************************************************
  304.  i f p r o b _ b o d y
  305.  ************************************************************************/
  306. int ifprob_body (label, s, args, ibufptr)
  307. char *label;
  308. int s;
  309. struct arg *args[];
  310. char *ibufptr;
  311. {
  312. /* This is a header routine for the one that actually instruments the code.
  313.    For reasons surrounding instrumentation of do-loop terminals, it is
  314.    often better to delay the instrumented output. The routines incr_output
  315.    and emitf77 are for delayed and immediate output, respectively.
  316. */
  317.     int q;
  318.     struct probnode *getprobnode();
  319.  
  320.     if (body_first_time == TRUE) {
  321.  
  322. /* At the top of the program body a branch to the end is emitted where 
  323.    one of the statistics keeping routines is told how much space to set 
  324.    aside for gathering statistics for this routine.
  325. */
  326.         if (preamble_dumped == FALSE)
  327.             ifprob_preamble();
  328.  
  329.         preamble_dumped = TRUE;
  330.          
  331. /* Check for and skip past statement functions.
  332. */
  333.         if (statement_fn (s, args) == TRUE) {
  334.             emitf77 (NULL, "%s", ibufptr);
  335.             return (OK);
  336.         }
  337.  
  338.         ifprob_branch ();
  339.  
  340. /* Turn implicit declarations explicit.
  341. */
  342.         explicit();
  343.  
  344. /* Count the number of times this routine has been entered
  345. */
  346.         emitf77 (NULL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  347.                   root,root,ifpcount,root,root,ifpcount);
  348.         probptr->linenumber = source_line_number-1;
  349.         probptr->type = ENTRY;
  350.         probptr = probptr->next = getprobnode();
  351.         ifpcount+=1;
  352.  
  353.         body_first_time = FALSE;
  354.     }
  355.  
  356.     reset_incr_output();
  357.     executable_statement = TRUE;
  358.     q = ifprob_body2 (s, args, ibufptr);
  359.     if (q != NOMATCH) emitf77 (label, NULL, NULL);
  360.     return(q);
  361. }
  362.  
  363. /*************************************************************************
  364.  i f p r o b _ b o d y 2
  365.  ************************************************************************/
  366. int ifprob_body2 (s, args, ibufptr)
  367. int s;
  368. struct arg *args[];
  369. char *ibufptr;
  370. {
  371.  
  372. /* This routine is specific for processing the body of a FORTRAN routine
  373.    which is being 'ifprobbed'.
  374.  
  375.    Inputs:   label - statement label if there is one, or NULL
  376.          s - an int telling what type of statement this is.
  377.                  (i.e. IFTHEN, GOTO...)
  378.              args - argument pointers.
  379.  
  380.    Modifies: ifpcount, makes probnodes.
  381.  
  382.    Outputs:  nothing
  383. */
  384.     struct probnode *getprobnode();
  385.     int newlabel();   
  386.     char *ltext();
  387.     char chtemp[6];
  388.     int unitfound, formatfound;   /* flags for handling I/O statements. */
  389.     int stype;
  390.     char *car, *cddr;
  391.     struct arg *part2, *part1;
  392.     struct arg *args2[MAXARGS];
  393.  
  394. #ifdef DEBUG
  395.     printf ("ifprob_body2: statement type = %d\n",s);
  396. #endif
  397.  
  398.     switch (s) {
  399.  
  400.         case IFTHEN: 
  401.  
  402. /* For a logical IF followed by a THEN: Instrument the lines just before
  403.    and just after to measure how often the condition is true.
  404. */
  405.             incr_output (NL, "IF(%s)THEN", args[0]->text);
  406.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  407.                   root,root,ifpcount,root,root,ifpcount);
  408.             probptr->linenumber = source_line_number;
  409.             probptr->type = IFTHEN;
  410.             probptr = probptr->next = getprobnode();
  411.             ifpcount+=1;
  412.             break;
  413.  
  414.         case ELSIFTH: 
  415.  
  416. /* In the middle of a block if: Measure the number of times this condition
  417.    is true.
  418. */
  419.             incr_output (NL, "ELSEIF(%s)THEN", args[0]->text);
  420.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  421.                   root,root,ifpcount,root,root,ifpcount);
  422.             probptr->linenumber = source_line_number;
  423.             probptr->type = ELSIFTH;
  424.             probptr = probptr->next = getprobnode();
  425.             ifpcount++;
  426.             break;
  427.  
  428.         case ELS: 
  429.  
  430. /* It should be clear how many times we make it to the else clause
  431.    if we were to calculate it.
  432. */
  433.             incr_output (NL, "ELSE");
  434.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  435.                   root,root,ifpcount,root,root,ifpcount);
  436.             probptr->linenumber = source_line_number;
  437.             probptr->type = ELS;
  438.             probptr = probptr->next = getprobnode();
  439.             ifpcount++;
  440.             break;
  441.         
  442.         case ELSIF: 
  443.  
  444. /* Turn an else-if into an else-if-then and add a line to measure how 
  445.    often it is true.
  446. */
  447.             incr_output (NL, "ELSEIF(%s)THEN", args[0]->text);
  448.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  449.                   root,root,ifpcount,root,root,ifpcount);
  450.             ifpcount++;
  451.  
  452. /* Recursively match and parse the logical consequent.
  453. */
  454.             recursive_body (args[1]->text, args2, ifprob_body2);
  455.  
  456.             probptr->linenumber = source_line_number;
  457.             probptr->type = ELSIF;
  458.             probptr = probptr->next = getprobnode();
  459.             break;
  460.  
  461.         case LOGIF: 
  462.  
  463. /* This LOGICAL IF will be turned into a BLOCK IF with code inserted
  464.    to measure activity. There is a danger here; A one line statement
  465.    is being turned into a three line statement. If the statement turns 
  466.    out to be a do loop terminal it is important to execute every bit
  467.    of the transformed version. Also, the consequent may need to be
  468.    parsed as well. For these two reasons, output is delayed until
  469.    after the whole statement is parsed. The consequent is parsed
  470.    recursively within the context of the current statement. 
  471.    By taking these careful steps such constructs as
  472.  
  473.       DO 10 I=1,N
  474.    5  CALL GZERNINFRATZ (A,B,C)
  475.   10  IF (A(I) .EQ. U) IF (B(I) .EQ. V) IF(C(I) .EQ. W) GOTO 5
  476.  
  477.    Will be parsed correctly (even if they're illegal).
  478. */
  479.             incr_output (NL,"IF(%s)THEN", args[0]->text);
  480.             incr_output (NL,"%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  481.                   root,root,ifpcount,root,root,ifpcount);
  482.             ifpcount+=1;
  483.  
  484. /* Recursively match and parse the logical consequent.
  485. */
  486.             recursive_body (args[1]->text, args2, ifprob_body2);
  487.             incr_output(NL,"ENDIF");
  488.             probptr->linenumber = source_line_number;
  489.             probptr->type = LOGIF;
  490.             probptr = probptr->next = getprobnode();
  491.  
  492.             incr_output (NL,"%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  493.                   root,root,ifpcount,root,root,ifpcount);
  494.             probptr->linenumber = source_line_number;
  495.             probptr->type = LOGIF;
  496.             probptr = probptr->next = getprobnode();
  497.             ifpcount+=1;
  498.             break;
  499.         
  500.         case ENDIF: 
  501.  
  502. /* Anything could've happened within the block if. Instrument the outside.
  503. */
  504.             incr_output (NL, "ENDIF");
  505.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  506.                   root,root,ifpcount,root,root,ifpcount);
  507.             probptr->linenumber = source_line_number;
  508.             probptr->type = ENDIF;
  509.             probptr = probptr->next = getprobnode();
  510.             ifpcount++;
  511.             break;
  512.         
  513.         case ARITHIF: 
  514.  
  515. /* An arithmetic IF will be replaced with an IF-THEN-ELSEIF-THEN-ENDIF
  516.    sequence.
  517. */
  518.             incr_output (NL,"%sRR=%s", root, args[0]->text);
  519.             incr_output (NL,"IF(%sRR.LT.0)THEN",root);
  520.             incr_output (NL,"%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  521.                   root,root,ifpcount,root,root,ifpcount);
  522.             incr_output (NL,
  523.                "GOTO%s",(member_lstack(newlabel(args[1]->text)) == TRUE ?
  524.                 ltext(newlabel(args[1]->text)+2) : 
  525.                 ltext(newlabel(args[1]->text))));
  526.             probptr->linenumber = source_line_number;
  527.             probptr->type = ARITHIF;
  528.             probptr = probptr->next = getprobnode();
  529.             incr_output (NL, "ELSEIF(%sRR.EQ.0)THEN", root, args[0]->text);
  530.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  531.                   root,root,ifpcount+1,root,root,ifpcount+1);
  532.             incr_output (NL,
  533.                "GOTO%s",(member_lstack(newlabel(args[2]->text)) == TRUE ?
  534.                 ltext(newlabel(args[2]->text)+2) : 
  535.                 ltext(newlabel(args[2]->text))));
  536.             incr_output (NL, "ELSE");
  537.             incr_output (NL,
  538.                "GOTO%s",(member_lstack(newlabel(args[3]->text)) == TRUE ?
  539.                 ltext(newlabel(args[3]->text)+2) : 
  540.                 ltext(newlabel(args[3]->text))));
  541.             incr_output (NL, "ENDIF");
  542.             probptr->linenumber = source_line_number;
  543.             probptr->type = ARITHIF;
  544.             probptr = probptr->next = getprobnode();
  545.             ifpcount+=2;
  546.             break;
  547.  
  548.         case GOTO:
  549.  
  550. /* GOTOs are important because the label following must be converted
  551.    to one of ours.
  552. */       
  553.  
  554.             incr_output (NL,
  555.                "GOTO%s",(member_lstack(newlabel(args[0]->text)) == TRUE ?
  556.                 ltext(newlabel(args[0]->text)+2) : 
  557.                 ltext(newlabel(args[0]->text))));
  558.             break;
  559.  
  560.         case CGOTO:
  561.  
  562. /* The spot immediately following the goto needs to be instrumented. Then
  563.    all of the label numbers have to be changed.
  564. */
  565.             part2 = args[0];
  566.             incr_output (NL, "GOTO(",args[0]->text);
  567.             incr_output (OL, "%s", 
  568.                 (member_lstack(newlabel(args[1]->text)) == TRUE ?
  569.                 ltext(newlabel(args[1]->text)+2) : 
  570.                 ltext(newlabel(args[1]->text))));
  571.  
  572.             cddr = args[2]->text;
  573.             while (match (cddr, &lbllst, args) != NOMATCH) {
  574.                 cddr = (args[7] == NULL ? "" : args[7]->text);
  575.                 car  = args[6]->text;
  576.                 incr_output (OL, ",%s", 
  577.                     (member_lstack(newlabel(car)) == TRUE ?
  578.                     ltext(newlabel(car)+2) : 
  579.                     ltext(newlabel(car))));
  580.             }
  581.  
  582.             incr_output (OL, "),%s", part2->text);
  583.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  584.                   root,root,ifpcount,root,root,ifpcount);
  585.             probptr->linenumber = source_line_number;
  586.             probptr->type = CGOTO;
  587.             probptr = probptr->next = getprobnode();
  588.             ifpcount++;
  589.             break;
  590.  
  591.         case IOSTMT:
  592.  
  593. /* I/O statements can contain labels for transfer of flow upon reaching an
  594.    error. These have to be changed to our internal numbers. It is not my
  595.    place to anticipate every type of I/O specifier ever written, since this
  596.    is an area where each manufacturer stretches their legs. Additionally,
  597.    non-positional, label driven parameters are a pain to match. The innards
  598.    of these I/O statements will be disected in search of 'END=' and 'ERR='.
  599.  
  600.    $LD3($X0!)[$A1[,$X2]]
  601.           \
  602.             \ match
  603.               \ 
  604.   (*)   $B`,`$6[,$X7]  --- else done
  605.             \
  606.               \ match
  607.                 \          else
  608.                $LC4$X3 --- match --- $B`=`4!=$X5 ---> output      
  609.                {end= \                    \
  610.                 err=   \ newlabel           \ else
  611.                 fmt=}    \                    if unit=NULL       go to (*)
  612.                          go back to (*)          unit=$6
  613.                                               elseif fmt=NULL
  614.                                                  fmt =$6 ---> output
  615. */
  616.  
  617. /* Initialize some local vars needed to keep track of parsing the IO
  618.    statement.
  619. */
  620.         unitfound      = FALSE;
  621.             formatfound    = FALSE;
  622.             stype          = args[3]->value;
  623.             cddr           = args[0]->text;
  624.             part1          = args[1];
  625.         part2          = args[2];
  626.  
  627. /* Output the first part of the statement
  628. */
  629.             incr_output (NL,"%s(",args[3]->text);
  630.  
  631. /* The argument list is iteratively disassembled by the rule "$B`,`6[,$X7]".
  632. */
  633.             while (match (cddr, &arglst, args) != NOMATCH) {
  634.                 cddr = (args[7] == NULL ? "" : args[7]->text);
  635.                 car  = args[6]->text;
  636.  
  637. /* Check for the strings err=, end= and fmt=. These have special meaning to
  638.    us since we mean to replace the labels. The new format label number is
  639.    bumped up by one. This is so that if a branch was being taken with the
  640.    format label as the target it can be instrumented.
  641. */
  642.                 if (match (car, &iolst, args) != NOMATCH) {
  643.             switch (args[4]->value) {
  644.  
  645.                     case ERREQ:
  646.                         incr_output(OL,
  647.                             "ERR=%s%s",ltext(newlabel(args[3]->text)),
  648.                                     (*cddr == '\0' ? "" : ","));
  649.                         break;
  650.  
  651.             case ENDEQ:
  652.                         incr_output(OL,
  653.                             "END=%s%s",ltext(newlabel(args[3]->text)),
  654.                                     (*cddr == '\0' ? "" : ","));
  655.                         break;
  656.  
  657.             case FMTEQ:
  658.                         formatfound = TRUE;
  659.                         incr_output(OL,"FMT=%s%s",
  660.                                     (isdigit(*(args[3]->text)==TRUE) 
  661.                                      ? ltext(newlabel(args[3]->text)+1)
  662.                                      : args[3]->text),
  663.                                     (*cddr == '\0' ? "" : ","));
  664.                     }
  665.             }
  666.  
  667. /* Otherwise, check for anything that looks like 'foo=bar'. If this
  668.    is not an I/O specifier of that type, then it might be the unit
  669.    or format specifier.
  670. */
  671.                 else if (match (car, &xeqx, args) != NOMATCH)
  672.                     incr_output (OL,"%s%s",car,(*cddr == '\0' ? "" : ","));
  673.  
  674.                 else {
  675.                     if (unitfound == FALSE) {
  676.                         incr_output(OL,"UNIT=%s%s",car,
  677.                 (*cddr == '\0' ? "" : ","));
  678.                         unitfound = TRUE;
  679.                     }
  680.  
  681. /* It can only be a format specifier if this is a read or write statement. 
  682.    A lone label in any other type of I/O statement is probably an error,
  683.    but I will let it go.
  684. */
  685.                     else if (formatfound == FALSE && 
  686.                             (stype == WRT || stype == RD)) {
  687.                         incr_output(OL,"FMT=%s%s",
  688.                                     (isdigit(*car) == TRUE 
  689.                                      ? ltext(newlabel(car)+1)
  690.                                      : car), (*cddr == '\0' ? "" : ","));
  691.                         formatfound = TRUE;
  692.                     }
  693.                     else
  694.                         incr_output(OL,"%s%s",car,(*cddr == '\0' ? "" : ","));
  695.                 }
  696.             }
  697.             incr_output (OL,")");
  698.             if (part1 != NULL) {
  699.             incr_output (OL,"%s",part1->text);
  700.                 if (part2 != NULL)
  701.                     incr_output (OL,",%s",part2->text);
  702.             }
  703.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  704.                   root,root,ifpcount,root,root,ifpcount);
  705.             probptr->linenumber = source_line_number;
  706.             probptr->type = IOSTMT;
  707.             probptr = probptr->next = getprobnode();
  708.             ifpcount++;
  709.             break;
  710.         
  711.         case PRTNRD:
  712.  
  713. /* Print and Read statements without cilists have format specifiers that
  714.    have to be looked at.
  715. */
  716.             part1          = args[1];
  717.             part2          = args[2];
  718.             if (isdigit(*(args[0]->text)))
  719.                 incr_output (NL, "%s%s",args[3]->text,
  720.                     ltext(newlabel(args[0]->text)+1));
  721.             else
  722.                 incr_output (NL, "%s%s",args[3]->text, args[0]->text);
  723.  
  724.             if (part1 != NULL) {
  725.             incr_output (OL,"%s",part1->text);
  726.                 if (part2 != NULL)
  727.                     incr_output (OL,",%s",part2->text);
  728.             }
  729.             break;
  730.  
  731.     case FORMAT:
  732.  
  733. /* All labels are potential branch targets. Labels on format statments
  734.    are different and must be treated differently. They statement is marked
  735.    non-executable so it will receive special treatment by emitf77.
  736. */
  737.             executable_statement = FALSE;
  738.             incr_output (NL,"FORMAT(%s)",args[0]->text);
  739.             break;
  740.  
  741.         case DOLOOP:
  742.  
  743. /* Instrument a vanilla do-loop structure. The interesting count is the
  744.    number of times through the loop. In theory the number of times the 
  745.    loop has been entered is already recorded. There is a problem at the
  746.    bottom of the loop. Assume:
  747.  
  748.        DO 10 I=1,10
  749.        IF (Z) GO TO 10
  750.  10    J = J * 1 + 8 / K....    <- exact number of counts here difficult.
  751.        IF (X) GO TO 10
  752.  
  753.   A working transformation would be:
  754.  
  755.        DO 11 I=1,10
  756.        IF (Z) GO TO 12
  757.   12   J = J * 1 + 8 / K ....    <- count
  758.   11   CONTINUE
  759.        GO TO 13
  760.   10   J = J * 1 + 8 / K ....    <- count
  761.   13   CONTINUE
  762.        IF (X) GO TO 10
  763.  
  764.   with the two counts added to get a correct measure of the number of
  765.   times the line computing J is executed.
  766.  
  767.    The algorithm will be:
  768.         Look up new label
  769.         If this is the start of a loop, 
  770.             add label to lstack (stack of loop labels)
  771.             add 1 to number returned.
  772.         Else if this a termination point for a loop we are currently in
  773.             add 2 to the number returned.
  774.         Upon reaching the termination point, add the nightmare shown
  775.         just above.
  776.  
  777.   Update: added support for Do ... enddo. November 23, 1990.
  778.   Update: added support for Dowhile ... enddo, March 26, 1993.
  779. */
  780.  
  781. /* Add the new termination point to the labelstack and (possibly) to
  782.    the list of known labels.
  783. */
  784.             if (args[0] != (struct arg *) NULL) {
  785.                 push_lstack (newlabel(args[0]->text));
  786.                 strcpy (chtemp ,ltext(newlabel(args[0]->text)+1));
  787.                 incr_output (NL,
  788.                      "DO%s%s=%s,%s,%s",chtemp,
  789.                      args[1]->text, args[2]->text, args[3]->text,
  790.                      (args[4] == NULL ? "1" : args[4]->text));
  791.             }
  792.  
  793. /* No label to worry about with do...enddo
  794. */
  795.             else {
  796.                 incr_output (NL, "DO%s=%s,%s,%s",
  797.                      args[1]->text, args[2]->text, args[3]->text,
  798.                      (args[4] == NULL ? "1" : args[4]->text));
  799.             }
  800.             incr_output (NL, 
  801.                   "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  802.                   root,root,ifpcount,root,root,ifpcount);
  803.             probptr->linenumber = source_line_number;
  804.             probptr->type = DOLOOP;
  805.             probptr = probptr->next = getprobnode();
  806.             ifpcount+=1;
  807.             break;
  808.  
  809.         case DOWHILE:
  810.             incr_output (NL, "DOWHILE(%s)", args[0]->text);
  811.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  812.                   root,root,ifpcount,root,root,ifpcount);
  813.             probptr->linenumber = source_line_number;
  814.             probptr->type = DOWHILE;
  815.             probptr = probptr->next = getprobnode();
  816.             ifpcount+=1;
  817.             break;
  818.  
  819. /* Do something with assignment statements.
  820. */
  821.         case ASSIGN:
  822.             if (args[1] != NULL)
  823.                 incr_output (NL, "%s(%s)=%s",args[0]->text, args[1]->text,
  824.                          args[2]->text);
  825.             else
  826.                 incr_output (NL, "%s=%s",args[0]->text, args[2]->text);
  827.             break;
  828.  
  829. /* We need to be sure that the exit routine is called on the way out. All
  830.    stop statements are modified.
  831. */
  832.         case STOP:
  833.             incr_output (NL,"CALL%sXX",root);
  834.             if (args[0] != (struct arg *) NULL)
  835.                 incr_output (NL,"STOP%s", args[0]->text);
  836.             else
  837.                 incr_output (NL,"STOP");
  838.             break;
  839.  
  840. /* Do...endo loop termination needs a count to be taken after the loop
  841.    terminal
  842. */
  843.         case ENDDO: 
  844.  
  845.             incr_output (NL, "ENDDO");
  846.             incr_output (NL, "%sSS(%sOO+%d)=%sSS(%sOO+%d)+1",
  847.                   root,root,ifpcount,root,root,ifpcount);
  848.             probptr->linenumber = source_line_number;
  849.             probptr->type = ENDDO;
  850.             probptr = probptr->next = getprobnode();
  851.             ifpcount++;
  852.             break;
  853.         
  854.       case RETN:
  855.               if (args[0] != NULL)
  856.                   incr_output (NL, "RETURN%s",args[0]->text);
  857.               else
  858.                   incr_output (NL, "RETURN");
  859.               break;
  860.  
  861. /* This is a kludge until all of the possible source rules are implemented
  862.    in rules.h. Upon hitting the end, return NOMATCH to get out of the
  863.    program body loop. The 'args[0]' check is to unsure against other END
  864.    sorts of things... like 'END DO'.
  865. */
  866.         case ENDSTMT:
  867.             if (args[0] == (struct arg *) NULL)
  868.                 return (NOMATCH);
  869.           
  870. /* Look at the label if there is one. The label number produced in the
  871.    output may have to be adjusted according to the scheme for instrumenting
  872.    a doloop as discussed above.
  873. */
  874.         default:
  875.             stmt_buffer_empty = TRUE;           
  876.             incr_output (NL,"%s", ibufptr);
  877.     }
  878. }
  879. /*************************************************************************
  880.  i f p r o b _ e n d
  881.  ************************************************************************/
  882. ifprob_end()
  883. {
  884.     struct lablnode *local, *last;
  885.     inside_module = FALSE;
  886.     stmt_buffer_empty = TRUE;
  887.  
  888. /* Do other stuff:
  889. */
  890.     ifprob_postamble ();
  891.     emitf77 (NULL, "END");
  892.     if (ismain == TRUE)
  893.     ifprob_routines ();
  894.  
  895. /* Chain the remaining free label nodes onto the current list so that they'll
  896.    be reused.
  897. */
  898.     if (lstart != (struct lablnode *) NULL)  {
  899.          local = lstart;
  900.          while (local != (struct lablnode *) NULL) {
  901.              last  = local;
  902.              local = last->next;
  903.          }
  904.          last->next = lfree;
  905.     }
  906.  
  907. /* Create history file entry for the ifprob data to go into when the program 
  908.    is run.
  909. */
  910.     ifprob_history ();
  911.     ifpcount = 0;
  912. /*   dump_symtab();
  913. */
  914. }
  915.  
  916. /*************************************************************************
  917.  i f p r o b _ c l n p
  918.  ************************************************************************/
  919. ifprob_clnp()
  920.  
  921. /* Perform final cleanup before leaving the ifprobber.
  922. */
  923. {
  924.     if (inside_module == TRUE)
  925.     ifprob_end();
  926.  
  927. }
  928.