plroot.pl

自动生成VERILOG 工具

#
# This file is part of the Perlilog project.
#
# Copyright (C) 2003, Eli Billauer
#
# 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 of the License, or
# (at your option) any later version.
#
# 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.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# A copy of the license can be found in a file named "licence.txt", at the
# root directory of this project.
#

# Perlilog's basic root class
${__PACKAGE__.'::errorcrawl'}='system';
#our $errorcrawl='system';
sub new {
  my $this = shift;
  my $self = $this->SUPER::new(@_);
  my $class = ref($this) || $this;
  $self = {} unless ref($self); 
  bless $self, $class;
  $self->store_hash([], @_);
  if (defined $Perlilog::interface_rec) {
    my $name = $self->get('nick');
    puke("New \'$class\' transient object created without the 'nick' property set\n")
      unless (defined $name);
    puke("New \'$class\' transient object created with illegal nick: \'$name\'\n")
      unless ($name=~/^[a-zA-Z_]\w*$/);	
    $self -> set('perlilog-transient', 'transient'); 
  } else {
    my $name = $self->get('name');
    puke("New \'$class\' object created without the 'name' property set\n")
      unless (defined $name);
    puke("New \'$class\' object created with illegal name: ".$self->prettyval($name)."\n")
      unless ($name=~/^[a-zA-Z_]\w*$/);

    blow("New \'$class\' object created with an already occupied name: \'$name\'\n")
      if (exists $Perlilog::objects{$name});
    my $lc = lc($name);
    foreach (keys %Perlilog::objects) {
      blow("New \'$class\' object created with a name \'$name\' when \'$_\' is already in the system (only case difference)\n")
	if (lc($_) eq $lc);
    }
    $Perlilog::objects{$name}=$self;
    my $papa = $self->get('parent');
    $self -> setparent($papa) if (ref($papa));
  }
  $self -> const('perlilog-object-count', $Perlilog::objectcounter++);
  return $self;
}  

sub sustain {
  my $self = shift;
  my $name = $self->suggestname($self->get('nick'));
  $self->const('name', $name);
  $Perlilog::objects{$name}=$self;
  $self -> set('perlilog-transient', 'sustained'); 
  my $papa = $self->get('parent');
  $self -> setparent($papa) if (ref($papa));
}

sub who {
  my $self = shift;
  return "object \'".$self->get('name')."\'";
}

sub safewho {
  my ($self, $who) = @_;
  return "(non-object item)" unless ($self->isobject($who));
  return $who->who;
}

sub isobject {
  my ($self, $other) = @_;
  my $r = ref $other;
  return 1 if (Perlilog::definedclass($r) == 2);
  return undef;
}

sub objbyname {
  my ($junk, $name) = @_;
  return $Perlilog::objects{$name};
}

sub suggestname {
  my ($self, $name) = @_;
  my $sug = $name;
  my ($bulk, $num) = ($name =~ /^(.*)_(\d+)$/);
  my %v;

  foreach (keys %Perlilog::objects) { $v{lc($_)}=1; } # Store lowercased names
  unless (defined $bulk) {
    $bulk = $name;
    $num = 0;
  }
  
  while ($v{lc($sug)}) {
    $num++;
    $sug = $bulk.'_'.$num;
  }
  return $sug;
}

sub get {
  my $self = shift;
  my $prop = shift;
  my $final;

  my @path = (ref($prop)) ? @{$prop} : ($prop);

  $final = $self->{join("\n", 'plPROP', @path)};

  # Now try to return it the right way. If we have a reference, then
  # the property is set. So if the calling context wants an array, why
  # hassle? Let's just give an array.
  # But if a scalar is expected, and we happen to have only one
  # member in the list -- let's be kind and give the first value
  # as a scalar.

  if (ref($final)) {
    return @{$final} if (wantarray);
    return ${$final}[0];
  }

  # We got here, so the property wasn't defined. Now, if
  # we return an undef in an array context, it's no good, because it
  # will be considered as a list with lenght 1. If the property
  # wasn't defined we want to say "nothing" -- and that's an empty list.

  return () if (wantarray);

  # Wanted a scalar? Undef is all we can offer now.

  return undef;
}

sub getraw {
  my $self = shift;
 
  return $self->{join("\n", 'plPROP', @_)};
}

sub store_hash {
  my $self = shift;
  my $rpath = shift;
  my @path = @{$rpath};
  my %h = @_;

  foreach (keys %h) {
    my $val = $h{$_};

    if (ref($val) eq 'HASH') {
      $self->store_hash([@path, $_], %{$val});
    } elsif (ref($val) eq 'ARRAY') {
      $self->const([@path, $_], @{$val});
    } else {
      $self->const([@path, $_], $val);
    }
  }
}

sub const {
  my $self = shift;
  my $prop = shift;

  my @path = (ref($prop)) ? @{$prop} : ($prop);

  my @newval = @_;

  my $pre = $self->getraw(@path);

  if (defined($pre)) {
    puke("Attempt to change a settable property into constant\n")
      unless (ref($pre) eq 'PL_const');

    my @pre = @{$pre};

    my $areeq = ($#pre == $#newval);
    my $i;
    my $eq = $self->get(['plEQ',@path]);

    if (ref($eq) eq 'CODE') {
      for ($i=0; $i<=$#pre; $i++) {
	$areeq = 0 unless (&{$eq}($pre[$i], $newval[$i]));
      }
    } else { 
      for ($i=0; $i<=$#pre; $i++) {
	$areeq = 0 unless ($pre[$i] eq $newval[$i]); 
      }
    }

    unless ($areeq) {
      if (($#path==2) && ($path[0] eq 'vars') && ($path[2] eq 'dim')) {
	# This is dimension inconsintency. Will happen a lot to novices,
	# and deserves a special error message.
	wrong("Conflict in setting the size of variable \'$path[1]\' in ".
	      $self->who.". The conflicting values are ".
	      $self->prettyval(@pre)." and ".$self->prettyval(@newval).
	      ". (This usually happens as a result of connecting variables of".
	      " different sizes, possibly indirectly)\n");
	
	
      } else {
	{ local $@; require Perlilog::PLerrsys; }  # XXX fix require to not clear $@?
	my ($at, $hint) = &Perlilog::PLerror::constdump();
	
	wrong("Attempt to change constant value of \'".
	      join(",",@path)."\' to another unequal value ".
	      "on ".$self->who." $at\n".
	      "Previous value was ".$self->prettyval(@pre).
	      " and the new value is ".$self->prettyval(@newval)."\n$hint\n");
      }
    }
  } else {
    if ($Perlilog::callbacksdepth) {
      my $prop = join ",",@path;
      my $who = $self->who;
      hint("On $who: \'$prop\' = ".$self->prettyval(@newval)." due to magic property setting\n");
    }
    $self->domutate((bless \@newval, 'PL_const'), @path);

    my $cbref = $self->getraw('plMAGICS', @path);
    return unless (ref($cbref) eq 'PL_settable');
    my $subref;

    $Perlilog::callbacksdepth++;
    while (ref($subref=shift @{$cbref}) eq 'CODE') {
      &{$subref}($self, @path);
    }
     $Perlilog::callbacksdepth--;
  }
}

sub set {
  my $self = shift;
  my $prop = shift;

  my @path;
  @path = (ref($prop)) ? @{$prop} : ($prop);

  my @newval = @_;

  my $pre = $self->getraw(@path);
  my $ppp = ref($pre);
  puke ("Attempted to set a constant property\n")
    if ((defined $pre) && ($ppp ne 'PL_settable'));
  $self->domutate((bless \@newval, 'PL_settable'), @path);
  return 1;
}

sub domutate {
  my $self = shift;
  my $newval = shift;
  my $def = 0;
  $def=1 if ((defined ${$newval}[0]) || ($#{$newval}>0));
 
  if ($def) {
    $self->{join("\n", 'plPROP', @_)} = $newval;
  } else { delete $self->{join("\n", 'plPROP', @_)}; }
  return 1;
}

sub seteq {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  my $eq = shift;
  puke("Callbacks should be references to subroutines\n")
    unless (ref($eq) eq 'CODE');
  $self->set(['plEQ', @path], $eq);
}

sub addmagic {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  my $callback = shift;

  unless (defined($self->get([@path]))) {   
    $self->punshift(['plMAGICS', @path], $callback);
  } else {
    $Perlilog::callbacksdepth++;
    &{$callback}($self, @path);
    $Perlilog::callbacksdepth--;
  }
}

sub registerobject {
  my $self = shift;
  my $phase = shift;
  if (defined $phase) {
    return undef if ($phase eq 'noreg');
    return $self -> globalobj -> ppush('beginobjects', $self) if ($phase eq 'begin');
    return $self -> globalobj -> ppush('endobjects', $self) if ($phase eq 'end');
  }
  return $self -> globalobj -> ppush('objects', $self);
}

sub pshift {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  my $pre = $self->getraw(@path);
  if (ref($pre) eq 'PL_settable') {
    return shift @{$pre}; 
  } else {
    return $self->set($prop, undef) # We're changing a constant property here. Will puke.
      if (defined $pre);
    return undef; # There was nothing there.