perlilog.pm

自动生成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.
#

require 5.004;
use Perlilog::PLerror;
package Perlilog;
use Perlilog::PLerror;
use strict 'vars';

BEGIN {
  @Perlilog::warnings = ();
  %Perlilog::classes = ();
  $SIG{__WARN__} = sub {
    my ($class) = ($_[0] =~ /unquoted string.*?\"(.*?)\".*may clash/i);
    if (defined $class) {
      push @Perlilog::warnings, $_[0]; 
    } else {
      warn ($_[0])
    }
  };
}

END {
  $SIG{__WARN__} = sub {warn $_[0]; }; # Prevent an endless recursion
  foreach (@Perlilog::warnings) {
    my ($class) = ($_ =~ /unquoted string.*?\"(.*?)\".*may clash/i);
    warn ($_) 
      unless (defined $Perlilog::classes{$class});
  }
}

# We use explicit package names rather than Perl 5.6.0's "our", so
# perl 5.004 won't yell at us.

@Perlilog::ISA = (Exporter);
@Perlilog::EXPORT = qw[&init &override &underride &inherit &inheritdir &interface &interfaceclass
		       &constreset &definedclass &globalobj &execute];
$Perlilog::VERSION = '0.3';
$Perlilog::STARTTIME = localtime();

$Perlilog::perlilogflag = 0;
$Perlilog::globalobject=();
$Perlilog::interface_rec = undef;
@Perlilog::interface_excuses = ();

unless ($Perlilog::perlilogflag) {
  $Perlilog::perlilogflag = 1; # Indicate that this clause has been run once
  $Perlilog::errorcrawl='system';
  $Perlilog::callbacksdepth = 0; # This indicates when callbacks are going on.
  undef $Perlilog::wrong_flag;

  #For unloaded classes: Value is [classfile, parent class, first-given classname].
  %Perlilog::classes = ('PL_hardroot', 1);
  %Perlilog::objects = ();
  @Perlilog::VARS=(undef, undef); # First two variables may be addressed accidentally
  @Perlilog::EQVARS=(undef, undef); # The first two point to themselves.
  @Perlilog::interface_classes = ();
  $Perlilog::objectcounter = 0;
  
  {
    my $home = $INC{'Perlilog.pm'};
    ($home) = ($home =~ /^(.*)Perlilog\.pm$/);
    blow("Failed to resolve Perlilog.pm's directory")
      unless (defined $home);
    $Perlilog::home = $home;
  }

  $Perlilog::classhome = "${Perlilog::home}Perlilog/sysclasses/";
  inherit('root',"${Perlilog::classhome}PLroot.pl",'PL_hardroot');
  inherit('codegen',"${Perlilog::classhome}PLcodegen.pl",'root');
  inherit('verilog',"${Perlilog::classhome}PLverilog.pl",'codegen');
  inherit('global',"${Perlilog::classhome}PLglobal.pl",'codegen');
  inherit('port',"${Perlilog::classhome}PLport.pl",'root');
  inherit('interface',"${Perlilog::classhome}PLinterface.pl",'verilog');
  inherit('site_init',"${Perlilog::classhome}site_init.pl",'PL_hardroot');
}

sub init {
  site_init -> init;
}
sub inherit {
  my $class = shift;
  my $file = shift;
  my $papa = shift;

  puke("Attempt to create the already existing class \'$class\'\n")
    if $Perlilog::classes{$class};

  puke("No parent class defined for \'$class\'\n")
    unless (defined $papa);
  $Perlilog::classes{$class} = [$file, $papa, $class];
  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${class}::Perlilog_dummy_variable"}; 
  undef ${"${class}::Perlilog_dummy_variable"}; # No single use warning...
  return 1;
}

sub inheritdir {
  my $dir = shift;
  my $papa = shift;

  ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes

  blow("Nonexistent directory \'$dir\'\n")
    unless (-d $dir);

  do_inheritdir($dir, $papa);
  return 1;
}

sub do_inheritdir {
  my $dir = shift;
  my $papa = shift;

  ($dir) = ($dir =~ /^(.*?)[\/\\]*$/); # Remove trailing slashes

  return unless (opendir(DIR,$dir));
  my @files=sort readdir(DIR);
  closedir(DIR);
  my @dirs = ();
  my %newclasses = ();

  foreach my $file (@files) {
    next if (($file eq '.') || ($file eq '..'));
    my $thefile = $dir.'/'.$file;

    if (-d $thefile) {
      next unless ($file =~ /^[a-zA-Z][a-zA-Z0-9_]*$/);
      push @dirs, $file, $thefile;
    } else {
      my ($class) = ($file =~ /^([a-zA-Z][a-zA-Z0-9_]*)\.pl$/i);
      next unless (defined $class);
      $class = lc $class; # Lowercase the class
      blow("inheritdir: Attempt to create the already existing class \'".$class.
	   "\' with \'$thefile\' (possibly symbolic link loop?)\n")
	if ($Eobj::classes{$class});
      inherit($class, $thefile, $papa);
      $newclasses{$class} = 1;
    }
  }
  while ($#dirs > 0) { # At least two entries...
    my $newpapa = lc shift @dirs;
    my $descend = shift @dirs;
    
    blow("inheritdir: Could not descend to directory \'$descend\' because there was no \'".
	 $newpapa.".pl\' file in directory \'$dir\'\n")
      unless ($newclasses{$newpapa});
    do_inheritdir($descend, $newpapa);
  }
}

sub override {
  my $class = shift;
  my $file = shift;
  my $papa = shift;

  unless ($Perlilog::classes{$class}) {
    return inherit($class, $file, $papa)
      if defined ($papa);
    puke("Tried to override nonexisting class \'$class\', and no alternative parent given\n");
  }

  puke("Attempt to override class \'$class\' after it has been loaded\n")
    unless ref($Perlilog::classes{$class});

  # Now create a new name for the previous class pointer

  my $newname=$class.'_PL_';
  my $i=1;
  while (defined $Perlilog::classes{$newname.$i}) {$i++;}
  $newname=$newname.$i;
  
  # This is the operation of overriding

  $Perlilog::classes{$newname}=$Perlilog::classes{$class};
  $Perlilog::classes{$class}=[$file, $newname, $class];

  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${newname}::Perlilog_dummy_variable"};
  undef ${"${newname}::Perlilog_dummy_variable"}; # No single use warning

  return 1;
}

sub underride {
  my $class = shift;
  my $file = shift;

  unless ($Perlilog::classes{$class}) {
    puke("Tried to underride a nonexisting class \'$class\'\n");
  }

  puke("Attempt to underride class \'$class\' after it has been loaded\n")
    unless ref($Perlilog::classes{$class});

  # Now create a new name for the previous class pointer

  my $newname=$class.'_PL_';
  my $i=1;
  while (defined $Perlilog::classes{$newname.$i}) {$i++;}
  $newname=$newname.$i;
  
  my $victim = $class;

 # Now we look for the grandfather
 SEARCH: while (1) {
    my $parent = ${$Perlilog::classes{$victim}}[1];
    if (${$Perlilog::classes{$parent}}[2] ne $class) { # Same family?
      last SEARCH;
    } else {
      $victim = $parent; # Climb up the family tree
    }
  }
  # This is the operation of parenting

  $Perlilog::classes{$newname}=[$file, ${$Perlilog::classes{$victim}}[1], $class];
  ${$Perlilog::classes{$victim}}[1]=$newname;

  # The following two lines are a Perl 5.8.0 bug workaround (early
  # versions). Google "stash autoload" for why.
  undef ${"${newname}::Perlilog_dummy_variable"};
  undef ${"${newname}::Perlilog_dummy_variable"}; # No single use warning.
  return 1;
}

#definedclass:
#0 - not defined, 1 - defined but not loaded, 2 - defined and loaded

sub definedclass {
  my $class = shift;
  my $p = $Perlilog::classes{$class};
  return 0 unless (defined $p);
  return 1 if ref($p);
  return 2;
}

sub interfaceclass {
  my $class = shift;
  puke("The class \'$class\' is not defined, and hence cannot be declared as an interface class\n")
    unless (definedclass($class));
  push @Perlilog::interface_classes, $class;
}

sub classload {
  my ($class, $schwonz) = @_;
  my $p = $Perlilog::classes{$class};
  my $err;

  blow($schwonz."Attempt to use undeclared class \'$class\'\n")
    unless (defined $p);

  # If $p isn't a reference, the class has been loaded.
  # This trick allows recursive calls.
  return 1 unless ref($p);