#!/usr/bin/perl

# Extract utility for SimH help text


#  Copyright (c) 2013, Timothe Litt

#  Permission is hereby granted, free of charge, to any person obtaining a
#  copy of this software and associated documentation files (the "Software"),
#  to deal in the Software without restriction, including without limitation
#  the rights to use, copy, modify, merge, publish, distribute, sublicense,
#  and/or sell copies of the Software, and to permit persons to whom the
#  Software is furnished to do so, subject to the following conditions:

#  The above copyright notice and this permission notice shall be included in
#  all copies or substantial portions of the Software.

#  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
#  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
#  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
#  THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
#  IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
#  CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

#  Except as contained in this notice, the name of the author shall not be
#  used in advertising or otherwise to promote the sale, use or other dealings
#  in this Software without prior written authorization from the author.

use warnings;
use strict;

# This utility attempts to read the C source of an emulator device and convert
# its help function to the structured help format.  Manual editing of the result
# will be required, but the mechanical work is done by the tool.
#
# A template for organizing the help into standard topics/subtopics is inserted
# along with the translation.  At this writing, everything is experimental, so
# the 'standard' format may change.  Nonetheless, this is suitable for experimentation.

use File::Basename;

my $prg = basename $0;

my $rtn;
my $ifn = '-';
my $ofn = '-';
my $line;
my $update;

while (@ARGV) {
    if( $ARGV[0] eq '--' ) {
	last;
    }
    if( $ARGV[0] eq '-dev' ) {
	shift;
	$rtn = shift;
	$rtn .= "_help";
	next;
    }
    if( $ARGV[0] eq '-u' ) {
	$update = 1;
	shift;
	next;
    }
    last if( $ARGV[0] !~ /^-/ );

    printf STDERR << "USAGE_";
Usage:
$prg -u -dev devname -func rtn infile outfile

devname is used to look for the existing help function name.
E.g. if the routine is cr_help, use -dev cr.

Alternatively, use -func to specify the full function name.

infile and outfile default to - (stdin and stdout)

$prg will attempt to produce a sensible device help string, although you
should expect that the result will require manual editing.  Complex C
constructs (preprocessor conditionals, if statements that generate strings)
are not automatically translated, but the old code will be preserved.

However, as it may have been partially translated, the result may not compile.

A template is installed so that you can move your information into the standard
sections.

Source code in the help function is reformatted - not to any particular
style, but as a consequence of how it is tokenized and parsed.  Use your
favorite pretty-printer if you don't like the results.

Normally, just the help function is output.  -u will output the entire file
(-u = "update")

USAGE_

    exit (0);
}

unless( defined $rtn ) {
    die "The help function must be specified with -func or -dev; -help for usage\n";
}

if( @ARGV ) {
    $ifn = shift;
}
if( @ARGV ) {
    $ofn = shift;
}

open( STDIN, "<$ifn" ) or
    die "Unable to open $ifn for input: $!\n";

open( STDOUT, ">$ofn" ) or
    die "Unable to open $ofn for output: $!\n";

$line = "";
while( <STDIN> ) {

    # Look for the help function
    if( /^(?:static\s+)?t_stat\s+$rtn\s*\(/ ) {
	$line = $_;
	while( $line !~ /\{/ && $line !~ /\)\s*;/ ) {
	    my $cont = <STDIN>;
	    if( !defined $cont ) {
		die "EOF in function definition\n";
	    }
	    $line .= $cont;
	}
	if( $line =~ /\)\s*;/ ) { # Just a prototype
	    if( $update ) {
		print $line;
	    }
	    $line = "";
	    next;
	}
	# Process the function body
	my $f = $line;
	my $b = '';
	my $bl = 1;
	my( %vargs, @vargs );
	my $help = '';
	my $comments = '';

	# Each statement in the body
	while (1) {
	    my ($tok, $val) = gettok();
	    last if( !defined $tok );

	    if ($tok eq '{') {                  # Track brace level
		$bl++;
		$b .= $tok;
	    } elsif ($tok eq '}') {
		die "Unmatched }\n" if ( --$bl < 0 );
		$b .= $tok;
		last if (!$bl);                # End of function
	    } elsif ($tok eq 'word' && $val eq 'fprintf') {
		# fprintf ( st, "string" ,args );
		# Save embedded comments, but don't confuse the parse.
		($tok, $val) = gettok(\$comments);
		if( $tok ne '(' ) {
		    $b .= " $val";
		    next;
		}
		($tok, $val) = gettok(\$comments);
		if( $tok ne 'word' || $val ne 'st' ) {
		    $b .= "fprintf ($val";
		    next;
		}
		($tok, $val) = gettok(\$comments);
		if( $tok ne ',' ) {
		    $b .= "fprintf (st$val";
		    next;
		}
		($tok, $val) = gettok(\$comments);
		if( $tok ne 'QS' ) {
		    $b .= "fprintf (st, $val";
		    next;
		}
		# Concatenate adjacent strings
		my $string = '';
		while( $tok eq 'QS' ) {
		    $string .= substr( $val, 1, length( $ val ) -2);
		    ($tok, $val) = gettok(\$comments);
		}
		# Check for format codes.  plain %s is all that can be automated
		if ($string =~ /(%[^%s])/) {
		    print STDERR "Line $.: Unsupported format code $1 in help string.  Please convert to %s\n";
		}
		# Rework argument list
		my $arg = '';
		my @vlist;
		my $pl = 1;             # Paren level
		while( $tok eq ',' ) {
		    ($tok, $val) = gettok(\$comments);
		    while( $tok ne ',' ) {
			if( $tok eq '(' ) {
			    $pl++;
			} elsif( $tok eq ')' ) {
			    die "Unmatched )" if( --$pl < 0);
			    last if( !$pl );
			}
			$arg .= " $val";
			($tok, $val) = gettok(\$comments);
		    }
		    if( !length $arg ) {
			print STDERR "Line $.: null argument to fprintf in $rtn\n";
			$string = "<<NULL>>";
		    }
		    unless( exists $vargs{$arg} ) {   # Assign each unique arg an index
			$vargs{$arg} = @vargs;
			push @vargs, $arg;
		    }
		    push @vlist, $vargs{$arg};        # Remember offset in this list
		    $arg = '';
		}
		die "Line $.: Missing ')' in fprintf\n" if( $tok ne ')' );
		($tok, $val) = gettok(\$comments);
		die "Line $.: Missing ';' in fprintf\n" if( $tok ne ';' );

		# Replace each escape with positional %s in new list.
		my $n = 0;
		$string =~ s/%([.\dlhs# +Lqjzt-]*[diouxXeEfFgGaAcspnm%])/
		  sprintf "%%%us",$vlist[$n++]+1/eg;
		$help .= $string;
		next;
	    } elsif ($tok eq 'word' && $val =~ /^fprint_(set|show|reg)_help(?:_ex)?$/) {
		my %alt = ( set  => "\$Set commands", 
			    show => "\$Show commmands", 
			    reg  => "\$Registers" );
		$b .= "/* Use \"$alt{$1}\" topic instead:\n";
		do {
		    $b .= " $val";
		    ($tok, $val) = gettok (\$comments);
		} while ($tok ne ';');
		$b .= ";\n*/\n";
		next;
	    }

	    # Random function body content

	    $b .= " $val";
	}
	# End of function - output new one
	print $f;                       # Function header
	print "const char helpString[] =\n";

	print << 'TEMPLATE_';
/* Template for re-arranging your help.
 * Lines marked with '+' in the translation seemed to be indented and will
 * indent 4 columns for each '+'.  See scp_help.h for a worked-out example.
 * The '*'s in the next line represent the standard text width of a help line */
     /****************************************************************************/
    " Insert your device summary here.  Keep it short.  Be sure to put a leading\n"
    " space at the start of each line.  Blank lines do appear in the output;\n"
    " don't add extras.\n"
    "1 Hardware Description\n"
    " The details of the hardware.  Feeds & speeds are OK here.\n"
    "2 Models\n"
    " If the device was offered in distinct models, a subtopic for each\n"
    "3 Model A\n"
    " Description of model A\n"
    "3 Model B\n"
    " Description of model B\n"
    "2 $Registers\n"
    " The register list of the device will automagically display above this\n"
    " line.  Add any special notes.\n"
    "1 Configuration\n"
    " How to configure the device under SimH.  Use subtopics\n"
    " if there is a lot of detail.\n"
    "2 $Set commands\n"
    " The SET commands for the device will automagically display above\n"
    " this line.  Add any special notes.\n"
    "2 OSNAME1\n"
    " Operating System-specif configuration details\n"
    " If the device needs special configuration for a particular OS, a subtopic\n"
    " for each such OS goes here.\n"
    "2 Files\n"
    " If the device uses external files (tapes, cards, disks, configuration)\n"
    " Create a subtopic for each here.\n"
    "3 Config file 1\n"
    " Description.\n"
    "2 Examples\n"
    " Provide usable examples for configuring complex devices.\n"
    " If the examples are more than a couple of lines, make a subtopic for each.\n"
    "1 Operation\n"
    " How to operate the device under SimH.  Attach, runtime events\n"
    " (e.g. how to load cards or mount a tape)\n"
    "1 Monitoring\n"
    " How to obtain and interpret status\n"
    "2 $Show commands\n"
    " The SHOW commands for the device will automagically display above\n"
    " this line.  Add any special notes.\n"
    "1 Restrictions\n"
    " If some aspects of the device aren't emulated or some host\n"
    " host environments that aren't (fully) supported, list them here.\n"
    "1 Debugging\n"
    "  Debugging information - provided by the device.  Tips for common problems.\n"
    "1 Related Devices\n"
    " If devices are configured or used together, list the other devices here.\n"
    " E.G. The DEC KMC/DUP are two hardware devices that are closely related;\n"
    " The KMC controlls the DUP on behalf of the OS.\n"

    /* **** Your converted help text starts hare **** */

TEMPLATE_

	my @lines = split /(\\n|\n)/, $help;
	while( @lines ) {
	    my $line = shift @lines;
	    my $term = shift @lines;
	    if ($term eq "\\n") {
		$line .= $term;
		$term = "\n";
	    }
	    if( $line =~ s/^(\s+)// ) {
		$line = ('+' x ((length( $1 ) +3)/4)) . $line;
	    } else {
		$line = ' ' . $line;
	    }

	    print "    \"$line\"\n" ;
	}
	print "    ;\n";
	print $b;                       # Stuff from body of old function
	if( length $comments ) {
	    print "\n$comments";
	}

	# Call scp_help

	print "\nreturn scp_help (st, dptr, uptr, helpString, cptr";

	%vargs = reverse %vargs;
	while( @vargs ) {
	    print ",\n                " . shift( @vargs );
	}

	print  ");\n}\n";
    } else {
	if( $update ) {
	    print $_;
	}
	next;
    }
}

exit (0);

my @pending;
sub nextc {
    if( @pending ) {
	my $c = shift @pending;
	return $c;
    }
    return getc;
}

sub gettoken {
    my $c;
    my $ql = 0;
    my $cl = 0;
    my $tok = '';

    while( defined(($c = nextc())) ) {
	if( $cl ) {
	    if( $c eq '*' ) {
		$c = nextc;
		die "EOF in comment\n" if( !defined $c );

		if ($c eq '/') {
		    $tok .= '*/';
		    return ('comment', $tok);
		}
		push @pending, $c;
		$c = '*';
	    }
	    $tok .= $c;
	    next;
	} elsif( $c eq '/' ) {
	    $c = nextc;
	    if( $c eq '*' ) {
		if (length $tok) {
		    push @pending, '/', '*';
		    return ('word', $tok);
		}
		$cl = 1;
		$tok = '/*';
		next;
	    }
	    push @pending, $c;
	    $c = '/';
	}
	if( $ql ) {
	    if( $c eq '\\' ) {
		$c = nextc;
		die "EOF in string\n" if( !defined $c );

		$tok .= "\\$c"; # eval "\"\\$c\"";
		next;
	    }
	    if( $c eq $ql ) {
		$tok .= $ql;
		return ("QS", $tok);
	    }
	    $tok .= $c;
	    next;
	}
	if( $c eq '"' || $c eq "'" ) {
	    $ql = $c;
	    $tok = $c;
	    next;
	}
	if ($c =~ /^\s$/) {
	    if( length $tok ) {
		return ('word', $tok);
	    }
	    next;
	}
	if ($c =~ /^\w$/) {
	    $tok .= $c;
	    next;
	}
	if( length $tok ) {
	    push @pending, $c;
	    return ('word', $tok);
	}
	if ($c eq '-') {
	    $c = nextc;
	    if( $c =~ /^[>=-]$/ ) {
		return ('op', "-$c");
	    }
	    push @pending, $c;
	    return ('op', '-');
	}
	if( $c eq '<' ) {
	    $c = nextc;
	    if( $c eq '=' ) {
		return ('op', "<$c");
	    }
	    if( $c eq '<' ) {
		my $c2 = nextc;
		if( $c2 eq '=' ) {
		    return ('op', "<<=");
		}
		push @pending, $c2;
		return ('op', '<<');
	    }
	    push @pending, $c;
	    return ('op', '<');
	}
	if( $c eq '>' ) {
	    $c = nextc;
	    if( $c eq '=' ) {
		return ('op', ">$c");
	    }
	    if( $c eq '>' ) {
		my $c2 = nextc;
		if( $c2 eq '=' ) {
		    return ('op', ">>=");
		}
		push @pending, $c2;
		return ('op', '>>');
	    }
	    push @pending, $c;
	    return ('op', '>');
	}
	if( $c eq '=' ) {
	    $c = nextc;
	    if( $c eq '=' ) {
		return ('op', '==');
	    }
	    push @pending, $c;
	    return ('op', '=');
	}
	if ($c =~ m,^[!*+/%&^|]$,) {
	    my $c2 = nextc;
	    if( $c2 eq '=' ) {
		return ('op', "$c$c2");
	    }
	    push @pending, $c2;
	    return ('op', $c);
	}
	if( $c =~ /^[&|]$/ ) {
	    my $c2 = nextc;
	    if( $c2 eq $c ) {
		return ('op', "$c$c");
	    }
	    push @pending, $c2;
	    return ('op', $c);
	}

	if ($c =~ /^[#}]$/ ) {
	    return ($c, "\n$c");
	}
	return ($c, ($c =~ /^[{;]$/? "$c\n" : $c));
    }
    return (undef, '<<EOF>>');
}

sub gettok {
    my $comments = $_[0];

    while( 1 ) {
	my( $token, $value ) = gettoken();
	return ($token, $value) if( !defined $token );

	if( $token eq 'comment' && $comments ) {
	    $$comments .= $value . "\n";
	    next;
	}
	return ($token, $value);
    }
}