plroot.pl

自动生成VERILOG 工具

  }
}

sub ppop {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  my $pre = $self->getraw(@path);
  if (ref($pre) eq 'PL_settable') {
    return pop @{$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.
  }
}

sub punshift {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  
  my @val = @_;

  my $pre = $self->getraw(@path);
  if (ref($pre) eq 'PL_settable') {
    unshift @{$pre}, @val; 
  } else {
    $self->set(\@path, (defined($pre))? ($pre, @val) : @val);
  }
}

sub ppush {
  my $self = shift;
  my $prop = shift;
  my @path = (ref($prop)) ? @{$prop} : ($prop);
  
  my @val = @_;

  my $pre = $self->getraw(@path);
  if (ref($pre) eq 'PL_settable') {
    push @{$pre}, @val; 
  } else {
    $self->set(\@path, (defined($pre))? (@val, $pre) : @val);
  }
}

sub globalobj {
  return &Perlilog::globalobj();
}

sub setparent {
  my ($self, $papa)=@_;
  wrong("Can't add a child to a static object ".$papa->who()."\n")
    if ($papa->get('static'));
  $self->const('parent', $papa);
  $papa->ppush('children',$self);
}

sub linebreak {
  my $self = shift;
  return &Perlilog::linebreak(@_);
}

sub objdump {
  my $self = shift;
  my @todump;

  unless (@_) {
    @todump = sort {$Perlilog::objects{$a}->get('perlilog-object-count') <=> 
		      $Perlilog::objects{$b}->get('perlilog-object-count')} 
    keys %Perlilog::objects;
    @todump = map {$Perlilog::objects{$_}} @todump; 
  } else {
    @todump = (@_);
  }

  foreach my $obj (@todump) {
    unless ($self->isobject($obj)) {
      my $r = $Perlilog::objects{$obj};
      if (defined $r) {
	$obj = $r;
      } else {
	print "Unknown object specifier ".$self->prettyval($obj)."\n\n";
	next;
      }
    }
    
    my @prefix = ();
    print $self->linebreak($self->safewho($obj).", class=\'".ref($obj)."\':")."\n";
    my $indent = '    ';
    foreach my $prop (sort keys %$obj) {
      my @path = split("\n", $prop);
      shift @path if ($path[0] eq 'plPROP');
      my $propname = pop @path;

      # Now we make sure that the @path will be exactly like @prefix
      # First, we shorten @prefix if it's longer than @path, or if it
      # has items that are unequal to @path.

      CHOP: while (1) {
	# If @prefix is longer, no need to check -- we need chopping
	# anyhow
	unless ($#path < $#prefix) {
	  my $i;
	  my $last = 1;
	  for ($i=0; $i<=$#prefix; $i++) {
	    if ($prefix[$i] ne $path[$i]) {
	      $last = 0; last;
	    }
	  }
	  last CHOP if $last;
	}
	my $tokill = pop @prefix;
	$indent = substr($indent, 0, -((length($tokill) + 3)));
      }

      my $out = $indent;

      # And now we fill in the missing @path to @prefix
      while ($#path > $#prefix) {
	my $toadd = $path[$#prefix + 1];
	push @prefix, $toadd;
	$out .= "$toadd > ";
	$toadd =~ s/./ /g; # Substitute any character with white space...
	$indent .= "$toadd   ";
      }
      $out .= "$propname=";

      # Now we pretty-print the value.
      my $valref = $obj->{$prop};
      my @val = (ref($valref)) ? @$valref : (undef);
 
      my $extraindent = $out;
      $extraindent =~ s/./ /g;

      $out .= $self->prettyval(@val);

      # Finally, we do some linebreaking, so that the output will be neat
      print $self->linebreak($out, $extraindent)."\n";
    }
    print "\n";
  }
}

sub prettyval {
  my $self = shift;
  my $MaxListToPrint = 4;
  my $MaxStrLen = 40;

  my @a = @_; # @a will be manipulated. Get a local copy

  if (@a > $MaxListToPrint) {
    # cap the length of $#a and set the last element to '...'
    $#a = $MaxListToPrint;
    $a[$#a] = "...";
  }
  for (@a) {
    # set args to the string "undef" if undefined
    $_ = "undef", next unless defined $_;
    if (ref $_) {
      if ($Perlilog::classes{ref($_)}) { # Is this a known object?
	$_='{'.$_->who.'}';    # Get the object's pretty ID
	next;
      }
      # force reference to string representation
      $_ .= '';
      s/'/\\'/g;
    }
    else {
      s/'/\\'/g;
      # terminate the string early with '...' if too long
      substr($_,$MaxStrLen) = '...'
	if $MaxStrLen and $MaxStrLen < length;
    }
    # 'quote' arg unless it looks like a number
    $_ = "'$_'" unless /^-?[\d.]+$/;
    # print high-end chars as 'M-<char>'
    s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
    # print remaining control chars as ^<char>
    s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  }
  
  # append 'all', 'the', 'data' to the $sub string
  return ($#a != 0) ? '(' . join(', ', @a) . ')' : $a[0];
}

# Notes about the treestudy function:
# 1. It can be rerun on a tree. It should be rerun direcly before
#    the 'treehash' will be used and/or the tree integrity is
#    a must.
# 2. It can be run on any object in the tree.
# 3. For each object, the path to the object itself will be via
#    the father (and back).
# 4. If the functions returns (as opposed to puke()s), the tree's
#    integrity is assured (no loops, proper parent-child cross refs).
# 5. If the function returns, we're sure that object references can
#    be resolved with the name and %Perlilog::objects (regarding the
#    objects in the tree).

sub treestudy {
  my $self = shift;
  my %beenthere = ($self, 1);
  my @beenlist = ($self);
  my ($i, $next);

  # We now climb up to reach grandpa

  $i=$self;
  while (defined ($next=$i->get('parent'))) {
    puke($i->who." has a non-object registered as a parent\n")
      unless $self->isobject($next);

    # If we've already been where we were just about to climb,
    # we have a loop. Very bad.
    if ($beenthere{$next}) {
      my $err = "Corrupted object tree (parent references are cyclic)\n";
      $err.="The path crawled was as follows: ";
      $err.=join(" -> ",map {$self->safewho($_); } (@beenlist, $next));
      puke("$err\n");
    }
    # Fine. Mark this point, and go on climbing.
    $beenthere{$next}=1;
    push @beenlist, $next;
    $i=$next;
  }

  # We now make calls to two recursive functions, that do the
  # real job. $i is the reference to the grandpa now.

  $i->treecrawldown;
  $i->treecrawlup;
  return $i;
}

# treecrawlup: The children tell parents who their children are

sub treecrawldown {
  my $self = shift;
  my @children = $self -> get('children');
  my ($child, $reflection); # Does this sound poetic to you?
  my %treepath=();
  my $n;

  # We now enrich our %treepath with everything that the
  # children tell us that they have

  foreach $child (@children) {
    # We begin with making sure that $child is in fact
    # a recognized object
    puke($self->who." has a non-object member registered as a child\n")
      unless $self->isobject($child);

    # We check up that the child recognizes us as the
    # parent. Except for the feelings involved, this check
    # assures there are no loops.
    $reflection = $child->get('parent');
    unless ($reflection eq $self) { # Poetic again?
      my ($s, $c, $r) = map {$self->safewho($_);} ($self, $child, $reflection);
      my $err="Faulty parent-child relations: ";
      $err.="$c is marked as a child of $s, ";
      $err.="but $r is the parent of $c\n";
      puke($err);
    }

    # Now we make sure that we can use the object's name
    # instead of a reference to it.

    puke($self->safewho($child)." is badly registered in the global object hash\n")
      unless ($child eq $Perlilog::objects{$child->get('name')});

    # We're safe now... We fill %treepath so that the
    # keys are those objects that we can reach, values
    # are which object to go to reach them. We also
    # add the direct way to the child.
    
    foreach ($child->get('name'), $child->treecrawldown) { # RECURSIVE CALL!
      $treepath{$_} = $child;
    }
  }
  $self->set('treepath', \%treepath);
  return keys %treepath; # Tell our caller what we can reach.
}

# treecrawlup - The children ask the parents what is above them
sub treecrawlup {
  my $self = shift;
  my @children = $self->get('children');
  my $tpr = $self->get('treepath'); # Tree Path Reference
  my $papa = $self->get('parent');
  my @ups;
  my $child;

  # If this object has a parent (true for all except the root
  # object), we learn from it about objects we haven't seen yet.

  if (ref($papa)) {
    @ups = ($papa->get('name'), keys %{$papa->get('treepath')});

    # If we didn't know about the object, we add it and point
    # to papa. Note that papa has a pointer to us, so we add
    # ourselves here too (intentional).
    # I truly apologize for the "${$tpr}{$_}" thing. It really
    # means "$treehash{$_}", where %treehash is exactly the one
    # created in treecrawldown().
      
    foreach (@ups) {
      ${$tpr}{$_} = $papa unless ref(${$tpr}{$_});
    }
  }
  # Now we know about all objects in the tree and how to reach
  # them. Let our children enjoy the same fun.

  foreach $child (@children) {
    $child->treecrawlup;
  }
}