% FILE PREPROFILE.WEB
%
% Here is TeX material that gets inserted after \input webmac

\def\hang{\hangindent 3em\indent\ignorespaces}
\font\ninerm=cmr9
\let\mc=\ninerm % medium caps for names like PASCAL
\def\PASCAL{{\mc PASCAL}}
\def\PA{\PASCAL}
\def\v{\.{\char'174}} % vertical (|) in typewriter font
\def\({} % kludge for alphabetizing certain module names

\def\title{PRE-PROFILE}
\def\topofcontents{\null
  \vfill
  \centerline{\ttitlefont PRE-PROFILE }
  \vskip 15pt
  \centerline{(Version 0, 1989)}
  \vfill}
\pageno=\contentspagenumber \advance\pageno by 1

% These macros for verbatim scanning are copied from MANMAC.TEX. But we cant
% use the vertical bar for a temporary escape character as WEAVE catches it.
% So we will use ! instead and hope for the best
\chardef\other=12
\def\ttverbatim{\begingroup
  \catcode`\\=\other  \catcode`\{=\other  \catcode`\}=\other  \catcode`\$=\other
  \catcode`\&=\other  \catcode`\#=\other  \catcode`\%=\other  \catcode`\~=\other
  \catcode`\_=\other  \catcode`\^=\other
  \obeyspaces \obeylines \tt}

\outer\def\begintt{$$\let\par=\endgraf \ttverbatim \parskip=0pt
  \catcode`\!=0 \rightskip-5pc \ttfinish}
{\catcode`\!=0 !catcode`!\=\other   % ! is temporary escape character
  !obeylines !obeyspaces    % end of line is active
  !gdef!ttfinish#1^^M#2\endtt{#1!vbox{#2}!endgroup$$}}

@* Introduction.

This is the Pre-Profile program, written by R.M.Damerell as a companion to
Knuth's Profile. This program is not copyright and may be freely distributed.
The purpose of this program is to generate count files for use with Profile.
Suppose that you have a Pascal program -- lets call it ``Snail''-- which runs
unbearably slowly. A profiler is a program intended to enable you to speed up
your Snail by determining which part of the code of Snail is using most of the
execution time. Knuth's profiler can only be used if you have a ``count''
file; this lists the number of times each statement in Snail was executed in a
trial run.

In order to use Pre-profile on VMS, you must tangle, compile and link it as
usual, then define it as a VMS ``foreign'' command, say: \begintt
     $prp :== $DISK:[DIRECTORY]PREPROFILE.EXE  \endtt
(you must specify both disk and directory). Then run Pre-profile by:\begintt
     $PRP SNAIL  \endtt
Then Pre-profile will expect to find a file called {\tt snail.pas}. It reads
it and writes {\tt snail\_count.pas}. If all goes well, this file is a valid
\PA\ program that will do everything that {\tt snail} does and also generate
a count file called {\tt snail.cou}. Then you can (in theory) run Profile by
\begintt
$PROFILE SNAIL \endtt
Of course this will be entirely different on any other system; but getting
Profile running on another machine is a massive task anyway. Much of the code
of Pre-profile is simply copied from Profile.

@d banner=='This is PRE_PROFILE, Version 0, 1989.'

@P program PREPROFILE(target, monitor, input, output);
  const @<Constants in the outer block@> @/
  type @<Types in the outer block@> @/
  var @<Globals in the outer block@> @/
  @<Forward declarations@> @/
  @<Error handling procedures@> @/
  @<Low level procedures@>
  procedure initialize;
  var @!i,@!d:integer; {all-purpose indices}
  begin @<Set initial values@>;
  @<Open files@>
  end;

@ Labels are given symbolic names by the following definitions.

@d exit=10 {go here to leave a procedure}
@d found = 13

@ Here are some macros for common programming idioms.

@d incr(#) == #:=#+1 {increase a variable by unity}
@d decr(#) == #:=#-1 {decrease a variable by unity}
@d do_nothing == {empty statement}
@d return == goto exit {terminate a procedure call}
@d loop == @+ while true do@+ {repeat over and over until a |goto| happens}
@f return == nil

@ We assume that |case| statements may include a default case that applies
if no matching label is found. Thus, we shall use constructions like
@^system dependencies@>
$$\vbox{\halign{#\hfil\cr
|case x of|\cr
1: $\langle\,$code for $x=1\,\rangle$;\cr
3: $\langle\,$code for $x=3\,\rangle$;\cr
|othercases| $\langle\,$code for |x<>1| and |x<>3|$\,\rangle$\cr
|endcases|\cr}}$$
since most \PASCAL\ compilers have plugged this hole in the language by
incorporating some sort of default mechanism. For example, the compiler
used to develop \.{WEB} and \TeX\ allows `|others|:' as a default label,
and other \PASCAL s allow syntaxes like `\ignorespaces|else|\unskip' or
`\\{otherwise}' or `\\{otherwise}:', etc. The definitions of |othercases|
and |endcases| should be changed to agree with local conventions.
(Of course, if no default mechanism is available, the |case| statements of
this program must be extended by listing all remaining cases.)

When the \PASCAL\ source program being processed by \.{PROFILE} has
default cases, we assume below that the default case is labeled with
some recognizable keyword, and that the |count_file| contains a count
for this label just like any other.

@d othercases == otherwise {default for cases not listed explicitly}
@d endcases == @+end {follows the default case in an extended |case| statement}
@f othercases == else
@f endcases == end

@* Character strings.

In this section I have tried to provide some tolerable string-handling
facilities in despite of the restrictions of \PASCAL. Most \.{WEB} programs
convert their input to an internal seven-bit code that is essentially standard
ASCII, the ``American Standard Code for Information Interchange.''  The
conversion is done immediately when each character is read in. Conversely,
characters are converted from ASCII to the user's external representation just
before they are output. RMD: I have deleted all this, as in CRUDETYPE.

@d zchr( #) == chr( #)
@d zord( #) == ord( #)
@d min_halfword==0
@d max_halfword==65535
@d string_length = 100 { a guess of course}
@d max_byte = 255 {Valid on VMS}

@<Types...@>=
  byte = 0..max_byte ;
  ASCII_code = 0..max_byte ;
  halfword=min_halfword..max_halfword;
  s_ptr = 0..string_length ;
  s_dat = packed array[ s_ptr] of  ASCII_code;
  string= packed record
    len: byte;
    data: s_dat ;
  end ;

@ |@!blank| is used for initialising strings. It should not be altered
anywhere but here.

@<Set init...@>=
  blank.len := 0 ;
  for i := 1 to string_length do
  blank.data[i] := " " ;

@ @<Glob...@>=
  blank: string ;

@* Opening files.
The input and output conventions of this program have been copied from those
of \.{WEAVE} and \.{TANGLE}.  Therefore people who need to make
modifications should already know how to do it. Terminal output is done by
writing on file |term_out|, which is assumed to consist of characters of type
|text_char|.
The |update_terminal| procedure is called when we want
to make sure that everything we have output to the terminal so far has
actually left the computer's internal buffers and been sent.
@^system dependencies@>

@d term_out == output
@d print(#)==write(term_out,#) {`|print|' means write on the terminal}
@d print_ln(#)==write_ln(term_out,#) {`|print|' and then start new line}
@d new_line==write_ln(term_out) {start new line}
@d print_nl(#)==  {print information starting on a new line}
  begin new_line; print(#);
  end
@d send( #) == write_ln( monitor, #)
@d update_terminal == do_nothing
   {VMS Pascal does this automatically}                  

@ The main input comes from |target|, as explained earlier, and output goes to
|monitor|.

@d text_file == text

@<Globals...@>=
  target,monitor: text_file ;
  file_name, count_file_name, mon_file_name :  varying[100] of char;
  s: integer;  {status after an attempted |open|}

@ The following code opens these files. In VMS, the best way to do this is to
fetch a ``command line'', which may contain the input file name. If this
fails, we ask again on the terminal.
@^system dependencies@>

@d VAX_immed==@= %immed @>
@d VAX_descr==@= %descr @>
@d VAX_ref==@= %ref @>
@d VAX_foreign == @= lib$get_foreign@>
@d VAX_continue == @=continue@>
@d get_set == begin line := 0; loc := 1 ; buf_len := 0 ; end;

@<Forw...@>=
 function VAX_foreign(
  VAX_descr cmdlin:[volatile] varying[nnn] of char
  := VAX_immed 0;
  VAX_descr prompt:[volatile] varying[mmm] of char
  := VAX_immed 0;
  var len : [volatile] halfword := VAX_immed 0;
  var flag : [volatile] integer := VAX_immed 0)
    :integer; extern;

@ @<Open files@>=
  VAX_foreign(file_name,,,);
  repeat
    open( target, file_name, old,default := '*.PAS',
      error:= VAX_continue) ;
    s := status( target);
    if s=0 then reset( target, error:=  VAX_continue) ;
    s := status( target);
    if s <> 0 then begin
      write_ln ( term_out,
        'OPEN failed for PASCAL file, try a new file name?') ;
      read_ln( input, file_name) ;
    end;
  until s = 0 ;
  writev( count_file_name , file_name, '.COU') ;
  writev( mon_file_name, file_name, '_COUNT.PAS') ;
  open( monitor, mon_file_name, new) ;
  rewrite( monitor);

@* Reporting errors to the user.

A global variable called |history| will contain one of four values
at the end of every run: |spotless| means that no unusual messages were
printed; |harmless_message| means that a message of possible interest
was printed but no serious errors were detected; |error_message| means that
at least one error was found; |fatal_message| means that the program
terminated abnormally. The value of |history| does not influence the
behavior of the program; it is simply computed for the convenience
of systems that might want to use such information.

@d spotless=0
@d harmless_message=1
@d error_message=2
@d fatal_message=3
@#
@d mark_harmless==@t@>@+if history=spotless then history:=harmless_message
@d mark_error==history:=error_message
@d mark_fatal==history:=fatal_message

@<Glob...@>=@!history:spotless..fatal_message; {how bad was this run?}

@ @<Set init...@>=history:=spotless;

@ The command `|err_print('! Error message')|' will report a syntax error to
the user, by printing the error message at the beginning of a new line and
then giving an indication of where the error was spotted in the source file.
The actual error indications are provided by a procedure called |error|. Since
\.{PROFILE} is supposedly working from a running \PASCAL\ program, its error
messages have not been jazzed up for super error recovery. The main purpose of
the many possible calls to |err_print| in this program is merely to give some
assurance that \.{PROFILE} knows what it is doing. If a fatal error occurs,
then the program will force a crash. With the VMS debugger, you can then
interrogate variables, etc. An overflow stop occurs if \.{PROFILE}'s tables
aren't large enough. The next procedure is a primitive debugging aid.  All
internally detected errors call |pause|. Then they can be caught by a
suitable debugger command.

@<Error handling...@>=
  procedure pause; begin end;@#

  procedure error; {prints location of error message}
  var k,l: byte ; {indices into |buffer|}
  begin @< Print error location based on input buffer@> ;
    update_terminal; mark_error; pause;
  end;

@ The error locations can be indicated by using the global variables |loc| and
|line|, which tell respectively the first unlooked-at position in |buffer| and
the current line number. This routine should be modified on systems whose
standard text editor has special line-numbering conventions.
 @^system dependencies@>

@<Print error location based on input buffer@>=
  begin print('. (');
    print_ln('l.', line:1, ')');
    if loc>=buffer.len then l:=buffer.len else l:=loc-1;
    for k:= 1 to l do print(zchr(buffer.data[k]));
    new_line;
    for k:=1 to l do print(' '); {space out the next line}
    for k:=l+1 to buffer.len do print(zchr(buffer.data[k]));
    {print the part not yet read}
    new_line ; {this space separates the message from future dots}
  end

@ I chose the square root of -1 as this does not figure prominently in
\TeX-related programs.
@^square root@>

@d err_print(#)== begin new_line; print(#); error; end
@d fatal_error(#)==begin new_line; print(#); crash; end
@d overflow(#)==fatal_error('! Sorry, ',#,' capacity exceeded')
  @.Sorry, x capacity exceeded@>

@<Error handling...@>=
procedure crash;
var u: real;
begin
  u := -1 ;
  error;
  mark_fatal ;
  u := sqrt(u) ;
end;

@ @d push == incr( depth);
  l_stack[ depth] := line ;
  loc_stack[ depth] := loc ;
@d pop == decr( depth);

@<Glob...@>= l_stack: array[0..1000] of integer ;
loc_stack: array[0..1000] of integer ;
depth: integer;

@ @<Set init...@>= depth := 0 ;

@* Low-level input and output.

@ The |input_ln| procedure brings the next line of input into |buffer| and
returns the value |true|, unless the file has already been entirely read, in
which case it returns |false|.

@<Low level procedures@>=
  function input_ln(var f:text_file):boolean;
  {inputs a line or returns |false|}
  var mm:ASCII_code; c:char;
  begin buffer := blank ;
    if eof(f) then input_ln:=false
    else  begin while not eoln(f) do
      begin c:=f^; get(f); mm := zord(c) ;
        if mm = @'11 then mm := " " ;  {convert tab to space}
        incr(buffer.len);
        buffer.data[buffer.len]:= mm ;
        if buffer.len>=string_length -1 then
        begin while not eoln(f) do get(f);
          err_print('!Input line too long');
        end;
      end;
      read_ln(f);
      input_ln:=true;
      incr(buffer.len); {Add a space pad at end}
    end;
  end;
    @.Input line too long@>@.Bad character...@>

@ Output is held in a string called |@!out_buf|. The |flush_out| procedure
prints it if it is nonempty. It also counts lines of output.

@<Low level procedures@>=
  procedure flush_out;
  var p: integer ;
  begin
    if out_buf.len > 0 then begin
      for p := 1 to out_buf.len do
      write( monitor, zchr( out_buf.data[p]) ) ;
      write_ln( monitor) ;
      out_buf := blank ;
      incr( out_line) ;
      if out_line mod 100 = 0 then
      begin print('.');
        if out_line mod 500 = 0 then print(out_line:1);
        update_terminal; {progress report}
      end ;
    end;
  end;

@ @<Glob...@>=
  buffer: string; {Input buffer}
  out_buf: string ;
  out_line: integer ;

@ @<Set init...@>=
  line:=0;
  buffer := blank ;
  out_line := 0 ;

@ The following parameters are set big enough to handle \TeX, so they
should be sufficient for most applications of \.{PROFILE}.

@<Constants...@>=
  @!line_length=70; {lines of unannotated \PASCAL\ output}

@* Initializing the table of reserved words.

The reserved words of \PASCAL\ (e.g., `\&{begin}') are given distinctive code
values (e.g., `|begin_code|').

@d begin_code =1
@d case_code = begin_code +1
@d end_code = case_code +1
@d do_code = end_code +1
@d else_code = do_code +1
@d extern_code = else_code +1
@d for_code = extern_code +1
@d forward_code = for_code +1
@d goto_code = forward_code +1
@d if_code = goto_code +1
@d other_case = if_code +1
@d of_code = other_case + 1
@d program_code = of_code +1
@d repeat_code = program_code +1
@d then_code = repeat_code +1
@d type_code = then_code +1
@d until_code = type_code +1
@d with_code = until_code +1
@d while_code = with_code +1
@d strong_word = while_code
@#
@d var_code = while_code +1
@d function_code = var_code +1
@d procedure_code = function_code +1

@d max_word = procedure_code

@d semicolon = procedure_code + 1
@d colon = semicolon + 1
@d bra = colon + 1
@d ket = bra + 1
@d c_arr_code = ket + 1
@d c_ind_code = c_arr_code + 1
@d c_fil_code = c_ind_code + 1
@d number = c_fil_code + 1
@d other_id = number + 1
@d simple = other_id + 1

@d max_id = other_id
@#
@d row_len = 60

@<Set up all the reserved words@>=
  next_id := 1 ;
  reserve( 'begin case end do else extern for forward goto if otherwise ' );
  reserve( 'of program repeat then type until with while                ' );
  reserve( ' var function procedure                                     ' );
  {Now clean up afterwards, as follows:}
  buffer:= blank ; out_buf := blank ;
  loc := 0 ; token := 0 ;

@ @P   procedure get_next; forward; @#
    procedure reserve( row: words) ;
    var i, n :integer;
    begin
      buffer := blank ;
      for i := 1 to row_len do
      buffer.data[i] := zord( row[i] ) ;
      buffer.len := row_len + 1;
      buffer.data[row_len + 1 ] := ";" ;
      loc := 0; next ;
      token := 1 ;
      get_next;
      repeat
        n := loc - token ;
        for i := 1 to n do id[next_id, i] := buffer.data[ token + i - 1] ;
        for i := n + 1 to max_id_len do id[next_id, i] := " "  ;
        id_len[next_id ] := n ;
        token := loc ;
        incr( next_id ) ;
        get_next;
      until cur_code <> other_id ;
    end;

@ @<Types...@>= words= packed array[1..row_len] of char ;

@ @<Globals...@>=
  @!id: array [1..max_id, 1..max_id_len] of ASCII_code ;
  @!id_len: array [1..max_id] of integer ;
  @!next_id: integer ;

@ @<Const...@>= max_id_len = 10 ;

@ @<Set init...@>=
  for i := 1 to max_id do begin
    id_len[i] := 0 ;
    for d := i to max_id_len do id[i, d] := 0;
  end;

@* Getting the next token.

The parsing routines of Pre-profile are simplified versions of those of
Profile. They can be simplified because Pre-profile is interested only in the
flow of control in the |target| program. So any material below the level of a
\PA\ simple statement merely gets copied to the output. A ``top down'' or
``recursive descent'' parsing strategy is used, in which the program has
looked ahead one token in the input. A token is a special character like
`\.+'; or a special pair of characters like `\.{<=}'; or a reserved word like
`\.{ARRAY}'; or an identifier; or a numeric constant; or a string constant.
Furthermore a token may be preceded by any number of blanks and/or comments
enclosed in braces; blanks are removed, but the comments are considered to be
part of the token.

Whenever a token is acceptable to the syntax, that token is swallowed (never
to be put back), and the program looks ahead for another token. This
elementary lookahead is done by the |get_next| routine. Just before it does
the lookahead, it copies the previous token to the output.

@p procedure copy_last_token ;
var cur_char: ASCII_code ;
leng, p: integer ;
begin
  leng := loc - token ;
  if leng > 0  then begin
    if leng + out_buf.len > line_length then flush_out
    else @<Do we need a space? @> ;
    for p := 1 to leng do
    out_buf.data[ out_buf.len + p] := buffer.data[token + p - 1] ;
    out_buf.len := out_buf.len + leng ;
    token := loc ;
  end;
end;

@ We must insert a space between two identifiers or numbers:

@<Do we need a space? @>=
  begin
    cur_char := out_buf.data[out_buf.len] ;
    if letter or digit then begin
      cur_char := buffer.data[token] ;
      if letter or digit then incr( out_buf.len);
    end;
  end

@ These global variables help |get_next| control the low-level activities
associated with taking characters out of the input buffer:

@<Glob...@>=
  @!line:integer; {the number of the current line in the current file}
  @!loc:s_ptr; {the next character position to be read from the buffer}
  @!token:s_ptr; {Where the last previous token started}
  @!cur_char: ASCII_code ;
  @!cur_code: byte; {|id_code| or other code in current lookahead token}

@ The |get_line| procedure is called when |loc>buffer.len|; it puts the next
line of input into the buffer and updates the other variables appropriately. A
space is placed at the right end of the line. It also calls |flush_out|.

@d next == incr( loc) ; cur_char := buffer.data[ loc]

@<Low level procedures@>=
  procedure get_line; {inputs the next line}
  begin flush_out;
    incr(line);
    if not input_ln( target) then
    fatal_error('Premature end of PASCAL file');
    loc:=0; next; token := 1 ;
  end;
  @.Premature end...@>

@ Here now is the program for |get_next|. Remember that a call of |get_next|
means, essentially, ``I accept the previous token. Look ahead for another,
because I will want to look at it later.''

@d unknown = 125 {any impossible value}
@d upper == ( ( cur_char >= "A") and ( cur_char <= "Z" ))
@d lower == ( ( cur_char >= "a") and ( cur_char <= "z" ))
@d letter ==
  ( upper or lower or ( cur_char = "_") or ( cur_char = "$" )  )
@d digit ==  ( ( cur_char >= "0") and ( cur_char <= "9" ))
@d eat( #) == while ( # ) do begin next; end
@d eat_low( #) ==
  while # do begin
    if upper then buffer.data[ loc] :=
    buffer.data[ loc] + "a" - "A" ;
    next; end 
@d set_code(#)==begin cur_code:=#; next; end
@d compress(#)==begin next; next; cur_code:=#; end

@P procedure get_next;
  label found ;
  var n, k, leng : s_ptr;
  begin copy_last_token ;
    cur_code := unknown ;
    while cur_code = unknown do begin
      if loc > buffer.len then get_line;
      token := loc ;
      if letter then @<Get an identifier or reserved word @>
      else if digit then @<Get a number @>
      else case cur_char of
      "'": @<Get a string @>;
      "{": get_comment ;
      @<Translate a special character, compressing two-symbol
        combinations like ``\.{<=}'' into a single symbol @>;                     
      0," ",@'11: begin next; end ; {ignore nulls, spaces, and tabs}
      othercases set_code( simple) ;
      endcases;
    end;
  end;

@ @<Translate a special character...@>=
  ";":set_code(semicolon);
  "(":if buffer.data[loc+1] = "*" then get_comment else set_code(bra);
  ")":set_code(ket);
  ":":if buffer.data[loc+1]="="
  then compress(simple)@+else set_code(colon);
  "<",">":if ( buffer.data[loc+1]="=") or ( buffer.data[loc+1]=">")
  then compress(simple)@+else set_code(simple);
  ".":if buffer.data[loc+1]="."
  then compress(simple)@+else set_code(simple)

@ @<Get an identifier or reserved word@>=
  begin
    eat_low( letter or digit);
    leng := loc - token ;
    cur_code := other_id ;
    for n := 1 to max_id do
    @<If token equals |id[n]|, set |cur_code = n| and |goto found| @>;                     
    found: end

@ @<If token...@>=
  if leng = id_len[n] then begin
    k := 1 ;
    while ( k <= leng) and ( id[ n, k] = buffer.data[ k-1+token])
    do incr( k) ;
    if k > leng then begin
      cur_code := n ; goto found;
    end;
  end 

@ Inside a string, the quote char. is represented by 2 consecutive quotes. We
can treat this as a set of strings without embedded quotes, concatenated.

@d quote == ( cur_char = "'" )

@<Get a string@>=
  begin
    buffer.data[ buffer.len+1] := "'" ;
    while quote do begin
      next ;
      eat( not quote);
      if loc > buffer.len then
        err_print('! String constant didn''t end');
      next;
    end;
    cur_code:=simple;
  end;
    @. String constant...@>

@ @<Get a number@>=
  begin cur_code := number;
    eat( digit ) ;
    if ( cur_char = ".") and ( buffer.data[loc+1]<>"." ) then
    begin cur_code:=simple ;
      next;
      eat( digit) ;
    end;
    if ( cur_char ="E") or ( cur_char ="e") then
    begin cur_code:=simple ;
      next ;
      if ( cur_char = "-" ) or ( cur_char = "+" ) then
      begin next; end;
      eat( digit) ;
    end;
  end

@ @<Low level procedures@>=
  procedure get_comment ;
  var brace:boolean ;
  begin
    brace := ( cur_char= "{" ) ;
    @<Check for \.{\{\^\}} comment: print message if this is found@>;
    repeat next;
      if loc > buffer.len then get_line ;
    until ( brace and ( cur_char = "}")) or
    ( not brace) and ( cur_char = "*" ) and ( buffer.data[loc+1] = ")" ) ;
    if not brace then incr( loc) ;
    next;
    token := loc ;
  end ;

@ @<Check for...@>=
  if ( brace and ( buffer.data[loc+1]="^") and ( buffer.data[loc+2]="}") )
  or ( not brace and ( buffer.data[loc+2]="^") and ( buffer.data[loc+3]="*")
    and ( buffer.data[loc+4]=")") )
  then err_print( 'Black hole comment, PREPROFILE cannot handle this') ;
    @.Black hole@>

@ @P
  procedure copy_ket;
  begin
    push;
    while cur_code <> ket do begin
      get_next;
      if cur_code = bra then copy_ket;
      if cur_code <= strong_word then
      err_print( 'Word out of context inside brackets' );
    end;
    get_next; pop;
  end;
    @.Word out of context @>

@ @P
  procedure copy ;
  begin push; get_next;
    while cur_code >= bra do begin
      if cur_code = bra then copy_ket
      else if cur_code = ket then begin
        err_print( 'Too many KETs' );
        get_next;
      end
      else get_next;
    end;
    pop;
  end;
    @.Too many KETs @>

@ When we need to swallow a semicolon, |get_semi| does the trick.

@P procedure get_semi ;
  begin if cur_code<>semicolon then
    begin err_print('! spurious stuff before the semicolon is being skipped');
      repeat get_next;
      until cur_code=semicolon;
    end;
    get_next;
  end;

@ The most common error message that occurs in typical top-down parsing
routines is the following.

@d expected(#)==err_print('! "',#,'" was expected')

@* Statements.

The next procedure is |get_statement|. Basically, this is just a multiway
switch between different kinds of \PASCAL\ statements. Here we must consider
the overall purpose of Pre-Profile. The |target| program has to be altered to
generate a count file. At each point where Profile will expect a count,
Pre-profile must insert a statement to step a counter. So in |get_statement|,
|@!count_it| asserts that the current statement has to be counted, and
|@!plant_count| will actually do the insertion. But we must be careful because
if we just do a |plant_count|, we get nonsense like this:

\begintt
if A then B else C ;   \endtt
gets translated into \begintt
if A then incr(counter); B else incr(counter); C ; \endtt
So in general, B and C must be enclosed in |begin|---|end| brackets.

@p procedure get_statement ( count_it:  boolean) ;
begin push ;
  @<Deal with many types of statement@>
  pop;
end ;

@ If there is already a |begin|, we need not insert |begin|--|end| to enclose
a count.

@<Deal with many types of statement@>=
  if (cur_code = begin_code) then
  @<Process a compound statement@>
  else if count_it then begin
    flush_out; send( 'begin ' ); plant_count( true) ;
    get_statement( false) ;
    flush_out; send( 'end') ;
  end

@ @< Process a compound statement@>=
  begin get_next;
    if count_it then plant_count( true) ;
    repeat get_statement( false);
      if cur_code <> end_code then get_semi ;
    until cur_code=end_code ;
    get_next;
  end

@ @<Deal with many types of statement@>=
  else if (cur_code = semicolon) or (cur_code =end_code) then do_nothing
    {an empty statement}
  else
  case cur_code of
    number:  @< Process a labelled statement@> ;
    other_id:  copy ;   {assignment or procedure call}
    repeat_code: @<Process a repeat statement@> ;
    if_code: @< Process an if statement@> ;
    case_code: @< Process a case statement@> ;
    for_code, while_code: @< Process a for statement@> ;
    goto_code: @< Process a go to statement@> ;
    with_code: @< Process a with statement@> ;
    othercases begin expected( 'statement') ; get_next; end;
  endcases ;

@ @<Process a repeat statement@>=
  begin get_next;
    plant_count( true) ;
    while cur_code <> until_code do begin
      get_statement( false);
      if cur_code <> until_code then get_semi ;
    end ;
    copy;
  end

@ @<Process a labelled statement@>=
  begin get_next;
    if cur_code<>colon then expected(':')@+else get_next;
    get_statement( true) ;
  end

@ @<Process an if statement@>=
  begin copy;
    if cur_code<>then_code then expected('then')@+else get_next;
    if ( cur_code<>end_code)
    and ( cur_code<>semicolon)
    and ( cur_code<>else_code)
    and ( cur_code<>until_code) then {controlled statement is nonempty}
    get_statement( true)
    else plant_count( false);
    if cur_code=else_code then
    begin  get_next; get_statement( true); end;
  end ;

@ @<Process a case statement@>=
  begin copy;
    if cur_code<>of_code then expected('of')@+else get_next;
    while ( cur_code = number) or (cur_code = other_id) or
    (cur_code = other_case) do
    begin
      while (cur_code <> other_case) and (cur_code <> colon)
      do copy ;
      get_next;
      get_statement( true);
      while cur_code = semicolon do get_next;
    end;
    if cur_code<>end_code then expected('end')@+else get_next;
  end

@ @<Process a for statement@>=
  begin copy;
    if cur_code<>do_code then expected('do')@+else get_next;
    get_statement( true);
  end

@ @<Process a go to statement@>=
  begin get_next;
    if cur_code<>number then expected('label')@+else get_next;
  end

@ @<Process a with statement@>=
  begin copy;
    if cur_code<>do_code then expected('do')@+else get_next;
    get_statement( false);
  end

@* Declarations.

The scanning process reaches its glorious heights in the climactic |get_block|
procedure. Here we must intervene at several places to declare extra
variables, initialise them, and eventually write all the accumulated counts
onto the countfile. But this only happens in the outermost block of |target|.
When |get_block| starts, we have just read the word |procedure| or whatever
that introduces it. |@!top| asserts we are in the outermost block.

One problem not properly tackled is the extra variables must not clash with
the original variables of |target|. As a temporary hack, I gave them unusual
names. The modified |target| uses these names for: the array of counts; a
pointer into this array; and the file variable by which it will refer to the
countfile.

@d nam_len = 9  {The next 3 names must be this length}
@d count_array == 'ZWQQXHWQZM'
@d count_index == 'ZWQQXHWQZR'
@d count_var   == 'ZWQQXHWQZQ'
@d check == count_array, '[', max_counts:1, ']'

@P procedure get_block( top:boolean) ;
var want_vars: boolean ;
begin push;
  want_vars := top ;
  @<Run through the header@>
  if cur_code<>semicolon then expected(';')@+else get_next;
  if ( cur_code = forward_code) or ( cur_code = extern_code)
  then begin get_next; get_next; end
  else begin
    while cur_code <> begin_code do
    @<Get a declaration@> ;
    if top then @<Handle the outermost statement@>
    else begin
      get_statement( true) ;
      get_next;
    end ;
  end;
  pop;
end;

@ I assume here that the program has some global variables.

@<Get a dec...@>=
  begin
    if (cur_code = var_code) and want_vars then
    @<Declare extra variables@>
    else if ( cur_code = procedure_code) or ( cur_code = function_code)
    then get_block( false)
    else copy ;
  end

@ In the program header, declare the file variable.

@<Run through...@>=
  get_next ; get_next ;
  if top and ( cur_code = bra) then begin
    get_next;
    flush_out;
    send ( count_var, ', ' ) ;
    copy_ket ;
  end
  else if top then begin
    flush_out;
    send ( ' ( ', count_var, ') ' );
  end
  else if cur_code = bra then copy_ket ;
  if cur_code = colon then copy;

@ @<Declare extra...@>=
  begin get_next; flush_out ;
    want_vars := false ;
    send ( count_var, ' : text ; ' ) ;
    send ( count_array, ' : array [1..', 10000:1, '] of integer ; ') ;
    send ( count_index, ' : integer ; ') ;
  end

@ When we get here, we have just seen the `|begin|' of the main program. First
pass it through, then initialise the counters...

@<Handle the outermost statement@>=
  begin
    get_next ;
    flush_out ;
    send( 'for ', count_index , ' := 1 to ', 10000:1, ' do ') ;
    send( count_array, ' [', count_index, '] := 0 ; ' ) ;

@ Then actually read the program...

@<Handle the outermost statement@>=
  plant_count( true) ;
  repeat get_statement( false);
    if cur_code <> end_code then get_semi ;
  until cur_code=end_code ;

@ Now we come to the heavy stuff; Take a set of statements that will generate
the count file and write a sort of ``meta-program'' that will insert these
into |target|.

@<Handle the outermost statement@>=
  flush_out ;
  send( ' ; open( ', count_var, ', ''', count_file_name, ''' , new );' ) ;
  send( ' rewrite ( ', count_var, ' ) ; ' ) ;
  send( 'for ', count_index , ' := 1 to ', ( max_counts-1 ):1, ' do ') ;
  send( 'writeln (', count_var, ', ', count_array ,
    ' [', count_index, ']:1 ) ; ' ) ;
  send( 'writeln (', count_var, ', -1:1 );' ) ;
  send( 'close( ', count_var, '); ') ;
  get_next ;
end

@ At every point in |target| where Profile will expect to read a count, this
procedure inserts one. |semi| asserts that a semicolon is needed after the
count (i.e. not before an ``|else|''.)

@<Low level procedures@>=
  procedure plant_count( semi: boolean);
  begin
    flush_out ;
    send( check, ':= ', check, '+1' ) ;
    if semi then send( ';') ;
    incr( max_counts) ;
  end;

@ @<Glob...@>= max_counts: integer;

@ @<Set init...@>= max_counts := 1 ;

@* The program.
    Now there's only one thing left to do, namely to parse an entire
\PASCAL\ program (meanwhile doing all the profiling). This is where
\.{PROFILE} itself begins and ends.

@P begin initialize; @<Set up all...@>;
    print_ln(banner); {print a ``banner line''}
    get_next; {get the first token}
    if cur_code<>program_code then expected('program') ;
    get_block( true); {this is where most of the work is done}
    if cur_char <> "." then expected('.');
    flush_out ;
    send ( '.' ) ;
    {if all went well, that's the `\&{end.}' of the program}
    @<Print the job |history|@>;
end.

@ Some implementations may wish to pass the |history| value to the
operating system so that it can be used to govern whether or not other
programs are started. Here we simply report the history to the user.
@^system dependencies@>

@< Print the job |history|@>=
  case history of
  spotless: print_nl('(No errors were found.)');
  harmless_message: print_nl('(Did you see the warning message above?)');
  error_message: print_nl('(Pardon me, but I think I spotted something wrong.)');
  fatal_message: print_nl('(That was a fatal error, my friend.)');
end {there are no other cases}

@* System-dependent changes.
This module should be replaced, if necessary, by changes to the program
that are necessary to make \.{PROFILE} work at a particular installation.
It is usually best to design your change file so that all changes to
previous modules preserve the module numbering; then everybody's version
will be consistent with the printed program. More extensive changes,
which introduce new modules, can be inserted here; then only the index
itself will get a new module number.
@^system dependencies@>

@* Index.
Here is a cross-reference table for the \.{PROFILE} processor.  All
sections in which an identifier is used are listed with that identifier,
except that reserved words are indexed only in unusual cases.  Underlined
entries correspond to where the identifier was declared. Error messages
and a few other things like ``system dependencies'' are indexed here too.


@z
%
% ========================= END OF FILE =============================