1# Copyright (c) 1997-2021 2# Ewgenij Gawrilow, Michael Joswig, and the polymake team 3# Technische Universität Berlin, Germany 4# https://polymake.org 5# 6# This program is free software; you can redistribute it and/or modify it 7# under the terms of the GNU General Public License as published by the 8# Free Software Foundation; either version 2, or (at your option) any 9# later version: http://www.gnu.org/licenses/gpl.txt. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15#------------------------------------------------------------------------------- 16 17use strict; 18use namespaces; 19use warnings qw(FATAL void syntax misc); 20use feature 'state'; 21 22package Polymake::Core::BigObjectType; 23 24my $construct_node; 25sub construct_node : lvalue { $construct_node } 26 27# outer BigObjectType during rulefile loading 28declare $scope_owner; 29 30############################################################################## 31# Collection of information common to all Objects of the same type 32# (such as property names, rules, etc.) 33 34use Polymake::Struct ( 35 [ new => '$$@' ], 36# 37# Environmental data 38# 39 [ '$name' => '#1' ], # own name 40 [ '$application' => '#2' ], # -> Application 41 [ '$extension' => '$Extension::loading' ], 42 '$pkg', # perl class 43 [ '$context_pkg' => 'undef' ], # for abstract parameterized object types resulting from local derivation 44 # as a property of another parameterized BigObjectType: 45 # perl class of the enclosing BigObjectType (i.e. property owner) 46 [ '$params' => 'undef' ], # for parameterized types: list of BigObjectType or PropertyType describing the parameters 47 '&abstract', 48 [ '&perform_typecheck' => '\&PropertyType::concrete_typecheck' ], 49 [ '&construct' => '\&PropertyType::construct_object' ], 50 [ '&parse' => '\&BigObject::new_named' ], 51 [ '&toString' => '\&BigObject::print_me' ], 52 [ '&JSONschema' => '\&Serializer::big_object_schema' ], 53# 54# Derivation relations 55# 56 '@super', # ( BigObjectType ) base classes 57 # For non-parametrized and generic types it exactly reflects the object type declaration. 58 # For concrete instances of parametrized types the base classes follow in the order: 59 # - named full specializations (restricted by preconditions) 60 # - anonymous full specialization (w/o preconditions) 61 # - concrete instances of matching partial specializations 62 # - own generic type 63 # - concrete instance(s) of base types 64 '@linear_isa', # transitive closure of @super in C3 resolution order 65 [ '$generic' => 'undef' ], # BigObjectType of the own generic type; 66 # for concrete instances of partial specialization: the parametrized specialization 67 [ '$full_spez' => 'undef' ], # full specializations of parametrized types: concrete BigObjectType pkg or spez. name => Specialization 68# 69# Own components 70# 71 '%properties', # 'name' => Property 72 '%permutations', # 'name' => permutation Property 73 '%producers', # own rules producing a property: Property/Key => [ Rule, ... ] 74 '%all_producers', # cached own and inherited rules: Property/Key => [ Rule, ... ] 75 '%shortcuts', # cached own and inherited shortcut rules 76 '%rules_by_label', # own labeled producing rules: '*.label' => ControlList 77 '%all_rules_by_label', # cached own and inherited labeled rules 78 '@production_rules', # ( Rule ) all production rules directly applicable to this object type and descendants (for search by header) 79# 80 [ '$specializations' => 'undef' ], # ( Specialization ) for parameterized types with partial specializations: the abstract objects 81 [ '$borrowed_from' => 'undef' ], # other Specializations defining properties this Specialization or generic type refers to 82# 83 [ '$help' => 'undef' ], # Help::Topic if loaded 84); 85 86#################################################################################### 87# 88# Constructor 89# 90# new BigObjectType('name', Application, [ type params ], [ super BigObjectType, ... ]); 91# 92sub new { 93 my $self = &_new; 94 Struct::learn_package_retrieval($self, \&pkg); 95 my $tparams = splice @_, 0, 3; 96 my $self_sub = sub { $self }; 97 my $generic_type; 98 99 unless ($construct_node) { 100 $construct_node = new_root Overload::Node; 101 Overload::add_instance("Polymake::Core::BigObject", ".construct", undef, \&BigObject::new_empty, 102 [0, 0], undef, $construct_node); 103 $construct_node->add_fallback(\&BigObject::new_filled); 104 } 105 106 if (defined($self->application)) { 107 $self->pkg = $self->application->pkg."::".$self->name; 108 if (defined($tparams)) { 109 $self->abstract = \&type; 110 undef $self->perform_typecheck; 111 $self->params = PropertyParamedType::create_param_placeholders($self->pkg, $self->application, $tparams); 112 } 113 Overload::add_instance($self->pkg, ".construct", undef, \&BigObject::new_copy, 114 [1, 1, $self->pkg ], undef, $construct_node); 115 Overload::add_instance($self->pkg, ".construct", undef, \&BigObject::new_filled_copy, 116 [3, 3+Overload::SignatureFlags::has_trailing_list, $self->pkg, '$', '$'], undef, $construct_node); 117 } else { 118 # it is an instance of an abstract BigObject type 119 # the first super-BigObject is always the own abstract type 120 $generic_type = $_[0]; 121 $self->application = $generic_type->application; 122 $self->extension = $generic_type->extension; 123 $self->pkg = $generic_type->pkg; 124 $self->params = $tparams; 125 PropertyParamedType::scan_params($self); 126 if ($self->abstract) { 127 if (defined($self->context_pkg)) { 128 push @{$self->super}, $generic_type; 129 push @{$self->linear_isa}, $generic_type, @{$generic_type->linear_isa}; 130 $self->generic=$generic_type; 131 } 132 return $self; 133 } 134 define_function($self->pkg, "typeof", $self_sub, 1); 135 } 136 137 define_function($self->pkg, "type", $self_sub, 1); 138 if (!$self->abstract) { 139 define_function($self->pkg, ".type", $self_sub); 140 } 141 PropertyType::create_method_new($self); 142 143 # proceed with parent classes 144 if (@_) { 145 set_extension($self->extension, $_->extension) for @_; 146 modify_super($self, 0, 0, @_); 147 if (defined $generic_type) { 148 $self->generic=$generic_type; 149 150 my %required_spezs; 151 if (defined $generic_type->borrowed_from) { 152 $required_spezs{$_}=1 for keys %{$generic_type->borrowed_from}; 153 } 154 if (defined $generic_type->specializations) { 155 my @matching_spezs=map { pick_specialization($_, $self) } @{$generic_type->specializations}; 156 157 foreach my $spez (@matching_spezs) { 158 my $gen_spez=$spez->generic; 159 $required_spezs{$gen_spez} |= 2; 160 if (defined $gen_spez->borrowed_from) { 161 $required_spezs{$_} |= 1 for keys %{$gen_spez->borrowed_from}; 162 } 163 } 164 165 modify_super($self, 0, 0, @matching_spezs); 166 } 167 168 # verify correctness of inheritance relationship between specializations 169 while (my ($spez, $status)=each %required_spezs) { 170 if ($status == 1 && list_index($self->linear_isa, $spez)<0) { 171 my @bad=grep { defined($_->borrowed_from) && $_->borrowed_from->{$spez} } @{$self->super}; 172 die "Invalid inheritance: ", join(", ", map { $_->full_name } @bad), 173 "\n refer", @bad==1 && "s", " to properties defined in ", $spez->full_name, 174 "\n which does not match the object type ", $self->full_name, "\n"; 175 } 176 } 177 } 178 } else { 179 no strict 'refs'; 180 push @{$self->pkg."::ISA"}, "Polymake::Core::BigObject"; 181 mro::set_mro($self->pkg, "c3"); 182 } 183 184 push @{$self->application->object_types}, $self; 185 $self; 186} 187 188#################################################################################### 189sub pick_specialization { 190 my $spez=shift; 191 &{$spez->match_node->resolve(\@_) // return ()} 192} 193 194sub all_partial_specializations { 195 my ($self, $for_spez)=@_; 196 ( ($self != $for_spez && defined($self->specializations) 197 ? (grep { $_ != $for_spez } @{$self->specializations}) : () ), 198 map { defined($_->specializations) ? @{$_->specializations} : () } @{$self->linear_isa} 199 ) 200} 201#################################################################################### 202sub full_specialization { 203 my ($self, $concrete) = @_; 204 ($self->full_spez //= { })->{$concrete->pkg} //= new Specialization(undef, $concrete->pkg."::_Full_Spez", $concrete); 205} 206#################################################################################### 207sub modify_super { 208 my ($self, $pos, $remove, @types) = @_; 209 mro::set_mro($self->pkg, "c3") unless @{$self->super}; 210 splice @{$self->super}, $pos, $remove, @types; 211 my @pkgs = map { $_->pkg } @types; 212 namespaces::using($self->pkg, @pkgs); 213 no strict 'refs'; 214 splice @{$self->pkg."::ISA"}, $pos, $remove, @pkgs; 215 update_inheritance($self); 216} 217 218sub update_inheritance { 219 my ($self) = @_; 220 my $linear_isa = mro::get_linear_isa($self->pkg); 221 # ignore the type itself and ubiquitous BigObject 222 @{$self->linear_isa} = map { $_->type } grep { !/^Polymake::Core::/ } @$linear_isa[1..$#$linear_isa]; 223} 224 225sub concrete_instances { 226 my ($self) = @_; 227 grep { $_->generic == $self && !$_->abstract } &derived 228} 229 230sub concrete_super_instances { 231 my ($self) = @_; 232 my @list; 233 foreach my $super (reverse @{$self->super}) { 234 last if $super->abstract || $super->full_spez_for == $self; 235 push @list, $super; 236 } 237 reverse @list 238} 239#################################################################################### 240sub isa { 241 my ($self, $other) = @_; 242 if (is_string($other)) { 243 $other = $self->application->eval_type($other, 1) or return; 244 } 245 return $self == $other || list_index($self->linear_isa, $other) >= 0; 246} 247#################################################################################### 248sub deserialize : method { 249 my ($self, $src) = @_; 250 if (is_hash($src)) { 251 &BigObject::deserialize 252 } else { 253 croak( "wrong serialized representation of ", $self->full_name, " - anonymous hash expected" ); 254 } 255} 256#################################################################################### 257# for compatibility with PropertyType: 258 259*type=\&PropertyType::type; 260*mangled_name=\&PropertyParamedType::mangled_name; 261*full_name=\&PropertyParamedType::full_name; 262*typecheck=\&PropertyType::typecheck; 263*add_constructor=\&PropertyType::add_constructor; 264*performs_deduction=\&PropertyParamedType::performs_deduction; 265*set_extension=\&PropertyParamedType::set_extension; 266*type_param_index=\&PropertyType::type_param_index; 267*derived=\&PropertyType::derived; 268define_function(__PACKAGE__, ".type", \&type); 269 270sub qualified_name { 271 my ($self) = @_; 272 defined($self->params) && !$self->abstract ? &PropertyParamedType::qualified_name : &PropertyType::qualified_name 273} 274 275sub required_extensions { 276 my ($self) = @_; 277 defined($self->params) && !$self->abstract ? &PropertyParamedType::required_extensions : &PropertyType::required_extensions 278} 279 280sub concrete_type { 281 # undef context_pkg means we are in a generic parameterized object class, hence nothing to deduce 282 defined($_[0]->context_pkg) ? &PropertyParamedType::concrete_type : pop 283} 284 285sub descend_to_generic { 286 my ($self, $pkg)=@_; 287 if (@{$self->linear_isa}) { 288 return $self if defined($self->generic) && $self->generic->pkg eq $pkg; 289 foreach my $super_proto (@{$self->linear_isa}) { 290 return $super_proto if defined($super_proto->generic) && $super_proto->generic->pkg eq $pkg; 291 } 292 } 293 undef 294} 295#################################################################################### 296sub find_super_type_param { 297 my ($self, $name) = @_; 298 my @result; 299 foreach my $super (@{$self->linear_isa}) { 300 if (!instanceof Augmented($super) and defined($super->params) and my ($param) = grep { $_->name eq $name } @{$super->params}) { 301 @result = ($super, $param); 302 } 303 } 304 @result; 305} 306#################################################################################### 307# "property name" => Property or undef 308sub lookup_property { 309 my ($obj_type, $prop_name) = @_; 310 # full spezialization objects share all properties with full instances 311 my $self = $obj_type->full_spez_for // $obj_type; 312 # negative results are not cached 313 $self->properties->{$prop_name} // do { 314 my $prop; 315 foreach my $super (@{$self->linear_isa}) { 316 if (defined($prop = $super->properties->{$prop_name})) { 317 if ($prop->flags & Property::Flags::is_permutation) { 318 $prop = instantiate_permutation($self, $prop); 319 } elsif (!$self->abstract && ($prop->flags & Property::Flags::is_subobject || !($prop->flags & Property::Flags::is_concrete))) { 320 $prop = instantiate_property($self, $prop_name, $prop); 321 } 322 return $self->properties->{$prop_name} = $prop; 323 } 324 } 325 if ($self->abstract) { 326 foreach my $spez (($self->generic // $self)->all_partial_specializations($self)) { 327 if (defined($prop = $spez->properties->{$prop_name})) { 328 $spez = $prop->defined_for; 329 my ($borrower, $lender) = ($self->outer_object_type, $spez->outer_object_type); 330 ($borrower->borrowed_from //= { })->{$lender} ||= do { 331 # verify the correctness of borrowing 332 foreach my $proto ($borrower->concrete_instances) { 333 if (list_index($proto->linear_isa, $lender) < 0) { 334 die "Invalid inheritance: ", $self->full_name, 335 "\n refers to property $prop_name defined in ", $spez->full_name, 336 "\n which does not match the derived object type ", $proto->full_name, "\n"; 337 } 338 } 339 1 340 }; 341 return $self->properties->{$prop_name} = $prop; 342 } 343 } 344 } 345 undef 346 } 347} 348 349sub instantiate_property { 350 my ($self, $prop_name, $prop) = @_; 351 if ($prop->name ne $prop_name) { 352 # found an overridden property in one of the ancestors: 353 # take the overriding instance 354 if ($prop->overrides ne $prop_name) { 355 die "internal error: property ", $prop->name, " cached under the name '$prop_name'\n"; 356 } 357 return lookup_property($self, $prop->name); 358 } 359 my $owner = $prop->belongs_to; 360 if (defined(my $gen_proto = $owner->generic)) { 361 # move from a specialization to the abstract type 362 $owner = $gen_proto; 363 } 364 if ($owner == $self->generic) { 365 unless ($prop->flags & Property::Flags::is_concrete) { 366 $prop = $prop->clone_for_owner($self); 367 create_prop_method($self, $prop); 368 } 369 $prop 370 } else { 371 if ($prop->flags & Property::Flags::is_subobject) { 372 # instantiate the property for each of the concrete ancestors; they are dwelling at the end of the base class list 373 # augmented instances might need to be mixed in the case of multiple inheritance 374 if (my @instances = collect_augmented_super_instances($self, $prop_name)) { 375 if (@instances > 1) { 376 $prop = $prop->clone_for_augmented(new Augmented($prop, $self, map { $_->type } @instances)); 377 create_prop_method($self, $prop); 378 return $prop; 379 } else { 380 return $instances[0]; 381 } 382 } elsif ($prop->flags & Property::Flags::is_concrete) { 383 return $prop; 384 } 385 } 386 387 # instantiate the property at its birthplace 388 foreach my $super (@{$self->linear_isa}) { 389 # the concrete object type must appear before all specializations and generic types 390 if ($super->generic == $owner) { 391 # if $self is a parametrized augmented type, we might have found the abstract property instance cached in the generic augmented type 392 # because it precedes the pure types in the inheritance list, thus in fact the concrete property instance might already exist 393 return $super->properties->{$prop_name} //= do { 394 $prop = $prop->clone_for_owner($super); 395 create_prop_method($super, $prop); 396 $prop 397 }; 398 } 399 } 400 croak( "internal error: could not find the concrete instance of ", $owner->full_name, " among ancestors of ", $self->full_name, 401 " (", join(", ", map { $_->full_name } @{$self->super}), ") while instantiating property ", $prop->name ); 402 } 403} 404 405sub instantiate_permutation { 406 my ($self, $prop) = @_; 407 # only a dependent abstract type may inherit the permutation instance from its generic type, 408 # all other types might introduce own properties and therefore need personalized permutation instances 409 if ($self->abstract && defined($self->context_pkg)) { 410 if ($prop->belongs_to != $self->generic) { 411 $prop = lookup_property($self->generic, $prop->name); 412 } 413 } else { 414 $prop = $prop->clone_for_owner($self); 415 create_prop_method($self, $prop); 416 } 417 $prop 418} 419 420sub lookup_overridden_property { 421 my ($self, $prop) = @_; 422 foreach my $super (@{$self->linear_isa}) { 423 if ($super->full_spez_for != $self && !$super->isa($prop->overrides_for) && $super->isa($prop->defined_for)) { 424 return lookup_property($super, $prop->overrides); 425 } 426 } 427 undef 428} 429 430sub property { 431 my ($self, $prop_name) = @_; 432 lookup_property($self, $prop_name) or croak( "unknown property ", $self->full_name, "::$prop_name" ); 433} 434 435sub init_pseudo_prop { 436 state $prop = _new Property(".initial", undef, undef); 437} 438 439sub collect_augmented_super_instances { 440 my ($self, $prop_name) = @_; 441 my @list; 442 foreach my $super ($self->concrete_super_instances) { 443 if (defined(my $found_prop = lookup_property($super, $prop_name))) { 444 if ($found_prop->flags & Property::Flags::is_augmented) { 445 if (@list == 1 && !($list[0]->flags & Property::Flags::is_augmented)) { 446 $list[0] = $found_prop; 447 } elsif (!@list || list_index(\@list, $found_prop) < 0) { 448 push @list, $found_prop; 449 } 450 } elsif (!@list) { 451 push @list, $found_prop; 452 } 453 } 454 } 455 @list 456} 457 458sub help_ref_to_prop { 459 my ($self, $from_app, $prop_name)=@_; 460 ($self->application != $from_app && $self->application->name."::").$self->name."::$prop_name"; 461} 462#################################################################################### 463# "property name" => bool 464# Returns TRUE if the property is overridden for this object type or one of its ancestors. 465# Returns undef if the property is not known at all. 466sub is_overridden { 467 my ($self, $prop_name) = @_; 468 if (defined(my $prop = lookup_property($self, $prop_name))) { 469 $prop->name ne $prop_name; 470 } else { 471 undef 472 } 473} 474#################################################################################### 475# Property => "name" 476# Returns the name of the overriding property if appropriate. 477sub property_name { 478 my ($self, $prop) = @_; 479 lookup_property($self, $prop->property_name)->name 480} 481#################################################################################### 482sub list_permutations { 483 my ($self) = @_; 484 (values %{$self->permutations}), (map { values %{$_->permutations} } @{$self->linear_isa}) 485} 486#################################################################################### 487# private: 488sub create_prop_method { 489 my ($self, $prop)=@_; 490 define_function($self->pkg, $prop->name, 491 create_prop_accessor($prop->flags & Property::Flags::is_multiple 492 ? [ $prop, \&BigObject::get_multi, \&BigObject::put_multi ] 493 : [ $prop, \&BigObject::get, \&BigObject::put ], 494 $self->pkg)); 495} 496 497# private: 498sub add_property { # => Property 499 my ($self, $prop) = @_; 500 if ($enable_plausibility_checks && defined(my $old_prop = lookup_property($self, $prop->name))) { 501 croak( $old_prop->belongs_to == $self 502 ? "multiple definition of property '".$prop->name."'" 503 : "redefinition of inherited property '".$prop->name."' not allowed" ); 504 } 505 &create_prop_method; 506 $self->properties->{$prop->name} = $prop; 507} 508 509sub add_permutation { 510 my ($self, $name, $pure_prop) = @_; 511 if ($enable_plausibility_checks && defined(my $old_prop = lookup_property($self, $name))) { 512 croak( $old_prop->flags & Property::Flags::is_permutation 513 ? ( $old_prop->belongs_to == $self 514 ? "multiple definition of permutation '$name'" 515 : "redefinition of inherited permutation '$name' not allowed" ) 516 : "permutation $name conflicts with property ".$old_prop->defined_for->full_name."::$name" ); 517 } 518 my $perm = new Permutation($name, $self->augment($pure_prop), $self); 519 create_prop_method($self, $perm); 520 $pure_prop->name .= ".pure"; 521 $pure_prop->flags |= Property::Flags::is_non_storable; 522 $self->properties->{$pure_prop->name} = $pure_prop; 523 $self->permutations->{$name} = 524 $self->properties->{$name} = $perm; 525} 526#################################################################################### 527# private: 528sub find_overridden_property { 529 my ($self, $prop_name) = @_; 530 my $prop; 531 foreach my $super (@{$self->linear_isa}) { 532 # only properties inherited from other types or from other enclosing types may be overridden 533 if ($super != $self->generic && $super->outer_object_type != $scope_owner) { 534 defined($prop = lookup_property($super, $prop_name)) 535 and return $prop; 536 } 537 } 538 # this will croak if $prop_name is unknown 539 $prop = property($self, $prop_name); 540 croak( "Can't override a property $prop_name defined in the same class family ", $prop_name->defined_for->full_name ); 541} 542#################################################################################### 543sub override_property { # "new name", "old name", Help => Property 544 my ($self, $prop_name, $old_prop_name, $new_type, $help) = @_; 545 if ($enable_plausibility_checks) { 546 if (defined($old_prop_name)) { 547 if (instanceof Specialization($scope_owner) && !$scope_owner->is_anon_full_spez) { 548 croak( "A property can't be overridden in a partial or conditional specialization" ); 549 } 550 } else { 551 if (instanceof Specialization($self) || instanceof Augmented($self)) { 552 croak( "Property type can only be overridden in a derived object type" ); 553 } 554 } 555 } 556 my $old_prop = find_overridden_property($self, $old_prop_name // $prop_name); 557 558 if ($enable_plausibility_checks && defined($new_type)) { 559 $old_prop->flags & Property::Flags::is_subobject 560 or croak( "invalid type override for an atomic property ", $old_prop_name // $prop_name ); 561 if ($old_prop->flags & Property::Flags::is_twin and $new_type != $self) { 562 croak( "Twin property $prop_name automatically inherits the enclosing object type, the override definition must end with ': self'" ); 563 } 564 if ($new_type->pkg eq $old_prop->type->pkg) { 565 croak( "invalid property type override: new type is identical to the overridden one" ); 566 } 567 ($new_type->generic // $new_type)->isa($old_prop->type->pure_type->generic // $old_prop->type->pure_type) 568 or croak( "invalid property type override: ", $new_type->full_name, " is not derived from ", $old_prop->type->pure_type->full_name ); 569 } 570 571 my $prop=$old_prop->override_by($prop_name, $self, $new_type); 572 573 if (defined($new_type) and $old_prop->flags & Property::Flags::is_augmented) { 574 $prop->change_to_augmented(new Augmented($prop, $self)); 575 } 576 577 if (defined($old_prop_name)) { 578 $self->properties->{$old_prop_name} = add_property($self, $prop); 579 define_function($self->pkg, $old_prop_name, UNIVERSAL::can($self->pkg, $prop_name)); 580 581 if (defined($help)) { 582 $help->annex->{header} = "property $prop_name : ".$prop->type->full_name."\n"; 583 weak($help->annex->{property} = $prop); 584 $help->text =~ s/UNDOCUMENTED\n//; 585 $help->text .= " Alias for property [[" . $old_prop->defined_for->help_ref_to_prop($self->application, $old_prop_name) . "]].\n"; 586 } 587 } else { 588 $self->properties->{$prop_name} = $prop; 589 create_prop_method($self, $prop); 590 591 # derived classes might have cached the original property or its concrete instances 592 foreach my $derived ($self->derived) { 593 my $cached_prop = $derived->properties->{$prop_name} or next; 594 if ($cached_prop == $old_prop) { 595 $derived->properties->{$prop_name} = $prop; 596 } elsif ($cached_prop->flags & Property::Flags::is_concrete && $self->isa($cached_prop->belongs_to->generic // $cached_prop->belongs_to)) { 597 delete $derived->properties->{$prop_name}; 598 } 599 } 600 } 601 $prop; 602} 603#################################################################################### 604# protected: 605sub invalidate_prod_cache { 606 my ($self, $key) = @_; 607 if (defined(delete $self->all_producers->{$key})) { 608 delete $self->shortcuts->{$key}; 609 invalidate_prod_cache($_, $key) for $self->derived; 610 } 611} 612 613 614sub rule_is_applicable { 615 my ($self, $rule) = @_; 616 if (defined(my $overridden_in = $rule->overridden_in)) { 617 foreach my $other (@$overridden_in) { 618 return 0 if $self == $other || list_index($self->linear_isa, $other) >= 0; 619 } 620 } 621 1 622} 623 624sub add_producers_of { 625 my ($self, $key) = splice @_, 0, 2; 626 push @{$self->producers->{$key}}, @_; 627 invalidate_prod_cache($self, $key); 628} 629 630sub get_producers_of { 631 my ($self, $prop, $stop_after) = @_; 632 my $key = $prop->key; 633 $self->all_producers->{$key} ||= do { 634 my @list; 635 if (defined(my $own_prod = $self->producers->{$key})) { 636 @list = @$own_prod; 637 } 638 if (!defined($stop_after) && defined($prop->defined_for)) { 639 $stop_after = $prop->defined_for->pure_type; 640 if (defined($stop_after->generic)) { 641 $stop_after = $stop_after->generic; 642 } elsif (!defined($stop_after->abstract)) { 643 # this is not an abstract super type so we need to find the last 644 # matching specialization to check all of them for rules 645 my @siblings = grep {defined($_->full_spez_for) && $_->full_spez_for->pure_type == $stop_after} @{$stop_after->linear_isa}; 646 if (@siblings > 0) { 647 $stop_after = $siblings[-1]; 648 } 649 } 650 } 651 if ($stop_after != $self) { 652 foreach my $super_proto (@{$self->linear_isa}) { 653 $super_proto->all_producers->{$key} //= 0; # mark for cache invalidation 654 if (defined(my $super_prod = $super_proto->producers->{$key})) { 655 push @list, grep { rule_is_applicable($self, $_) } @$super_prod; 656 } 657 last if $stop_after == $super_proto; 658 } 659 } 660 \@list 661 }; 662} 663 664# only shortcuts directly creating the property asked for are stored here 665sub get_shortcuts_for { 666 my ($self, $prop) = @_; 667 $self->shortcuts->{$prop->key} //= 668 [ grep { instanceof Rule::Shortcut($_) and 669 $_->output->[0]->[-1]->key == $prop->property_key 670 } @{ $self->get_producers_of($prop) } 671 ] 672} 673#################################################################################### 674# protected: 675sub invalidate_label_cache { 676 my ($self, $wildcard) = @_; 677 if (defined(delete $self->all_rules_by_label->{$wildcard})) { 678 invalidate_label_cache($_, $wildcard) for $self->derived; 679 } 680} 681 682sub get_rules_by_label { 683 my ($self, $wildcard) = @_; 684 $self->all_rules_by_label->{$wildcard} ||= do { 685 # signal for invalidate_label_cache should it happen later 686 $_->all_rules_by_label->{$wildcard} //= 0 for @{$self->linear_isa}; 687 Preference::merge_controls(grep { defined($_) } map { $_->rules_by_label->{$wildcard} } $self, @{$self->linear_isa}) 688 }; 689} 690 691#################################################################################### 692# protected: 693sub add_rule_labels { 694 my ($self, $rule, $labels)=@_; 695 foreach my $label (@$labels) { 696 my $wildcard = $label->wildcard_name; 697 my $ctl_list; 698 if (defined ($ctl_list = $self->rules_by_label->{$wildcard})) { 699 invalidate_label_cache($self, $wildcard); 700 } else { 701 $self->rules_by_label->{$wildcard} = $ctl_list = [ ]; 702 } 703 $label->add_control($ctl_list, $rule); 704 } 705} 706#################################################################################### 707# protected: 708# "NAME.NAME" => (Property) 709sub encode_descending_path { 710 my ($self, $string) = @_; 711 my $prop; 712 map { 713 $self = $prop->type if $prop; 714 $prop = property($self, $_); 715 } split /\./, $string; 716} 717 718# "parent.<...>.PROP_NAME.<...> => Property::Path 719# Leading "parents" may also be expressed as "ancestor(TYPE)" 720sub encode_property_path { 721 my ($self, $string)=@_; 722 my $up=0; 723 while ($string =~ s/^parent\.//) { 724 if (instanceof Augmented($self)) { 725 ++$up; 726 $self=$self->parent_property->belongs_to; 727 } else { 728 croak("can't refer to parents of a non-augmented object type ", $self->full_name); 729 } 730 } 731 if (!$up && $string =~ s/^ancestor\(($balanced_re)\)\.//) { 732 my $parent_type=eval "typeof $1"; 733 croak("invalid parent type $1: $@") if $@; 734 for (;;) { 735 if (instanceof Augmented($self)) { 736 ++$up; 737 $self=$self->parent_property->belongs_to; 738 if ($self->isa($parent_type)) { 739 last; 740 } 741 } elsif ($up) { 742 croak($_[0]->full_name, " has no ascendants of type ", $parent_type->full_name); 743 } else { 744 croak("can't refer to parents of a non-augmented object type ", $self->full_name); 745 } 746 } 747 } 748 new Property::Path($up, encode_descending_path($self, $string)); 749} 750 751# 'NAME.NAME | ...' => [ [ Property, ... ] ] 752# flags(RETVAL)==Property::Flags::is_permutation if the paths descend into a permutation subobject 753sub encode_read_request { 754 my ($self, $req)=@_; 755 my $perm_seen; 756 my @alternatives=map { 757 my @path=encode_descending_path($self, $_); 758 $perm_seen ||= Property::find_first_in_path(\@path, Property::Flags::is_permutation)>=0; 759 \@path 760 } split /\s*\|\s*/, $req; 761 if ($perm_seen) { 762 set_array_flags(\@alternatives, Property::Flags::is_permutation); 763 } 764 \@alternatives 765} 766#################################################################################### 767# for compatibility with Augmented types, e.g. when only derived owner types define some additional properties 768*pure_type=\&type; 769sub final_type { pop } 770sub outer_object_type { shift } 771sub parent_property { undef } 772sub enclosed_in_restricted_spez { 0 } 773 774# for compatibility with Specialization 775sub preconditions { undef } 776sub full_spez_for { undef } 777sub is_anon_full_spez { 0 } 778#################################################################################### 779sub override_rule { 780 my ($self, $super, $label)=@_; 781 my $matched; 782 foreach my $rule ($label->list_all_rules) { 783 if (is_object($super)) { 784 next if !$super->isa($rule->defined_for); 785 } else { 786 next if $self==$rule->defined_for || list_index($self->linear_isa, $rule->defined_for)<0; 787 } 788 $matched=1; 789 if (defined($rule->overridden_in)) { 790 push @{$rule->overridden_in}, $self if list_index($rule->overridden_in, $self)<0; 791 } else { 792 $rule->overridden_in=[ $self ]; 793 } 794 } 795 if ($enable_plausibility_checks && !$matched) { 796 warn_print( "\"$_[3]\", line $_[4]: override declaration does not match any inherited rules" ); 797 } 798} 799#################################################################################### 800sub find_rule_label { 801 my ($self, $pattern)=@_; 802 $self->application->prefs->find_label($pattern) 803} 804 805sub find_rules_by_pattern { 806 my ($self, $pattern)=@_; 807 if ($pattern =~ /^ $hier_id_re $/xo) { 808 # specified by label 809 my $label=$self->find_rule_label($pattern) 810 or die "unknown label \"$pattern\"\n"; 811 grep { $self->isa($_->defined_for) } $label->list_all_rules 812 813 } elsif ($pattern =~ /:/) { 814 # specified by header: 815 Rule::header_search_pattern($pattern); 816 grep { $_->header =~ $pattern } map { @{$_->production_rules} } $self, @{$self->linear_isa} 817 818 } else { 819 die "invalid rule search pattern: expected a label or a complete header in the form \"OUTPUT : INPUT\"\n"; 820 } 821} 822 823sub disable_rules { 824 my @rules=&find_rules_by_pattern 825 or die "no matching rules found\n"; 826 Scheduler::temp_disable_rules(@rules); 827} 828#################################################################################### 829sub add_method_rule { 830 my ($self, $header, $code, $name)=@_; 831 my $rule = special Rule($header, $code, $self); 832 $rule->flags = Rule::Flags::is_function; 833 substr($rule->header, 0, 0) = "user_method "; 834 $rule->analyze_spez_preconditions; 835 if (defined($name)) { 836 # non-polymorphic method, no call redirection via overload resolution 837 my $rules = [ $rule ]; 838 define_function($self->pkg, $name, 839 sub : method { 840 &{ (Scheduler::resolve_rules($_[0], $rules) // croak("could not provide all required input properties") )->code }; 841 }); 842 } 843 $rule; 844} 845#################################################################################### 846sub augment { 847 my ($self, $prop)=@_; 848 my ($augm, $augm_super, $cloned_prop, $update_caches); 849 850 if ($prop->flags & Property::Flags::is_permutation) { 851 my $pure_prop = $prop->type->pure_property; 852 $augm = $self->augment($pure_prop); 853 $prop->change_to_augmented($augm); 854 # TODO: reactivate if needed, or delete, together with Permutation::update_pure_type 855 if (false) { 856 # update permuted types in every derived class to use the augmented base "pure" type 857 foreach my $derived (grep { $_ != $self->full_spez_for && !defined($_->full_spez_for) } $self->derived) { 858 my $cached_prop = $derived->properties->{$prop->name} or next; 859 $cached_prop != $prop 860 or croak( "internal error: permutation ", $prop->name, " instance shared between different types ", 861 $derived->full_name, " and ", $self->full_name ); 862 $cached_prop->update_pure_type(property($derived, $pure_prop->name)->type); 863 } 864 } 865 866 } elsif ($prop->belongs_to == $self) { 867 if ($prop->flags & Property::Flags::is_augmented and 868 !defined($prop->overrides) || $prop->type->parent_property == $prop) { 869 return $prop->type; 870 } 871 $augm = new Augmented($prop, $self); 872 $prop->change_to_augmented($augm); 873 $update_caches = !($prop->flags & Property::Flags::is_concrete); 874 875 } elsif ($prop->belongs_to == $self->full_spez_for) { 876 return Specialization::augment_in_full_spez($self, $prop); 877 878 } else { 879 ($augm, $augm_super, $update_caches) = $self->create_augmentation($prop); 880 $cloned_prop = $self->properties->{$prop->name} = $prop->clone_for_augmented($augm, $self); 881 create_prop_method($self, $cloned_prop); 882 } 883 884 if ($update_caches) { 885 # derived classes might have cached the original property; update or delete the cache entries 886 foreach my $derived ($self->derived) { 887 my $cached_prop = $derived->properties->{$prop->name} or next; 888 if ($cached_prop == $prop) { 889 if (defined($cloned_prop)) { 890 # the derived class has inherited the original property, now it is shadowed by the cloned one 891 if ($cloned_prop->flags & Property::Flags::is_concrete || $derived->abstract) { 892 $derived->properties->{$prop->name} = $cloned_prop; 893 } else { 894 # augmentation is parametrized, the concrete instance will be created later on demand 895 delete $derived->properties->{$prop->name}; 896 } 897 } elsif (!($prop->flags & Property::Flags::is_concrete || $derived->abstract) || $prop->flags & Property::Flags::is_permutation) { 898 # augmentation is parametrized, the concrete instance will be created later on demand 899 delete $derived->properties->{$prop->name}; 900 } 901 902 } elsif (defined($augm_super)) { 903 # other augmentations downstream have already been treated by the new augmentation itself; 904 # only handle classes which inherited a concrete instance of augm_super 905 if ($augm_super == $cached_prop->type->generic) { 906 if ($derived->generic == ($self->generic // $self)) { 907 # clone the property for this concrete instance; 908 # the augmentation will propagate itself to all concrete descendants 909 my $cloned_concrete_prop = 910 $derived->properties->{$prop->name} = 911 $prop->clone_for_augmented($augm->concrete_type($derived, $cached_prop->type), $derived); 912 create_prop_method($derived, $cloned_concrete_prop); 913 } else { 914 # it's an intermediate class without own augmentations 915 delete $derived->properties->{$prop->name}; 916 } 917 } 918 } elsif ($cached_prop->flags & Property::Flags::is_augmented) { 919 # this augmentation was at the root of the hierarchy, now it has to absorb the new one 920 if ($cached_prop->type->super->[0] == $cached_prop->type->pure_type) { 921 $cached_prop->type->inject_inheritance($augm); 922 } 923 924 } else { 925 # cached_prop must be a concrete instance of the generic original property 926 ($cached_prop->flags & Property::Flags::is_concrete) > ($prop->flags & Property::Flags::is_concrete) 927 or croak( "internal error: unexpected property instance of ", $cached_prop->name, 928 " found in ", $derived->full_name ); 929 if (defined($cloned_prop) || $derived->generic != ($self->generic // $self)) { 930 # the derived class has inherited a concrete instance of the original property; 931 # a new concrete instance will be created or fetched later on demand 932 delete $derived->properties->{$prop->name}; 933 } else { 934 # we can't delete the property because it's stored in the accessor methods; 935 # this will create a new concrete augmentation which won't have any descendants yet 936 $cached_prop->change_to_augmented($augm->concrete_type($derived)); 937 } 938 } 939 } 940 } 941 942 $augm 943} 944 945sub create_augmentation { 946 my ($self, $prop)=@_; 947 my @augm_super= $prop->flags & Property::Flags::is_augmented ? ($prop->type) : (); 948 my $augm=new Augmented($prop, $self, @augm_super); 949 ($augm, $augm_super[0], 1); 950} 951#################################################################################### 952sub help_topic { 953 my $self=shift; 954 $self->help // ($self->application // return)->help->find_type_topic($self, "objects", @_); 955} 956#################################################################################### 957sub override_help { 958 my ($self, $group, $item, $text)=@_; 959 my ($inherited_topic)=map { $_->help_topic(1)->find($group, $item) } @{$self->linear_isa} 960 or croak( "help topic $group/$item not found anywhere in base types of ", $self->full_name ); 961 if ($inherited_topic->parent->category) { 962 $text='# @category ' . $inherited_topic->parent->name . "\n" . $text; 963 } 964 my $topic=$self->help_topic(1)->add([ $group, $item ], $text); 965 foreach (qw(spez property header)) { 966 if (defined (my $ref=$inherited_topic->annex->{$_})) { 967 if (ref($ref)) { 968 weak($topic->annex->{$_}=$ref); 969 } else { 970 $topic->annex->{$_}=$ref; 971 } 972 } 973 } 974 $topic 975} 976#################################################################################### 977sub set_file_suffix { 978 my ($self, $suffix) = @_; 979 define_function($self->pkg, "default_file_suffix", sub : method { $suffix }); 980 push @{$self->application->file_suffixes}, $suffix; 981} 982#################################################################################### 983sub reopen_subobject { 984 my ($self, $path) = @_; 985 foreach my $prop_name (split /\./, $path) { 986 my $prop = property($self, $prop_name); 987 if (($prop->flags & (Property::Flags::is_subobject | Property::Flags::is_twin)) == Property::Flags::is_subobject) { 988 $self = $self->augment($prop); 989 } elsif ($prop->flags & Property::Flags::is_twin) { 990 croak( "a twin property cannot be augmented" ); 991 } else { 992 croak( "an atomic property definition cannot be augmented" ); 993 } 994 } 995 $self 996} 997#################################################################################### 998package Polymake::Core::BigObjectType::RuleLikeMethodNode; 999 1000use Polymake::Struct( 1001 [ '@ISA' => 'Overload::Node' ], 1002); 1003 1004# instead of single sub references, every code slot contains a list of rule-like methods 1005 1006sub store_code { 1007 my ($self, $i, $rule)=@_; 1008 push @{$self->code->[$i] //= [ ]}, $rule; 1009} 1010 1011sub store_ellipsis_code { 1012 my ($self, $rule)=@_; 1013 push @{$self->ellipsis_code //= [ ]}, $rule; 1014} 1015 1016sub dup_ellipsis_code { 1017 my ($self, $upto)=@_; 1018 push @{$self->code}, map { [ @{$self->ellipsis_code} ] } @{$self->code}..$upto; 1019} 1020 1021sub push_code { 1022 my ($self, $n, $rule)=@_; 1023 push @{$self->code}, map { [ $rule ] } 1..$n; 1024} 1025 1026sub resolve { 1027 my ($self, $args)=@_; 1028 if (defined (my $rulelist=&Overload::Node::resolve)) { 1029 (Scheduler::resolve_rules($args->[0], $rulelist) // croak( "could not provide all required input properties" ))->code; 1030 } else { 1031 undef 1032 } 1033} 1034 1035#################################################################################### 1036package Polymake::Core::BigObjectType::Augmented; 1037 1038use Polymake::Struct ( 1039 [ '@ISA' => 'BigObjectType' ], 1040 [ new => '$$@' ], 1041 [ '$name' => '#2->name ."__". #1->name ."__augmented"' ], 1042 [ '$application' => '#2->application' ], 1043 [ '$parent_property' => 'undef' ], 1044 [ '$outer_object_type' => 'undef' ], 1045 [ '$pure_type' => '#1->type->pure_type' ], 1046 [ '$enclosed_in_restricted_spez' => '#2->enclosed_in_restricted_spez || defined(#2->preconditions)' ], 1047 [ '$full_spez_for' => 'undef' ], 1048 '$is_anon_full_spez', 1049 '%inst_cache', # for abstract types: owner BigObjectType => concrete instance 1050 # for concrete types: autonomous BigObjectType => Augmented 1051); 1052 1053# constructor: (parent) Property, (owner) BigObjectType, super Augmented => 1054sub new { 1055 my $self = &_new; 1056 my ($prop, $owner, @super) = @_; 1057 1058 $self->pkg = $owner->pkg."::_prop_".$prop->name =~ s/\.pure$//r; 1059 define_function($self->pkg, "type", sub { $self }, 1); 1060 RuleFilter::create_self_method_for_object($self); 1061 1062 weak($self->outer_object_type = $owner->outer_object_type); 1063 1064 if ($self->outer_object_type->abstract) { 1065 $self->context_pkg = $self->outer_object_type->context_pkg; 1066 $self->abstract = \&type; 1067 } elsif ($self->pure_type->abstract) { 1068 $self->pure_type = $self->pure_type->concrete_type($self->outer_object_type); 1069 } 1070 1071 my $inherit_pure_type; 1072 if (!@super && defined($prop->overrides)) { 1073 my $overridden = $owner->lookup_overridden_property($prop); 1074 if ($overridden->flags & Property::Flags::is_augmented) { 1075 push @super, $overridden->type; 1076 $inherit_pure_type = $overridden->type->pure_type != $self->pure_type; 1077 } 1078 } 1079 modify_super($self, 0, 0, @super, $inherit_pure_type || !@super ? $self->pure_type : ()); 1080 1081 if (instanceof Specialization($scope_owner)) { 1082 if ($self->abstract) { 1083 my $augm_generic = $super[0]; 1084 if (instanceof Specialization($augm_generic->outer_object_type)) { 1085 # derived augmentation of a property introduced in a partial specialization 1086 } else { 1087 # introduced a new augmentation in a partial specialization: 1088 # inject it into all matching concrete instances 1089 weak($self->generic = $augm_generic); 1090 push @{$augm_generic->specializations //= [ ]}, $self; 1091 1092 while (my ($concrete_owner, $concrete_augm) = each %{$augm_generic->inst_cache}) { 1093 if ($concrete_owner->isa($owner)) { 1094 (my $pos = list_index($concrete_augm->super, $augm_generic)) >= 0 1095 or croak( "internal error: super(", $concrete_augm->full_name, ") does not contain the generic augmentation ", $augm_generic->full_name); 1096 modify_super($concrete_augm, $pos, 0, $self); 1097 $_->update_inheritance for $concrete_augm->derived; 1098 } 1099 } 1100 } 1101 } 1102 # augmentations in full specializations are included into the concrete instance directly in augment() 1103 1104 } elsif (@super) { 1105 propagate_inheritance($self, $owner, @super); 1106 } 1107 1108 $self; 1109} 1110#################################################################################### 1111use Polymake::Struct ( 1112 [ 'alt.constructor' => 'new_concrete' ], 1113 [ new => '$' ], 1114 [ '$name' => '#1->name' ], 1115 [ '$application' => '#1->application' ], 1116 [ '$extension' => '#1->extension' ], 1117 [ '$context_pkg' => '#1->context_pkg' ], 1118 [ '$generic' => 'weak(#1)' ], 1119 [ '$pure_type' => 'undef' ], 1120 [ '$enclosed_in_restricted_spez' => '0' ], 1121); 1122 1123sub concrete_type { 1124 my ($src, $owner, @concrete_super) = @_; 1125 $src->abstract 1126 or croak( "internal error: attempt to construct a concrete instance of non-abstract augmentation ", $src->full_name ); 1127 if (defined(my $augm_generic = $src->generic)) { 1128 $src = $augm_generic; 1129 } 1130 1131 $src->inst_cache->{$owner} //= do { 1132 my $self = new_concrete($src, $src); 1133 my $prop_name = $src->parent_property->name; 1134 if ($owner->pkg =~ /::_Full_Spez\b/) { 1135 croak("internal error: Augmented::concrete_type called from a wrong context"); 1136 } 1137 $self->pkg = $owner->pkg . "::_prop_" . ($prop_name =~ s/\.pure$//r); 1138 define_function($self->pkg, "type", sub { $self }, 1); 1139 1140 weak($self->outer_object_type = $owner->outer_object_type); 1141 if (!@concrete_super) { 1142 @concrete_super = map { $_->type } grep { $_->flags & Property::Flags::is_augmented } $owner->collect_augmented_super_instances($prop_name); 1143 } 1144 $self->pure_type = @concrete_super 1145 ? $concrete_super[0]->pure_type : 1146 $src->pure_type->abstract 1147 ? $src->pure_type->concrete_type($self->outer_object_type) 1148 : $src->pure_type; 1149 modify_super($self, 0, 0, $src->matching_specializations($owner, $self->pure_type), $src, 1150 @concrete_super || $self->pure_type == $src->pure_type ? @concrete_super : $self->pure_type); 1151 propagate_inheritance($self, $owner, @concrete_super); 1152 $self; 1153 }; 1154} 1155 1156sub concrete_specialization { 1157 my ($src, $owner, $pure_type)=@_; 1158 $src->abstract 1159 or croak( "internal error: attempt to construct a concrete instance of non-abstract augmentation ", $src->full_name ); 1160 1161 # find the concrete instance of the enclosing specialization 1162 my $owner_spez; 1163 my $gen_spez=$src->parent_property->belongs_to; 1164 foreach (@{$owner->linear_isa}) { 1165 if ($_->generic == $gen_spez) { 1166 $owner_spez=$_; 1167 last; 1168 } 1169 } 1170 1171 $owner_spez 1172 or croak( "internal error: could not find a concrete instance of augmentation ", $gen_spez->full_name, " among ancestors of ", $owner->full_name ); 1173 1174 $src->inst_cache->{$owner_spez} //= do { 1175 my $self=new_concrete($src, $src); 1176 my $prop_name=$src->parent_property->name; 1177 $self->pkg=$owner_spez->pkg."::_prop_${prop_name}"; 1178 define_function($self->pkg, "type", sub { $self }, 1); 1179 $self->pure_type=$pure_type; 1180 weak($self->outer_object_type=$owner_spez->outer_object_type); 1181 if ($src->generic) { 1182 # property defined in the generic enclosing type 1183 modify_super($self, 0, 0, $src); 1184 } else { 1185 # property borrowed from another specialization 1186 modify_super($self, 0, 0, $src, concrete_specialization($src->super->[0], $owner, $pure_type)); 1187 } 1188 $self; 1189 }; 1190} 1191 1192sub matching_specializations { 1193 my ($self, $owner, $pure_type)=@_; 1194 if ($self->specializations) { 1195 map { concrete_specialization($_, $owner, $pure_type) } grep { $owner->isa($_->parent_property->belongs_to) } @{$self->specializations}; 1196 } else { 1197 () 1198 } 1199} 1200 1201sub inject_inheritance { 1202 my ($self, $augm_super)=@_; 1203 $self->super->[0]=$augm_super; 1204 namespaces::using($self->pkg, $augm_super->pkg); 1205 { no strict 'refs'; 1206 ${$self->pkg."::ISA"}[0]=$augm_super->pkg; 1207 } 1208 if ($augm_super->abstract && $self->abstract) { 1209 my $super_generic=$augm_super->parent_property->belongs_to; 1210 while (my ($concrete_owner, $concrete_augm)=each %{$self->inst_cache}) { 1211 foreach my $super_concrete ($concrete_owner->concrete_super_instances) { 1212 if ($super_concrete->isa($super_generic)) { 1213 # the concrete augmentation can't have any concrete super classes so far 1214 modify_super($concrete_augm, -1, 0, $augm_super->concrete_type($super_concrete->descend_to_generic($super_generic->pkg))); 1215 last; 1216 } 1217 } 1218 } 1219 } 1220 $_->update_inheritance for $self, $self->derived; 1221} 1222 1223sub propagate_inheritance { 1224 my ($self, $owner, @override)=@_; 1225 my %overridden; 1226 @overridden{@override}=(); 1227 1228 foreach my $derived (map { $_->derived } @override) { 1229 if ($derived != $self && 1230 ($derived->abstract || !$self->abstract) && 1231 $derived->parent_property->belongs_to->isa($owner)) { 1232 my $replaced=0; 1233 for (my $i=0; $i<=$#{$derived->super}; ) { 1234 if (exists $overridden{$derived->super->[$i]}) { 1235 if ($replaced) { 1236 splice @{$derived->super}, $i, 1; 1237 no strict 'refs'; 1238 splice @{$derived->pkg."::ISA"}, $i, 1; 1239 } else { 1240 namespaces::using($derived->pkg, $self->pkg); 1241 $derived->super->[$i]=$self; 1242 no strict 'refs'; 1243 ${$derived->pkg."::ISA"}[$i]=$self->pkg; 1244 ++$i; 1245 $replaced=1; 1246 } 1247 } else { 1248 ++$i; 1249 } 1250 } 1251 if ($replaced) { 1252 $_->update_inheritance for $derived, $derived->derived; 1253 } 1254 } 1255 } 1256} 1257 1258#################################################################################### 1259sub final_type { 1260 my ($self, $given_type)=@_; 1261 $self->abstract || $given_type->abstract 1262 and croak( "internal error: attempt to construct a concrete augmented type from ", 1263 ($self->abstract && "abstract base "), $self->full_name, 1264 " and ", ($autonomous_type->abstract && "abstract autonomous type "), $autonomous_type->full_name ); 1265 my $autonomous_type=$given_type->pure_type; 1266 if ($autonomous_type == $self->pure_type) { 1267 $self 1268 } else { 1269 $self->inst_cache->{$autonomous_type} //= create_derived($self, $self->parent_property, $autonomous_type); 1270 } 1271} 1272#################################################################################### 1273sub full_name { 1274 my ($self)=@_; 1275 (@_==1 && $self->pure_type->full_name . " as ") . $self->parent_property->belongs_to->full_name(0) . "::" . $self->parent_property->name; 1276} 1277 1278sub descend_to_generic { 1279 $_[0]->outer_object_type->descend_to_generic($_[1]) // $_[0]->pure_type->descend_to_generic($_[1]); 1280} 1281 1282sub concrete_super_instances { 1283 my ($self)=@_; 1284 $self->super->[0] == $self->pure_type ? () : &BigObjectType::concrete_super_instances; 1285} 1286#################################################################################### 1287sub augmentation_path { 1288 my ($self)=@_; 1289 my ($parent_prop, @path); 1290 while (defined ($parent_prop=$self->parent_property)) { 1291 push @path, $parent_prop; 1292 $self=$parent_prop->belongs_to; 1293 } 1294 reverse @path; 1295} 1296 1297sub create_augmentation { 1298 my ($self, $prop) = @_; 1299 if (instanceof Specialization($scope_owner)) { 1300 &Specialization::create_augmentation; 1301 } else { 1302 my ($augm, @augm_super); 1303 my @owner_augm_path = augmentation_path($self); 1304 my @prop_augm_path = augmentation_path($prop->belongs_to); 1305 if (@prop_augm_path == @owner_augm_path) { 1306 # there is already another augmentation on the same nesting level 1307 push @augm_super, $prop->type; 1308 } else { 1309 # try to find or establish an augmentation with one or more outer enclosing object types stripped off 1310 STRIP_OFF: 1311 while (@owner_augm_path) { 1312 my $outer = shift(@owner_augm_path)->type->pure_type; 1313 if ($outer->abstract && defined($outer->generic)) { 1314 # pass through dependent abstract types 1315 $outer = $outer->generic; 1316 } 1317 foreach (@owner_augm_path, $prop) { 1318 if ($outer->isa($_->defined_for)) { 1319 my $sub_prop = $outer->property($_->name); 1320 $outer = $outer->augment($sub_prop); 1321 } else { 1322 next STRIP_OFF; 1323 } 1324 } 1325 push @augm_super, $outer; 1326 last; 1327 } 1328 } 1329 $augm = new Augmented($prop, $self, @augm_super); 1330 ($augm, $augm_super[0], 1); 1331 } 1332} 1333#################################################################################### 1334sub find_rule_label { 1335 &BigObjectType::find_rule_label // do { 1336 my $pure_type_app=$_[0]->pure_type->application; 1337 if ($pure_type_app != $_[0]->application) { 1338 $pure_type_app->prefs->find_label($_[1]) 1339 } else { 1340 undef 1341 } 1342 } 1343} 1344#################################################################################### 1345# private: 1346sub provide_help_topic { 1347 my ($owner, $force, @descend) = @_; 1348 my $topic = $owner->help_topic($force) or return; 1349 foreach my $prop (@descend) { 1350 my $help_group = $prop->flags & Property::Flags::is_permutation ? "permutations" : "properties"; 1351 $topic = $topic->find("!rel", $help_group, $prop->name) // do { 1352 $force or return; 1353 my $text = ""; 1354 my $refer_to = $prop->defined_for; 1355 if ($owner != $refer_to) { 1356 if (my $prop_topic = $prop->belongs_to->help_topic->find($help_group, $prop->name)) { 1357 if ($prop_topic->parent->category) { 1358 $text='# @category ' . $prop_topic->parent->name . "\n"; 1359 } 1360 } 1361 $text .= "Augmented subobject " . $refer_to->full_name . "::" . $prop->name . "\n" 1362 . "# \@display noshow\n"; 1363 } 1364 $topic = $topic->add([ $help_group, $prop->name ], $text); 1365 $topic->annex->{property}=$prop; 1366 $topic 1367 }; 1368 $owner = $prop->belongs_to; 1369 } 1370 $topic 1371} 1372 1373sub help_topic { 1374 my ($self, $force) = @_; 1375 $self->help //= do { 1376 if ($scope_owner) { 1377 # need a help node during rulefile loading 1378 my @descend = augmentation_path($self); 1379 if (instanceof Specialization($scope_owner)) { 1380 my $gen_topic = provide_help_topic($scope_owner->generic // $scope_owner->full_spez_for, $force, @descend) or return; 1381 ($self->generic // $self->full_spez_for)->help //= $gen_topic; 1382 $gen_topic->new_specialization($scope_owner); 1383 } elsif ($scope_owner != $descend[0]->belongs_to) { 1384 $force and die "internal error: augmentation path does not match the compilation scope\n"; 1385 return; 1386 } else { 1387 my $topic = provide_help_topic($scope_owner, $force, @descend) or return; 1388 push @{$topic->related}, uniq( map { ($_, @{$_->related}) } grep { defined($_) && ref($_) !~ /\bSpecialization$/ } 1389 map { $_->help_topic } @{$self->linear_isa} ); 1390 foreach my $other ($self->derived) { 1391 if (defined($other->help)) { 1392 push @{$other->help->related}, $topic; 1393 } 1394 } 1395 $topic 1396 } 1397 } else { 1398 $self->pure_type->help_topic; 1399 } 1400 }; 1401} 1402 1403sub help_ref_to_prop { 1404 my ($self, $for_app, $prop_name) = @_; 1405 $self->outer_object_type->help_ref_to_prop($for_app, join(".", (map { $_->name } augmentation_path($self)), $prop_name)); 1406} 1407#################################################################################### 1408use Polymake::Struct ( 1409 [ 'alt.constructor' => 'new_derived' ], 1410 [ new => '$$$' ], 1411 [ '$name' => '#1->name' ], 1412 [ '$application' => '#1->application' ], 1413 [ '$extension' => '#1->extension' ], 1414 [ '$parent_property' => 'weak(#2)' ], 1415 [ '$outer_object_type' => '#1->outer_object_type' ], 1416 [ '$pure_type' => '#3' ], 1417 [ '$enclosed_in_restricted_spez' => '#1->enclosed_in_restricted_spez' ], 1418 [ '$inst_cache' => 'undef' ], 1419); 1420 1421sub create_derived { 1422 my ($src, $prop, $autonomous_type) = @_; 1423 my $self = new_derived($prop->flags & Property::Flags::is_permutation ? "Polymake::Core::BigObjectType::Permuted" : __PACKAGE__, @_); 1424 $self->pkg = $autonomous_type->pkg."::__as__".$src->pkg; 1425 define_function($self->pkg, "type", sub { $self }, 1); 1426 modify_super($self, 0, 0, $src, $autonomous_type); 1427 set_extension($self->extension, $autonomous_type->extension); 1428 if ($autonomous_type->abstract) { 1429 $self->abstract = \&type; 1430 } 1431 $self; 1432} 1433#################################################################################### 1434package Polymake::Core::BigObjectType::Permuted; 1435 1436use Polymake::Struct ( 1437 [ '@ISA' => 'Augmented' ], 1438); 1439 1440sub get_producers_of { 1441 my ($self)=@_; 1442 # No production rules should be inherited from the non-permuted type, otherwise the scheduler would drive crazy. 1443 # Therefore the collection should stop in the pure permutation type. 1444 BigObjectType::get_producers_of(@_, $self->super->[0]->pure_type); 1445} 1446 1447sub pure_property { $_[0]->super->[0]->parent_property } 1448 1449sub concrete_type { 1450 my ($self, $owner) = @_; 1451 create_derived($owner->property(&pure_property->name)->type, $self->parent_property, $owner); 1452} 1453 1454sub full_name { 1455 my ($self)=@_; 1456 $self->pure_type->full_name . "::" . $self->parent_property->name 1457} 1458#################################################################################### 1459package Polymake::Core::BigObjectType::Specialization; 1460 1461use Polymake::Struct ( 1462 [ '@ISA' => 'BigObjectType' ], 1463 [ new => '$$$;$' ], 1464 [ '$application' => '#3->application' ], 1465 [ '$match_node' => 'undef' ], 1466 [ '$preconditions' => 'undef' ], 1467 [ '$full_spez_for' => 'undef' ], 1468 '$is_anon_full_spez', 1469); 1470 1471# Constructor: new Specialization('name', 'pkg', generic_ObjectType | generic_Specialization | concrete_ObjectType, [ type params ] ) 1472sub new { 1473 my $self = &_new; 1474 my (undef, $pkg, $gen_proto, $tparams) = @_; 1475 my $concrete_proto; 1476 1477 if (defined($pkg)) { 1478 $self->pkg = $pkg; 1479 if ($tparams) { 1480 # new abstract specialization 1481 $self->abstract = \&type; 1482 undef $self->perform_typecheck; 1483 my $param_index = -1; 1484 $self->params = [ map { new ClassTypeParam($_, $pkg, $self->application, ++$param_index) } @$tparams ]; 1485 $self->name //= do { 1486 my (undef, $file, $line) = caller; 1487 $def_line -= 2; # accounting for code inserted in RuleFilter 1488 $gen_proto->name." defined at $file, line $line" 1489 }; 1490 $self->match_node = new_root Overload::Node; 1491 push @{$gen_proto->specializations //= [ ]}, $self; 1492 } else { 1493 # new full specialization 1494 $concrete_proto = $gen_proto; 1495 $gen_proto = $concrete_proto->generic; 1496 if (defined($self->name)) { 1497 (($gen_proto // $concrete_proto)->full_spez //= { })->{$self->name} = $self; 1498 } else { 1499 $self->is_anon_full_spez = true; 1500 $self->name = $concrete_proto->full_name; 1501 } 1502 $self->params = $concrete_proto->params; 1503 } 1504 } else { 1505 # a concrete instance of a specialization 1506 $self->name = $gen_proto->name; 1507 $self->extension = $gen_proto->extension; 1508 $self->pkg = $gen_proto->pkg; 1509 $self->params = $tparams; 1510 PropertyParamedType::scan_params($self); 1511 } 1512 my $self_sub = define_function($self->pkg, "type", sub { $self }, 1); 1513 $self->generic = $gen_proto; 1514 if (defined($concrete_proto)) { 1515 RuleFilter::create_self_method_for_object($self); 1516 1517 weak($self->full_spez_for = $concrete_proto); 1518 1519 # inherit all the same as the concrete type but restricted full specializations 1520 my ($anon_pos, $pos) = positions_of_full_spez($concrete_proto); 1521 modify_super($self, 0, 0, @{$concrete_proto->super}[$pos..$#{$concrete_proto->super}]); 1522 if ($self->is_anon_full_spez) { 1523 if (defined($anon_pos)) { 1524 croak( "internal error: created duplicate instance for full specialization ", 1525 $concrete_proto->super->[$anon_pos]->full_name, " (", $concrete_proto->super->[$anon_pos]->pkg, 1526 ") and ", $self->full_name, " (", $self->pkg, ")" ); 1527 } 1528 # inject it in restricted specializations too, if any 1529 modify_super($_, 0, 0, $self) for @{$concrete_proto->super}[0..$pos-1]; 1530 } 1531 modify_super($concrete_proto, $pos, 0, $self); 1532 $_->update_inheritance for $concrete_proto->derived; 1533 1534 } else { 1535 modify_super($self, 0, 0, $gen_proto); 1536 } 1537 $self; 1538} 1539 1540# inject concrete instances of this specialization into all matching object types 1541sub apply_to_existing_types { 1542 my ($self) = @_; 1543 my $gen_proto = $self->generic; 1544 my @concrete_types = grep { !$_->abstract } $gen_proto->derived; 1545 # first update the ISA lists of matching instances of the same generic type 1546 foreach my $concrete (@concrete_types) { 1547 if ($concrete->generic == $gen_proto 1548 and 1549 my ($spez) = pick_specialization($self, $concrete)) { 1550 # all partial specializations go in front of the generic type 1551 modify_super($concrete, list_index($concrete->super, $gen_proto), 0, $spez); 1552 } 1553 } 1554 # then regenerate the super lists of all derived types 1555 $_->update_inheritance for @concrete_types; 1556} 1557 1558# concrete BigObjectType -> indexes into its super list 1559sub positions_of_full_spez { 1560 my ($self) = @_; 1561 my $pos = 0; 1562 foreach my $spez (@{$self->super}) { 1563 last if $spez->full_spez_for != $self; 1564 return ($pos, $pos) if $spez->is_anon_full_spez; 1565 ++$pos; 1566 } 1567 (undef, $pos) 1568} 1569#################################################################################### 1570sub augment_in_full_spez { 1571 my ($self, $prop) = @_; 1572 my ($augm, $augm_generic, $augm_concrete); 1573 1574 if ($prop->flags & Property::Flags::is_augmented) { 1575 $augm_concrete = $prop->type; 1576 $augm_generic = $augm_concrete->generic; 1577 } elsif (defined(my $gen_proto = $self->full_spez_for->generic)) { 1578 $augm_generic = $gen_proto->augment($gen_proto->property($prop->name)); 1579 # $prop must be updated here 1580 $prop->flags & Property::Flags::is_augmented 1581 or croak( "internal error: property instance ", $prop->name, " for ", $prop->belongs_to->full_name, 1582 " not updated after augment(", $gen_proto->full_name, ")" ); 1583 $augm_concrete = $prop->type; 1584 } else { 1585 $augm_concrete = $self->full_spez_for->augment($prop); 1586 $prop->flags & Property::Flags::is_augmented 1587 or croak( "internal error: property instance ", $prop->name, " for ", $prop->belongs_to->full_name, 1588 " not updated after augment(", $self->full_spez_for->full_name, ")" ); 1589 } 1590 1591 my ($anon_pos, $pos) = positions_of_full_spez($augm_concrete); 1592 if ($scope_owner->is_anon_full_spez) { 1593 if (defined($anon_pos)) { 1594 # already there? 1595 return $augm_concrete->super->[$anon_pos]; 1596 } 1597 } elsif ($pos > 0) { 1598 # seen augmentations from some full specializations: maybe the desired one already exists? 1599 foreach my $spez (@{$augm_concrete->super}[0..$pos-1]) { 1600 if ($spez->parent_property->belongs_to == $self) { 1601 return $spez; 1602 } 1603 } 1604 } 1605 1606 # need a separate augmentation for this specialization 1607 # inherit all the same as the concrete type but other restricted full specializations 1608 $augm = new Augmented($prop, $self, @{$augm_concrete->super}[$pos..$#{$augm_concrete->super}]); 1609 if ($scope_owner->is_anon_full_spez) { 1610 $augm->is_anon_full_spez = true; 1611 weak($augm->parent_property = $prop); 1612 $self->properties->{$prop->name} = $prop; 1613 # inject it into inheritance lists of augmentations for restricted specializations, if any 1614 modify_super($_, 0, 0, $augm) for @{$augm_concrete->super}[0..$pos-1]; 1615 } else { 1616 $self->properties->{$prop->name} = $prop->clone_for_augmented($augm, $self); 1617 } 1618 $augm->generic = $augm_generic; 1619 weak($augm->full_spez_for = $augm_concrete); 1620 if ($augm_generic) { 1621 $augm_generic->inst_cache->{$self} = $augm; 1622 } 1623 modify_super($augm_concrete, $pos, 0, $augm); 1624 1625 $augm 1626} 1627 1628sub create_augmentation { 1629 my ($self, $prop) = @_; 1630 if (my $concrete_proto = $scope_owner->full_spez_for) { 1631 if ($concrete_proto != $self->full_spez_for) { 1632 # it's a nested augmentation; redirected here from Augmented:: 1633 $concrete_proto = $self->full_spez_for // $self; 1634 } 1635 if ($concrete_proto->generic) { 1636 local $scope_owner = $concrete_proto->generic->outer_object_type; 1637 $concrete_proto->generic->augment($concrete_proto->generic->property($prop->name)); 1638 $prop = $concrete_proto->property($prop->name); 1639 } else { 1640 $prop = $concrete_proto->augment($prop)->parent_property; 1641 } 1642 augment_in_full_spez($self, $prop); 1643 1644 } elsif (instanceof Specialization($prop->belongs_to->outer_object_type) && $prop->belongs_to->abstract) { 1645 # The property must have been introduced in another specialization (borrowed from). 1646 my $augm_super = $prop->belongs_to->augment($prop); 1647 (new Augmented($augm_super->parent_property, $self, $augm_super), $augm_super, 1); 1648 1649 } else { 1650 # The property is introduced in or inherited by the generic part of the object type: 1651 # always make sure there is a generic augmentation for it, even if not explicitly declared in the rules. 1652 my $augm_gen = do { 1653 # prevent endless recursion when redirected here from Augmented:: 1654 local $scope_owner = $self->generic->outer_object_type; 1655 $self->generic->augment($prop); 1656 }; 1657 new Augmented($augm_gen->parent_property, $self, $augm_gen); 1658 } 1659} 1660#################################################################################### 1661sub append_precondition { 1662 my ($self, $header, $code, $checks_definedness) = @_; 1663 my $precond = special Rule($header, $code, $self); 1664 $precond->flags = ($checks_definedness ? Rule::Flags::is_precondition | Rule::Flags::is_definedness_check : Rule::Flags::is_precondition) | Rule::Flags::is_spez_precondition; 1665 $precond->header = "precondition " . $precond->header . " ( specialization " . $self->name . " )"; 1666 push @{$self->preconditions //= [ ]}, $precond; 1667} 1668 1669sub add_permutation { 1670 croak( "A type specialization can't have own permutation types; consider introducing a derived `big' object type for this" ); 1671} 1672#################################################################################### 1673sub full_name { 1674 my ($self)=@_; 1675 if (defined $self->full_spez_for) { 1676 # full specialization 1677 $self->name . " (specialization)" 1678 } elsif ($self->name =~ / defined at /) { 1679 # unnamed partial specialization 1680 "$`<" . join(",", map { $_->full_name } @{$self->params}) . ">$&$'" 1681 } else { 1682 # named partial specialization 1683 &PropertyParamedType::full_name 1684 } 1685} 1686 1687sub help_ref_to_prop { 1688 my $self=shift; 1689 ($self->full_spez_for // $self->generic)->help_ref_to_prop(@_) 1690} 1691 1692sub help_topic { 1693 my ($self, $force)=@_; 1694 $self->help // do { 1695 if ($force) { 1696 if ($enable_plausibility_checks && $self->name =~ / defined at /) { 1697 croak( "For the sake of better documentation, specializations introducing user-visible features (properties, methods, etc.) must be named" ); 1698 } 1699 $self->help=($self->generic // $self->full_spez_for)->help_topic($force)->new_specialization($self); 1700 } else { 1701 undef 1702 } 1703 } 1704} 1705 1706sub pure_type { 1707 my ($proto)=@_; 1708 if (defined $proto->full_spez_for) { 1709 $proto=$proto->full_spez_for; 1710 } 1711 while (defined $proto->generic) { 1712 $proto=$proto->generic; 1713 } 1714 $proto 1715} 1716#################################################################################### 1717# special prototype objects for Array<BigObject> 1718 1719package Polymake::Core::BigObjectArray; 1720 1721use Polymake::Struct ( 1722 [ '@ISA' => 'PropertyType' ], 1723 [ new => '' ], 1724 [ '$name' => '"BigObjectArray"' ], 1725 [ '$pkg' => '__PACKAGE__' ], 1726 [ '$application' => 'undef' ], 1727 [ '$extension' => 'undef' ], 1728 [ '$dimension' => '1' ], 1729 [ '&serialize' => '\&serialize_func' ], 1730 [ '&deserialize' => '\&deserialize_meth' ], 1731 [ '&equal' => '\&equal_sub' ], 1732 [ '&isa' => '\&isa_meth' ], 1733); 1734 1735sub serialize_func { 1736 my ($arr, $options) = @_; 1737 [ map { $_->serialize($options) } @$arr ] 1738} 1739 1740sub deserialize_meth : method { 1741 my ($self, $src, @options) = @_; 1742 if (is_array($src)) { 1743 my $obj_proto = $self->params->[0]; 1744 bless [ map { BigObject::deserialize($obj_proto, $_, @options) } @$src ], $self->pkg 1745 } else { 1746 croak( "wrong serialized representation of ", $self->full_name, " - anonymous array expected" ); 1747 } 1748} 1749 1750Struct::pass_original_object(\&deserialize_meth); 1751 1752sub equal_sub { 1753 my ($arr1, $arr2) = @_; 1754 my $e = $#$arr1; 1755 return 0 if $e != $#$arr2; 1756 for (my $i = 0; $i <= $e; ++$i) { 1757 return 0 if $arr1->[$i]->diff($arr2->[$i]); 1758 } 1759 1 1760} 1761 1762sub isa_meth : method { 1763 my ($self, $arr) = @_; 1764 UNIVERSAL::isa($arr, __PACKAGE__) && $arr->type->params->[0]->isa($self->params->[0]); 1765} 1766 1767Struct::pass_original_object(\&isa_meth); 1768 1769sub construct_from_list : method { 1770 my ($self, $list) = @_; 1771 # the contained Objects have already been checked during overload resolution 1772 bless $list, $self->pkg; 1773} 1774 1775sub construct_with_size : method { 1776 my ($self, $n) = @_; 1777 my $elem_type = $self->params->[0]; 1778 bless [ map { BigObject::new_named($elem_type, $_) } 0..$n-1 ], $self->pkg; 1779} 1780 1781sub resize { 1782 my ($self, $n) = @_; 1783 my $old_size = @$self; 1784 if ($n < $old_size) { 1785 $#$self = $n-1; 1786 } else { 1787 my $elem_type = $self->type->params->[0]; 1788 push @$self, map { BigObject::new_named($elem_type, $_) } $old_size..$n-1; 1789 } 1790} 1791 1792sub copy { 1793 my ($self) = @_; 1794 inherit_class([ map { $_->copy } @$self ], $self); 1795} 1796 1797# For the exotic case of size passed in string form. 1798# Everything else will lead to an exception. 1799sub construct_with_size_str : method { 1800 construct_with_size($_[0], extract_integer($_[1])); 1801} 1802 1803sub new_generic { 1804 my $self = &_new; 1805 $self->construct_node = new_root Overload::Node; 1806 Overload::add_instance(__PACKAGE__, ".construct", undef, \&construct_with_size, 1807 [ 1, 1, Overload::integer_package() ], undef, $self->construct_node); 1808 $self; 1809} 1810 1811sub typeof { state $me = &new_generic; } 1812 1813sub init_constructor : method { 1814 my ($super, $self) = @_; 1815 $self->construct_node = $super->construct_node; 1816 Overload::add_instance($self->pkg, ".construct", undef, \&construct_from_list, 1817 [ 1, 1+Overload::SignatureFlags::has_repeated, [ $self->params->[0]->pkg, "+" ] ], undef, $self->construct_node); 1818 1819 $self->parse = \&construct_with_size_str; 1820 overload::OVERLOAD($self->pkg, '""' => ($self->toString = sub { "BigObjectArray" })); 1821 1822 # put BigObjectArray in front of generic Array as to inherit the correct constructors 1823 # TODO: find a more elegant/generic way of achieving this, e.g. by specializing the generic types in the rules. 1824 no strict 'refs'; 1825 @{$self->pkg."::ISA"} = (__PACKAGE__, $self->generic->pkg); 1826} 1827 18281 1829 1830# Local Variables: 1831# cperl-indent-level:3 1832# indent-tabs-mode:nil 1833# End: 1834