package types;

use 5.008;
use strict;
use warnings;
use optimize;

our $VERSION;
$VERSION = do { my @r = (q$Revision: 1.5 $ =~ /\d+/g); $r[0] = 0; sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker


my %typed;
my %op_returns;
my %function_returns;
my %function_params;
use constant SVpad_TYPED => 0x40000000;
use B qw(OPpTARGET_MY OPf_MOD SVf_POK);
use B::Utils;

our %const_map = (
	  "B::NV" => 'float',
	  "B::IV" => 'int',
	  "B::PV" => 'string',
	    );


sub compare_type {
    my($a,$b) = @_;
    if($a eq $b) {
	return 1;
    }
    return 0;
}

sub B::NULL::name { "void" }
use Data::Dumper;
sub check {
    my $class = shift;
    my $op = shift;
    my $cv = $op->find_cv();

    #if($^H & 0x00000010) {
    unless($optimize::state->private & 0x00000010) {
	return;
    }


#    if($op->name eq 'padsv') {
#	print $op->flags ."\n";
#    }

    if(ref($op) eq 'B::PADOP' && $op->name eq 'gv') {
#	$op->dump;
	my $target = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
#	$target->dump;
#	exit;
    }

    if($op->name eq 'int') {
	$op_returns{$op->seq}->{type} = 'int';
	$op_returns{$op->seq}->{name} = 'int()';
    }

    if($op->name eq 'padsv') {
	my $target = (($cv->PADLIST->ARRAY)[0]->ARRAY)[$op->targ];
	if(UNIVERSAL::isa($target,'B::SV') && $target->FLAGS & SVpad_TYPED) {
	    $typed{$cv->ROOT->seq}->{$op->targ}->{type} = $target->SvSTASH->NAME;
	    $typed{$cv->ROOT->seq}->{$op->targ}->{name} = $target->PV;
	} elsif(UNIVERSAL::isa($target,'B::SV') && 
		exists($typed{$cv->ROOT->seq}->{$target->PV})) {
	    $typed{$cv->ROOT->seq}->{$op->targ} = $typed{$cv->ROOT->seq}->{$target->PV};
	}
    }
    if($cv->FLAGS & SVf_POK && !$function_params{$cv->START->seq}) {
	#we have, we have, we have arguments
	my @type;
	my @name;
	my $i = 1;
	foreach (split ",", $cv->PV)  {
	    my ($type, $sigil, $name) = split /\b/, $_;
	#    print "$type - $sigil - $name \n";	    
	    push @type, $type;
	    if($sigil && $name)  {
		push @name, $sigil.$name;
		$typed{$cv->ROOT->seq}->{"$sigil$name"}->{type} = $type;
		$typed{$cv->ROOT->seq}->{"$sigil$name"}->{name} = $sigil.$name;
	    } else {
		push @name, "Argument $i";
	    }
	    $i++;
	}

	$function_params{$cv->START->seq}->{name} = \@name;
	$function_params{$cv->START->seq}->{type} = \@type;


	#print $cv->PV . "\n";
	$cv->PV(";@");

    }

    if(ref($op->next) ne 'B::NULL' &&
       ($op->next->name =~/2cv$/ || 
	($op->next->name eq 'null' && $op->next->oldname =~/2cv$/))) {
	my $entersub = $op->next;
	my $i = 1;

	while($entersub->name ne 'entersub' && 
	      ref($entersub->next) ne 'B::NULL') {
	    $i++ if($entersub->name ne 'null');
	    $entersub = $entersub->next;

	}
	if($entersub->name eq 'entersub') {
	    my $sv; 
	    if(ref($op) eq 'B::PADOP') {
		$sv = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
	    } else {
		die;
	    }
	    if(ref($sv->CV) ne 'B::SPECIAL') {
		my $foo = $sv->CV->START->seq;
		if(exists($function_returns{$foo})) {
		    $op_returns{$op->seq + $i}->{type} = $function_returns{$foo}->{type};
		    $op_returns{$op->seq + $i}->{name} = $sv->STASH->NAME . "::" . $sv->SAFENAME."()";
#		print "AND IT HAS A RETURN VALUE $i\n";
		}
		if(exists($function_params{$foo})) {
		    my $param_list = $entersub->first();
		    get_list_proto($param_list, $cv);
		    $param_list = delete($op_returns{$param_list->seq});
		    pop(@{$param_list->{type}});
		    pop(@{$param_list->{name}});
#		    print Data::Dumper::Dumper($function_params{$foo});
#		    print Data::Dumper::Dumper($param_list);
		    match_protos($function_params{$foo}, $param_list);
		}
#	    $sv->CV->dump();
	    }
	}
    }

sub match_protos {
    my ($target, $source) = @_;
    my $targets = scalar @{$target->{name}} - 1;
    my $sources = scalar @{$source->{name}} - 1;

    if($sources < $targets) {
	die "Not enough items in list at " . 
	    $optimize::state->file . ":" . 
		$optimize::state->line . "\n";
    }
    foreach my $i (0..$targets) {
	my ($target_name, $target_type) = 
	    ($target->{name}->[$i], $target->{type}->[$i]);
	my ($source_name, $source_type) = 
	    ($source->{name}->[$i], $source->{type}->[$i]);
	if((!$target_type->isa($source_type) and !$source_type->isa($target_type)) or ($target_type->can('check') && !$target_type->check($source_type))) {
	    die "Type mismatch in list for" . 
		" $source_type ($source_name) to $target_type ($target_name) at " . 
		    $optimize::state->file . ":" . 
			$optimize::state->line . "\n";
	}

	 
    }
}
    
    if(ref($op->next) ne 'B::NULL') {
#	print $op->name . " - " . $op->next->name . "\n";
    }
    if(ref($op->next) ne 'B::NULL' &&
       ref($op->next->next) ne 'B::NULL' &&
       $op->next->next->name eq 'entersub') {
#	print "sub entry\n";
    }


    if(ref($op) eq 'B::LISTOP' && $op->first->name eq 'pushmark') {
	get_list_proto($op,$cv);
    }    
    

    if(ref($op->next) ne 'B::NULL' &&
       ref($cv->START) ne 'B::NULL' &&
       ($op->next->name eq 'lineseq' &&
	$op->next->next->name =~/^leave/) ||
       $op->next->name eq 'return') {
	my ($type, $value, $const) = get_type($op, $cv);
	my $lineseq = $op->next;
	my $leave = $lineseq->next;

      	if(exists($function_returns{$cv->START->seq}) &&
	   $function_returns{$cv->START->seq}->{type} ne $type) {
	    die "Return type mismatch: " . $op->name . 
		" $type at " . 
		    $optimize::state->file . ":" . 
			$optimize::state->line . " does not match" .
			    " return value $function_returns{$cv->START->seq}->{type}".
				" at $function_returns{$cv->START->seq}->{file}\n";
	    
	    
	    
	}
	
	
	my $subname = "";
	
	if(ref($cv->GV) ne 'B::SPECIAL' && $cv->GV->SAFENAME ne '__ANON__') {
	    $subname = $cv->GV->STASH->NAME . "::" . $cv->GV->SAFENAME;
	}
	if($subname && exists($function_returns{$subname}) &&
	   $function_returns{$subname}->{type} ne $type) {
	    die "Function $subname redefined with a different type (was $function_returns{$subname}->{type} now $type) at " . $optimize::state->file . ":" . $optimize::state->line . "\n";
	}


	
	$function_returns{$cv->START->seq}->{type}  = $type;
	$function_returns{$cv->START->seq}->{name} = $value;
	$function_returns{$cv->START->seq}->{file} = $optimize::state->file . ":" . $optimize::state->line;

	if($subname) {
	    $function_returns{$subname} = $function_returns{$cv->START->seq};
#	    print "GOT subname $subname\n";
	}
#	print "scope leave retval ($type, $value): " . $op->name . "-" . $lineseq->next->name . "\n";


    }





    if(ref($op) eq 'B::BINOP') {
	
	my ($lhs, $rhs, $target, $expr, $const, $mod);
	my ($lhs_v, $rhs_v, $target_v, $expr_v);
	

	if($op->private & OPpTARGET_MY && 
	   exists($typed{$cv->ROOT->seq}->{$op->targ})) {
		$target   = $typed{$cv->ROOT->seq}->{$op->targ}->{type};
		$target_v = $typed{$cv->ROOT->seq}->{$op->targ}->{name};
	}

	if($op->first->name eq 'padsv'
	   && exists($typed{$cv->ROOT->seq}->{$op->first->targ})) {
	    $rhs    = $typed{$cv->ROOT->seq}->{$op->first->targ}->{type};
	    $rhs_v  = $typed{$cv->ROOT->seq}->{$op->first->targ}->{name};
	} elsif(exists($op_returns{$op->first->seq})) {
	    $rhs = $op_returns{$op->first->seq}->{type};
	    $rhs_v = $op_returns{$op->first->seq}->{name};
	} elsif($op->first->name eq 'const' && 
		exists($const_map{ref($op->first->sv)})) {
	    $rhs = $const_map{ref($op->first->sv)};
	    $rhs_v = "constant '" . $op->first->sv->sv."'";
	    $const++;
	} elsif($op->first->name eq 'null' &&
		$op->first->oldname eq 'list') {
	    get_list_proto($op->first,$cv);
	} 

	if($op->last->name eq 'padsv'
	   && exists($typed{$cv->ROOT->seq}->{$op->last->targ})) {
	    $lhs    = $typed{$cv->ROOT->seq}->{$op->last->targ}->{type};
	    $lhs_v  = $typed{$cv->ROOT->seq}->{$op->last->targ}->{name};
	    if($op->last->flags & OPf_MOD) {
		die "target should be empty" if($target);
		$target = $lhs;
		$target_v = $lhs_v;
		$mod++;
	    }
	} elsif(exists($op_returns{$op->last->seq})) {
	    $lhs = $op_returns{$op->last->seq}->{type};
	    $lhs_v = $op_returns{$op->last->seq}->{name};
	} elsif($op->last->name eq 'const' && 
		exists($const_map{ref($op->last->sv)})) {
	    $lhs = $const_map{ref($op->last->sv)};
	    $lhs_v = "constant '" . $op->last->sv->sv."'";

	} elsif($op->last->name eq 'null' &&
		$op->last->oldname eq 'list') {
	    get_list_proto($op->first,$cv);
	}


	$lhs_v = $lhs = "unknown" unless($lhs);
	$rhs_v = $rhs = "unknown" unless($rhs);
	
	$target_v = $target = "" unless($target);


	return if($target eq '' && $const);


	#first lets deterimne what the expression returns
	# if they are equal the expression returns that
	# otherwise it returns what is higher on he inclusion team

	
	{
	    my($is_lhs, $is_rhs) = (0,0);
	    if($lhs->can("check") && $lhs->check($rhs)) {
		$is_lhs = 1;
	    } elsif($lhs->isa($rhs)) {
		$is_lhs = 1;
	    }

	    if($rhs->can("check") && $rhs->check($lhs)) {
		$is_rhs = 1;
	    } elsif($rhs->isa($lhs)) {
		$is_rhs = 1;
	    }
	    if($is_lhs && $is_rhs) {
		$expr = $lhs;

	    } elsif($is_lhs) {
		$expr = $lhs;
#		print "$lhs < $rhs\n";
	    } elsif($is_rhs) {
		$expr = $rhs;
#		print "$rhs < $lhs\n";
	    } else {
		die "Type mismatch, can't " . $op->name . 
		    " $rhs ($rhs_v) to $lhs ($lhs_v) at " . 
			$optimize::state->file . ":" . 
			    $optimize::state->line . "\n";
	    }
	    $expr_v = "$lhs_v, $rhs_v";
#	    print "Expression returns ($expr) ($expr_v)" .
#		$optimize::state->file . ": . " . 
#		    $optimize::state->line . "\n";
	}
	

#	return if(!$lhs and $op->first->name eq 'const');
	
#

	unless($target) {
	    #the target is empty
	    $op_returns{$op->seq}->{type} = $expr;
	    $op_returns{$op->seq}->{name} = $expr_v;	    
	    return;
	}
	
#	print "$expr - $target\n";
#	print "$target->isa($expr): ". $target->isa($expr) . "\n";
#	print "$expr->isa($target): ". $expr->isa($target) . "\n";



	if((!$target->isa($expr) and !$expr->isa($target)) or ($target->can('check') && !$target->check($expr))) {
	    if($mod) {
		die "Type mismatch, can't " . $op->name . 
		    " $rhs ($rhs_v) to $lhs ($lhs_v) at " . 
			$optimize::state->file . ":" . 
			    $optimize::state->line . "\n";
	    } else {
		die "Type mismatch, can't assign result of $lhs $lhs_v " 
		    . $op->name . " $rhs $rhs_v to $target ($target_v) at " 
			. $optimize::state->file . ":" 
			    . $optimize::state->line . "\n";
	    }
	}
	$op_returns{$op->seq}->{type} = $target;
	$op_returns{$op->seq}->{name} = $target_v;
    }

}

BEGIN { $optimize::loaded{"types"} = __PACKAGE__ }

sub import {
    my ($package, $filename, $line) = caller;
    #$^H |= 0x00020000; 
    #$^H{"use_types"}++;
    $^H |= 0x00000010;
#    optimize->register(\&entry, $package, $filename, $line);
}

sub unimport {
    my ($package, $filename, $line) = caller;
    $^H &= ~ 0x00000010;
    #$^H |= 0x00020000; 
    #delete($^H{"use_types"});
#    optimize->unregister($package);
}

sub get_type {
    my($op, $cv) = @_;
    my ($type, $value, $const) = ("","",0);
    if($op->name eq 'padsv'
       && exists($typed{$cv->ROOT->seq}->{$op->targ})) {
	$type   = $typed{$cv->ROOT->seq}->{$op->targ}->{type};
	$value  = $typed{$cv->ROOT->seq}->{$op->targ}->{name};
    } elsif(exists($op_returns{$op->seq})) {
	$type  = $op_returns{$op->seq}->{type};
	$value = $op_returns{$op->seq}->{name};
    } elsif($op->name eq 'const' && 
	    exists($const_map{ref($op->sv)})) {
	$type  = $const_map{ref($op->sv)};
	$value = "constant '" . $op->sv->sv."'";
	$const++;
    } elsif($op->name eq 'null' &&
	    $op->oldname eq 'list') {
	get_list_proto($op,$cv);
    } else {
	$type = $value = "unknown";
    }
    return ($type, $value, $const);
}

sub get_list_proto {
    my ($op, $cv) = @_;
    my $o = $op->first->sibling();
#    print "start\n";
    my @type;
    my @name;
    while(ref($o) ne 'B::NULL') {
	my $kid = $o;
	if($o->name eq 'null') {
	    $kid = $o->first;
	}
	if($kid->name eq 'padsv' &&
	   exists($typed{$cv->ROOT->seq}->{$kid->targ})) {
	    push @type, $typed{$cv->ROOT->seq}->{$kid->targ}->{type}; 
	    push @name, $typed{$cv->ROOT->seq}->{$kid->targ}->{name};	
	} elsif(exists($op_returns{$kid->seq})) {
	    push @type, $op_returns{$kid->seq}->{type}; 
	    push @name, $op_returns{$kid->seq}->{name};
	} elsif($kid->name eq 'const' && 
		exists($const_map{ref($kid->sv)})) {
	    push @type, $const_map{ref($kid->sv)};
	    push @name, $kid->sv->sv;
	} else {
	    push @type, "unknown";
	    push @name, "unknown";
	}
#	    print $kid->name . "\n";
	$o = $o->sibling;
    }

    if(@type > 1) {
	$op_returns{$op->seq}->{type} = \@type;
	$op_returns{$op->seq}->{name} = \@name;
    } else {
	$op_returns{$op->seq}->{type} = $type[0];
	$op_returns{$op->seq}->{name} = $name[0];
    }
    use Data::Dumper;
#    print Dumper(\@type);

}

package unknown;
our $dummy = 1;


package int;
our $dummy = 1;
sub check {
    return 0 if($_[0] eq 'int' && ($_[1] ne 'number' && $_[1] ne 'int'));    
    return 1;
}
package float;
use base qw(int);
sub check {
    return 0 if($_[1] eq 'string');
    return 1;
}
our $dummy = 1;
package number;
use base qw(float);
sub check {
    return 0 if($_[1] eq 'string');
    return 1;
}
our $dummy = 1;
package string;
use base qw(number);
sub check { return 1};
1;
__END__


=head1 NAME

types - Perl pragma for strict type checking

=head1 SYNOPSIS

  use types;
  my int $int;
  my float $float;
  $int = $float; # BOOM compile time error!

=head1 ABSTRACT

This pragma uses the optimzie module to analyze the optree and
turn on compile time type checking

=head1 SYNOPSIS

    my float $foo = "string"; #compile time error
    sub foo (int $foo) { my ($foo) = @_ };
    foo("hi"); #compile time error   

    my int $int;
    sub foo { my float $foo; return $foo }
    $int = $foo; # compile time error

=head1 DESCRIPTION

This pragma uses the optimzie module to analyze the optree and
turn on compile time type checking

Currently we support int, float, number ,string and user defined classes, 
the implict casting rules are as follows.

    
    int    < > number
    int      > float
    float  < > number
    number   > string


Normall type casting is allowed both up and down the inheritance tree,
so in theory user defined classes should work already, requires one
to do use base or set @ISA at compileitme in a BEGIN block.

=head2 Return values

Return values are implicitly figerd out by the subroutine, this includes 
both falling of the end or by expliticly calling return, if two return 
values of the same sub differ you will get an error message.

=head2 Arguments

Arguments are declared with prototype syntax, they can either be named
or just typed, if typed only the calling convertions are checked, if
named then that named lexical will get that type without the need
for expliticty typing it, thus allowing list assignment from @_

=head2 EXPORT

None.

=head1 BUGS

Please report bugs and submit patches using http://rt.cpan.org/


=head1 SEE ALSO

L<optimize> L<B::Generate> L<optimizer>

=head1 AUTHOR

Arthur Bergman, E<lt>ABERGMAN@CPAN.ORGE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2002 by Arthur Bergman

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut