#! /usr/bin/perl

# NASM map file to lDebug commands processor
#  by C. Masloch, 2019
#
# Usage of the works is permitted provided that this
# instrument is retained with the works, so that any entity
# that uses the works is notified of this instrument.
#
# DISCLAIMER: THE WORKS ARE WITHOUT WARRANTY.

use warnings;
use strict;

use Getopt::Long;

our $showorigin1 = 0;
our $showorigin2 = 0;
our $showsection1 = 0;
our $showsection2 = 1;
our $showsection3 = 0;
our $showsymbol1 = 0;
our $showsymbol2 = 1;
our $showsymbol3 = 1;
our $showsymbol4 = 1;
our $showsymbol5 = 1;
our $showpara = 0;
our $showsetstate = 0;
our $usesectionbase = 1;
our $useshort = 1;
our $useparts = 1;
our $useendflag = 0;
our $usesort = 1;
our $format = "zz";
# our $format = "insert.asm";
our @sections = ();

GetOptions(
	'showorigin1!' => \$showorigin1,
	'showorigin2!' => \$showorigin2,
	'showsection1!' => \$showsection1,
	'showsection2!' => \$showsection2,
	'showsection3!' => \$showsection3,
	'showsymbol1!' => \$showsymbol1,
	'showsymbol2!' => \$showsymbol2,
	'showsymbol3!' => \$showsymbol3,
	'showsymbol4!' => \$showsymbol4,
	'showsymbol5!' => \$showsymbol5,
	'showpara!' => \$showpara,
	'showsetstate!' => \$showsetstate,
	'usesectionbase!' => \$usesectionbase,
	'useshort!' => \$useshort,
	'useparts!' => \$useparts,
	'useendflag!' => \$useendflag,
	'usesort!' => \$usesort,
	'format=s' => \$format,
	'section=s@' => \@sections,
) or die;

sub unrecognised {
  our ($state, $paraname, $_);
  die("error during state ".$state." (para $paraname),"
	." unrecognised line:\n ".'"'.$_.'"'."\n");
};
sub setstate {
  our ($state, $handle);
  $state = shift;
  if ($showsetstate) {
    print $handle "; state: ".$state."\n";
  };
};
sub trim {
  my $str = shift;
  $str =~ s/^\s+|\s+$//g;
  return $str;
};
sub addsymbol {
      our ($origin, $showsymbol1, $handle, @symbols, $usesort);
      my $str = shift;
      my $flags = shift;
      my $isstart = shift;
      if ($str =~ /^\s*([0-9A-Fa-f]+)\s+([0-9A-Fa-f]+)\s+(\S+)\s*$/) {
	my %symbol = (	real => hex($1),
			virtual => hex($2),
			name => $3,
			flags => $flags,
			isstart => $isstart );
	%symbol = (	%symbol,
			linear => $symbol{real} - $origin,
			offset => $symbol{virtual} );
	if ($showsymbol1) {
	  print $handle "\n";
	  foreach my $key (sort keys %symbol) {
	    print $handle ("; ".$key."=".$symbol{$key}."\n");
	  };
	};
	if ($symbol{name} =~ /(["'\n\t ])/) {
	  die("invalid character ($1) in symbol\n");
	}
	if ($usesort and not $isstart) {
	  push @symbols, \%symbol;
	} else {
	  displaysymbol(\%symbol);
	}
      } else {
	die("invalid symbol line format\n");
      }
};
sub displaysymbol {
	my $symbol_ref = shift;
	my %symbol = %{ $symbol_ref };
	my $flags = $symbol{flags};
	my $isstart = $symbol{isstart};
	our ($origin, $showsymbol2, $numsymbols, $format);
	our ($totalnumsymbols, %sections, $currentsection, $handle);
	if ($showsymbol2) {
	  if ($format eq "zz") {
	    if ($useshort) {
	      if ($usesectionbase and not $isstart) {
		printf $handle "z add l=(%06X + sl.section.%s.start)"
			." o=%04X s='%s'%s\n",
			$symbol{linear} - ($sections{$currentsection}{start} - $origin),
			$sections{$currentsection}{name},
			$symbol{offset}, $symbol{name},
			($flags == 0 ? "" : sprintf(" f=%04X", $flags));
	      } else {
		printf $handle "z add l=(%06X + v1) o=%04X s='%s'%s\n",
			$symbol{linear}, $symbol{offset}, $symbol{name},
			($flags == 0 ? "" : sprintf(" f=%04X", $flags));
	      }
	    } else {
	      if ($usesectionbase and not $isstart) {
		printf $handle "z add linear=(%06X + symbol.linear.section.%s.start)"
			." offset=%04X symbol='%s'%s\n",
			$symbol{linear} - ($sections{$currentsection}{start} - $origin),
			$sections{$currentsection}{name},
			$symbol{offset}, $symbol{name},
			($flags == 0 ? "" : sprintf(" flags=%04X", $flags));
	      } else {
		printf $handle "z add linear=(%06X + v1) offset=%04X symbol='%s'%s\n",
			$symbol{linear}, $symbol{offset}, $symbol{name},
			($flags == 0 ? "" : sprintf(" flags=%04X", $flags));
	      }
	    }
	  } elsif ($format eq "insert.asm") {
	    printf $handle "listentry 0%04Xh + _LINEARBASE, 0%04Xh, ".'"'."%s".'"'."\n",
			$symbol{linear}, $symbol{offset}, $symbol{name};
	  } else {
	    die("unknown format selected\n");
	  }
	}
	$numsymbols += 1;
	$totalnumsymbols += 1;
}
sub emitendsymbol {
  our ($endsymbol, $showsymbol3, $numsymbols, $handle, $useendflag);
  our (@symbols, $usesort);
  if (defined $endsymbol) {
    my $endflag = 0;
    $useendflag and $endflag = 0x100;
    addsymbol($endsymbol, $endflag, 0);
    $endsymbol = undef;
  }
  if ($usesort) {
    foreach my $symbol ( sort { $a->{linear} <=> $b->{linear} } @symbols ) {
      displaysymbol(\%{ $symbol });
    }
    @symbols = ();
  }
  if ($showsymbol3 and $numsymbols != 0) {
    if ($numsymbols == 1) {
      printf $handle "; 1 symbol\n";
    } else {
      printf $handle "; %u symbols\n", $numsymbols;
    }
  }
  $numsymbols = 0;
}

our %sections = ();
our @symbols = ();
our $origin = 0;
our $paraname = "";
our $endsymbol = undef;
our $state = 0;
our $numsymbols = 0;
our $totalnumsymbols = 0;
our $numsections = 0;
our $have_set_origin = 0;
our $currentsection;
our $handle;
my $bufferbases;
my $buffersymbols;
my $handlebases;
my $handlesymbols;

if (not $useparts) {
  $handle = *STDOUT;
} else {
  open $handlebases, '>', \$bufferbases or die("cannot open variable: $!");
  open $handlesymbols, '>', \$buffersymbols or die("cannot open variable: $!");
  $handle = $handlesymbols;
}

while (<>) {
  if (/^\s*$/) {
    next;
  };
  chomp;
  if (/^-+ /) {
    if (/^-+\s*(.*)\s+-+$/) {
      $paraname = trim($1);
      $showpara and printf $handle "; para: $paraname\n";
    } else {
      die("error during para detection\n");
    };
    if ($paraname =~ /^program origin$/i) {
      setstate(1);
    } elsif ($paraname =~ /^sections \(summary\)$/i) {
      setstate(2);
    } elsif ($paraname =~ /^symbols$/i) {
      setstate(4);
    } elsif ($paraname =~ /^no section$/i) {
      if ($state != 4) {
	unrecognised();
      };
    } elsif (($state >= 4 and $state <= 6) and $paraname =~ /^section (\S+)$/i) {
      emitendsymbol();
      $currentsection = $1;
      my %sections_hash = map { $_ => 1 } @sections;
      if (scalar (%sections_hash) and ! exists $sections_hash{$currentsection}) {
        setstate(4);
        next;
      }
      $showsection2 and printf $handle "; section ".'"'.$currentsection.'"'."\n";
      if (not exists $sections{$currentsection}) {
	die("section ".'"'.$currentsection.'"'." not found\n");
      }
      $showsection3 and printf $handle "; section found\n";
      if ($useparts) {
        $handle = $handlebases;
      }
      addsymbol(sprintf("%06X %04X %s",
		$sections{$currentsection}{start},
		$sections{$currentsection}{vstart},
		"section.$sections{$currentsection}{name}.start"), 0x120, 1);
      $numsections += 1;
      if ($useparts) {
        $handle = $handlesymbols;
      }
      $endsymbol = (sprintf("%06X %04X %s",
			$sections{$currentsection}{stop},
			$sections{$currentsection}{stop}
			 - $sections{$currentsection}{start}
			 + $sections{$currentsection}{vstart},
			"section.$sections{$currentsection}{name}.end"));
      setstate(5);
    } elsif ($paraname =~ /^section (\S+)$/i
		or $paraname =~ /^nasm map file$/i
		or $paraname =~ /^sections \(detailed\)$/i
		) {
      setstate(0);
    } else {
      die("unknown paragraph name ".'"'.$paraname.'"'."\n");
    };
  } else {
    if ($state == 0) {
      next;
    } elsif ($state == 1) {
      if (/^\s*([0-9A-Fa-f]+)\s*$/) {
	if ($have_set_origin) {
	  die("invalid subsequent origin specification\n");
	}
	if (scalar %sections) {
	  die("invalid origin specification after sections\n");
	}
	$have_set_origin = 1;
	$origin = hex($1);
	if ($showorigin1) {
	  printf $handle "; origin set to %04Xh\n", $origin;
	}
	if ($showorigin2) {
	  printf $handle "r v0 := %04X\n", $origin;
	}
	next;
      };
    } elsif ($state == 2) {
      if (/^\s*vstart\s+start\s+stop\s+length\s+class\s+name\s*$/i) {
	setstate(3);
	next;
      };
    } elsif ($state == 3) {
      if (/^\s*([0-9A-Fa-f]+)\s+([0-9A-Fa-f]+)\s+([0-9A-Fa-f]+)\s+([0-9A-Fa-f]+)\s+(nobits|progbits)\s+(\S+)\s*$/) {
	my %section = (	vstart => hex($1),
			start => hex($2),
			stop => hex($3),
			length => hex($4),
			name => $6 );
	if ($showsection1) {
	  foreach my $key (sort keys %section) {
	    print $handle ("; ".$key."=".$section{$key}."\n");
	  };
	  print $handle "\n";
	};
	%{ $sections{$6} } = %section;
	next;
      };
    } elsif ($state == 4) {
      next;
    } elsif ($state == 5) {
      if (/^\s*real\s+virtual\s+name\s*$/i) {
	setstate(6);
	next;
      };
    } elsif ($state == 6) {
      if (/^\s*([0-9A-Fa-f]+)\s+([0-9A-Fa-f]+)\s+(\S+)\s*$/) {
	addsymbol($_, 0, 0);
	next;
      };
    };
    unrecognised();
  };
};

emitendsymbol();

if ($useparts) {
  $handle = $handlebases;
}
if ($showsymbol5) {
  if ($numsections == 1) {
    printf $handle "\n; total 1 section\n";
  } else {
    printf $handle "\n; total %u sections\n", $numsections;
  }
}
if ($useparts) {
  $handle = $handlesymbols;
}

if ($showsymbol4) {
  if ($totalnumsymbols == 1) {
    printf $handle "\n; total 1 symbol\n";
  } else {
    printf $handle "\n; total %u symbols\n", $totalnumsymbols;
  }
}

if ($useparts) {
  close $handlebases;
  close $handlesymbols;
  print "y :addbases\n";
  print "goto :addsymbols\n";
  print "\n:addbases\n";
  print $bufferbases;
  print "goto :eof\n";
  print "\n:addsymbols\n";
  print $buffersymbols;
  print "goto :eof\n";
}