File Coverage

blib/lib/Mylisp/Lint.pm

Criterion	Covered	Total	%
statement	17	71	23.9
branch	0	6	0.0
condition			n/a
subroutine	6	17	35.2
pod	0	11	0.0
total	23	105	21.9

package Mylisp::Lint;

use 5.012;
no warnings "experimental";

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT =
  qw(is_define new_lint update_pos report ns in_package in_ns out_block out_ns set_name_value get_name_value);
use Spp::Builtin;
use Spp::Tools;
use Mylisp::Type;

sub is_define {
  my ($t, $name) = @_;
  my $stack = $t->{'stack'};
  for my $ns (@{$stack}) {
    my $stable = $t->{'st'};
    if (exists $stable->{$ns}{$name}) { return 1 }
  }
  return 0;
}

sub new_lint {
  my $code   = shift;
  my $parser = get_type_parser();
  my $patter = get_type_ast();
  { 'code'    => $code,
    'offline' => 'offline',
    'stack'   => [],
    'st'      => {},
    'return'  => 'str',
    'parser'  => $parser,
    'patter'  => $patter
  };
}

sub update_pos {
  my ($t, $atom) = @_;
  $t->{'offline'} = offline($atom);
}

sub report {
  my ($t, $message) = @_;
  my $code    = $t->{'code'};
  my $offline = $t->{'offline'};
  my ($off_str, $line_str) = flat($offline);
  my $off  = to_int($off_str);
  my $line = to_int($line_str);
  my $str  = to_end(substr($code, $off));
  say "line: $line $message";
  say "   $str\n   ^";
}

sub ns {
  my $t     = shift;
  my $stack = $t->{'stack'};
  return $stack->[0];
}

sub in_package {
  my ($t, $ns) = @_;
  in_ns($t, $ns);
  set_name_value($t, $ns, 'package');
}

sub in_ns {
  my ($t, $ns) = @_;
  $t->{'st'}{$ns} = {};
  unshift @{ $t->{'stack'} }, $ns;
}

sub out_block {
  my ($t, $ns) = @_;
  out_ns($t);
  my $table = $t->{'st'};
  delete $table->{$ns};
}
sub out_ns { my $t = shift; shift @{ $t->{'stack'} }; }

sub set_name_value {
  my ($t, $name, $value) = @_;
  my $ns     = ns($t);
  my $stable = $t->{'st'};
  if (exists $stable->{$ns}{$name}) {
    report($t, "exists symbol define |$name|.");
  }
  $t->{'st'}{$ns}{$name} = $value;
}

sub get_name_value {
  my ($t, $name) = @_;
  my $stack = $t->{'stack'};
  for my $ns (@{$stack}) {
    my $stable = $t->{'st'};
    if (exists $stable->{$ns}{$name}) {
      return $t->{'st'}{$ns}{$name};
    }
  }
  report($t, "symbol <$name> not define!");
}
1;