(*$S- ;Turn off messages on non-standard PASCAL *)

PROGRAM Header_stripper(OUTPUT,SOURCE,HEADERS);

{+ HDRSTRIPR

 This program is used to strip the header comments from a source text file.
 The format of the HDRSTRIPR command line is:

    $ HDRSTRIPR  input_file

 where input_file is the name of the source text file to be read.  There
 is no default file type assumed for the input_file.  By default, the 
 output file produced has the same file name as the input file and has
 file type .TXT (or .HLP if /HELP is selected).

2 Qualifiers
/OUTPUT=output_file

 Defines the output filespec. The default is to write the output
 file on the current device and directory with the filename from the
 input_file and a file type of ".TXT" (unless /HELP is selected,
 then the file type is ".HLP"). 

/SELECT=type (D=ALL)

 This qualifier defines which types of headers are to be selected
 for stripping from the input text.  The choices are:

	ALL       All header types
	EXTERNAL  Headers for external routines.
	INTERNAL  Headers for internal routines (identified by a
	          slash, "/", following the header start marker).
	MODULE    Headers for files/modules (identified by a plus,
	          "+", following the header start marker).

/TAB
/NOTAB (D)

 If /TAB is selected, the output text lines are each preceeded by a
 single tab character.  The default is /NOTAB. 

/PAGE
/NOPAGE (D)

 If /PAGE is selected, the output file is paginated by trying to fit
 more than one header per page (separated by three blank lines) or
 starting a header on a new page if too few lines remain on the
 current page.  The default is /NOPAGE. 

/REMOVE
/NOREMOVE (D)

 If /REMOVE is selected, the comment markers at the start of each
 line of the header (where appropriate) are removed from the output
 text.

/HELP

 If /HELP is selected, then the output file is in the format for
 input to the library to generate a HELP library. 

/STRIP=type (D=HEADER)

 This qualifier selects the type of comments to be stripped from the
 input text.  The values are:

	HEADER	Selects routine header comments to strip (normal
		default case).
	PCODE	Selects pseudo-code comments (following the header
		comments in MACRO programs only).
	BOTH	Selects both HEADER and PCODE.

/LOG
/NOLOG (D)

 This option selects whether information about what headers were
 processed, etc. should be printed at the terminal (on SYS$OUTPUT). 
 The default is /NOLOG. 
-}
{
  Modifications:

  V1.0	26-Feb-82	FJN	Created
  V1.1	01-Mar-82	FJN	Modified READ_LINE to fix problem with line end
  V2.0	18-Mar-82	FJN	Expanded to include /REMOVE and /HELP options
  V2.1	28-Dec-82	FJN	Added handling for VAX-11 C comments

}
{+2Header_Format
 The header is defined as the block of comment lines (usually at the
 start of a module or routine) delimited by lines with "?+"
 (beginning) and "?-" (ending) at the start of the line.  The question
 mark, "?", represents the comment character (or character sequence)
 for a particular language.  The recognized languages and the formats
 of the header start and end sequences are: 

	MACRO	;+ and ;-
	FORTRAN	C+ and C-  (lowercase "c" also accepted)
	LEAP	*+ and *-
	DCL	$!+ and $!-
	PASCAL	??+ and -?? where ?? are the 1 or 2 character PASCAL
		comment start/end character sequences.
	C	/*+ and -*/

 Note the slightly different format for the PASCAL header flags. 
 Also, the header flags must be the first characters on their line. 

2 Header_Type

 No assumptions are made about the contents of header comments for any
 of the lines other than the first header line (with the "+" after the
 comment character).  This line has the form "?+x<name>" where
 "<name>" is the routine name for which this is a header (or the
 filename if this is a "module" header).  The "x" is either a "+" to
 indicate a module header for a file of several routines
 ("?++filename"), a space (" ") to indicate a global or
 externally-used routine ("?+ entry_name"), or a slash ("/") to
 indicate an internally-used routine ("?+/entry_name"). 

 In order to allow for headers being used to generate HELP files, the
 header-type character (after the first + and before the module/entry
 point name) can also be a single digit.  The possibilities are thus: 

    +	Module header (used for HELP only if /SELECT=MODULE is used).
    /	Internal routine (never used for HELP).
<space>	External routine (name is preceeded by "1 " for HELP).
    1	External routine, same as <space>.
   2-9	Additional levels of information corresponding to HELP
		subtopics.
    0	External routine or additional information not to be 
		included in HELP.

-}

CONST
    string_size = 133;		{Maximum source line size}
    max_lines = 300;		{Maximum number of lines per header}
    page_length = 58;		{Number of lines/page for paging}
    error_exit = 0;		{Error exit status: generic warning}

TYPE
    WORD_RANGE = 0..65535;		{Integer unsigned word range}
    BYTE_RANGE = 0..255;		{Integer unsigned byte range}
    WORD_TYPE = PACKED RECORD		{Word length integer}
		word : WORD_RANGE
		END;
    BYTE_TYPE = PACKED RECORD		{Byte length integer}
		byte : BYTE_RANGE
		END;
    STRING_RANGE = 1..string_size;
    STRING = PACKED ARRAY [STRING_RANGE] OF CHAR;
    LINE_TYPE = (FIRST,OTHER,LAST);	{Types are first or last of header (or
					 pseudo-code block) or other}
    HEADER_TYPE = (INT,EXT,MODU); 	{Types of headers}
    LANGUAGE = (MACRO,FORTRAN,LEAP,PASCAL,DCL,VAX11C);

VAR
    EOS : CHAR;				{End of string flag}
    add_a_tab,paging,log : BOOLEAN;	{Flags for /TAB,/PAGE,/LOG options}
    strip_headers,strip_pcode : BOOLEAN;{Flags for /STRIP option}
    select_int,select_ext : BOOLEAN;	{Flags for /SELECT option}
    remove,make_help : BOOLEAN;		{Flags for /REMOVE and /HELP options}
    select_mod : BOOLEAN;		{Flag for /SELECT=MODULE option}
    module_type : LANGUAGE;		{Set to current header comment type}
    SOURCE,HEADERS : FILE OF CHAR;	{Input and output files}
    input_file,output_file : STRING;	{Input/Output file name strings}
    iline : STRING;			{Holds a line of input text}
    inlen : INTEGER;			{Count of characters in input line}
    source_count,header_count : INTEGER;{Count of lines read/written}
    in_header : BOOLEAN;		{Flag when inside header block}
    save_header : BOOLEAN;		{Flag when saving header block}
    in_pcode,save_pcode : BOOLEAN;	{Similar flags for pseudo-code blocks}
    old_name,new_name : STRING;		{Header names}
    line_count : INTEGER;		{Count of lines on current page}
    exit_status : INTEGER;		{Program exit status}
{
  Define the storage area for the header lines text and their lengths.
}
    header_store : PACKED ARRAY [1..max_lines] OF STRING;
    lines : INTEGER;			{Number of header lines in storage}
{
  Define the "constants" of a string of NULL character (0's) and of blanks
}
    NULL_STRING : STRING;
    BLANK_STRING : STRING;

VALUE
    add_a_tab := FALSE;			{Default is /NOTABS}
    paging := FALSE;			{Default is /NOPAGE}
    log := FALSE;			{Default is /NOLOG}
    remove := FALSE;			{Default is /NOREMOVE}
    make_help := FALSE;			{Default is not to do /HELP}
    strip_headers := TRUE; strip_pcode := FALSE;
					{Default is /STRIP=HEADERS}
    select_int := TRUE; select_ext := TRUE;
					{Default is /SELECT=ALL}
    select_mod := TRUE;
    lines := 0;
    source_count := 0; header_count := 0;
    line_count := 0;
    BLANK_STRING := (string_size OF ' ');	{A full string of blanks}
    exit_status := 1;			{Success exit status}

PROCEDURE LIB$STOP( %IMMED status : INTEGER );
    EXTERN;
PROCEDURE SYS$EXIT( %IMMED status : INTEGER );
    EXTERN;
FUNCTION STR$RIGHT( %STDESCR dst_str,src_str : STRING;
		start_pos : INTEGER ) : INTEGER;
    EXTERN;
FUNCTION STR$LEFT( %STDESCR dst_str,src_str : STRING;
		end_pos : INTEGER ) : INTEGER;
    EXTERN;
FUNCTION LIB$LOCC( %STDESCR char_str : PACKED ARRAY [STRING_RANGE] OF CHAR;
		%STDESCR src_str : STRING ) : INTEGER;
    EXTERN;
FUNCTION LIB$SKPC( %STDESCR char_str : PACKED ARRAY [STRING_RANGE] OF CHAR;
		%STDESCR src_str : STRING ) : INTEGER;
    EXTERN;
FUNCTION STR$TRIM( %STDESCR dst_str,src_str : STRING;
		VAR out_len : WORD_TYPE ) : INTEGER;
    EXTERN;
FUNCTION SYS$TRNLOG( %STDESCR lognam : STRING; VAR rsllen : WORD_TYPE;
		%STDESCR rslbuf : STRING;
		%IMMED table,acmode,dsbmsk : INTEGER ) : INTEGER;
    EXTERN;

PROCEDURE status_test( status : INTEGER );
    BEGIN {Status_test: test VMS System service/library completion status}
    IF NOT ODD(status) THEN LIB$STOP(status);
    END; {Status_test}

PROCEDURE get_name(stcol : INTEGER; VAR hdr_line,name : STRING);
    VAR
	col,stc : INTEGER;
    BEGIN
    stc := stcol - 1;
    col := stc;
    REPEAT
	col := col + 1;
	name[col-stc] := hdr_line[col];
	UNTIL hdr_line[col]=EOS;
    END; {Get_name}

PROCEDURE default_filetype( VAR file_spec : STRING;
		file_type : PACKED ARRAY [STRING_RANGE] OF CHAR );
    VAR
	tmp_str : STRING;
	fts,fns,tmp,loc : INTEGER;
	tslen,fslen : WORD_TYPE;

    BEGIN {Default_filetype}
    status_test(STR$TRIM(file_spec,file_spec,fslen));
    IF file_spec[fslen.word]=':' THEN
	status_test(SYS$TRNLOG(file_spec,fslen,file_spec,0,0,0));
    fns := LIB$LOCC('] ',file_spec);
    IF fns=0 THEN fns := LIB$LOCC(': ',file_spec);
    IF fns<fslen.word THEN
	BEGIN {File spec is not just a logical/device name}
	tmp_str := BLANK_STRING;
	status_test(STR$RIGHT(tmp_str,file_spec,fns+1));
	status_test(STR$TRIM(tmp_str,tmp_str,tslen));
	fts := LIB$LOCC('. ',tmp_str);
	IF fts=0 THEN
	    BEGIN {No file type in file spec}
	    fts := LIB$LOCC('; ',tmp_str);
	    loc := fns + fts;
	    IF fts=0 THEN loc := loc + tslen.word + 1;
	    file_spec[loc] := '.';
	    loc := loc + 1;
	    FOR tmp := 1 TO 3 DO
		BEGIN {Add default file type to file spec}
		file_spec[loc] := file_type[tmp];
		loc := loc + 1;
		END;
	    IF fts<>0 THEN
		REPEAT {Copy version number to after file type}
		    file_spec[loc] := tmp_str[fts];
		    loc := loc + 1;
		    fts := fts + 1;
		    UNTIL fts>tslen.word;
	    END; {Test for file type IF}
	END; {Test for file spec just logical name/device name}
    END; {Default_filetype}

PROCEDURE get_filename( VAR file_spec,file_name : STRING );
    VAR
	tmp_str : STRING;
	fts,fns,tmp,loc : INTEGER;
	tslen,fslen : WORD_TYPE;

    BEGIN {Get_filename}
    status_test(STR$TRIM(file_spec,file_spec,fslen));
    IF file_spec[fslen.word]=':' THEN
	status_test(SYS$TRNLOG(file_spec,fslen,file_spec,0,0,0));
    fns := LIB$LOCC('] ',file_spec);
    IF fns=0 THEN fns := LIB$LOCC(': ',file_spec);
    IF fns<fslen.word THEN
	BEGIN {File spec is not just a logical/device name}
	tmp_str := BLANK_STRING;
	status_test(STR$RIGHT(tmp_str,file_spec,fns+1));
	status_test(STR$TRIM(tmp_str,tmp_str,tslen));
	fts := LIB$LOCC('. ',tmp_str);
	IF fts=0 THEN
	    BEGIN {No file type in file spec check for version}
	    fts := LIB$LOCC('; ',tmp_str);
	    IF fts=0 THEN fts := tslen.word + 1;
	    END; {Test for file type IF}
	status_test(STR$LEFT(file_name,tmp_str,fts-1));
	END; {Test for file spec just logical name/device name}
    END; {Get_filename}

PROCEDURE replace_tabs( VAR line : STRING );
    VAR
	length : WORD_TYPE;
	loc : INTEGER;

    BEGIN
    status_test(STR$TRIM(line,line,length));
    loc := LIB$LOCC('	 ',line);
    WHILE loc<>0 DO
	BEGIN
	line[loc] := ' ';
	loc := LIB$LOCC('	 ',line);
	END;
    END; {Replace_tabs}

PROCEDURE options_strip( VAR cmd_line,options : STRING;
			VAR cmd_len,opt_len : WORD_TYPE );
    VAR
	loc : INTEGER;

    BEGIN
    loc := LIB$LOCC('/ ',cmd_line);
    WHILE loc<>0 DO
	BEGIN
	WHILE ((loc<=cmd_len.word) AND (cmd_line[loc]<>' ')) DO
	    BEGIN
	    opt_len.word := opt_len.word + 1;
	    options[opt_len.word] := cmd_line[loc];
	    cmd_line[loc] := ' ';
	    loc := loc + 1;
	    END;
	loc := LIB$LOCC('/ ',cmd_line);
	END;
    status_test(STR$TRIM(cmd_line,cmd_line,cmd_len));
    END; {Options_strip}

PROCEDURE option_process( VAR option : STRING );
    CONST
	%INCLUDE 'FERMI$LIB_INC:CLIMSGDEF.PAS/NOLIST'
    TYPE
	option_list = (OPT$LOG,OPT$PAGE,OPT$TAB,OPT$STRIP,OPT$SELECT,
			OPT$REMOVE,OPT$HELP);
    VAR
	negative : BOOLEAN;
	loc : INTEGER;

    FUNCTION opt_type( VAR opt_str : STRING; ifneg : BOOLEAN) : option_list;
	VAR
	    loc : INTEGER;
	BEGIN
	IF ifneg THEN
	    loc := 2
	    ELSE
	    loc := 0;
	CASE opt_str[loc+1] OF
	'L' : {/LOG or /NOLOG}
	    opt_type := OPT$LOG;
	'P' : {/PAGE or /NOPAGE}
	    opt_type := OPT$PAGE;
	'H' : {/HELP or /NOHELP}
	    opt_type := OPT$HELP;
	'R' : {/REMOVE or /NOREMOVE}
	    opt_type := OPT$REMOVE;
	'T' : {/TAB or /NOTAB}
	    opt_type := OPT$TAB;
	'S' : {/SELECT or /STRIP}
	    IF opt_str[loc+2]='E' THEN
		opt_type := OPT$SELECT
		ELSE
		opt_type := OPT$STRIP;
	    OTHERWISE LIB$STOP(CLI$_IVKEYW);
	    END; {Option type CASE}
	END; {Opt_type}

    BEGIN {Option_process}
    negative := (option[1]='N') AND (option[2]='O');
    CASE opt_type(option,negative) OF
    OPT$LOG : {/LOG or /NOLOG}
	log := negative;
    OPT$PAGE : {/PAGE or /NOPAGE}
	paging := negative;
    OPT$TAB : {/TAB or /NOTAB}
	add_a_tab := negative;
    OPT$HELP : {/HELP or /NOHELP}
	IF negative THEN
	    LIB$STOP(CLI$_NOTNEG)
	    ELSE
	    make_help := TRUE;
    OPT$REMOVE : {/REMOVE or /NOREMOVE}
	remove := negative;
    OPT$STRIP : {/STRIP=HEADERS|PCODE|BOTH}
	BEGIN
	IF negative THEN LIB$STOP(CLI$_NOTNEG);
	loc := LIB$LOCC('= ',option);
	IF loc=0 THEN LIB$STOP(CLI$_VALREQ);
	CASE option[loc+1] OF
	'B' : {/STRIP=BOTH}
	    BEGIN
	    strip_headers := TRUE;
	    strip_pcode := TRUE;
	    END;
	'P' : {/STRIP=PCODE}
	    BEGIN
	    strip_pcode := TRUE;
	    strip_headers := FALSE;
	    END;
	'H' : {/STRIP=HEADERS}
	    BEGIN
	    strip_headers := TRUE;
	    strip_pcode := FALSE;
	    END;
	    OTHERWISE LIB$STOP(CLI$_INVKEY);
	    END; {Inner CASE statement}
	END; {/STRIP CASE value}
    OPT$SELECT : {/SELECT=ALL|EXTERNAL|INTERNAL|MODULE}
	BEGIN
	IF negative THEN LIB$STOP(CLI$_NOTNEG);
	loc := LIB$LOCC('= ',option);
	IF loc=0 THEN LIB$STOP(CLI$_VALREQ);
	CASE option[loc+1] OF
	'A' : {/SELECT=ALL}
	    BEGIN
	    select_ext := TRUE;
	    select_int := TRUE;
	    select_mod := TRUE;
	    END;
	'E' : {/SELECT=EXTERNAL}
	    BEGIN
	    select_ext := TRUE;
	    select_int := FALSE;
	    select_mod := TRUE;
	    END;
	'I' : {/SELECT=INTERNAL}
	    BEGIN
	    select_ext := FALSE;
	    select_int := TRUE;
	    select_mod := TRUE;
	    END;
	'M' : {/SELECT=MODULE}
	    BEGIN
	    select_ext := FALSE;
	    select_int := FALSE;
	    select_mod := TRUE;
	    END;
	    OTHERWISE LIB$STOP(CLI$_INVKEY);
	    END; {Inner CASE statement}
	END; {/SELECT CASE value}
	END; {First qualifier character CASE statement}
    END; {Option_process}

PROCEDURE command_line(VAR input_spec,output_spec : STRING);
    CONST
	%INCLUDE 'FERMI$LIB_INC:CLIMSGDEF.PAS/NOLIST'
    VAR
	options,cmd_line : STRING;
	cmd_len : WORD_TYPE;
	loc,tmp : INTEGER;
	opt_len : INTEGER;

    FUNCTION LIB$GET_FOREIGN( %STDESCR get_str : STRING;
		%STDESCR prompt_str : PACKED ARRAY [STRING_RANGE] OF CHAR;
		VAR out_len : WORD_TYPE ) : INTEGER;
	EXTERN;
    FUNCTION LIB$GET_INPUT( %STDESCR get_str : STRING;
		%STDESCR prompt_str : PACKED ARRAY [STRING_RANGE] OF CHAR;
		VAR out_len : WORD_TYPE ) : INTEGER;
	EXTERN;
    FUNCTION STR$UPCASE( %STDESCR des_str,src_str : STRING ) : INTEGER;
	EXTERN;
    FUNCTION STR$POS_EXTR( %STDESCR dst_str,src_str : STRING;
		start_pos,end_pos : INTEGER ) : INTEGER;
	EXTERN;

    BEGIN {Command_line processing}
    cmd_line := BLANK_STRING; cmd_len.word := 0;
    status_test(LIB$GET_FOREIGN(cmd_line,'File: ',cmd_len));
    status_test(STR$UPCASE(cmd_line,cmd_line));
    input_spec := BLANK_STRING; output_spec := BLANK_STRING;
    options := BLANK_STRING; opt_len := 0;
    IF cmd_line[1]='/' THEN
	BEGIN {Command qualifiers must be stripped}
	opt_len := LIB$LOCC('  ',cmd_line);
	status_test(STR$LEFT(options,cmd_line,opt_len));
	IF opt_len=cmd_len.word THEN
	    BEGIN {Just command qualifiers, prompt for input spec}
	    status_test(LIB$GET_INPUT(cmd_line,'File: ',cmd_len));
	    status_test(STR$UPCASE(cmd_line,cmd_line));
	    END
	    ELSE
	    BEGIN {Blank out command quals and move input spec}
	    FOR tmp := 1 TO opt_len DO
		cmd_line[tmp] := ' ';
	    loc := LIB$SKPC('  ',cmd_line);
	    status_test(STR$RIGHT(cmd_line,cmd_line,loc));
	    status_test(STR$TRIM(cmd_line,cmd_line,cmd_len));
	    END;
	END; {Command qualifier IF}
    loc := LIB$LOCC('/ ',cmd_line);
    IF loc<>0 THEN
	BEGIN {Qualifiers following input spec}
	IF opt_len=0 THEN
	    BEGIN {No command qualifiers}
	    status_test(STR$RIGHT(options,cmd_line,loc));
	    status_test(STR$TRIM(options,options,cmd_len));
	    opt_len := cmd_len.word;
	    END
	    ELSE
	    BEGIN {Tack new options on with command qualifiers}
	    FOR tmp := loc TO cmd_len.word DO
		BEGIN
		opt_len := opt_len + 1;
		options[opt_len] := cmd_line[tmp];
		END;
	    END;
	status_test(STR$LEFT(input_spec,cmd_line,loc-1));
	END
	ELSE
	input_spec := cmd_line;
    get_filename(input_spec,output_spec);
    loc := 1;
    WHILE loc<opt_len DO
	BEGIN {Scan qualifiers}
	options[loc] := ' ';			{Blank output the "/"}
	tmp := LIB$LOCC('/ ',options) - 1;
	IF tmp<0 THEN tmp := opt_len;		{Last qualifier}
	cmd_line := BLANK_STRING;
	status_test(STR$POS_EXTR(cmd_line,options,loc+1,tmp));
	FOR loc := loc + 1 TO tmp DO options[loc] := ' ';
	IF NOT ((cmd_line[1]='O') AND (cmd_line[2]='U')) THEN
	    option_process(cmd_line)
	    ELSE
	    BEGIN
	    tmp := LIB$LOCC('= ',cmd_line);
	    IF tmp>0 THEN
		BEGIN
		output_spec := BLANK_STRING;
		status_test(STR$RIGHT(output_spec,cmd_line,tmp+1));
		END
		ELSE LIB$STOP(CLI$_VALREQ);
	    END;
	END; {WHILE loop}
    END; {Command_line}    

FUNCTION header_test( VAR line : STRING; length : INTEGER;
			VAR mark_length : INTEGER ) : LINE_TYPE;
    FUNCTION hdr_tst( achar : CHAR ) : LINE_TYPE;
	BEGIN
	CASE achar OF
	'+' : {Start of header}
	    hdr_tst := FIRST;
	'-' : {End of header}
	    hdr_tst := LAST;
	    OTHERWISE hdr_tst := OTHER;
	    END;
	END; {Hdr_tst}
    BEGIN {Header_test}
    mark_length := 2;
    header_test := OTHER;
    IF length>=2 THEN
	CASE line[1] OF
	';','C','c','*' : {Comments for MACRO, FORTRAN and LEAP}
	    header_test := hdr_tst(line[2]);
	'$' : {Comments for DCL}
	    IF line[2]='!' THEN
		BEGIN
		header_test := hdr_tst(line[3]);
		mark_length := 3;
		END;
	'{' : {Comment start for PASCAL}
	    IF line[2]='+' THEN header_test := FIRST;
	'(' : {Alternate form of comment start for PASCAL}
	    IF (line[2]='*') AND (line[3]='+') THEN
		BEGIN
		header_test := FIRST;
		mark_length := 3;
		END;
	'/' : {Comment start for VAX-11 C}
	    IF (line[2]='*') AND (line[3]='+') THEN
		BEGIN
		header_test := FIRST;
		mark_length := 3;
		END;
	'-' : {Possible header end (of comment) for PASCAL or C}
	    CASE line[2] OF
	    '}' : {End of comment for PASCAL}
		header_test := LAST;
	    '*' : {Alternate form of comment end for PASCAL or C}
		IF (line[3]=')') OR (line[3]='/') THEN
		    BEGIN
		    header_test := LAST;
		    mark_length := 3;
		    END;
		END; {end of inner CASE}
	    END; {end of CASE}
    END; {Header_test}

FUNCTION module_test(VAR line : STRING; mark_length : INTEGER) : LANGUAGE;
    BEGIN
    IF mark_length=3 THEN
	BEGIN {Only DCL, PASCAL and C have 3 character header forms}
	IF line[1]='$' THEN
	    module_test := DCL
	    ELSE IF line[1]='/' THEN
	    module_test := VAX11C
	    ELSE
	    module_test := PASCAL;
	END
	ELSE
	CASE line[1] OF
	';' : {MACRO comment line}
	    module_test := MACRO;
	'C','c' : {FORTRAN comment line}
	    module_test := FORTRAN;
	'*' : {LEAP comment line}
	    module_test := LEAP;
	OTHERWISE module_test := PASCAL;
	    END;
    END; {Module_test}

FUNCTION text_equal(VAR text1,text2 : STRING) : BOOLEAN;
    VAR
	col : INTEGER;
    BEGIN
    col := 1;
    WHILE ((text1[col]<>EOS) AND (text1[col]=text2[col])) DO
	col := col + 1;
    text_equal := text1[col]=text2[col];
    END; {Text_equal}

FUNCTION skip_cols( comment_type : LANGUAGE; stcol : INTEGER;
			VAR line : STRING) : INTEGER;
    VAR
	tcol : INTEGER;
    BEGIN {Skip_cols}
    IF remove THEN
	BEGIN
	CASE comment_type OF
	MACRO,FORTRAN,LEAP :
	    tcol := stcol + 1;
	DCL :
	    tcol := stcol + 2;
	PASCAL,VAX11C :
	    tcol := stcol;
	    END;
	IF tcol=1 THEN
	    skip_cols := 1
	    ELSE
	    IF line[tcol-1]=EOS THEN
		skip_cols := tcol - 1
		ELSE
		skip_cols := tcol;
	END
	ELSE
	skip_cols := 1;
    END; {Skip_cols}

PROCEDURE read_line( VAR line : STRING; VAR length : INTEGER );
    VAR
	onechr : CHAR;
    BEGIN
    length := 0;
    WHILE NOT (EOF(SOURCE) OR EOLN(SOURCE)) DO
	BEGIN
	length := length + 1;
	READ(SOURCE,onechr);
	line[length] := onechr
	END;
    IF EOLN(SOURCE) THEN READLN(SOURCE);
    line[length+1] := EOS;
    END; {Read_line}

PROCEDURE type_string(VAR text : STRING);
    VAR
	col : INTEGER;
	onechr : CHAR;
    BEGIN
    col := 1;
    WHILE text[col]<>EOS DO
	BEGIN
	onechr := text[col];
	WRITE(onechr);
	col := col + 1;
	END;
    END; {Type_string}

PROCEDURE store_line( stcol : INTEGER; VAR line : STRING);
    VAR
	col,stc : INTEGER;
    BEGIN
    lines := lines + 1;
    IF lines>max_lines THEN
	BEGIN
	WRITE('  Header longer than ',max_lines,' lines: ');
	type_string(new_name);
	WRITELN;
	HALT;
	END ELSE BEGIN
	stc := stcol - 1;
	col := stc;
	REPEAT
	    col := col + 1;
	    header_store[lines][col-stc] := line[col];
	    UNTIL line[col]=EOS;
	END;
    END; {Store_line}

PROCEDURE write_header;
    CONST
	TAB = '	';
	SPACE = ' ';
    VAR
	col,tmp : INTEGER;
	onechr : CHAR;
    BEGIN
    IF paging AND (lines<>0) AND (NOT text_equal(old_name,new_name)) THEN
	BEGIN
	tmp := line_count + lines + 3;
	IF tmp > page_length THEN
	    BEGIN
	    PAGE(HEADERS);
	    line_count := lines;
	    END ELSE BEGIN
	    IF line_count>0 THEN
		BEGIN
		WRITELN(HEADERS);
		WRITELN(HEADERS);
		WRITELN(HEADERS);
		END;
	    line_count := tmp;
	    END;
	END;
    FOR tmp := 1 TO lines DO
	BEGIN
	IF add_a_tab THEN WRITE(HEADERS,TAB);
	col := 1;
	WHILE header_store[tmp][col]<>EOS DO
	    BEGIN
	    onechr := header_store[tmp][col];
	    WRITE(HEADERS,onechr);
	    col := col + 1;
	    END;
	WRITELN(HEADERS);
	END;
    header_count := header_count + lines;
    lines := 0;
    old_name := new_name;
    END; {Write_header}

PROCEDURE process_header(VAR line : STRING; linelen : INTEGER);
    VAR
	mark : INTEGER;				{Length of the header marker}
	tmp : INTEGER;
	onechr : CHAR;
	hdr_type : HEADER_TYPE;

    FUNCTION hdr_type_tst(VAR line : STRING; length,htpos : INTEGER) :
	HEADER_TYPE;
	BEGIN {hdr_type_tst}
	IF htpos>length THEN
	    hdr_type_tst := EXT		{Default to external if no text}
	    ELSE
	    CASE line[htpos] OF
	    '+' : {Module level header}
		hdr_type_tst := MODU;
	    '/' : {Internal routine header}
		hdr_type_tst := INT;
		OTHERWISE hdr_type_tst := EXT; {All other characters}
		END; {end of CASE}
	END; {hdr_type_tst}

    FUNCTION help_level(VAR line : STRING; length,htpos : INTEGER) : INTEGER;
	BEGIN {help_level}
	IF htpos>length THEN
	    help_level := 0		{If no text, default to non-HELP}
	    ELSE
	    IF line[htpos] IN ['0'..'9'] THEN
		help_level := ORD(line[htpos]) - ORD('0')
		ELSE
		IF line[htpos]=' ' THEN
		    help_level := 1	{Treat space as a '1'}
		    ELSE
		    help_level := 0;	{All non-digit characters}
	END; {help_level}

    BEGIN {Process_header}
    CASE header_test(line,linelen,mark) OF
    OTHER : 			{Non-header or a line inside a header}
	IF save_header THEN store_line(skip_cols(module_type,1,iline),iline);
    FIRST : 			{Header start line}
	BEGIN
	hdr_type := hdr_type_tst(line,linelen,mark+1);
	module_type := module_test(line,mark);
	get_name(mark+2,line,new_name);
	IF in_header THEN
	    BEGIN
	    WRITE(' Header start without ending previous header:');
	    type_string(old_name);
	    WRITELN;
	    exit_status := error_exit;
	    write_header;
	    END;
	in_header := TRUE;
	save_header := (select_int AND (hdr_type=INT)) OR
			(select_ext AND (hdr_type=EXT)) OR
			(select_mod AND (hdr_type=MODU));
	IF make_help THEN
	    BEGIN
	    tmp := help_level(line,linelen,mark+1);
	    save_header := save_header AND (tmp>0);
	    IF save_header THEN
		BEGIN
		iline[mark] := CHR(tmp+ORD('0'));
		iline[mark+1] := ' ';
		mark := mark - 2;
		END;
	    END;
	IF in_header THEN
	    BEGIN
	    IF remove THEN
		tmp := mark + 2
		ELSE
		tmp := 1;
	    IF save_header THEN store_line(tmp,line);
	    IF log THEN
		BEGIN
		IF save_header THEN
		    WRITE(' Stripping ')
		    ELSE
		    WRITE('  Skipping ');
		WRITE('header: ');
		type_string(new_name);
		WRITELN;
		END;
	    END;
	END;
    LAST : 			{Header termination line}
	IF in_header THEN
	    BEGIN
	    IF save_header THEN
		BEGIN
		IF remove THEN
		    BEGIN
		    IF hdr_type=MODU THEN
			tmp := mark + 2
			ELSE
			tmp := mark + 1;
		    store_line(tmp,iline);
		    END
		    ELSE
		    store_line(1,line);
		    END;
	    write_header;
	    in_header := FALSE;
	    save_header := FALSE;
	    END ELSE
	    BEGIN
	    WRITE('  Loose header ending found.');
	    exit_status := error_exit;
	    END;
	END;	{End of CASE statement}
    END; {Process_header}

{Begin main program code here}
    BEGIN
    {Initialize the string of NULL's and the end-of-string marker}
    EOS := CHR(0);
    FOR inlen := 1 TO string_size DO NULL_STRING[inlen] := CHR(0);
    old_name := NULL_STRING;
    {
    Get remainder of command line to check for option selections
    }
    command_line(input_file,output_file);
    IF make_help THEN
	BEGIN
	{
	When /HELP is selected, the setting of the other qualifiers are
	overriden.  In particular /HELP forces the following settings to
	be in effect:
		/NOTAB/NOPAGE/STRIP=HEADER/SELECT=EXTERNAL/REMOVE
	}
	select_int := FALSE;
	select_ext := TRUE;
	select_mod := FALSE;
	strip_headers := TRUE;
	strip_pcode := FALSE;
	paging := FALSE;
	add_a_tab := FALSE;
	remove := TRUE;
	{
	When /HELP is selected, the default output file type is .HLP.
	}
	default_filetype(output_file,'HLP')
	END
	ELSE
	{
	The normal default output file type is .TXT.
	}
	default_filetype(output_file,'TXT');
    OPEN(FILE_VARIABLE:=SOURCE,FILE_NAME:=input_file,HISTORY:=OLD);
    RESET(SOURCE);
    OPEN(FILE_VARIABLE:=HEADERS,FILE_NAME:=output_file,HISTORY:=NEW);
    REWRITE(HEADERS);
    {
    Begin processing the input file and writing the headers to the output file.
    }
    WHILE NOT EOF(SOURCE) DO
	BEGIN
	read_line(iline,inlen);
	source_count := source_count + 1;
	process_header(iline,inlen);
	END;	{End of WHILE statement}
    {
    Here when end of file is reached
    }
    CLOSE(SOURCE);
    IF in_header THEN
	BEGIN
	WRITE(' Header unterminated at EOF:');
	type_string(new_name);
	WRITELN;
	exit_status := error_exit;
	write_header;
	END;
    CLOSE(HEADERS);
    IF log THEN
	BEGIN
	WRITELN;
	WRITELN(source_count,' source lines read.');
	WRITELN(header_count,' header lines written.');
	WRITELN;
	END;
    SYS$EXIT(exit_status);
    END. {End of main program}