# Copyright (c) 1997-2006
# Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
# http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
#
# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the
# Free Software Foundation; either version 2, or (at your option) any
# later version: http://www.gnu.org/licenses/gpl.txt.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#----------------------------------------------------------------------------
# $Project: polymake $$Id: Overload.pm 7279 2006-03-21 14:46:19Z gawrilow $
use strict;
use namespaces;
require 'Poly/regex.pl';
package Poly::Overload::Node;
use Struct (
[ new => '$$$' ],
[ '$min_arg' => '#1' ], # min and max possible number of arguments.
[ '$max_arg' => '#2' ], # undef => unlimited ( signature with trailing @ or keywords)
[ '$backtrack' => '#3' ], # another Node
[ '$next_arg' => 'undef' ], # skip untyped scalars which don't need checking; undef => stop checking
'$signature',
'@code', # \&sub or (label controlled) list
'$ellipsis_code', # \&sub with unlimited arglist
[ '$default_args' => 'undef' ], # to push into @_
[ '$keywords' => 'undef' ], # [ \%keyword_table, ... ] when signature with keywords
);
####################################################################################
sub clone {
my ($src)=@_;
bless [ $src->min_arg, $src->max_arg, 0, $src->next_arg, $src->signature,
[ @{$src->code} ],
$src->ellipsis_code,
$src->default_args,
$src->keywords,
];
}
####################################################################################
sub demangle {
my ($self, $n_args)=@_;
my $sig=$self->signature;
$sig =~ s/\@/::/g;
if (@_==1) {
$sig =~ s/^\.([^,]+)(?:,(.*))?$/$1($2)/;
} elsif ($n_args > $sig =~ tr/,/,/) {
$sig =~ s/^\.([^,]+)(?:,(.*))?$/$1($2,...)/;
} else {
$sig =~ s/^\.([^,]+)(?:,((?:[^,]+.*?){$n_args}).*)?$/$1($2)/;
}
$sig;
}
####################################################################################
sub _expand {
my ($self, $new_min, $new_max, $new_proto_length)=@_;
if ($new_min < $self->min_arg) {
if (@{$self->code}) {
unshift @{$self->code}, (undef) x ($self->min_arg - $new_min);
}
$self->min_arg=$new_min;
}
my $limit=defined($new_proto_length) ? $new_proto_length : $self->next_arg;
if (defined $self->max_arg) {
if (defined $new_max) {
assign_min($limit, $new_max);
assign_max($self->max_arg, $new_max);
} else {
undef $self->max_arg;
}
}
return $limit;
}
####################################################################################
sub expand {
my ($self, $new_min, $new_max, $new_proto_length, $new_code)=@_;
my $limit=&_expand;
if ($self->ellipsis_code && $#{$self->code} < $limit-$self->min_arg) {
croak( "ambiguous overloading for ", demangle($self) );
}
for (my $i=$new_min; $i<=$limit; ++$i) {
( $self->code->[$i-$self->min_arg] &&= croak( "ambiguous overloading for ", demangle($self, $i) )
) ||= $new_code;
}
if (defined($new_proto_length) && !defined($new_max)) {
if ($self->ellipsis_code || $#{$self->code} > $new_proto_length-$self->min_arg) {
croak( "ambiguous overloading for ", demangle($self) );
}
$self->ellipsis_code=$new_code;
}
}
####################################################################################
sub push_code {
my ($self, $new_code, $n)=@_;
push @{$self->code}, ($new_code) x $n;
}
####################################################################################
sub push_ellipsis_code {
my ($self, $new_code)=@_;
$self->ellipsis_code=$new_code;
}
####################################################################################
sub find_backtrack {
my ($nodesub)=@_;
my $node_of_interest=&$nodesub;
my $node=$node_of_interest;
for (;;) {
my $obj=method_owner($nodesub);
if (my $nextnodesub=$obj->can("SUPER::" . method_name($nodesub))) {
my $nextnode=&$nextnodesub;
$node->backtrack=$nextnode;
last if ref($nextnode->backtrack) or !$nextnode->backtrack;
$node=$nextnode;
$nodesub=$nextnodesub;
} else {
$node->backtrack=0;
last;
}
}
$node_of_interest->backtrack;
}
####################################################################################
# Node, \(original @_) => \&target_sub | control list | undef
sub resolve {
my ($node, $args)=@_;
my @backtrack;
my $n_repeated=0;
my $n_args=@$args;
for (;;) {
if ($n_args-$n_repeated >= $node->min_arg) {
if (!defined($node->max_arg) || $n_args <= $node->max_arg) {
if (!defined($node->next_arg) || $node->next_arg+$n_repeated >= $n_args) {
if ($node->keywords) {
my $first_kw=$args->[$node->min_arg+$n_repeated];
if (ref($first_kw) && ref($first_kw) ne "HASH") {
goto BACKTRACK;
}
push @$args, $node->default_args ? @{$node->default_args}[ $node->min_arg .. $#{$node->default_args} ] : (),
process_keywords($node->keywords, splice @$args, $node->min_arg+$n_repeated);
return $node->ellipsis_code;
} elsif ($node->default_args) {
push @$args, @{$node->default_args}[ $n_args-$n_repeated .. $#{$node->default_args} ];
}
return $node->code->[ $n_args-$n_repeated-$node->min_arg ] || $node->ellipsis_code;
}
if (defined (my $nodesub=can_signature($args->[$node->next_arg+$n_repeated], $node->signature, $node->keywords))) {
$node=$nodesub->($n_repeated);
if (my $bt_node=$node->backtrack) {
push @backtrack, ref($bt_node) ? $bt_node : $nodesub;
}
next;
}
}
}
BACKTRACK: {
$node=pop @backtrack or return undef;
if (is_code($node)) {
$node=find_backtrack($node) or redo BACKTRACK;
}
if (my $bt_node=$node->backtrack) {
push @backtrack, $bt_node;
}
}
}
}
####################################################################################
sub complain_mismatch {
"already defined without labels"
}
####################################################################################
package Poly::Overload::LabeledNode;
use Struct (
[ '@ISA' => 'Poly::Overload::Node' ],
);
####################################################################################
sub dup_or_new_code {
$_[0] ? &Poly::Preference::Label::dup_control : [ ];
}
####################################################################################
sub dup_code {
$_[0] && &Poly::Preference::Label::dup_control;
}
####################################################################################
sub clone {
my ($src)=@_;
my $self=bless [ $src->min_arg, $src->max_arg, 0, $src->next_arg, $src->signature,
[ map { dup_code($_) } @{$src->code} ],
dup_code($src->ellipsis_code),
$src->default_args,
$src->keywords,
];
$self;
}
####################################################################################
sub create_controls {
my ($list, $c, $labels)=@_;
foreach my $label (@$labels) {
$label->add_control($list, $c);
}
$list;
}
####################################################################################
sub expand {
my ($self, $new_min, $new_max, $new_proto_length, $new_code, $labels)=@_;
my $limit=&Poly::Overload::Node::_expand;
if (defined($new_proto_length) && !defined($new_max)) {
create_controls(( $self->ellipsis_code ||= [ ] ), $new_code, $labels);
assign_max($limit, $#{$self->code}+$self->min_arg);
}
for (my $i=$new_min; $i<=$limit; ++$i) {
create_controls(( $self->code->[$i-$self->min_arg] ||= dup_or_new_code($self->ellipsis_code) ),
$new_code, $labels);
}
}
####################################################################################
sub push_code {
my ($self, $new_code, $n, $labels)=@_;
while (--$n >= 0) {
push @{$self->code}, create_controls([ ], $new_code, $labels);
}
}
####################################################################################
sub push_ellipsis_code {
my ($self, $new_code, $labels)=@_;
$self->ellipsis_code=create_controls([ ], $new_code, $labels);
}
####################################################################################
sub resolve {
my $l=&Poly::Overload::Node::resolve;
$l && $l->[0];
}
####################################################################################
sub complain_mismatch {
"already defined with labels and signature"
}
####################################################################################
package Poly::Overload::Labeled;
sub new {
bless [ ], shift;
}
sub resolve {
$_[0]->[0];
}
sub complain_mismatch {
"already defined without signature"
}
####################################################################################
package Poly::Overload;
use Poly::Ext;
sub parse_signature {
(local $_, my ($pkg, $kw))=@_;
my (@proto, $min, @defaults, @repeated);
my $fixed=1;
s/\s+$//;
while (pos($_) < length($_)) {
if (/\G\s* ; \s*/gxc) {
if (defined $min) {
croak( "invalid signature: multiple ';'" );
}
$min=@proto;
next;
}
if (/\G\s* ($type_re | \$)
(?: (?<!\$) \s* (\+)
| \s*=\s* ( $quoted_re | (?= [\(\[\{]) $balanced_re | [^\s,]+ ) )? (?:\s*,)?/gxco) {
my ($type, $repeated, $default_value)=($1, $2, $3);
if (defined $default_value) {
unless (defined $min) {
croak( "only optional arguments may have default values" );
}
$#defaults=$#proto; # fill in 'undef's for the omitted default values
push @defaults, eval "package $pkg; $default_value";
if ($@) {
$@ =~ s/ at \(eval \d+.*$//;
croak( "invalid default value for argument ", @proto+1, ": $@" );
}
}
push @proto, $type;
push @repeated, $repeated;
undef $fixed if defined($repeated);
next;
}
if (/\G\s* % \s*$/gxc) {
if (!@$kw) {
croak( "missing keyword argument descriptions" );
}
foreach my $table (@$kw) {
if (!is_hash($table)) {
croak( "expected a hash with keyword descriptions, got ", ref($table) || $table );
}
}
$min=@proto unless defined $min;
if (@defaults) {
$#defaults=$#proto; # fill in 'undef's for the omitted default values
}
return ($min, undef, @defaults ? \@defaults : undef, \@repeated, @proto);
}
if (/\G\s* \@ \s*$/gxc) {
$min=@proto unless defined $min;
return ($min, undef, @defaults ? \@defaults : undef, \@repeated, @proto);
}
croak( "invalid signature '$_'" );
}
if (@$kw) {
croak( "missing '%' in signature" );
}
$min=@proto unless defined $min;
return ($min, $fixed && scalar(@proto), @defaults ? \@defaults : undef, \@repeated, @proto);
}
####################################################################################
my %dictionary;
declare $override;
sub dict_node {
my ($pkg, $name, $is_method, $node_type)=@_;
my $node=$dictionary{$pkg}->{$name};
if (defined($node)) {
if (ref($node) ne $node_type) {
croak( $is_method ? "method" : "function", " $pkg\::$name ", $node->complain_mismatch );
}
} elsif (my ($sub, $own)=namespaces::lookup_sub($pkg,$name)) {
if ($own) {
if (!$override) {
croak( "non-overloaded ", $is_method ? "method" : "function", " $pkg\::$name already ",
$own==1 ? ("imported from package ", method_owner($sub)) : ("defined") );
}
} else {
$node=$dictionary{method_owner($sub)}
and
$node=$node->{$name}
and
$dictionary{$pkg}->{$name}=$node;
}
}
return $node;
}
####################################################################################
sub _add {
my ($caller, $labels, $name, $proto, @kw)=@_;
my $pkg= $name =~ s/^(.*)::([^:]+)$/$2/ ? $1 : $caller;
my $code=pop(@kw);
my $is_method=is_method($code);
my ($min, $max, $default_args, $repeated, @proto)=parse_signature($proto,$caller,\@kw);
if ($is_method) {
++$min;
++$max if defined($max);
unshift @proto, $pkg;
unshift @$default_args, undef if $default_args;
}
my $node_type= $labels ? "Poly::Overload::LabeledNode" : "Poly::Overload::Node";
my ($signature, @last_glob, $last_repeated);
my $arg= $is_method ? 0 : -1;
if (defined (my $node=dict_node($pkg, $name, $is_method, $node_type))) {
($signature)= $node->signature =~ /^([^,]+)/;
DESCEND: {
while (++$arg <= $#proto && $proto[$arg] eq "\$") { $signature.=",\$" }
if ($arg <= $#proto) {
EXISTING: {
if (defined (my $next_arg=$node->next_arg)) {
if ($next_arg == $arg) {
$node->expand($min,$max,undef,$code,$labels);
$min=$arg+1 if $min<=$arg;
my $next_node_sub=$proto[$arg]->can($signature);
if (defined($next_node_sub) && $proto[$arg] eq method_owner($next_node_sub)) {
# exact match - more than one function have the $arg-prefix, must descend deeper
$signature .= ",$proto[$arg]";
$signature =~ s/::/\@/g;
$node=&$next_node_sub;
redo DESCEND;
}
} elsif ($next_arg < $arg) {
$node->expand($min,$max,undef,$code,$labels);
$min=$next_arg+1 if $min<=$next_arg;
if (defined (my $next_node_sub=UNIVERSAL->can($node->signature))) {
$node=&$next_node_sub;
redo EXISTING;
}
my $uni_node=$node_type->new($min,$max,0);
if ($min<=$arg) {
$uni_node->push_code($code,$arg-$min+1,$labels);
$uni_node->default_args=$default_args;
$min=$arg+1;
}
$uni_node->signature=$signature;
$uni_node->next_arg=$arg;
define_function("UNIVERSAL", $node->signature, sub : method { $uni_node });
} else { # $next_arg > $arg
my $uni_node=$node->clone;
assign_max($uni_node->min_arg, $arg+1);
$node->expand($min,$max,undef,$code,$labels);
$min=$arg+1 if $min<=$arg;
$node->signature=$signature;
$node->next_arg=$arg;
define_function("UNIVERSAL", $signature, sub : method { $uni_node });
}
} else {
# existing signature is a prefix of the new one
my $uni_node= (!defined($node->max_arg) || $node->max_arg > $arg)
&& $node_type->new(max($node->min_arg, $arg+1), $node->max_arg, 0);
if ($uni_node) {
$uni_node->signature=$node->signature;
$node->signature=$signature;
$uni_node->default_args=$node->default_args;
push @{$uni_node->code}, splice @{$node->code}, max($arg+1-$node->min_arg, 0);
if (!defined($node->max_arg)) {
$uni_node->ellipsis_code=$node->ellipsis_code;
$node->ellipsis_code='';
}
define_function("UNIVERSAL", $signature, sub : method { $uni_node });
}
$node->next_arg=$arg;
$node->expand($min,$max,undef,$code,$labels);
if ($min<=$arg) {
$node->default_args=$default_args;
$min=$arg+1;
}
return $code if !$uni_node;
}
@last_glob=($proto[$arg], $signature);
$last_repeated=$repeated->[$arg];
$signature .= ",$proto[$arg]$last_repeated";
$signature =~ s/::/\@/g;
}
} else {
for (;;) {
$node->expand($min,$max,$arg,$code,$labels);
if (defined (my $next_arg=$node->next_arg)) {
if (!defined($max) || $max>$next_arg) {
if (defined (my $next_node_sub=UNIVERSAL->can($node->signature))) {
$min=$next_arg+1 if $min<=$next_arg;
$node=&$next_node_sub;
next;
} else {
--$arg;
@last_glob=("UNIVERSAL", $node->signature);
last;
}
}
}
return $code;
}
}
}
} else {
# first instance of this function
$signature=".$pkg\@$name";
$signature =~ s/::/\@/g;
}
my $min_reached=$min<=$arg;
for (;;) {
while (++$arg <= $#proto && $proto[$arg] eq "\$" && !$last_repeated && ($arg<$min || !@kw)) { $signature.=",\$" }
my $node=$node_type->new($min, $max, @last_glob && $last_glob[0] !~ /^UNIVERSAL::/);
if ($min<=$arg) {
$node->default_args=$default_args;
if (@kw) {
$node->keywords=\@kw;
$node->push_ellipsis_code($code, $labels);
if ($min_reached && @last_glob) {
my $kw_node=$node_type->new($min-1, undef, 0);
$kw_node->signature="$last_glob[1],\$";
$kw_node->default_args=$default_args;
$kw_node->keywords=\@kw;
$kw_node->push_ellipsis_code($code, $labels);
define_function("Poly::Overload::keyword", $last_glob[1], sub : method { $kw_node });
}
} else {
$node->push_code($code,$arg-$min+1,$labels);
}
$min=$arg+1;
$min_reached=1;
}
$node->signature=$signature;
if (@last_glob) {
define_function(@last_glob, sub : method { $node });
if ($last_repeated) {
my $repeat_node=$node->clone;
$repeat_node->next_arg=$arg;
undef $repeat_node->backtrack;
define_function($last_glob[0], $signature, sub : method { ++$_[0]; $repeat_node });
}
} else {
$dictionary{$pkg}->{$name}=$node;
define_function($pkg, $name,
sub { &{ $node->resolve(\@_) || complain($pkg,$name,$is_method,@_) } },
$is_method);
if ($is_method and !UNIVERSAL::isa($pkg, "Poly::Overload::can")) {
no strict 'refs';
push @{"$pkg\::ISA"}, "Poly::Overload::can";
}
}
if ($arg > $#proto) {
if (@kw) {
if ($last_repeated) {
my $kw_node=$node_type->new($node->min_arg,undef,0);
$kw_node->signature="$signature,\$";
$kw_node->default_args=$default_args;
$kw_node->keywords=\@kw;
$kw_node->push_ellipsis_code($code, $labels);
define_function("Poly::Overload::keyword", $signature, sub : method { $kw_node });
$node->next_arg=$arg;
}
} else {
$node->push_ellipsis_code($code,$labels) unless defined($max);
}
last;
}
$node->next_arg=$arg;
@last_glob=($proto[$arg] ne "\$" ? $proto[$arg] : "UNIVERSAL", $signature);
$last_repeated=$repeated->[$arg];
$signature .= ",$proto[$arg]$last_repeated";
$signature =~ s/::/\@/g;
}
$code;
}
####################################################################################
sub complain {
my ($pkg, $name, $is_method)=splice @_, 0, 3;
my @args=map { ref($_) || "\$" } @_;
if (my $leading_object=$is_method && shift @args) {
croak( "no matching overloaded instance of $leading_object\->$name(" . join(",", @args) . ")" );
} else {
croak( "no matching overloaded instance of $pkg\::$name(" . join(",", @args) . ")" );
}
}
####################################################################################
sub add {
shift; # get rid of own package name
my $caller=caller;
my $label=ref($_[0]) && shift;
$label=[ $label ] if is_object($label);
if (is_code($_[1])) {
# without signature
croak( "neither labels nor signature specified" ) unless $label;
my ($name, $code)=@_;
my $is_method=is_method($code);
my $pkg= $name =~ s/^(.*)::([^:]+)$/$2/ ? $1 : $caller;
my $node=dict_node($pkg, $name, $is_method, "Poly::Overload::Labeled");
if (!defined($node)) {
$node=$dictionary{$pkg}->{$name}=new Labeled;
define_function($pkg, $name, sub { goto &{ $node->[0] } }, $is_method);
}
Poly::Overload::LabeledNode::create_controls($node, $code, $label);
} else {
# with signature
my $code=_add($caller, $label, @_);
if ($label) {
$_[0]=~/([^:]+)$/;
set_sub_name($code, $1);
set_prototype($code, $_[1]);
}
}
}
####################################################################################
sub add_global {
shift; # get rid of own package name
my $caller=caller;
my $label=ref($_[0]) && shift;
$label=[ $label ] if is_object($label);
my $name=$_[0];
my $code=$_[-1];
croak( "cannot declare a non-method '$name' as global" ) unless is_method($code);
croak( "package $caller tries to declare method '$name' as global although it comes from different package" )
unless method_owner($code) eq $caller;
$code=_add($caller, undef, @_);
$name =~ s/^.*::([^:]+)$/$1/;
if ($label) {
set_sub_name($code, $name);
set_prototype($code, $_[1]);
}
_add("Poly::Overload::Global", $label, $name, @_[1..$#_-1], sub { $code });
}
####################################################################################
# for labeled functions returns the entire control list!
sub resolve {
(undef, my $function)=splice @_, 0, 2;
my $pkg= $function =~ s/^(.*)::([^:]+)$/$2/ ? $1 : caller;
my $node;
$node=$dictionary{$pkg} and $node=$node->{$function} and Poly::Overload::Node::resolve($node,\@_);
}
####################################################################################
sub process_keywords {
my $tables=shift;
# process the given arguments
# for performance reasons we duplicate some code instead of branching in the loop
my (@unknown, @processed_args, $table, $t);
if (@$tables>1) {
my $direct_table=0;
push @processed_args, {} for 0..$#$tables;
for (my $i=0; $i<=$#_; ++$i) {
my $key=$_[$i];
if (is_hash($key)) {
if ($direct_table > $#$tables) {
croak( "too many hash arguments" );
}
push %{$processed_args[$direct_table++]}, %$key;
} elsif (ref($key) || ++$i > $#_) {
croak( "KEYWORD => value pairs expected" );
} else {
my $known;
$t=0;
foreach $table (@$tables) {
if (exists $table->{$key}) {
$processed_args[$t]->{$key} = $_[$i];
$known=1;
}
++$t;
}
push @unknown, $key unless $known;
}
}
} else {
my $args=$processed_args[0]={ };
$table=$tables->[0];
for (my $i=0; $i<=$#_; ++$i) {
my $key=$_[$i];
if (is_hash($key)) {
@$args{ keys %$key }=values %$key;
} elsif (ref($key) || ++$i > $#_) {
croak( "KEYWORD => value pairs expected" );
} elsif (exists $table->{$key}) {
$args->{$key} = $_[$i];
} else {
push @unknown, $key;
}
}
}
if (@unknown) {
my %known;
push %known, %$_ for @$tables;
delete @known{ keys %$_ } for @processed_args;
croak( "unknown keyword argument", (@unknown>1 && "s"), ": ", join(", ", @unknown),
"\nallowed keywords are: ", join(", ", sort keys %known) );
}
# filter the values and fill in the defaults
$t=0;
foreach $table (@$tables) {
my $args=$processed_args[$t++];
while (my ($key, $descr)=each %$table) {
if (exists $args->{$key}) {
$descr=$descr->[0] if is_ARRAY($descr);
$descr->($args,$key) if is_code($descr);
} elsif (is_ARRAY($descr)) {
my $default=$descr->[1];
if (is_code($default)) {
$default->($args, $key);
} elsif (defined($default)) {
$args->{$key}=$default;
$descr=$descr->[0];
$descr->($args,$key) if is_code($descr);
}
} elsif (defined($descr) && !is_code($descr)) {
$args->{$key}=$descr;
}
}
}
@processed_args
}
sub Poly::enum {
my ($default, %enum);
foreach my $name (@_) {
if ($name =~ /=default$/) {
$default=$`;
$enum{$`}=1;
} else {
$enum{$name}=1;
}
}
my $accept=sub {
my ($self, $key)=@_;
$enum{$self->{$key}}
or croak( "unknown option value: $key => $self->{$key}" );
};
defined($default) ? [ $accept, $default ] : $accept;
}
####################################################################################
package Poly::Overload::can;
sub can {
my $head=&UNIVERSAL::can or return undef;
my ($method)=splice @_, 1, 1;
my $node=$dictionary{method_owner($head)};
($node &&= $node->{$method}) ? $head=$node->resolve(\@_) : @_==1 ? $head : undef
}
####################################################################################
1
syntax highlighted by Code2HTML, v. 0.9.1