{[b+]}
{ NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE:

  Copyright 1980, 1981, 1984 by Oregon Software, Inc.
  All Rights Reserved.

  This computer program is the property of Oregon Software, Inc.
  of Portland, Oregon, U.S.A., and may be used
  and copied only as specifically permitted under written
  license agreement signed by Oregon Software, Inc.

  Whether this program is copied in whole or in part and whether this
  program is copied in original or in modified form, ALL COPIES OF THIS
  PROGRAM MUST DISPLAY THIS NOTICE OF COPYRIGHT AND OWNERSHIP IN FULL.

  Conversion Aid, for converting from Pascal-1 to Pascal-2
  Release version: 2.0J  Level: 3  Date: 24-Sep-1981 08:35:47
  Processor: PDP11
}

program convrs(input, output, source, result);

{ Processor to scan a Pascal 1.2 program and flag incompatibilities with
  Pascal 2 which will not be detected by the Pascal 2 compiler.

  The specific constructs detected are:

  1.  All embedded switches
  2.  Embedded macro code.
  3.  External procedure references.
  4.  External procedure definitions.
  5.  Use of the "Origin" feature.
  6.  Undiscriminated record variants.

  This is by no means a complete sample of all trouble spots,
  but it should catch most of the problems which the compiler won't
  catch.

  The command line syntax is: OUTPUT FILENAME = INPUT FILENAME.
  Default extension values are ".CVR" for output and ".PAS" for input.
}

procedure gmcr;external; {get RSX command line}

  label
    99; {exit label when eof encountered}

  const

    max_line_len = 132; {max length of an input line}
    max_id = 10; {max length of an identifier}

    ht = 9; {ord of tab character}

    blank_id = '          '; {a blank identifier}
    qvar = 'var       '; {reserved words}
    qend = 'end       ';
    qtype = 'type      ';
    qcase = 'case      ';
    qbegin = 'begin     ';
    qorigin = 'origin    ';
    qforward = 'forward   ';
    qfortran = 'fortran   ';
    qextern = 'external  ';
    qfunc = 'function  ';
    qproc = 'procedure ';

    file_name_len = 60; {max size of a file name}

    rt11 = true;{set true only if running on RT-11 system}
    rsts = false;{true only if running on RSTS system}
    rsx = false; {set true only if running on RSX system}

    rsxprompt = 'CON>'; {prompt to use if on RSX system}

    cmdlinelength = 132; { length of a command line }


  type

    file_name = packed array [1..file_name_len] of char;

    symbol = (procsy, funcsy, beginsy, externsy, forwardsy, typesy, varsy,
              casesy, endsy, originsy, fortransy, lpar, rpar, colon, ident,
              nonesy);

    symbol_set = set of symbol;

    identifier = packed array [1..max_id] of char;

    line_buffer = packed array [1..max_line_len] of char;

    message = (embed_switch, embed_code, extern_ref, origin_used,
               undesc_variant);

    message_set = set of message;

    cmdindex = 1..cmdlinelength; {pointer to chars in command line}

    cmdbuffer = packed array [cmdindex] of char; {command line buffer}


  var

    this_line: line_buffer; {line being read}
    line_len: 0..max_line_len; {chars read on this line}

    line_no: 0..maxint; {line number in file}

    current_file: file_name; {current file name}
    file_len: integer; {length of current file name}
    more_files: boolean; {there are more input files}
    endline: boolean; {end of current input line}

    source: text; {current source file}
    result: text; {result listing file}

    ch: char; {current char}
    sym: symbol; {current symbol}

    extern_count: integer; {switch counter for external procedures}

    {diagnostic data accumulated}

    messages_this_line: message_set; {messages applying to this line}
    messages: message_set; {all messages ever given}
    file_printed: boolean; {current file name already printed}

    cmdline: cmdbuffer; {actual command line read}
    cmdlength: cmdindex; {length of line being read in}

    fileline: cmdbuffer; {command line containing only files}
    nextf: cmdindex; {next character in fileline}
    dev_start, dev_end: 0..cmdlinelength; {start and end of current device}
    uic_start, uic_end: 0..cmdlinelength; {start and end of current uic}


  procedure getline(var line: cmdbuffer; {resulting command line}
                    var length: cmdindex {resulting command length} );

{ RT 11 procedure to get a command line no matter what its source.
}

    external;


  procedure exitst(status: integer {status for error on exit} );

{ Entrance to the library to exit with a status set to "status".
}
    external;


  procedure getcmdline;

    var
      i: integer; {induction var}


    begin {read the command into memory}
      if rsx then
        begin
gmcr;
        if input^ <> ' ' then
          begin
          repeat
            get(input)
          until (input^ = ' ');
          while not eoln and (input^ = ' ') do get(input);
          end;
        if input^ = ' ' then write(rsxprompt);
        if eoln then readln;
        end
      else if rsts then write('*');
      if rt11 then
        begin
        getline(cmdline, cmdlength);
        cmdlength := cmdlength + 1;
        end
      else
        begin
        cmdlength := 1;
        while not eoln do
          begin
          if cmdlength < cmdlinelength - 2 then
            begin
            read(input, cmdline[cmdlength]);
            cmdlength := cmdlength + 1;
            end
          else get(input);
          end;
        end;
      for i := cmdlength to cmdlinelength do cmdline[i] := ' ';
    end; {getcmdline}


  procedure scancmdline;

    var
      g, p: 0..cmdlinelength; {get and put pointers}
      c: char; {conversion buffer}


    begin {scan the command line, converting to upper case, and removing all
           except file names. This also sets qualifiers and checks file name
           syntax (at a low level, admittedly)}
      g := 1;
      p := 0;
      while g <= cmdlength do
        if cmdline[g] = '/' then
          begin
          g := g + 1;
          if cmdline[g] in ['e', 'E'] then extern_count := 1;
          while cmdline[g] in ['a'..'z', 'A'..'Z', '0'..'9'] do g := g + 1;
          end
        else if cmdline[g] in [' ', chr(ht)] then g := g + 1
        else
          begin
          c := cmdline[g];
          if c = '(' then c := '['
          else if c = ')' then c := ']'
          else if c in ['a'..'z'] then
            c := chr(ord(c) - ord('a') + ord('A'));
          p := p + 1;
          fileline[p] := c;
          g := g + 1;
          end;
      fileline[p + 1] := ' ';
      nextf := 1;
      dev_start := 2;
      dev_end := 1;
      uic_start := 2;
      uic_end := 1;
    end; {scancmdline}


  procedure next_file(var name: file_name; {next file name found}
                      var len: integer; {length of file name found}
                      var more: boolean {there are more files available} );

    var
      i: integer; {induction var}
      field_start: cmdindex; {start of an alphanumeric field}


    begin {Get the next input file from the command line}
      if fileline[nextf] in ['=', ','] then nextf := nextf + 1;
      field_start := nextf;
      while fileline[nextf] in ['A'..'Z', '0'..'9', '.', '$'] do
        nextf := nextf + 1;
      if fileline[nextf] = ':' then
        begin
        dev_start := field_start;
        field_start := cmdlinelength;
        dev_end := nextf;
        nextf := nextf + 1;
        end;
      if fileline[nextf] = ']' then
        begin
        uic_start := nextf;
        repeat
          nextf := nextf + 1;
        until fileline[nextf] = ']';
        uic_end := nextf;
        nextf := nextf + 1;
        end;
      if fileline[nextf] in ['A'..'Z', '.', '$', '0'..'9'] then
        begin
        field_start := nextf;
        while fileline[nextf] in ['A'..'Z', '.', '$', '0'..'9'] do
          nextf := nextf + 1;
        end;
      len := 0;
      for i := dev_start to dev_end do
        begin
        len := len + 1;
        name[len] := fileline[i];
        end;
      for i := uic_start to uic_end do
        begin
        len := len + 1;
        name[len] := fileline[i];
        end;
      for i := field_start to nextf - 1 do
        begin
        len := len + 1;
        name[len] := fileline[i];
        end;
      for i := len + 1 to file_name_len do name[i] := ' ';
      more := fileline[nextf] = ',';
      if not more then
        begin
        dev_end := dev_start - 1;
        uic_end := uic_start - 1;
        end;
    end;


  procedure initialize;


    begin
      messages_this_line := [];
      messages := [];
      file_printed := false;
      line_len := 0;
      line_no := 0;
      endline := false;
      extern_count := 0;

      getcmdline;
      scancmdline;
      next_file(current_file, file_len, more_files);
      rewrite(result, current_file, '.CVR');
      next_file(current_file, file_len, more_files);
      reset(source, current_file, '.PAS');

      writeln(result, 'Oregon Software Conversion Aid - Version 2.1D');
      writeln(result, cmdline: cmdlength);
      writeln(result);
    end; {initialize}


  procedure print_line;

    var
      this_msg: message; {induction var}


    begin
      line_no := line_no + 1;
      if messages_this_line <> [] then
        begin
        if not file_printed then
          begin
          writeln(result);
          writeln(result, 'File: ', current_file: file_len);
          writeln(result);
          file_printed := true;
          end;
        writeln(result, line_no: 6, ': ', this_line: line_len);
        for this_msg := embed_switch to undesc_variant do
          if this_msg in messages_this_line then
            begin
            write(result, ' *****  ');
            case this_msg of
              embed_switch: writeln(result, 'Pascal 1 embedded switches.');
              embed_code: writeln(result, 'Embedded macro code.');
              extern_ref:
                writeln(result,
                        'External procedure reference or definition.');
              origin_used: writeln(result, 'Origin''ed variable.');
              undesc_variant: writeln(result, 'Undescriminated variant.');
              end;
            end;
        messages := messages + messages_this_line;
        messages_this_line := [];
        end;
    end; {print_line}


  procedure mark_line(msg: message);


    begin {mark an error on the line}
      messages_this_line := messages_this_line + [msg];
    end; {mark_line}


  procedure next_ch;


    begin {Print the current input line if needed, then get the next
           character. If the current file has been exhausted, this procedure
           gets a new one from the command line. If all files have been
           exhausted, the routine aborts with a goto to label 99. As the line
           is read, it is saved in "this_line" for later printing if needed.}

      if endline then
        begin
        print_line;
        line_len := 0;
        endline := false;
        readln(source);
        if eof(source) then
          begin
          close(source);
          if more_files then next_file(current_file, file_len, more_files)
          else goto 99;
          reset(source, current_file, '.PAS');
          endline := false;
          line_no := 0;
          file_printed := false;
          end;
        end;
      if eoln(source) then
        begin
        endline := true;
        ch := ' ';
        end
      else
        begin
        read(source, ch);
        if line_len < max_line_len then
          begin
          line_len := line_len + 1;
          this_line[line_len] := ch;
          end;
        end;
    end; {next_ch}


  procedure next_sym;

    var
      done: boolean; {done with this scan}
      id: identifier; {id being built}
      id_char: 0..max_id; {characters read so far}
      end_ch: char; {end character for comment scan}


    procedure check_id;


      begin {see if the id is one of our few reserved words}
        sym := ident;
        case id_char of
          3:
            if id = qend then sym := endsy
            else if id = qvar then sym := varsy;
          4:
            if id = qtype then sym := typesy
            else if id = qcase then sym := casesy;
          5:
            if id = qbegin then sym := beginsy;
          6: if id = qorigin then sym := originsy;
          7:
            if id = qforward then sym := forwardsy
            else if id = qfortran then sym := fortransy;
          8:
            if id = qfunc then sym := funcsy
            else if id = qextern then sym := externsy;
          9: if id = qproc then sym := procsy;
          otherwise;
          end;
      end; {check_id}


    procedure switches;

      var
        opt_char: char; {switch option character just read}


      begin {scan pascal-1 switches}
        repeat
          next_ch;
          if ch in ['A', 'C', 'D', 'E', 'F', 'L', 'S', 'T', 'X'] then
            begin
            opt_char := ch;
            next_ch;
            if opt_char = 'E' then
              begin
              if ch = '-' then extern_count := extern_count - 1
              else extern_count := extern_count + 1;
              end
            else if opt_char = 'C' then mark_line(embed_code)
            else mark_line(embed_switch);
            next_ch;
            end;
        until ch <> ',';
      end; {switches}


    begin {Scan for the next interesting symbol, of which there are very few.}
      sym := nonesy;
      repeat
        if ch in ['A'..'Z', 'a'..'z'] then
          begin
          id_char := 0;
          id := blank_id;
          while ch in ['A'..'Z', 'a'..'z', '0'..'9'] do
            begin
            if id_char < max_id then
              begin
              id_char := id_char + 1;
              if ch in ['A'..'Z'] then
                id[id_char] := chr(ord(ch) - ord('A') + ord('a'))
              else id[id_char] := ch;
              end;
            next_ch;
            end;
          check_id;
          end
        else if ch = '''' then
          begin
          next_ch;
          repeat
            while ch <> '''' do next_ch;
            next_ch;
          until ch <> ''''
          end
        else if ch = '{' then
          begin
          next_ch;
          if ch = '$' then switches;
          while ch <> '}' do next_ch;
          next_ch;
          end
        else if ch in ['(', '/'] then
          begin
          if ch = '(' then end_ch := ')'
          else end_ch := '/';
          next_ch;
          if ch = '*' then
            begin
            next_ch;
            if ch = '$' then switches;
            while ch <> end_ch do
              begin
              while ch <> '*' do next_ch;
              next_ch;
              end;
            next_ch;
            end
          else if end_ch = ')' then sym := lpar;
          end
        else if ch = ')' then
          begin
          sym := rpar;
          next_ch;
          end
        else if ch = ':' then
          begin
          next_ch;
          if ch <> '=' then sym := colon
          end
        else next_ch;
      until sym <> nonesy;
    end; {next_sym}


  procedure skip_until(end_syms: symbol_set);


    begin {scan until a symbol in end_syms is found}
      while not (sym in end_syms) do next_sym;
    end;


  procedure scan_decl;


    begin {scan declarations}
      next_sym;
      repeat
        skip_until([procsy, funcsy, beginsy, casesy, originsy]);
        if sym = casesy then
          begin
          next_sym;
          next_sym;
          if sym <> colon then mark_line(undesc_variant);
          end
        else if sym = originsy then
          begin
          mark_line(origin_used);
          next_sym;
          end;
      until sym in [procsy, funcsy, beginsy];
    end; {scan_decl}


  procedure proc_header(level: integer);

    var
      paren_count: 0..maxint; {parenthesis level counter}


    begin {scan off a proc header at the level given specified}
      paren_count := 0;
      if (level = 1) and (extern_count > 0) then mark_line(extern_ref);
      next_sym;
      repeat
        next_sym;
        if sym = lpar then paren_count := paren_count + 1
        else if sym = rpar then paren_count := paren_count - 1;
      until paren_count = 0;
    end; {proc_header}


  procedure body;

    var
      begin_count: 0..maxint; {begin/case nesting level}


    begin {scan off a body}
      begin_count := 1;
      repeat
        next_sym;
        if sym in [beginsy, casesy] then begin_count := begin_count + 1
        else if sym = endsy then begin_count := begin_count - 1;
      until begin_count = 0;
    end; {body}


  procedure scan_program;

    var
      level: 0..maxint; {current procedure nesting level}


    begin {scan a program, looking for potential problems}
      level := 1;
      next_ch;
      next_sym;
      repeat
        skip_until([varsy, typesy, procsy, funcsy, beginsy, externsy,
                   forwardsy, fortransy]);
        case sym of
          varsy, typesy: scan_decl;
          procsy, funcsy:
            begin
            proc_header(level);
            level := level + 1;
            end;
          externsy:
            begin
            mark_line(extern_ref);
            level := level - 1;
            next_sym;
            end;
          fortransy, forwardsy:
            begin
            level := level - 1;
            next_sym;
            end;
          beginsy:
            begin
            body;
            level := level - 1;
            end;
          end;
      until level = 0;
    end; {scan_program}


  procedure print_summary;


    begin
      writeln(result);
      if extern_ref in messages then
        writeln(result, 'External routines used.');
      if messages * [embed_code, origin_used, undesc_variant] <> [] then
        writeln(result, 'Possible low-level coding techniques noted.');
      if messages * [extern_ref, embed_code, origin_used, undesc_variant] =
         [] then
        writeln(result,
                'No external routines or low-level techniques noted.');
    end; {print_summary}


  begin {convrs}
    initialize;
    scan_program;
  99:
    print_summary;
  end. {convrs}